Sources Esope | Cast3M

dyne34
C DYNE34    SOURCE    BP208322  20/09/18    21:16:26     10718          
      SUBROUTINE DYNE34(IPOIN1,IPOIN2,NUMEL1,NUMEL2,XP,YP,XPP,YPP,
     &                 XPALB,IPALB,XPTB,NLIAB,NPLB,I,NPOI,ID1,IP1,IND,
     &                 XBARY,YBARY)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*--------------------------------------------------------------------*
*                                                                    *
*     Op{rateur DYNE : algorithme de Fu - de Vogelaere               *
*     ________________________________________________               *
*                                                                    *
*     calcule les coordonn{es du barycentre form{ par les points     *
*     IPOIN1, IPOIN2, P, PP, NUMEL1 et NUMEL2.                       *
*                                                                    *
*     Param}tres:                                                    *
*                                                                    *
* e   IPOIN1  point du profil mobile                                 *
* e   IPOIN2  point du profil mobile                                 *
* e   NUMEL1  {l{ment du profil fixe                                 *
* e   NUMEL2  {l{ment du profil fixe                                 *
* e   I       num{ro de la liaison trait{e                           *
* e   XP,YP   coordonn{es du point P d'intersection                  *
* e   XPP,YPP coordonn{es du point PP d'intersection                 *
* e   NLIAB   nombre total de liaisons                               *
*  s  XBARY   coordonn{e suivant X                                   *
*  s  YBARY   coordonn{e suivant Y                                   *
*                                                                    *
*     Auteur, date de cr{ation:                                      *
*                                                                    *
*     Lionel VIVAN, le 1 f{vrier 1991.                               *
*                                                                    *
*--------------------------------------------------------------------*
*
      INTEGER IPALB(NLIAB,*)
      REAL*8 XPTB(NPLB,2,*),XPALB(NLIAB,*)
      PARAMETER ( ZERO = 0.D0 )
*
      ITYP   = IPALB(I,1)
      IDIM   = IPALB(I,3)
      NOMBN1 = IPALB(I,4)
      NOMBN2 = IPALB(I,5)
      ID2 = ID1 + IDIM
      ID3 = ID1 + 2*IDIM
      ID4 = ID1 + 3*IDIM
      ID6 = ID1 + 5*IDIM
      ID7 = ID6 + IDIM*NOMBN1
*
      XBARY = XP + XPP
      YBARY = YP + YPP
      ICAS = 0
      IF (IPOIN1.EQ.IPOIN2 ) THEN
         NBPOIN = 1
      ELSE IF (IPOIN1.GT.IPOIN2 ) THEN
         ICAS = 1
         NBPOIN = 2
         I2 = IPOIN1
 2       CONTINUE
         I2 = I2 - 1
         IF (I2.EQ.0) I2 = NOMBN2
         IF (I2.EQ.IPOIN2) GOTO 4
         NBPOIN = NBPOIN + 1
         GOTO 2
 4       CONTINUE
      ELSE
         ICAS = 2
         NBPOIN = 2
         I6 = IPOIN2
 6       CONTINUE
         I6 = I6 + 1
         IF (I6.EQ.(NOMBN2+1)) I6 = 1
         IF (I6.EQ.IPOIN1) GOTO 8
         NBPOIN = NBPOIN + 1
         GOTO 6
 8       CONTINUE
      ENDIF
      IF (ICAS.EQ.1) THEN
         IPT1 = IPOIN1
      ELSE
         IPT1 = IPOIN2
      ENDIF
      DO 10 IP = 1,NBPOIN
         IF (IPT1.EQ.(NOMBN2+1)) IPT1 = 1
         IF (IPT1.EQ.0) IPT1 = NOMBN2
         IPT2 = ID7 + IDIM*(IPT1-1)
         XP1 = ZERO
         YP1 = ZERO
         DO 12 ID = 1,IDIM
            XX1 = XPTB(NPOI,1,ID) + XPALB(I,IPT2+ID)
     &                              - XPALB(I,ID2+ID)
            XP1 = XP1 + ( XX1 * XPALB(I,ID3+ID) )
            YP1 = YP1 + ( XX1 * XPALB(I,ID4+ID) )
 12         CONTINUE
*        end do
         XBARY = XBARY + XP1
         YBARY = YBARY + YP1
         IF (ICAS.EQ.1) THEN
            IPT1 = IPT1 - 1
         ELSE
            IPT1 = IPT1 + 1
         ENDIF
 10      CONTINUE
*     end do
      NBPOI2 = 0
      IF (NUMEL1.NE.NUMEL2) THEN
         NBPOI2 = 1
         IF (ITYP.EQ.31) THEN
*           les num{ros d'{l{ments croissent
            I6 = NUMEL1
 40         CONTINUE
            I6 = I6 + 1
            IF (I6.EQ.(NOMBN1+1)) I6 = 1
            IF (I6.EQ.NUMEL2) GOTO 42
            NBPOI2 = NBPOI2 + 1
            GOTO 40
 42         CONTINUE
         ELSE
*           les num{ros d'{l{ments d{croissent
            I2 = NUMEL1
 30         CONTINUE
            I2 = I2 - 1
            IF (I2.EQ.0) I2 = NOMBN1
            IF (I2.EQ.NUMEL2) GOTO 32
            NBPOI2 = NBPOI2 + 1
            GOTO 30
 32         CONTINUE
         ENDIF
         IE1 = NUMEL1
         DO 20 IE = 1,NBPOI2
            IF (ITYP.EQ.31) THEN
*              les num{ros d'{l{ments croissent
               IE1 = IE1 + 1
               IF (IE1.EQ.(NOMBN1+1)) IE1 = 1
               IE2 = ID6 + IDIM*(IE1-1)
            ELSE
*              les num{ros d'{l{ments d{croissent
               IE2 = ID6 + IDIM*(IE1-1)
               IE1 = IE1 - 1
               IF (IE1.EQ.0) IE1 = NOMBN1
            ENDIF
            XE1 = ZERO
            YE1 = ZERO
            DO 22 ID = 1,IDIM
               XX1 = XPALB(I,IE2+ID) - XPALB(I,ID2+ID)
               XE1 = XE1 + ( XX1 * XPALB(I,ID3+ID) )
               YE1 = YE1 + ( XX1 * XPALB(I,ID4+ID) )
 22            CONTINUE
*           end do
            XBARY = XBARY + XE1
            YBARY = YBARY + YE1
 20         CONTINUE
*        end do
      ENDIF
      NBPOIT = 2 + NBPOIN + NBPOI2
      XBARY = XBARY / NBPOIT
      YBARY = YBARY / NBPOIT
*
      END