Sources Esope | Cast3M

bprima
C BPRIMA    SOURCE    CHAT      05/01/12    21:42:30     5004
      SUBROUTINE BPRIMA(IGAU,ITEL,MFR,NBNO,LRE,IFOU,NST,NN,DIM3,
     1                            XEL,SHPTOT,SHP,GRAD,BPRIM,DJAC)
C=======================================================================
C
C                 CALCULE LA MATRICE BPRIM
C
C          ROUTINE FORTRAN PUR
C          CODE SUO X.Z   JUILLET 1987
C=======================================================================
C  INPUT
C     IGAU=NUMERO DU POINT DE GAUSS
C     ITEL=NUMERO DE L ELEMENT DANS NOMTP
C     MFR =NUMERO DE LA FORMULATION
C     NBNO=NOMBRE DE NOEUDS
C     LRE =NOMBRE DE COLONNES DE LA MATRICE B
C     IFOU=IFOUR DE CCOPTIO
C     NST =NOMBRE DE COMPOSANTES DE CONTRAINTES
C     NN  =NUMERO DU MODE DE FOURIER
C     DIM3=EPAISSEUR (MASSIF CONTRAINTES PLANES)
C     XEL =COORDONNEES  DE L ELEMENT
C     SHPTOT(6,NBNO,NBGAU)=FONCTIONS DE FORMES ET DERIVEES
C     GRAD(9)=GRADIENTS DE THETA
C  ZONE DE TRAVAIL
C     SHP(6,NBNO)=TABLEAU DE TRAVAIL
C  OUTPUT
C     DJAC=JACOBIEN
C     BPRIM(6,LRE)=MATRICE B
C=======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION XEL(3,*),BPRIM(NST,*),SHP(6,*),SHPTOT(6,NBNO,*)
      DIMENSION BB(3,9),GEOM(20),XX(3),YY(3),GRAD(*)
      DATA XX/.5D0,.0D0,.5D0/
      DATA YY/.0D0,.5D0,.5D0/
C
      CALL ZERO(BPRIM,NST,LRE)
C
      IFR=IFOU+4
      IF (ITEL.EQ.28.OR.ITEL.EQ.45) GOTO 28
      GOTO (666,10,10,20,30,40) ,IFR
      GOTO 666
C
C     ELEMENTS MASSIFS BIDIM   CONTRAINTES PLANES OU DEFRMTNS PLANES
C
  10  CONTINUE
      DO 101 NP=1,NBNO
      SHP(1,NP)=SHPTOT(1,NP,IGAU)
      SHP(2,NP)=SHPTOT(2,NP,IGAU)
      SHP(3,NP)=SHPTOT(3,NP,IGAU)
  101 CONTINUE
      CALL DEVOLU(XEL,SHP,MFR,NBNO,IFOU,NN,2,DIM3,RR,DJAC)
      K=1
      DO 102 NP=1,NBNO
      BPRIM(1,K  )=SHP(2,NP)*GRAD(1)+SHP(3,NP)*GRAD(4)
      BPRIM(2,K+1)=SHP(2,NP)*GRAD(2)+SHP(3,NP)*GRAD(5)
      BPRIM(4,K+1)=BPRIM(1,K)
      BPRIM(4,K  )=BPRIM(2,K+1)
  102 K=K+2
      GOTO  666
C
C     ELEMENTS MASSIFS BIDIM AXISYMETRIQUE
C
  20  CONTINUE
      DO 201 NP=1,NBNO
      SHP(1,NP)=SHPTOT(1,NP,IGAU)
      SHP(2,NP)=SHPTOT(2,NP,IGAU)
      SHP(3,NP)=SHPTOT(3,NP,IGAU)
  201 CONTINUE
      CALL DEVOLU(XEL,SHP,MFR,NBNO,IFOU,NN,2,DIM3,RR,DJAC)
      K=1
      DO 202 NP=1,NBNO
      BPRIM(1,K  )=SHP(2,NP)*GRAD(1)+SHP(3,NP)*GRAD(4)
      BPRIM(2,K+1)=SHP(2,NP)*GRAD(2)+SHP(3,NP)*GRAD(5)
      BPRIM(3,K)=SHP(1,NP)/RR*GRAD(9)
      BPRIM(4,K+1)=BPRIM(1,K)
      BPRIM(4,K  )=BPRIM(2,K+1)
  202 K=K+2
      GOTO  666
