Sources Esope | Cast3M

lispr3
C LISPR3    SOURCE    CHAT      05/01/13    01:23:34     5004
      SUBROUTINE LISPR3(XE,EPA1,FISS1,V1,EPA2,FISS2,V2,D,XEL,BPSS,
     1  REL,I70,I343,I157,I158)
C=======================================================================
C
C      EBERSOLT MARS 85
C  ENTREES
C    XE(3,4)     = COORDONNEES DE LA POUTRE LINESPRING
C    EPA1        = EPAISSEUR NOEUDS 1 4
C    EPA2        = EPAISSEUR NOEUDS 2 3
C    FISS1       = PROFONDEUR DE LA FISSURE NOEUDS 1 4
C    FISS2       = PROFONDEUR DE LA FISSURE NOEUDS 2 3
C    V1(3)       = VECTEUR ORIENTANT LES NOEUDS 1 4
C    V2(3)       = VECTEUR ORIENTANT LES NOEUDS 2 3
C    D(2,2)      = MATRICE DE HOOKE
C  TABLEAU DE TRAVAIL
C    XEL(3,3)    = COORDONNEES LOCALES
C    BPSS(3,3)   = MATRICE DE PASSAGE
C  SORTIES
C    REL(24,24)  = MATRICE DE  RIGIDITE  AXES GLOBAUX
C    I70         = INDICERNABILITE DES 2 LEVRES
C    I343        = PROFONDEUR DE FISSURE NEGATIVE
C    I157        = LES 2 LEVRES SONT TROP ELOIGNEES
C    I158        = FISSURE TOTALEMENT TRAVERSANTE    RIGIDITE NULLE
C
C=======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER ( PENA = 1.D6,PENB = 1.D2 )
      PARAMETER ( EPS = 1.D-3,EPSINV = 1.D-3)
      PARAMETER ( XZER=0.D0,UNDEMI=.5D0,DEUX=2.D0,SIX=6.D0)
      PARAMETER ( QUATRE=4.D0,DOUZE=12.D0,TRSIX=36.D0)
      PARAMETER ( NPOINT=3,IZERO=0)
      PARAMETER ( X774=.774596669241483D0)
 
      DIMENSION XE(3,*),D(2,*),REL(24,*),V1(*),V2(*),BPSS(3,*),XEL(3,*)
      DIMENSION S(3),POIDS(3)
C
C
      S(1)=-X774
      S(2)= XZER
      S(3)= X774
      POIDS(1)=5.D0/9.D0
      POIDS(2)=8.D0/9.D0
      POIDS(3)=5.D0/9.D0
C
C     LES FISS1 ET FISS2 QUE L ON RECUPERE SONT AUX POINTS DE GAUSS
C     IL FAUT LES CALCULER AUX EXTREMITES
C
      FIS10 = (FISS1*(UNDEMI +UNDEMI/X774))+(FISS2*(UNDEMI-UNDEMI/X774))
      FIS20 = (FISS1*(UNDEMI -UNDEMI/X774))+(FISS2*(UNDEMI+UNDEMI/X774))
C
C     MISE A XZER DE LA RIGIDITE  ET DES INDICATEURS D ERREUR
C
      CALL ZERO(REL,24,24)
      I70 =0
      I343=0
      I157=0
      I158=0
C
      IF(FIS10.LT.XZER) THEN
      I343=1
      FIS10=XZER
      ENDIF
C
      IF(FIS20.LT.XZER) THEN
      I343=1
      FIS20=XZER
      ENDIF
C
C     EXTRACTION DE LA MATRICE DE PASSAGE
C
      DO 100 IA=1,3
      XEL(IA,1)=XE(IA,1)
      XEL(IA,2)=XE(IA,2)
      XEL(IA,3)=XE(IA,1)+(V1(IA)+V2(IA))*UNDEMI
 100  CONTINUE
      CALL VPAST(XEL,BPSS)
      DJA1=XZER
      DJA2=XZER
      DO 105 IA=1,3
      DJA1=DJA1+(XE(IA,1)-XE(IA,4))*BPSS(3,IA)
      DJA2=DJA2+(XE(IA,2)-XE(IA,3))*BPSS(3,IA)
 105  CONTINUE
      DJAC=DJA1*DJA2
      IF(DJAC.LT.0.) I195=1
C
C     HAUT  = LARGEUR ENTRE LES NOEUDS 1,4 ET 2,3
C
      HAUT=XZER
      XLARG1=XZER
      XLARG2=XZER
      DO 110 IA=1,3
      HAUT  =(XE(IA,2)-XE(IA,1))*(XE(IA,2)-XE(IA,1))+HAUT
      XLARG1=(XE(IA,4)-XE(IA,1))*(XE(IA,4)-XE(IA,1))+XLARG1
      XLARG2=(XE(IA,3)-XE(IA,2))*(XE(IA,3)-XE(IA,2))+XLARG2
  110 CONTINUE
      HAUT  =SQRT(HAUT)
      XLARG1=SQRT(XLARG1)
      XLARG2=SQRT(XLARG2)
      EPS1=XLARG1/HAUT
      EPS2=XLARG2/HAUT
      IF(EPS1.GT.EPS.OR.EPS2.GT.EPS) I157=1
      DJA1=DJA1/HAUT
      DJA2=DJA2/HAUT
      IF(DJA1.LT.1.D-3.AND.DJA2.LT.1.D-3) I70=1
