C LISPBS    SOURCE    CHAT      05/01/13    01:22:33     5004
      SUBROUTINE LISPBS(WORK,VELA,POIGAU,SHPTOT,
     1   NBPGAU,NBNO,XE,XFOLO,BPSS,XFORC)
C=====================================================================
C  ENTREES
C
C    WORK(NSTRS*NBPGAU) = CONTIEND LES CONTRAINTES DU LINESPRING
C    VELA(5*NBPGAU) = CARACTERISTIQUES
C    POIGAU(NBPGAU) = POIDS D INTEGRATION
C    SHPTOT(6,NBNO,NBPGAU) = FONCTIONS DE FORME
C    NBPGAU         = NOMBRE DE POINT D INTEGRATION
C    NBNO           = NOMBRE DE POINT DE L ELEMENT
C    XE(3,4)        = CORRDONEES DE L ELEMENT
C  TRAVAIL
C    XFOLO(LRE)     =     FORCES LOCALES
C    BPSS(3,3)      =     MATRICE DE PASSAGE
C  SORTIES
C    XFORC(LRE)     = FORCE NODALES
C       EBERSOLT AVRIL 86      ON SUPPOSE L EPAISSEUR CONSTANTE
C====================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER(UNSIX=.166666666666666D0,XZER=0.D0,DEUX=2.D0)
      PARAMETER(UN=1.D0)
      DIMENSION WORK(*),POIGAU(*),SHPTOT(6,NBNO,*)
      DIMENSION XFORC(*),XE(3,*),BPSS(3,*),XFOLO(*),VELA(*)
      DIMENSION XEP(6),XEL(3,3),IL(6)
C
      DATA IL/2,3,1,4,1,5/
C
      XEP(1)= UN
      XEP(2)= UN
      XEP(3)= UN
      XEP(4)= UN
      XEP(5)= XZER
      XEP(6)= UN
C
C    ON CALCULE LA MATRICE DE PASSAGE
C
      XEL(1,1)=XE(1,1)
      XEL(2,1)=XE(2,1)
      XEL(3,1)=XE(3,1)
      XX=(XE(1,1)-XE(1,2))*(XE(1,1)-XE(1,2))
     1  +(XE(2,1)-XE(2,2))*(XE(2,1)-XE(2,2))
     1  +(XE(3,1)-XE(3,2))*(XE(3,1)-XE(3,2))
      XX=SQRT(XX)
C
      XEL(1,2)=XE(1,2)
      XEL(2,2)=XE(2,2)
      XEL(3,2)=XE(3,2)
C
      XEL(1,3)=XE(1,1)+VELA(3)
      XEL(2,3)=XE(2,1)+VELA(4)
      XEL(3,3)=XE(3,1)+VELA(5)
C
      CALL VPAST(XEL,BPSS)
C
      DO 500 IA=1,6
      XEP(IA)=XEP(IA)*XX
  500 CONTINUE
C
      DO 100 IA=1,NBNO
      IF(IA.EQ.1.OR.IA.EQ.2) YY= UN
      IF(IA.EQ.3.OR.IA.EQ.4) YY=-UN
      DO 300 IC=1,6
      CC=XZER
      IX=IC+(IA-1)*6
      DO 200 IB=1,NBPGAU
      IJ=IL(IC)+(IB-1)*6
      CC=CC+SHPTOT(1,IA,IB)*WORK(IJ)*POIGAU(IB)*XEP(IC)*YY
  200 CONTINUE
      XFOLO(IX)=CC
  300 CONTINUE
  100 CONTINUE
C
      CALL TRPOSE(BPSS)
      CALL MATVEC(XFOLO,XFORC,BPSS,8)
C
      RETURN
      END