C
C     ELEMENTS MASSIFS BIDIM FOURIER
C
  30  CONTINUE
      DO 301 NP=1,NBNO
      SHP(1,NP)=SHPTOT(1,NP,IGAU)
      SHP(2,NP)=SHPTOT(2,NP,IGAU)
      SHP(3,NP)=SHPTOT(3,NP,IGAU)
  301 CONTINUE
      CALL DEVOLU(XEL,SHP,MFR,NBNO,IFOU,NN,2,DIM3,RR,DJAC)
      XNSUR=DBLE(NN)/RR
      K=1
      DO 302 NP=1,NBNO
      BPRIM(1,K  )= SHP(2,NP)*GRAD(1)+SHP(3,NP)*GRAD(4)-
     1              XNSUR*SHP(1,NP)*GRAD(7)
      BPRIM(1,K+2)= -SHP(1,NP)*GRAD(7)/RR
      BPRIM(2,K+1)= SHP(2,NP)*GRAD(2)+SHP(3,NP)*GRAD(5)-
     1              XNSUR*SHP(1,NP)*GRAD(8)
      BPRIM(3,K  )= SHP(1,NP)/RR*GRAD(9)
      BPRIM(3,K+2)= SHP(2,NP)*GRAD(3)+SHP(3,NP)*GRAD(6)+
     1              XNSUR*SHP(1,NP)*GRAD(9)
      BPRIM(4,K  )= BPRIM(2,K+1)
      BPRIM(4,K+1)= BPRIM(1,K  )
      BPRIM(4,K+2)=-SHP(1,NP)*GRAD(8)/RR
      BPRIM(5,K  )= SHP(2,NP)*GRAD(3)+SHP(3,NP)*GRAD(6)-
     1              XNSUR*SHP(1,NP)*GRAD(9)+SHP(1,NP)*GRAD(7)/RR
      BPRIM(5,K+2)= SHP(2,NP)*GRAD(1)+SHP(3,NP)*GRAD(4)+
     1              XNSUR*SHP(1,NP)*GRAD(7)-SHP(1,NP)*GRAD(9)/RR
      BPRIM(6,K  )= SHP(1,NP)*GRAD(8)/RR
      BPRIM(6,K+1)= SHP(2,NP)*GRAD(3)+SHP(3,NP)*GRAD(6)-
     1              XNSUR*SHP(1,NP)*GRAD(9)
      BPRIM(6,K+2)= SHP(2,NP)*GRAD(2)+SHP(3,NP)*GRAD(5)+
     1              XNSUR*SHP(1,NP)*GRAD(8)
  302 K=K+3
      GOTO  666
C
C     ELEMENTS MASSIFS TRIDIM
C
  40  CONTINUE
      DO 401 NP=1,NBNO
      SHP(1,NP)=SHPTOT(1,NP,IGAU)
      SHP(2,NP)=SHPTOT(2,NP,IGAU)
      SHP(3,NP)=SHPTOT(3,NP,IGAU)
      SHP(4,NP)=SHPTOT(4,NP,IGAU)
  401 CONTINUE
      CALL DEVOLU(XEL,SHP,MFR,NBNO,IFOU,NN,3,DIM3,RR,DJAC)
      K=1
      DO 402 NP=1,NBNO
      BPRIM(1,K  )=SHP(2,NP)*GRAD(1)+SHP(3,NP)*GRAD(4)+
     1             SHP(4,NP)*GRAD(7)
      BPRIM(2,K+1)=SHP(2,NP)*GRAD(2)+SHP(3,NP)*GRAD(5)+
     1             SHP(4,NP)*GRAD(8)
      BPRIM(3,K+2)=SHP(2,NP)*GRAD(3)+SHP(3,NP)*GRAD(6)+
     1             SHP(4,NP)*GRAD(9)
      BPRIM(4,K  )=BPRIM(2,1+K)
      BPRIM(4,K+1)=BPRIM(1,K  )
      BPRIM(5,K  )=BPRIM(3,2+K)
      BPRIM(5,K+2)=BPRIM(1,K  )
      BPRIM(6,K+1)=BPRIM(3,2+K)
      BPRIM(6,K+2)=BPRIM(2,1+K)
  402 K=K+3
      GOTO  666
C
C  28 IEME   ELEMENT :   DKT  ( N'EXISTER PAS )
C
  28  CONTINUE
      DO 127 NPOI=1,NBNO
      SHP(1,NPOI)=SHPTOT(1,NPOI,IGAU)
      SHP(2,NPOI)=SHPTOT(2,NPOI,IGAU)
      SHP(3,NPOI)=SHPTOT(3,NPOI,IGAU)
  127 CONTINUE
      CALL DEVOLU(XEL,SHP,MFR,NBNO,IFOU,NN,2,DIM3,RR,DJAC)
      K=1
      DO 227 NPOI=1,NBNO
      BPRIM(1,K  )=SHP(2,NPOI)
      BPRIM(1,K+1)=0.D0
      BPRIM(2,K  )=0.D0
      BPRIM(2,K+1)=SHP(3,NPOI)
      BPRIM(3,K  )=SHP(3,NPOI)
      BPRIM(3,K+1)=SHP(2,NPOI)
  227 K=K+6
      CALL GEOCST(XEL,GEOM)
      CALL BFDKT(XX(IGAU),YY(IGAU),GEOM,BB)
      DJAC=GEOM(17)
      K=2
      KK=0
      DO 327 NPOI=1,3
      DO 427 IX=1,3
      DO 527 IY=1,3
      BPRIM(3+IX,K+IY)=BB(IX,IY+KK)
  527 CONTINUE
  427 CONTINUE
      KK=KK+3
  327 K=K+6
 666  CONTINUE
      RETURN
      END