C
C     ASURW  = A  /  W   NOTATION CHEISSOUX
C
      W=(EPA1+EPA2)*UNDEMI
      ASURW=(FIS10+FIS20)/W
      ASUR1=FIS10/W
      ASUR2=FIS20/W
      IF(ASUR1.GT..98.AND.ASUR2.GT..98) I158=1
      IF(I158.EQ.1) GOTO 666
C
C       PENALISATION NORMALE
C
      PEWM=D(1,1)*W*PENA*HAUT/SIX
      PEWF=PEWM*W*W/DOUZE
      PEWM2=DEUX*PEWM
      PEWF2=DEUX*PEWF
C
C       PENALISATION SOUS INTEGRE
C
      PEWM15=D(1,1)*W*PENB*HAUT/QUATRE
      PEWF15=PEWM15*W*W/DOUZE
C
C       PENALISATION SI ELEMENT EXTREME
C
      PEWMEX=D(1,1)*W*PENA*HAUT*UNDEMI
      PEWFEX=PEWMEX*W*W/DOUZE
C
C     PENALISATION DES TERMES CONCERNANT K I SI FISSURE INEXISTANTE
C
      IF(ASURW.GT.EPSINV) GOTO 366
      REL(3 ,3 )=PEWM2
      REL(4 ,4 )=PEWF2
      REL(9 ,9 )=PEWM2
      REL(10,10)=PEWF2
      REL(3 ,9 )=PEWM
      REL(9 ,3 )=PEWM
      REL(4 ,10)=PEWF
      REL(10,4 )=PEWF
      GOTO 466
  366 CONTINUE
C
C     INTEGRATION NORMALE
C
      X1=XZER
      X2=XZER
      X3=XZER
      X4=XZER
      X5=XZER
      X6=XZER
      X7=XZER
      X8=XZER
      X9=XZER
      DO 500 IA=1,NPOINT
      H1=UNDEMI-UNDEMI*S(IA)
      H2=UNDEMI+UNDEMI*S(IA)
      ASURW=H1*ASUR1+H2*ASUR2
      CALL LISPAL(ASURW,ALMM,ALMF,ALFF,DELTA)
      DELTA=POIDS(IA)*D(1,1)*HAUT*UNDEMI/DELTA
C
      X1=X1+H1*H1*DELTA*ALFF
      X2=X2-H1*H1*DELTA*ALMF*W/SIX
      X3=X3+H1*H1*DELTA*ALMM*W*W/TRSIX
C
      X4=X4+H1*H2*DELTA*ALFF
      X5=X5-H1*H2*DELTA*ALMF*W/SIX
      X6=X6+H1*H2*DELTA*ALMM*W*W/TRSIX
C
      X7=X7+H2*H2*DELTA*ALFF
      X8=X8-H2*H2*DELTA*ALMF*W/SIX
      X9=X9+H2*H2*DELTA*ALMM*W*W/TRSIX
  500 CONTINUE
C
C     MISE EN PLACE DANS LA MATRICE DE RIGIDITE
C
      REL(3 ,3 )=X1
      REL(3 ,4 )=X2
      REL(4 ,3 )=X2
      REL(4 ,4 )=X3
C
      REL(9 ,3 )=X4
      REL(9 ,4 )=X5
      REL(10,3 )=X5
      REL(10,4 )=X6
C
      REL(3 ,9 )=X4
      REL(3 ,10)=X5
      REL(4 ,9 )=X5
      REL(4 ,10)=X6
C
      REL(9 ,9 )=X7
      REL(9 ,10)=X8
      REL(10,9 )=X8
      REL(10,10)=X9
C
C     PENALISATION DES TERMES NE CONCERNANT PAS K I
C
  466 CONTINUE
C
      REL(1 ,1 )=PEWM15
      REL(2 ,2 )=PEWM15
      REL(6 ,6 )=PEWF15
C
      REL(7 ,7 )=PEWM15
      REL(8 ,8 )=PEWM15
      REL(12,12)=PEWF15
C
      REL(1 ,7 )=PEWM15
      REL(7 ,1 )=PEWM15
      REL(2 ,8 )=PEWM15
      REL(8 ,2 )=PEWM15
      REL(6 ,12)=PEWF15
      REL(12,6 )=PEWF15
C
C     DOUBLE SYMETRISATION A PARTIR D UNE MATRICE 12 12 ON A UNE 24  24
C
      DO 900 IA=1,6
      DO 900 IB=1,6
C
      REL(IA+18,IB+18)= REL(IA  ,IB  )
      REL(IA   ,IB+18)=-REL(IA  ,IB  )
      REL(IA+18,IB   )=-REL(IA  ,IB  )
C
      REL(IA+12,IB+12)= REL(IA+6,IB+6)
      REL(IA+6 ,IB+12)=-REL(IA+6,IB+6)
      REL(IA+12,IB+6 )=-REL(IA+6,IB+6)
C
      REL(IA+12,IB+18)= REL(IA+6,IB  )
      REL(IA+18,IB+12)= REL(IA+6,IB  )
C
      REL(IA   ,IB+12)=-REL(IA+6,IB  )
      REL(IA+12,IB   )=-REL(IA+6,IB  )
C
      REL(IA+18,IB+6 )=-REL(IA+6,IB  )
      REL(IA+6 ,IB+18)=-REL(IA+6,IB  )
C
 900  CONTINUE
C
C      CHANGEMENT DU REPERE    EN FONCTION DE BPSS
C
      CALL TRANSK(REL,BPSS,24,4,IZERO)
C
  666 CONTINUE
      RETURN
      END