Télécharger la plaquette Cast3M


fr en

Télécharger barsou.eso

Retour à la liste

Numérotation des lignes : 

barsou

  1. C BARSOU    SOURCE    CHAT      11/04/14    21:15:10     6942
  2.        SUBROUTINE BARSOU
  3. *------------------------------------------------------------------------*
  4. *     Operateur BARSOU : Déplacement des noeuds milieu au quart          *
  5. *                                                                        *
  6. *     MELEME (e/s) : Pointeur sur un MELEME (TRI6 ou QUA 8)              *
  7. *     IPOIN    (e) : Pointe de fissure                                   *
  8. *  ou IPT3     (e) : Ligne de fissure dans le cas 3D massif              *
  9. *------------------------------------------------------------------------*
  10.  
  11.       IMPLICIT INTEGER(I-N)
  12.        IMPLICIT REAL*8 (A-H,O-Z)
  13. *
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMELEME
  18. -INC SMCOORD
  19. *
  20. *------------------------------------------------------------------------*
  21. *      Déclaration des segments temporaires nécessaires au traitement    *
  22. *------------------------------------------------------------------------*
  23. *        Segment des noeuds à déplacer                                   *
  24.        SEGMENT, PTDEP
  25.           INTEGER TPOIM(N), TPFIS(N), TPOIE(N)
  26.        ENDSEGMENT
  27.        POINTEUR IPTDP.PTDEP
  28. *        Segment des noeuds milieu de la ligne de fissures               *
  29.        SEGMENT, PTMIL
  30.           INTEGER TLFMI(N)
  31.        ENDSEGMENT
  32. *        Segment des pointes de fissure (pas de noeuds milieu)           *
  33.        SEGMENT, PTFIS
  34.           INTEGER TLFPT(N)
  35.        ENDSEGMENT
  36. *        Segment des élements contenant des noeuds à déplacer            *
  37.        SEGMENT, ELMDP
  38.           INTEGER TSOUS(N), TELMM(N), TPFIM(N), TTYPL(N), TNUPF(N)
  39.        ENDSEGMENT
  40. *
  41. *------------------------------------------------------------------------*
  42. *      Autres déclarations                                               *
  43. *------------------------------------------------------------------------*
  44.        REAL*8 V1(3), V2(3), V3(3), TDIST(20)
  45.        INTEGER TMRAN(4), TERAN(4)
  46.        INTEGER TMP15(14,3), TEP15(14,3), TMC20(19,3), TEC20(19,3)
  47.        INTEGER TMP13(13,4), TEP13(13,4), TMT10(10,3), TET10(14,3)
  48.        INTEGER TMQU8(7,2), TEQU8(7,2), TMTR6(5,2), TETR6(5,2)
  49.        DATA TMP15(1,1), TMP15(1,2), TMP15(1,3), TMP15(3,1), TMP15(3,2),
  50.      #  TMP15(3,3), TMP15(5,1), TMP15(5,2), TMP15(5,3), TMP15(10,1),
  51.      #  TMP15(10,2), TMP15(10,3), TMP15(12,1), TMP15(12,2), TMP15(12,3),
  52.      #  TMP15(14,1), TMP15(14,2), TMP15(14,3)
  53.      #  /2,6,7,2,4,8,4,6,9,7,11,15,8,11,13,9,13,15/
  54.        DATA TEP15(1,1), TEP15(1,2), TEP15(1,3), TEP15(3,1), TEP15(3,2),
  55.      #  TEP15(3,3), TEP15(5,1), TEP15(5,2), TEP15(5,3), TEP15(10,1),
  56.      #  TEP15(10,2), TEP15(10,3), TEP15(12,1), TEP15(12,2), TEP15(12,3),
  57.      #  TEP15(14,1), TEP15(14,2), TEP15(14,3)
  58.      #  /3,5,10,1,5,12,3,1,14,1,12,14,3,10,14,5,12,10/
  59.        DATA TMC20(1,1), TMC20(1,2), TMC20(1,3), TMC20(3,1), TMC20(3,2),
  60.      #  TMC20(3,3), TMC20(5,1), TMC20(5,2), TMC20(5,3), TMC20(7,1),
  61.      #  TMC20(7,2), TMC20(7,3), TMC20(13,1), TMC20(13,2), TMC20(13,3),
  62.      #  TMC20(15,1), TMC20(15,2), TMC20(15,3), TMC20(17,1), TMC20(17,2),
  63.      #  TMC20(17,3), TMC20(19,1), TMC20(19,2), TMC20(19,3)
  64.      #  /2,8,9,2,4,10,4,6,11,6,8,12,9,14,20,14,16,10,11,16,18,12,18,20/
  65.        DATA TEC20(1,1), TEC20(1,2), TEC20(1,3), TEC20(3,1), TEC20(3,2),
  66.      #  TEC20(3,3), TEC20(5,1), TEC20(5,2), TEC20(5,3), TEC20(7,1),
  67.      #  TEC20(7,2), TEC20(7,3), TEC20(13,1), TEC20(13,2), TEC20(13,3),
  68.      #  TEC20(15,1), TEC20(15,2), TEC20(15,3), TEC20(17,1), TEC20(17,2),
  69.      #  TEC20(17,3), TEC20(19,1), TEC20(19,2), TEC20(19,3)
  70.      #  /3,7,13,1,5,15,3,7,17,5,1,19,1,15,19,13,17,3,5,15,19,7,17,13/
  71.        DATA TMP13(1,1), TMP13(1,2), TMP13(1,3), TMP13(3,1), TMP13(3,2),
  72.      #  TMP13(3,3), TMP13(5,1), TMP13(5,2), TMP13(5,3), TMP13(7,1),
  73.      #  TMP13(7,2), TMP13(7,3), TMP13(13,1), TMP13(13,2), TMP13(13,3),
  74.      #  TMP13(13,4)
  75.      #  /2,8,9,2,4,10,4,6,11,6,8,12,9,10,11,12/
  76.        DATA TEP13(1,1), TEP13(1,2), TEP13(1,3), TEP13(3,1), TEP13(3,2),
  77.      #  TEP13(3,3), TEP13(5,1), TEP13(5,2), TEP13(5,3), TEP13(7,1),
  78.      #  TEP13(7,2), TEP13(7,3), TEP13(13,1), TEP13(13,2), TEP13(13,3),
  79.      #  TEP13(13,4)
  80.      #  /3,7,10,1,5,13,3,7,13,5,1,13,1,3,5,7/
  81.        DATA TMT10(1,1), TMT10(1,2), TMT10(1,3), TMT10(3,1), TMT10(3,2),
  82.      #  TMT10(3,3), TMT10(5,1), TMT10(5,2), TMT10(5,3), TMT10(10,1),
  83.      #  TMT10(10,2), TMT10(10,3)
  84.      #  /2,6,7,2,4,8,4,6,9,7,8,9/
  85.        DATA TET10(1,1), TET10(1,2), TET10(1,3), TET10(3,1), TET10(3,2),
  86.      #  TET10(3,3), TET10(5,1), TET10(5,2), TET10(5,3), TET10(10,1),
  87.      #  TET10(10,2), TET10(10,3)
  88.      #  /3,5,10,1,5,10,3,1,10,1,3,5/
  89.        DATA TMQU8(1,1), TMQU8(1,2), TMQU8(3,1), TMQU8(3,2), TMQU8(5,1),
  90.      #  TMQU8(5,2), TMQU8(7,1), TMQU8(7,2)
  91.      #  /2,8,2,4,4,6,6,8/
  92.        DATA TEQU8(1,1), TEQU8(1,2), TEQU8(3,1), TEQU8(3,2), TEQU8(5,1),
  93.      #  TEQU8(5,2), TEQU8(7,1), TEQU8(7,2)
  94.      #  /3,7,1,5,3,7,5,1/
  95.        DATA TMTR6(1,1), TMTR6(1,2), TMTR6(3,1), TMTR6(3,2), TMTR6(5,1),
  96.      #  TMTR6(5,2)
  97.      #  /2,6,2,4,4,6/
  98.        DATA TETR6(1,1), TETR6(1,2), TETR6(3,1), TETR6(3,2), TETR6(5,1),
  99.      #  TETR6(5,2)
  100.      #  /3,5,1,5,3,1/
  101. *
  102. *------------------------------------------------------------------------*
  103. *      Récupération du maillage et de la pointe                          *
  104. *           ou de la ligne de fissure                                    *
  105. *------------------------------------------------------------------------*
  106.        CALL LIROBJ('MAILLAGE', MELEME, 1, IRETOU)
  107.        IF (IERR .NE. 0) RETURN
  108.        IF (IRETOU .EQ. 0) RETURN
  109.        CALL LIRREE(ALPHA, 0, IRETOU)
  110.        IF (IERR .NE. 0) RETURN
  111.        IF (IRETOU .EQ. 0) THEN
  112.            ALPHA = 0.495
  113.        ELSE
  114.            IF (IIMPI.EQ.1) WRITE (*,*) 'REEL LU...'
  115.        ENDIF
  116.        IF (IIMPI.EQ.1) WRITE (*,*) 'OBJET MAILLAGE LU...'
  117.        CALL LIROBJ('MAILLAGE', IPT3, 0, IRETOU)
  118.        IF (IERR .NE. 0) RETURN
  119.        SEGACT, MCOORD*MOD
  120.        IF (IRETOU .EQ. 0) THEN
  121.           CALL LIROBJ('POINT', IPOIN, 1, IRETOU)
  122.           IF (IERR .NE. 0) RETURN
  123.           IF (IRETOU .EQ. 0) RETURN
  124.           IF (IIMPI.EQ.1) WRITE (*,*) 'OBJET POINT LU...'
  125.           N = 1
  126.           SEGINI, PTFIS
  127.           TLFPT(1) = IPOIN
  128.           IF (IIMPI.EQ.1) THEN
  129.              WRITE (*,*) '  Noeud de fissure : ', IPOIN
  130.           ENDIF
  131.           SEGDES, PTFIS
  132.           N = 0
  133.           SEGINI, PTMIL
  134.           SEGDES, PTMIL
  135.        ELSE
  136.           IF (IIMPI.EQ.1) WRITE (*,*) 'OBJET MAILLAGE LU...'
  137.           N = 0
  138.           SEGINI, PTFIS
  139.           SEGDES, PTFIS
  140.           N = 0
  141.           SEGINI, PTMIL
  142.           SEGDES, PTMIL
  143.           SEGACT, IPT3
  144.           IPT2 = IPT3
  145.           IP = 0
  146.           IF (IIMPI.EQ.1) WRITE (*,*) 'BOUCLE SUR LE MAILLAGE...'
  147. *----------POUR CHAQUE SOUS-ENSEMBLE
  148.           DO 13 IS = 1, MAX(1, IPT3.LISOUS(/1))
  149.              IF (IPT3.LISOUS(/1) .NE. 0) THEN
  150.                 IPT2 = IPT3.LISOUS(IS)
  151.                 SEGACT, IPT2
  152.              ENDIF
  153.              IF (IIMPI.EQ.1) THEN
  154.                 WRITE (*,*) 'OBJET MAILLAGE DE TYPE ', IPT2.ITYPEL
  155.              ENDIF
  156.              DO 12 IE = 1, IPT2.NUM(/2)
  157.                 SEGACT, PTMIL
  158.                 N = TLFMI(/1) + 1
  159.                 SEGADJ, PTMIL
  160.                 TLFMI(N) = IPT2.NUM(2, IE)
  161.                 IF (IIMPI .EQ. 1) THEN
  162.                    WRITE (*,*) '  Point milieu-fissure ',TLFMI(N)
  163.                 ENDIF
  164.                 SEGDES, PTMIL
  165.                 SEGACT, PTFIS
  166.                 IF (IP .EQ. 0) THEN
  167.                    IP = 1
  168.                    N = 1
  169.                    SEGADJ, PTFIS
  170.                    TLFPT(1) = IPT2.NUM(1, IE)
  171.                    IF (IIMPI .EQ. 1) THEN
  172.                       WRITE (*,*) '  Point fissure ',TLFPT(N)
  173.                    ENDIF
  174.                 ENDIF
  175.                 N = TLFPT(/1) + 1
  176.                 SEGADJ, PTFIS
  177.                 TLFPT(N) = IPT2.NUM(3, IE)
  178.                 IF (IIMPI .EQ. 1) THEN
  179.                    WRITE (*,*) '  Point fissure ',TLFPT(N)
  180.                 ENDIF
  181.                 SEGDES, PTFIS
  182.    12        CONTINUE
  183.              IF (IPT3.LISOUS(/1).NE.0) SEGDES, IPT2
  184.    13     CONTINUE
  185.           SEGDES, IPT3
  186.        ENDIF
  187. *------------------------------------------------------------------------*
  188. *      Récupération des éléments contenant des noeuds à déplacer         *
  189. *------------------------------------------------------------------------*
  190.        IF (IIMPI.EQ.1) WRITE (*,*) 'RECUPERATION DES ELEMENTS'
  191.        IK = 0
  192.        N = 0
  193.        SEGINI, ELMDP
  194.        SEGDES, ELMDP
  195.        SEGACT, PTFIS
  196.        INP = TLFPT(/1)
  197.        DO 5 IP = 1, INP
  198.           IPOIN = TLFPT(IP)
  199. *----------ON CHERCHE LES ELEMENTS CONTENANT LA POINTE DE FISSURE
  200.           SEGACT, MELEME
  201.           IPT1 = MELEME
  202.           DO 2 IS=1, MAX(1, MELEME.LISOUS(/1))
  203.              IF (MELEME.LISOUS(/1).NE.0) THEN
  204.                 IPT1 = MELEME.LISOUS(IS)
  205.                 SEGACT IPT1
  206.              ENDIF
  207.              DO 3 IE = 1, IPT1.NUM(/2)
  208.                 DO 4 IN = 1, IPT1.NUM(/1)
  209.                    IF (IPT1.NUM(IN, IE) .EQ. IPOIN) THEN
  210. *----------------------ON A TROUVE UN ELEMENT QUI CONTIENT LA POINTE
  211.                       SEGACT, ELMDP
  212.                       IF (TELMM(/1) .EQ. 0) THEN
  213.                          IK = IK + 1
  214.                          N = TELMM(/1) + 1
  215.                          SEGADJ, ELMDP
  216.                          TELMM(N) = IE
  217.                          TTYPL(N) = IPT1.ITYPEL
  218.                          TPFIM(N) = TLFPT(IP)
  219.                          TNUPF(N) = IN
  220.                          IF (MELEME.LISOUS(/1).NE.0) THEN
  221.                             TSOUS(N) = IS
  222.                          ELSE
  223.                             TSOUS(N) = 0
  224.                          ENDIF
  225.                          IF (IIMPI.EQ.1) THEN
  226.                       WRITE (*,*) '  Element : ',IE,' dans ',TSOUS(N)
  227.                       WRITE (*,*) '     fissure : ',TPFIM(N)
  228.                          ENDIF
  229.                       ELSE
  230.                          II = 1
  231.    6   IF(TELMM(II).NE.IE.OR.TSOUS(II).NE.IS.OR.TPFIM(II).NE.IPOIN) THEN
  232.                             II = II + 1
  233.                             IF (II .LE. TELMM(/1)) GOTO 6
  234.                             IK = IK + 1
  235.                             N = TELMM(/1) + 1
  236.                             SEGADJ, ELMDP
  237.                             TELMM(N) = IE
  238.                             TTYPL(N) = IPT1.ITYPEL
  239.                             TPFIM(N) = TLFPT(IP)
  240.                             TNUPF(N) = IN
  241.                             IF (MELEME.LISOUS(/1).NE.0) THEN
  242.                                TSOUS(N) = IS
  243.                             ELSE
  244.                                TSOUS(N) = 0
  245.                             ENDIF
  246.                             IF (IIMPI.EQ.1) THEN
  247.                         WRITE (*,*) '  Element : ',IE,' dans ',TSOUS(N)
  248.                         WRITE (*,*) '     fissure : ',TPFIM(N)
  249.                             ENDIF
  250.                          ENDIF
  251.                       ENDIF
  252.                       SEGDES, ELMDP
  253.                    ENDIF
  254.    4            CONTINUE
  255.    3         CONTINUE
  256.              IF (LISOUS(/1).NE.0) SEGDES, IPT1
  257.    2      CONTINUE
  258.           SEGDES, MELEME
  259.    5   CONTINUE
  260.        SEGDES, PTFIS
  261. *------------------------------------------------------------------------*
  262. *      Récupération des noeuds à déplacer                                *
  263. *------------------------------------------------------------------------*
  264.        N = 0
  265.        IF (IIMPI.EQ.1) WRITE (*,*) 'RECUPERATION DES NOEUDS'
  266.        SEGINI, PTDEP
  267.        SEGDES, PTDEP
  268.        SEGACT, MELEME
  269.        IPT1 = MELEME
  270.        SEGACT, ELMDP
  271.        SEGACT, PTDEP
  272.        IK = 0
  273. *-------POUR CHAQUE ELEMENT SELECTIONNE PRECEDEMMENT
  274.        IF (IIMPI.EQ.1) WRITE (*,*) ' ',TELMM(/1),' Elements à étudier'
  275.        DO 20 IE = 1, ELMDP.TELMM(/1)
  276.           IEFI = ELMDP.TNUPF(IE)
  277.           IF (ELMDP.TTYPL(IE).EQ.6) THEN
  278.              IF (IIMPI.EQ.1) WRITE (*,*) '  Element TRI6 # ', IE
  279.              INBNO = 6
  280.              GOTO 21
  281.           ENDIF
  282.           IF (ELMDP.TTYPL(IE).EQ.10) THEN
  283.              IF (IIMPI.EQ.1) WRITE (*,*) '  Element QUA8 # ', IE
  284.              INBNO = 8
  285.              GOTO 22
  286.           ENDIF
  287.           IF (ELMDP.TTYPL(IE).EQ.15) THEN
  288.              IF (IIMPI.EQ.1) WRITE (*,*) '  Element CU20 # ', IE
  289.              INBNO = 20
  290.              GOTO 23
  291.           ENDIF
  292.           IF (ELMDP.TTYPL(IE).EQ.17) THEN
  293.              IF (IIMPI.EQ.1) WRITE (*,*) '  Element PR15 # ', IE
  294.              INBNO = 15
  295.              GOTO 24
  296.           ENDIF
  297.           IF (ELMDP.TTYPL(IE).EQ.24) THEN
  298.              IF (IIMPI.EQ.1) WRITE (*,*) '  Element TE10 # ', IE
  299.              INBNO = 10
  300.              GOTO 25
  301.           ENDIF
  302.           IF (ELMDP.TTYPL(IE).EQ.26) THEN
  303.              IF (IIMPI.EQ.1) WRITE (*,*) '  Element PY13 # ', IE
  304.              INBNO = 13
  305.              GOTO 26
  306.           ENDIF
  307.           GOTO 20
  308.    21     CONTINUE
  309. ***--------CAS DES ELEMENTS TRI6
  310.           IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
  311.           SEGACT, IPT1
  312.           NPMI = 2
  313.           DO 211 IM = 1, NPMI
  314.              TMRAN(IM) = TMTR6(IEFI, IM)
  315.              TERAN(IM) = TETR6(IEFI, IM)
  316.   211     CONTINUE
  317.           GOTO 200
  318.    22     CONTINUE
  319. ***--------CAS DES ELEMENTS QUA8
  320.           IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
  321.           SEGACT, IPT1
  322.           NPMI = 2
  323.           DO 212 IM = 1, NPMI
  324.              TMRAN(IM) = TMQU8(IEFI, IM)
  325.              TERAN(IM) = TEQU8(IEFI, IM)
  326.   212     CONTINUE
  327.           GOTO 200
  328.    23     CONTINUE
  329. ***--------CAS DES ELEMENTS CU20
  330.           IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
  331.           SEGACT, IPT1
  332.           NPMI = 3
  333.           DO 213 IM = 1, NPMI
  334.              TMRAN(IM) = TMC20(IEFI, IM)
  335.              TERAN(IM) = TEC20(IEFI, IM)
  336.   213     CONTINUE
  337.           GOTO 200
  338.    24     CONTINUE
  339. ***--------CAS DES ELEMENTS PR15
  340.           IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
  341.           SEGACT, IPT1
  342.           NPMI = 3
  343.           DO 214 IM = 1, NPMI
  344.              TMRAN(IM) = TMP15(IEFI, IM)
  345.              TERAN(IM) = TEP15(IEFI, IM)
  346.   214    CONTINUE
  347.           GOTO 200
  348.    25     CONTINUE
  349. ***--------CAS DES ELEMENTS TE10
  350.           IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
  351.           SEGACT, IPT1
  352.           NPMI = 3
  353.           DO 215 IM = 1, NPMI
  354.              TMRAN(IM) = TMT10(IEFI, IM)
  355.              TERAN(IM) = TET10(IEFI, IM)
  356.   215     CONTINUE
  357.           GOTO 200
  358.    26     CONTINUE
  359. ***--------CAS DES ELEMENTS PY13
  360.           IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
  361.           SEGACT, IPT1
  362.           IF (IEFI .EQ. 13) THEN
  363.              NPMI = 4
  364.           ELSE
  365.              NPMI = 3
  366.           ENDIF
  367.           DO 216 IM = 1, NPMI
  368.              TMRAN(IM) = TMP13(IEFI, IM)
  369.              TERAN(IM) = TEP13(IEFI, IM)
  370.   216     CONTINUE
  371. ***--------RANGEMENT DES POINTS MILIEUX ET DES POINTS EXTREMITES
  372.   200     CONTINUE
  373.           IF (IK .EQ. 0) THEN
  374.              DO 220 IM = 1, NPMI
  375.                  IK = IK + 1
  376.                  N = IK
  377.                  SEGADJ, PTDEP
  378.                  PTDEP.TPOIM(N) = IPT1.NUM(TMRAN(IM), TELMM(IE))
  379.                  PTDEP.TPOIE(N) = IPT1.NUM(TERAN(IM), TELMM(IE))
  380.                  PTDEP.TPFIS(N) = ELMDP.TPFIM(IE)
  381.                  IF (IIMPI .EQ. 1) THEN
  382.                WRITE (*,*) 'POINT MILIEU       : ', PTDEP.TPOIM(N)
  383.                WRITE (*,*) '   Point extremite : ', PTDEP.TPOIE(N)
  384.                WRITE (*,*) '   Point fissure   : ', PTDEP.TPFIS(N)
  385.                  ENDIF
  386.   220        CONTINUE
  387.           ELSE
  388.              DO 230 IM = 1, NPMI
  389.                 II = 1
  390.   240      IF (PTDEP.TPOIM(II).NE.IPT1.NUM(TMRAN(IM),TELMM(IE))) THEN
  391.                    IF (II .LE. IK) THEN
  392.                       II = II + 1
  393.                       GOTO 240
  394.                    ELSE
  395.                       IK = IK + 1
  396.                       N = PTDEP.TPOIM(/1) + 1
  397.                       SEGADJ, PTDEP
  398.                       PTDEP.TPOIM(N) = IPT1.NUM(TMRAN(IM), TELMM(IE))
  399.                       PTDEP.TPOIE(N) = IPT1.NUM(TERAN(IM), TELMM(IE))
  400.                       PTDEP.TPFIS(N) = ELMDP.TPFIM(IE)
  401.                       IF (IIMPI .EQ. 1) THEN
  402.                WRITE (*,*) 'POINT MILIEU       : ', PTDEP.TPOIM(N)
  403.                WRITE (*,*) '   Point extremite : ', PTDEP.TPOIE(N)
  404.                WRITE (*,*) '   Point fissure   : ', PTDEP.TPFIS(N)
  405.                       ENDIF
  406.                    ENDIF
  407.                 ENDIF
  408.   230        CONTINUE
  409.           ENDIF
  410.           SEGDES, IPT1
  411.    20  CONTINUE
  412.        SEGDES, PTDEP
  413.        SEGDES, ELMDP
  414.        SEGDES, MELEME
  415. *
  416. *------------------------------------------------------------------------*
  417. *      Epuration du tableau contenant les noeuds milieu                  *
  418. *------------------------------------------------------------------------*
  419.        SEGACT, PTDEP
  420.        N = 1
  421.        SEGINI, IPTDP
  422.        IPTDP.TPOIM(1) = PTDEP.TPOIM(1)
  423.        IPTDP.TPFIS(1) = PTDEP.TPFIS(1)
  424.        IPTDP.TPOIE(1) = PTDEP.TPOIE(1)
  425.        DO 50, IP = 2, PTDEP.TPOIM(/1)
  426.           II = 1
  427.    51     IF (IPTDP.TPOIM(II) .NE. PTDEP.TPFIS(IP)) THEN
  428.              II = II + 1
  429.              IF (II .LE. IPTDP.TPOIM(/1)) GOTO 51
  430.              N = IPTDP.TPOIM(/1) + 1
  431.              SEGADJ, IPTDP
  432.              IPTDP.TPOIM(N) = PTDEP.TPOIM(IP)
  433.              IPTDP.TPFIS(N) = PTDEP.TPFIS(IP)
  434.              IPTDP.TPOIE(N) = PTDEP.TPOIE(IP)
  435.           ENDIF
  436.    50  CONTINUE
  437.        SEGDES, IPTDP
  438.        SEGDES, PTDEP
  439. *------------------------------------------------------------------------*
  440. *      Déplacement des noeuds milieu                                     *
  441. *------------------------------------------------------------------------*
  442. *
  443.        SEGACT, IPTDP
  444.        SEGACT, PTMIL
  445.        DO 40, IP = 1, IPTDP.TPOIM(/1)
  446.           IF (PTMIL.TLFMI(/1) .EQ. 0) GOTO 42
  447.           II = 1
  448.    41     IF (TLFMI(II) .NE. IPTDP.TPOIM(IP)) THEN
  449.              II = II + 1
  450.              IF (II .LE. TLFMI(/1)) GOTO 41
  451.              GOTO 42
  452.           ELSE
  453.              GOTO 40
  454.           ENDIF
  455.    42     IF (IIMPI.EQ.1) THEN
  456.              WRITE (*,*) 'Point milieu     : ', IPTDP.TPOIM(IP)
  457.              WRITE (*,*) '   Point fissure : ', IPTDP.TPFIS(IP)
  458.              WRITE (*,*) '   Point extreme : ', IPTDP.TPOIE(IP)
  459.           ENDIF
  460.           ALPE = 0.5*(ALPHA - 1.)*ALPHA
  461.           ALPM = (1. - ALPHA)*(ALPHA + 1)
  462.           ALPF = 0.5*ALPHA*(ALPHA + 1.)
  463.           IRPF = (IDIM + 1)*(IPTDP.TPFIS(IP) - 1)
  464.           IRPM = (IDIM + 1)*(IPTDP.TPOIM(IP) - 1)
  465.           IRPE = (IDIM + 1)*(IPTDP.TPOIE(IP) - 1)
  466.           DO 43 IC = 1, IDIM
  467.              XCOOR(IRPM + IC) = ALPF*XCOOR(IRPF + IC) +
  468.      #              ALPM*XCOOR(IRPM + IC) + ALPE*XCOOR(IRPE + IC)
  469.    43     CONTINUE
  470.    40  CONTINUE
  471.        IF (IIMPI.EQ.1) THEN
  472.           WRITE (*,*) IPTDP.TPOIM(/1), ' noeuds déplacés.'
  473.        ENDIF
  474.        SEGDES, IPTDP
  475.        SEGDES, PTMIL
  476. *------------------------------------------------------------------------*
  477. *      Suppression des segments temporaires                              *
  478. *------------------------------------------------------------------------*
  479.        SEGSUP, IPTDP
  480.        SEGSUP, PTDEP
  481.        SEGSUP, PTMIL
  482.        SEGSUP, PTFIS
  483.        SEGSUP, ELMDP
  484. *
  485.        RETURN
  486.        END
  487.  
  488.  
  489.  
  490.  
  491.  
  492.  
  493.  

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