Télécharger la plaquette Cast3M


fr en

Télécharger lisps2.eso

Retour à la liste

Numérotation des lignes : 

lisps2

  1. C LISPS2    SOURCE    CHAT      05/01/13    01:23:42     5004
  2.       SUBROUTINE LISPS2(XE,EPA1,FISS1,V1,EPA2,FISS2,V2,D,XDDL,XEL,BPSS,
  3.      1     XDDLOC,NPOINT,XSTRS,I69,I70,I195,I157)
  4. C=======================================================================
  5. C
  6. C  EBERSOLT MARS 85
  7. C  UHLMANN  OCTOBRE 94
  8. C
  9. C  ENTREES
  10. C    XE(3,4)     = COORDONNEES DE LA POUTRE LINESPRING
  11. C    EPA1        = EPAISSEUR NOEUDS 1 4
  12. C    EPA2        = EPAISSEUR NOEUDS 2 3
  13. C    FISS1       = PROFONDEUR DE LA FISSURE NOEUDS 1 4
  14. C    FISS2       = PROFONDEUR DE LA FISSURE NOEUDS 2 3
  15. C    V1(3)       = VECTEUR ORIENTANT LES NOEUDS 1 4
  16. C    V2(3)       = VECTEUR ORIENTANT LES NOEUDS 2 3
  17. C    D(2,2)      = MATRICE DE HOOKE
  18. C    XDDL(24)    = D.D.L. DU LINESPRING
  19. C    NPOINT      = NOMBRE DE POINTS DE CONTRAINTES
  20. C  TABLEAU DE TRAVAIL
  21. C    XEL(3,3)    = COORDONNEES LOCALES
  22. C    BPSS(3,3)   = MATRICE DE PASSAGE
  23. C    XDDLOC(24)  = D.D.L. LOCAUX
  24. C  SORTIES
  25. C    XSTRS(NPOINT*6)= CONTRAINTES LINESPRING
  26. C    I69         = FISSURE TOTALEMENT TRAVERSANTE  CONTRAINTES MISES A 0
  27. C    I70         = INDICERNABILITE DES 2 LEVRES
  28. C    I343        = PROFONDEUR DE FISSURE NULLE
  29. C    I157        = LES 2 LEVRES SONT TROP ELOIGNEES
  30. C
  31. C=======================================================================
  32. C
  33.       IMPLICIT INTEGER(I-N)
  34.       IMPLICIT REAL*8(A-H,O-Z)
  35. C    Include contenant quelques constantes dont XPI :
  36. -INC CCREEL
  37.       PARAMETER(UNDEMI=.5D0,SIX=6.D0)
  38.       PARAMETER(DOUZE=12.D0,TRSIX=36.D0)
  39.       PARAMETER(EPS=2.D-3,PENA=1.D6,EPSINV=1.D-3,PENB=1.D6)
  40.       PARAMETER(X774=.774596669241483D0)
  41. C
  42.       DIMENSION XE(3,*),D(2,*),XSTRS(*),V1(*),V2(*),BPSS(3,*),XEL(3,*)
  43.       DIMENSION S(3),XDDL(*),XDDLOC(*)
  44. C
  45.       IF(NPOINT.EQ.1) THEN
  46.          S(1)= XZERO
  47.       ELSE IF(NPOINT.EQ.3) THEN
  48.          S(1)=-X774
  49.          S(2)= XZERO
  50.          S(3)= X774
  51.       ENDIF
  52. C
  53. C    ON RECUPERE LES FISS AUX POINTS DE GAUSS IL FAUT LES CALCULER
  54. C          AUX EXTREMITES
  55. C
  56.       FISS1 = (FISS1*(UNDEMI +UNDEMI/X774))+(FISS2*(UNDEMI-UNDEMI/X774))
  57.       FISS2 = (FISS1*(UNDEMI -UNDEMI/X774))+(FISS2*(UNDEMI+UNDEMI/X774))
  58. C
  59.       NPOIN6=6*NPOINT
  60. C
  61. C     MISE A ZERO DES CONTRAINTES  DES INDICATEURS D ERREURS ET DES D.D.
  62. C
  63.       DO  90 IA=1,NPOIN6
  64.          XSTRS(IA)=XZERO
  65.  90   CONTINUE
  66.       I69 =0
  67.       I70 =0
  68. C      I343=0
  69.       I157=0
  70.       I195=0
  71. C
  72.       IF(FISS1.LT.XZERO) THEN
  73. C         I343=1
  74.          FISS1=XZERO
  75.       ENDIF
  76. C
  77.       IF(FISS2.LT.XZERO) THEN
  78. C         I343=1
  79.          FISS2=XZERO
  80.       ENDIF
  81. C
  82. C     EXTRACTION DE LA MATRICE DE PASSAGE:
  83. C
  84.       DO 100 IA=1,3
  85.          XEL(IA,1)=XE(IA,1)
  86.          XEL(IA,2)=XE(IA,2)
  87.          XEL(IA,3)=XE(IA,1)+(V1(IA)+V2(IA))*UNDEMI
  88.  100  CONTINUE
  89. C
  90. C-----------------------------------------------
  91.       CALL VPAST(XEL,BPSS)
  92.       CALL MATVEC(XDDL,XDDLOC,BPSS,8)
  93. C-----------------------------------------------
  94. C     système local: x,y et z
  95. C     Noeud 1 (_NO1):
  96. C      XNO1=(XE(1,1)*BPSS(1,1))+(XE(2,1)*BPSS(1,2))+(XE(3,1)*BPSS(1,3))
  97. C      YNO1=(XE(1,1)*BPSS(2,1))+(XE(2,1)*BPSS(2,2))+(XE(3,1)*BPSS(2,3))
  98. C      ZNO1=(XE(1,1)*BPSS(3,1))+(XE(2,1)*BPSS(3,2))+(XE(3,1)*BPSS(3,3))
  99. C     Noeud2  (_NO2):
  100. C      XNO2=(XE(1,2)*BPSS(1,1))+(XE(2,2)*BPSS(1,2))+(XE(3,2)*BPSS(1,3))
  101. C      YNO2=(XE(1,2)*BPSS(2,1))+(XE(2,2)*BPSS(2,2))+(XE(3,2)*BPSS(2,3))
  102.       ZNO2=(XE(1,2)*BPSS(3,1))+(XE(2,2)*BPSS(3,2))+(XE(3,2)*BPSS(3,3))
  103. C     Noeud 3 (_NO3):
  104. C      XNO3=(XE(1,3)*BPSS(1,1))+(XE(2,3)*BPSS(1,2))+(XE(3,3)*BPSS(1,3))
  105. C      YNO3=(XE(1,3)*BPSS(2,1))+(XE(2,3)*BPSS(2,2))+(XE(3,3)*BPSS(2,3))
  106.       ZNO3=(XE(1,3)*BPSS(3,1))+(XE(2,3)*BPSS(3,2))+(XE(3,3)*BPSS(3,3))
  107. C
  108. C     Direction z: Différence entre noeud 2 et noeud 3:
  109.       DZ23 = ZNO2 - ZNO3
  110. C     ________________________________________________________________
  111. C
  112.       DJA1=XZERO
  113.       DJA2=XZERO
  114.       DO 105 IA=1,3
  115.          DJA1=DJA1+(XE(IA,1)-XE(IA,4))*BPSS(3,IA)
  116.          DJA2=DJA2+(XE(IA,2)-XE(IA,3))*BPSS(3,IA)
  117.  105  CONTINUE
  118.       DJAC=DJA1*DJA2
  119.       IF(DJAC.LT.-1.D-20) I195=1
  120. C     HAUT  = LARGEUR ENTRE LES NOEUDS 1,4 ET 2,3
  121.       HAUT=XZERO
  122.       XLARG1=XZERO
  123.       XLARG2=XZERO
  124.       DO 110 IA=1,3
  125.          HAUT  =(XE(IA,2)-XE(IA,1))*(XE(IA,2)-XE(IA,1))+HAUT
  126.          XLARG1=(XE(IA,4)-XE(IA,1))*(XE(IA,4)-XE(IA,1))+XLARG1
  127.          XLARG2=(XE(IA,3)-XE(IA,2))*(XE(IA,3)-XE(IA,2))+XLARG2
  128.  110  CONTINUE
  129.       HAUT  =SQRT(HAUT)
  130.       XLARG1=SQRT(XLARG1)
  131.       XLARG2=SQRT(XLARG2)
  132.       EPS1=XLARG1/HAUT
  133.       EPS2=XLARG2/HAUT
  134.       IF(EPS1.GT.EPS.OR.EPS2.GT.EPS) I157=1
  135.       DJA1=DJA1/HAUT
  136.       DJA2=DJA2/HAUT
  137.       IF(DJA1.LT.1.D-6.AND.DJA2.LT.1.D-6) I70=1
  138. C
  139. C     ASURW  = A/W   NOTATION CHEISSOUX
  140. C
  141.       W=(EPA1+EPA2)*UNDEMI
  142.       ASURW=(FISS1+FISS2)/W
  143.       ASUR1=FISS1/W
  144.       ASUR2=FISS2/W
  145.       IF(ASUR1.GT..98D0.AND.ASUR2.GT..98D0) I69=1
  146.       IF(I69.EQ.1) GOTO 666
  147. C
  148. C     TRANSFORMATION DE D:
  149.       D(1,1)=D(1,1)*W
  150.       D(2,2)=D(2,2)*W*W*W/DOUZE
  151. C
  152.       PEWM=D(1,1)*PENA
  153.       PEWF=D(2,2)*PENA
  154.       PEWMB=D(1,1)*PENB
  155.       PEWFB=D(2,2)*PENA
  156.       IF (ASURW.GT.EPSINV) THEN
  157. C
  158. C     BOUCLE SUR LES POINTS DE CONTRAINTES
  159. C
  160.          DO 200 IA=1,NPOINT
  161.             H1=UNDEMI-UNDEMI*S(IA)
  162.             H2=UNDEMI+UNDEMI*S(IA)
  163.             ASURW=(H1*FISS1+H2*FISS2)/W
  164.             A    = H1*FISS1+H2*FISS2
  165. C
  166. C     ON RECUPERE LES COEFFICIENTS ALPHAS ET F I
  167. C--------------------------------------------------
  168.             CALL LISPAL(ASURW,ALMM,ALMF,ALFF,DELTA)
  169.             CALL LISPFI(ASURW,FM,FF)
  170. C     CALL INTER2D
  171. C--------------------------------------------------
  172.             DELTA=D(1,1)/DELTA
  173. C
  174. C     CALCUL DES COEFFICIENTS R1 R2 R3 R4
  175. C
  176.             R1= DELTA*ALFF/W
  177.             R2=-DELTA*ALMF/SIX
  178.             R3=-DELTA*ALMF/SIX
  179.             R4= DELTA*ALMM*W/TRSIX
  180. C
  181. C     REMPLISSAGE DES CONTRAINTES:
  182. C
  183.             IF (DZ23.GE.0) THEN
  184.                EPXZ=(XDDLOC(1 )-XDDLOC(19))*H1+(XDDLOC(7 )-XDDLOC(13))
  185.      $              *H2
  186.                EPYZ=(XDDLOC(2 )-XDDLOC(20))*H1+(XDDLOC(8 )-XDDLOC(14))
  187.      $              *H2
  188.                DD  =(XDDLOC(3 )-XDDLOC(21))*H1+(XDDLOC(9 )-XDDLOC(15))
  189.      $              *H2
  190.                RT  =(XDDLOC(4 )-XDDLOC(22))*H1+(XDDLOC(10)-XDDLOC(16))
  191.      $              *H2
  192.                RTZZ=(XDDLOC(6 )-XDDLOC(24))*H1+(XDDLOC(12)-XDDLOC(18))
  193.      $              *H2
  194.             ELSE
  195.                EPXZ=(XDDLOC(19)-XDDLOC(1 ))*H1+(XDDLOC(13)-XDDLOC(7 ))
  196.      $              *H2
  197.                EPYZ=(XDDLOC(20)-XDDLOC(2 ))*H1+(XDDLOC(14)-XDDLOC(8 ))
  198.      $              *H2
  199.                DD  =(XDDLOC(21)-XDDLOC(3 ))*H1+(XDDLOC(15)-XDDLOC(9 ))
  200.      $              *H2
  201.                RT  =(XDDLOC(22)-XDDLOC(4 ))*H1+(XDDLOC(16)-XDDLOC(10))
  202.      $              *H2
  203.                RTZZ=(XDDLOC(24)-XDDLOC(6 ))*H1+(XDDLOC(18)-XDDLOC(12))
  204.      $              *H2
  205.             ENDIF
  206. C     __________________________________________________________
  207. C
  208.             IX=6*(IA-1)
  209. C
  210.             XSTRS(IX+1)=DD*R1+RT*R2
  211.             XSTRS(IX+2)=PEWMB*EPXZ
  212.             XSTRS(IX+3)=PEWMB*EPYZ
  213.             XSTRS(IX+4)=DD*R3+RT*R4
  214.             XSTRS(IX+5)=PEWFB*RTZZ
  215. C
  216.             X1=XSTRS(IX+1)/W
  217.             X4=XSTRS(IX+4)*SIX/(W*W)
  218. C     ________________________________________
  219. C
  220. C     CALCUL DE K I   ET DE J
  221. C
  222.             XXX=XPI*A
  223.             XXX=SQRT(XXX)
  224.             XKIE       =(X1*FM+X4*FF)*XXX
  225.             XSTRS(IX+6)= XKIE
  226. C
  227.  200     CONTINUE
  228. C
  229. C    SI FISSURE INEXISTANTE
  230. C
  231. C                ON FAIT UN C.S.T. POUR L ELEMENT DU BOUT
  232. C
  233.       ELSE IF(ASURW.LE.EPSINV) THEN
  234. C
  235.          DO 150 IA=1,NPOINT
  236.             H1=UNDEMI-UNDEMI*S(IA)
  237.             H2=UNDEMI+UNDEMI*S(IA)
  238.             EPXZ =(XDDLOC(1 )-XDDLOC(19))*H1+(XDDLOC(7 )-XDDLOC(13))*H2
  239.             EPYZ =(XDDLOC(2 )-XDDLOC(20))*H1+(XDDLOC(8 )-XDDLOC(14))*H2
  240. C
  241.             DD1  = XDDLOC(3 )-XDDLOC(21)
  242.             DD2  = XDDLOC(9 )-XDDLOC(15)
  243.             DD =  DD1*H1 + DD2*H2
  244. C
  245.             RT1  = XDDLOC(4 )-XDDLOC(22)
  246.             RT2  = XDDLOC(10)-XDDLOC(16)
  247.             RT =  RT1*H1 + RT2*H2
  248. C
  249.             RTZZ =(XDDLOC(6 )-XDDLOC(24))*H1+(XDDLOC(12)-XDDLOC(18))*H2
  250.             IX=6*(IA-1)
  251.             XSTRS(IX+1)=PEWM*DD
  252.             XSTRS(IX+2)=PEWMB*EPXZ
  253.             XSTRS(IX+3)=PEWMB*EPYZ
  254.             XSTRS(IX+4)=PEWF*RT
  255.             XSTRS(IX+5)=PEWFB*RTZZ
  256.             XSTRS(IX+6)=XZERO
  257.  150     CONTINUE
  258.       ENDIF
  259.  666  CONTINUE
  260.       RETURN
  261.       END
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales