C BARSOU    SOURCE    CHAT      11/04/14    21:15:10     6942
       SUBROUTINE BARSOU
*------------------------------------------------------------------------*
*     Operateur BARSOU : Déplacement des noeuds milieu au quart          *
*                                                                        *
*     MELEME (e/s) : Pointeur sur un MELEME (TRI6 ou QUA 8)              *
*     IPOIN    (e) : Pointe de fissure                                   *
*  ou IPT3     (e) : Ligne de fissure dans le cas 3D massif              *
*------------------------------------------------------------------------*

      IMPLICIT INTEGER(I-N)
       IMPLICIT REAL*8 (A-H,O-Z)
*

-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
*
*------------------------------------------------------------------------*
*      Déclaration des segments temporaires nécessaires au traitement    *
*------------------------------------------------------------------------*
*        Segment des noeuds à déplacer                                   *
       SEGMENT, PTDEP
          INTEGER TPOIM(N), TPFIS(N), TPOIE(N)
       ENDSEGMENT
       POINTEUR IPTDP.PTDEP
*        Segment des noeuds milieu de la ligne de fissures               *
       SEGMENT, PTMIL
          INTEGER TLFMI(N)
       ENDSEGMENT
*        Segment des pointes de fissure (pas de noeuds milieu)           *
       SEGMENT, PTFIS
          INTEGER TLFPT(N)
       ENDSEGMENT
*        Segment des élements contenant des noeuds à déplacer            *
       SEGMENT, ELMDP
          INTEGER TSOUS(N), TELMM(N), TPFIM(N), TTYPL(N), TNUPF(N)
       ENDSEGMENT
*
*------------------------------------------------------------------------*
*      Autres déclarations                                               *
*------------------------------------------------------------------------*
       REAL*8 V1(3), V2(3), V3(3), TDIST(20)
       INTEGER TMRAN(4), TERAN(4)
       INTEGER TMP15(14,3), TEP15(14,3), TMC20(19,3), TEC20(19,3)
       INTEGER TMP13(13,4), TEP13(13,4), TMT10(10,3), TET10(14,3)
       INTEGER TMQU8(7,2), TEQU8(7,2), TMTR6(5,2), TETR6(5,2)
       DATA TMP15(1,1), TMP15(1,2), TMP15(1,3), TMP15(3,1), TMP15(3,2),
     #  TMP15(3,3), TMP15(5,1), TMP15(5,2), TMP15(5,3), TMP15(10,1),
     #  TMP15(10,2), TMP15(10,3), TMP15(12,1), TMP15(12,2), TMP15(12,3),
     #  TMP15(14,1), TMP15(14,2), TMP15(14,3)
     #  /2,6,7,2,4,8,4,6,9,7,11,15,8,11,13,9,13,15/
       DATA TEP15(1,1), TEP15(1,2), TEP15(1,3), TEP15(3,1), TEP15(3,2),
     #  TEP15(3,3), TEP15(5,1), TEP15(5,2), TEP15(5,3), TEP15(10,1),
     #  TEP15(10,2), TEP15(10,3), TEP15(12,1), TEP15(12,2), TEP15(12,3),
     #  TEP15(14,1), TEP15(14,2), TEP15(14,3)
     #  /3,5,10,1,5,12,3,1,14,1,12,14,3,10,14,5,12,10/
       DATA TMC20(1,1), TMC20(1,2), TMC20(1,3), TMC20(3,1), TMC20(3,2),
     #  TMC20(3,3), TMC20(5,1), TMC20(5,2), TMC20(5,3), TMC20(7,1),
     #  TMC20(7,2), TMC20(7,3), TMC20(13,1), TMC20(13,2), TMC20(13,3),
     #  TMC20(15,1), TMC20(15,2), TMC20(15,3), TMC20(17,1), TMC20(17,2),
     #  TMC20(17,3), TMC20(19,1), TMC20(19,2), TMC20(19,3)
     #  /2,8,9,2,4,10,4,6,11,6,8,12,9,14,20,14,16,10,11,16,18,12,18,20/
       DATA TEC20(1,1), TEC20(1,2), TEC20(1,3), TEC20(3,1), TEC20(3,2),
     #  TEC20(3,3), TEC20(5,1), TEC20(5,2), TEC20(5,3), TEC20(7,1),
     #  TEC20(7,2), TEC20(7,3), TEC20(13,1), TEC20(13,2), TEC20(13,3),
     #  TEC20(15,1), TEC20(15,2), TEC20(15,3), TEC20(17,1), TEC20(17,2),
     #  TEC20(17,3), TEC20(19,1), TEC20(19,2), TEC20(19,3)
     #  /3,7,13,1,5,15,3,7,17,5,1,19,1,15,19,13,17,3,5,15,19,7,17,13/
       DATA TMP13(1,1), TMP13(1,2), TMP13(1,3), TMP13(3,1), TMP13(3,2),
     #  TMP13(3,3), TMP13(5,1), TMP13(5,2), TMP13(5,3), TMP13(7,1),
     #  TMP13(7,2), TMP13(7,3), TMP13(13,1), TMP13(13,2), TMP13(13,3),
     #  TMP13(13,4)
     #  /2,8,9,2,4,10,4,6,11,6,8,12,9,10,11,12/
       DATA TEP13(1,1), TEP13(1,2), TEP13(1,3), TEP13(3,1), TEP13(3,2),
     #  TEP13(3,3), TEP13(5,1), TEP13(5,2), TEP13(5,3), TEP13(7,1),
     #  TEP13(7,2), TEP13(7,3), TEP13(13,1), TEP13(13,2), TEP13(13,3),
     #  TEP13(13,4)
     #  /3,7,10,1,5,13,3,7,13,5,1,13,1,3,5,7/
       DATA TMT10(1,1), TMT10(1,2), TMT10(1,3), TMT10(3,1), TMT10(3,2),
     #  TMT10(3,3), TMT10(5,1), TMT10(5,2), TMT10(5,3), TMT10(10,1),
     #  TMT10(10,2), TMT10(10,3)
     #  /2,6,7,2,4,8,4,6,9,7,8,9/
       DATA TET10(1,1), TET10(1,2), TET10(1,3), TET10(3,1), TET10(3,2),
     #  TET10(3,3), TET10(5,1), TET10(5,2), TET10(5,3), TET10(10,1),
     #  TET10(10,2), TET10(10,3)
     #  /3,5,10,1,5,10,3,1,10,1,3,5/
       DATA TMQU8(1,1), TMQU8(1,2), TMQU8(3,1), TMQU8(3,2), TMQU8(5,1),
     #  TMQU8(5,2), TMQU8(7,1), TMQU8(7,2)
     #  /2,8,2,4,4,6,6,8/
       DATA TEQU8(1,1), TEQU8(1,2), TEQU8(3,1), TEQU8(3,2), TEQU8(5,1),
     #  TEQU8(5,2), TEQU8(7,1), TEQU8(7,2)
     #  /3,7,1,5,3,7,5,1/
       DATA TMTR6(1,1), TMTR6(1,2), TMTR6(3,1), TMTR6(3,2), TMTR6(5,1),
     #  TMTR6(5,2)
     #  /2,6,2,4,4,6/
       DATA TETR6(1,1), TETR6(1,2), TETR6(3,1), TETR6(3,2), TETR6(5,1),
     #  TETR6(5,2)
     #  /3,5,1,5,3,1/
*
*------------------------------------------------------------------------*
*      Récupération du maillage et de la pointe                          *
*           ou de la ligne de fissure                                    *
*------------------------------------------------------------------------*
       CALL LIROBJ('MAILLAGE', MELEME, 1, IRETOU)
       IF (IERR .NE. 0) RETURN
       IF (IRETOU .EQ. 0) RETURN
       CALL LIRREE(ALPHA, 0, IRETOU)
       IF (IERR .NE. 0) RETURN
       IF (IRETOU .EQ. 0) THEN
           ALPHA = 0.495
       ELSE
           IF (IIMPI.EQ.1) WRITE (*,*) 'REEL LU...'
       ENDIF
       IF (IIMPI.EQ.1) WRITE (*,*) 'OBJET MAILLAGE LU...'
       CALL LIROBJ('MAILLAGE', IPT3, 0, IRETOU)
       IF (IERR .NE. 0) RETURN
       SEGACT, MCOORD*MOD
       IF (IRETOU .EQ. 0) THEN
          CALL LIROBJ('POINT', IPOIN, 1, IRETOU)
          IF (IERR .NE. 0) RETURN
          IF (IRETOU .EQ. 0) RETURN
          IF (IIMPI.EQ.1) WRITE (*,*) 'OBJET POINT LU...'
          N = 1
          SEGINI, PTFIS
          TLFPT(1) = IPOIN
          IF (IIMPI.EQ.1) THEN
             WRITE (*,*) '  Noeud de fissure : ', IPOIN
          ENDIF
          SEGDES, PTFIS
          N = 0
          SEGINI, PTMIL
          SEGDES, PTMIL
       ELSE
          IF (IIMPI.EQ.1) WRITE (*,*) 'OBJET MAILLAGE LU...'
          N = 0
          SEGINI, PTFIS
          SEGDES, PTFIS
          N = 0
          SEGINI, PTMIL
          SEGDES, PTMIL
          SEGACT, IPT3
          IPT2 = IPT3
          IP = 0
          IF (IIMPI.EQ.1) WRITE (*,*) 'BOUCLE SUR LE MAILLAGE...'
*----------POUR CHAQUE SOUS-ENSEMBLE
          DO 13 IS = 1, MAX(1, IPT3.LISOUS(/1))
             IF (IPT3.LISOUS(/1) .NE. 0) THEN
                IPT2 = IPT3.LISOUS(IS)
                SEGACT, IPT2
             ENDIF
             IF (IIMPI.EQ.1) THEN
                WRITE (*,*) 'OBJET MAILLAGE DE TYPE ', IPT2.ITYPEL
             ENDIF
             DO 12 IE = 1, IPT2.NUM(/2)
                SEGACT, PTMIL
                N = TLFMI(/1) + 1
                SEGADJ, PTMIL
                TLFMI(N) = IPT2.NUM(2, IE)
                IF (IIMPI .EQ. 1) THEN
                   WRITE (*,*) '  Point milieu-fissure ',TLFMI(N)
                ENDIF
                SEGDES, PTMIL
                SEGACT, PTFIS
                IF (IP .EQ. 0) THEN
                   IP = 1
                   N = 1
                   SEGADJ, PTFIS
                   TLFPT(1) = IPT2.NUM(1, IE)
                   IF (IIMPI .EQ. 1) THEN
                      WRITE (*,*) '  Point fissure ',TLFPT(N)
                   ENDIF
                ENDIF
                N = TLFPT(/1) + 1
                SEGADJ, PTFIS
                TLFPT(N) = IPT2.NUM(3, IE)
                IF (IIMPI .EQ. 1) THEN
                   WRITE (*,*) '  Point fissure ',TLFPT(N)
                ENDIF
                SEGDES, PTFIS
   12        CONTINUE
             IF (IPT3.LISOUS(/1).NE.0) SEGDES, IPT2
   13     CONTINUE
          SEGDES, IPT3
       ENDIF
*------------------------------------------------------------------------*
*      Récupération des éléments contenant des noeuds à déplacer         *
*------------------------------------------------------------------------*
       IF (IIMPI.EQ.1) WRITE (*,*) 'RECUPERATION DES ELEMENTS'
       IK = 0
       N = 0
       SEGINI, ELMDP
       SEGDES, ELMDP
       SEGACT, PTFIS
       INP = TLFPT(/1)
       DO 5 IP = 1, INP
          IPOIN = TLFPT(IP)
*----------ON CHERCHE LES ELEMENTS CONTENANT LA POINTE DE FISSURE
          SEGACT, MELEME
          IPT1 = MELEME
          DO 2 IS=1, MAX(1, MELEME.LISOUS(/1))
             IF (MELEME.LISOUS(/1).NE.0) THEN
                IPT1 = MELEME.LISOUS(IS)
                SEGACT IPT1
             ENDIF
             DO 3 IE = 1, IPT1.NUM(/2)
                DO 4 IN = 1, IPT1.NUM(/1)
                   IF (IPT1.NUM(IN, IE) .EQ. IPOIN) THEN
*----------------------ON A TROUVE UN ELEMENT QUI CONTIENT LA POINTE
                      SEGACT, ELMDP
                      IF (TELMM(/1) .EQ. 0) THEN
                         IK = IK + 1
                         N = TELMM(/1) + 1
                         SEGADJ, ELMDP
                         TELMM(N) = IE
                         TTYPL(N) = IPT1.ITYPEL
                         TPFIM(N) = TLFPT(IP)
                         TNUPF(N) = IN
                         IF (MELEME.LISOUS(/1).NE.0) THEN
                            TSOUS(N) = IS
                         ELSE
                            TSOUS(N) = 0
                         ENDIF
                         IF (IIMPI.EQ.1) THEN
                      WRITE (*,*) '  Element : ',IE,' dans ',TSOUS(N)
                      WRITE (*,*) '     fissure : ',TPFIM(N)
                         ENDIF
                      ELSE
                         II = 1
   6   IF(TELMM(II).NE.IE.OR.TSOUS(II).NE.IS.OR.TPFIM(II).NE.IPOIN) THEN
                            II = II + 1
                            IF (II .LE. TELMM(/1)) GOTO 6
                            IK = IK + 1
                            N = TELMM(/1) + 1
                            SEGADJ, ELMDP
                            TELMM(N) = IE
                            TTYPL(N) = IPT1.ITYPEL
                            TPFIM(N) = TLFPT(IP)
                            TNUPF(N) = IN
                            IF (MELEME.LISOUS(/1).NE.0) THEN
                               TSOUS(N) = IS
                            ELSE
                               TSOUS(N) = 0
                            ENDIF
                            IF (IIMPI.EQ.1) THEN
                        WRITE (*,*) '  Element : ',IE,' dans ',TSOUS(N)
                        WRITE (*,*) '     fissure : ',TPFIM(N)
                            ENDIF
                         ENDIF
                      ENDIF
                      SEGDES, ELMDP
                   ENDIF
   4            CONTINUE
   3         CONTINUE
             IF (LISOUS(/1).NE.0) SEGDES, IPT1
   2      CONTINUE
          SEGDES, MELEME
   5   CONTINUE
       SEGDES, PTFIS
*------------------------------------------------------------------------*
*      Récupération des noeuds à déplacer                                *
*------------------------------------------------------------------------*
       N = 0
       IF (IIMPI.EQ.1) WRITE (*,*) 'RECUPERATION DES NOEUDS'
       SEGINI, PTDEP
       SEGDES, PTDEP
       SEGACT, MELEME
       IPT1 = MELEME
       SEGACT, ELMDP
       SEGACT, PTDEP
       IK = 0
*-------POUR CHAQUE ELEMENT SELECTIONNE PRECEDEMMENT
       IF (IIMPI.EQ.1) WRITE (*,*) ' ',TELMM(/1),' Elements à étudier'
       DO 20 IE = 1, ELMDP.TELMM(/1)
          IEFI = ELMDP.TNUPF(IE)
          IF (ELMDP.TTYPL(IE).EQ.6) THEN
             IF (IIMPI.EQ.1) WRITE (*,*) '  Element TRI6 # ', IE
             INBNO = 6
             GOTO 21
          ENDIF
          IF (ELMDP.TTYPL(IE).EQ.10) THEN
             IF (IIMPI.EQ.1) WRITE (*,*) '  Element QUA8 # ', IE
             INBNO = 8
             GOTO 22
          ENDIF
          IF (ELMDP.TTYPL(IE).EQ.15) THEN
             IF (IIMPI.EQ.1) WRITE (*,*) '  Element CU20 # ', IE
             INBNO = 20
             GOTO 23
          ENDIF
          IF (ELMDP.TTYPL(IE).EQ.17) THEN
             IF (IIMPI.EQ.1) WRITE (*,*) '  Element PR15 # ', IE
             INBNO = 15
             GOTO 24
          ENDIF
          IF (ELMDP.TTYPL(IE).EQ.24) THEN
             IF (IIMPI.EQ.1) WRITE (*,*) '  Element TE10 # ', IE
             INBNO = 10
             GOTO 25
          ENDIF
          IF (ELMDP.TTYPL(IE).EQ.26) THEN
             IF (IIMPI.EQ.1) WRITE (*,*) '  Element PY13 # ', IE
             INBNO = 13
             GOTO 26
          ENDIF
          GOTO 20
   21     CONTINUE
***--------CAS DES ELEMENTS TRI6
          IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
          SEGACT, IPT1
          NPMI = 2
          DO 211 IM = 1, NPMI
             TMRAN(IM) = TMTR6(IEFI, IM)
             TERAN(IM) = TETR6(IEFI, IM)
  211     CONTINUE
          GOTO 200
   22     CONTINUE
***--------CAS DES ELEMENTS QUA8
          IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
          SEGACT, IPT1
          NPMI = 2
          DO 212 IM = 1, NPMI
             TMRAN(IM) = TMQU8(IEFI, IM)
             TERAN(IM) = TEQU8(IEFI, IM)
  212     CONTINUE
          GOTO 200
   23     CONTINUE
***--------CAS DES ELEMENTS CU20
          IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
          SEGACT, IPT1
          NPMI = 3
          DO 213 IM = 1, NPMI
             TMRAN(IM) = TMC20(IEFI, IM)
             TERAN(IM) = TEC20(IEFI, IM)
  213     CONTINUE
          GOTO 200
   24     CONTINUE
***--------CAS DES ELEMENTS PR15
          IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
          SEGACT, IPT1
          NPMI = 3
          DO 214 IM = 1, NPMI
             TMRAN(IM) = TMP15(IEFI, IM)
             TERAN(IM) = TEP15(IEFI, IM)
  214    CONTINUE
          GOTO 200
   25     CONTINUE
***--------CAS DES ELEMENTS TE10
          IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
          SEGACT, IPT1
          NPMI = 3
          DO 215 IM = 1, NPMI
             TMRAN(IM) = TMT10(IEFI, IM)
             TERAN(IM) = TET10(IEFI, IM)
  215     CONTINUE
          GOTO 200
   26     CONTINUE
***--------CAS DES ELEMENTS PY13
          IF (ELMDP.TSOUS(IE).NE.0) IPT1 = MELEME.LISOUS(TSOUS(IE))
          SEGACT, IPT1
          IF (IEFI .EQ. 13) THEN
             NPMI = 4
          ELSE
             NPMI = 3
          ENDIF
          DO 216 IM = 1, NPMI
             TMRAN(IM) = TMP13(IEFI, IM)
             TERAN(IM) = TEP13(IEFI, IM)
  216     CONTINUE
***--------RANGEMENT DES POINTS MILIEUX ET DES POINTS EXTREMITES
  200     CONTINUE
          IF (IK .EQ. 0) THEN
             DO 220 IM = 1, NPMI
                 IK = IK + 1
                 N = IK
                 SEGADJ, PTDEP
                 PTDEP.TPOIM(N) = IPT1.NUM(TMRAN(IM), TELMM(IE))
                 PTDEP.TPOIE(N) = IPT1.NUM(TERAN(IM), TELMM(IE))
                 PTDEP.TPFIS(N) = ELMDP.TPFIM(IE)
                 IF (IIMPI .EQ. 1) THEN
               WRITE (*,*) 'POINT MILIEU       : ', PTDEP.TPOIM(N)
               WRITE (*,*) '   Point extremite : ', PTDEP.TPOIE(N)
               WRITE (*,*) '   Point fissure   : ', PTDEP.TPFIS(N)
                 ENDIF
  220        CONTINUE
          ELSE
             DO 230 IM = 1, NPMI
                II = 1
  240      IF (PTDEP.TPOIM(II).NE.IPT1.NUM(TMRAN(IM),TELMM(IE))) THEN
                   IF (II .LE. IK) THEN
                      II = II + 1
                      GOTO 240
                   ELSE
                      IK = IK + 1
                      N = PTDEP.TPOIM(/1) + 1
                      SEGADJ, PTDEP
                      PTDEP.TPOIM(N) = IPT1.NUM(TMRAN(IM), TELMM(IE))
                      PTDEP.TPOIE(N) = IPT1.NUM(TERAN(IM), TELMM(IE))
                      PTDEP.TPFIS(N) = ELMDP.TPFIM(IE)
                      IF (IIMPI .EQ. 1) THEN
               WRITE (*,*) 'POINT MILIEU       : ', PTDEP.TPOIM(N)
               WRITE (*,*) '   Point extremite : ', PTDEP.TPOIE(N)
               WRITE (*,*) '   Point fissure   : ', PTDEP.TPFIS(N)
                      ENDIF
                   ENDIF
                ENDIF
  230        CONTINUE
          ENDIF
          SEGDES, IPT1
   20  CONTINUE
       SEGDES, PTDEP
       SEGDES, ELMDP
       SEGDES, MELEME
*
*------------------------------------------------------------------------*
*      Epuration du tableau contenant les noeuds milieu                  *
*------------------------------------------------------------------------*
       SEGACT, PTDEP
       N = 1
       SEGINI, IPTDP
       IPTDP.TPOIM(1) = PTDEP.TPOIM(1)
       IPTDP.TPFIS(1) = PTDEP.TPFIS(1)
       IPTDP.TPOIE(1) = PTDEP.TPOIE(1)
       DO 50, IP = 2, PTDEP.TPOIM(/1)
          II = 1
   51     IF (IPTDP.TPOIM(II) .NE. PTDEP.TPFIS(IP)) THEN
             II = II + 1
             IF (II .LE. IPTDP.TPOIM(/1)) GOTO 51
             N = IPTDP.TPOIM(/1) + 1
             SEGADJ, IPTDP
             IPTDP.TPOIM(N) = PTDEP.TPOIM(IP)
             IPTDP.TPFIS(N) = PTDEP.TPFIS(IP)
             IPTDP.TPOIE(N) = PTDEP.TPOIE(IP)
          ENDIF
   50  CONTINUE
       SEGDES, IPTDP
       SEGDES, PTDEP
*------------------------------------------------------------------------*
*      Déplacement des noeuds milieu                                     *
*------------------------------------------------------------------------*
*
       SEGACT, IPTDP
       SEGACT, PTMIL
       DO 40, IP = 1, IPTDP.TPOIM(/1)
          IF (PTMIL.TLFMI(/1) .EQ. 0) GOTO 42
          II = 1
   41     IF (TLFMI(II) .NE. IPTDP.TPOIM(IP)) THEN
             II = II + 1
             IF (II .LE. TLFMI(/1)) GOTO 41
             GOTO 42
          ELSE
             GOTO 40
          ENDIF
   42     IF (IIMPI.EQ.1) THEN
             WRITE (*,*) 'Point milieu     : ', IPTDP.TPOIM(IP)
             WRITE (*,*) '   Point fissure : ', IPTDP.TPFIS(IP)
             WRITE (*,*) '   Point extreme : ', IPTDP.TPOIE(IP)
          ENDIF
          ALPE = 0.5*(ALPHA - 1.)*ALPHA
          ALPM = (1. - ALPHA)*(ALPHA + 1)
          ALPF = 0.5*ALPHA*(ALPHA + 1.)
          IRPF = (IDIM + 1)*(IPTDP.TPFIS(IP) - 1)
          IRPM = (IDIM + 1)*(IPTDP.TPOIM(IP) - 1)
          IRPE = (IDIM + 1)*(IPTDP.TPOIE(IP) - 1)
          DO 43 IC = 1, IDIM
             XCOOR(IRPM + IC) = ALPF*XCOOR(IRPF + IC) +
     #              ALPM*XCOOR(IRPM + IC) + ALPE*XCOOR(IRPE + IC)
   43     CONTINUE
   40  CONTINUE
       IF (IIMPI.EQ.1) THEN
          WRITE (*,*) IPTDP.TPOIM(/1), ' noeuds déplacés.'
       ENDIF
       SEGDES, IPTDP
       SEGDES, PTMIL
*------------------------------------------------------------------------*
*      Suppression des segments temporaires                              *
*------------------------------------------------------------------------*
       SEGSUP, IPTDP
       SEGSUP, PTDEP
       SEGSUP, PTMIL
       SEGSUP, PTFIS
       SEGSUP, ELMDP
*
       RETURN
       END