Télécharger la plaquette Cast3M


fr en

Télécharger jaucau.eso

Retour à la liste

Numérotation des lignes : 

jaucau

  1. C JAUCAU    SOURCE    AM        18/06/06    21:15:01     9834           
  2.  
  3.       SUBROUTINE JAUCAU (NBNN,tab1,Ncoele,NBPTEL,SHPTOT,XE1,XE2,
  4.      &                   SHPWRK,tab,MWRK6,LHOOK,
  5.      &                   KCAS,mwrk5,LADIM,mele,iipdpg)
  6.  
  7.       implicit real*8(a-h,o-z)
  8.       implicit integer (i-n)
  9.  
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13.  
  14.       SEGMENT MWRK5
  15.         REAL*8 BGR(NGRA,LRE),BB(2,NGRA),gradi(ngra),R(ngra),u(ngra)
  16.         REAL*8 TENS(9),tentra(9),xddls2(lre)
  17.       ENDSEGMENT
  18. *
  19.       SEGMENT MWRK6
  20.        INTEGER ITRES1(NBPTEL)
  21.        REAL*8 PRODDI(NBPTEL,LHOO2),PRODDO(NBPTEL,LHOO2)
  22.        REAL*8 DDHOOK(LHOOK,LHOOK),DDHOMU(LHOOK,LHOOK)
  23.        REAL*8 VEC(LHOOK),VEC2(LHOOK)
  24.       ENDSEGMENT
  25. *
  26.       dimension xe1(3,*),xe2(3,*)
  27.       dimension shpwrk(6,*),shptot(6,NBNN,*)
  28.       dimension tab(nbptel,*),tab1(nbptel,*)
  29.       DIMENSION IDD(3),RM(6,6),SM(6,6)
  30.  
  31. C
  32.       PARAMETER (RAC2 = 1.414213562373090 D0)
  33. C
  34.       DATA IDD/2,3,1/
  35. C
  36.       xxzero=0.d0
  37.       if (kcas.eq.2) then
  38.         xxr=2.0d0
  39.         uxr=0.5d0
  40.       else
  41.         xxr=1.d0
  42.         uxr=1.D0
  43.       endif
  44.  
  45. C
  46. C     MISE A ZERO DES CONTRAINTES OU DES DEFORMATIONS
  47. C
  48.       DO 50 IB=1,NCOELE
  49.         DO 50 IA=1,NBPTEL
  50.           TAB(IA,IB)=0.D0
  51.   50  CONTINUE
  52.       DO i = 1, 9
  53.         TENS(i) = xxZero
  54.       ENDDO
  55.  
  56.       ngra=gradi(/1)
  57.       lre=xddls2(/1)
  58.       NHRM=NIFOUR
  59.  
  60. C Calcul de l'increment de deplacement
  61.       ia=0
  62.       do iou=1,NBNN
  63.         do iyu=1, idim
  64.           ia=ia+1
  65.           xddls2(ia)= XE2(iyu,iou) - xe1(iyu,iou)
  66.         enddo
  67.       enddo
  68. C - MODES DE CALCUL EN DEFORMATIONS "PLANES" GENERALISEES
  69.       IF (IDIM.EQ.3) THEN
  70. C         RIEN FAIRE !
  71. C CAS 2D :
  72.       ELSE IF (IDIM.EQ.2) THEN
  73. CC CAS 2D PLAN DEFO GENE
  74. C Rq : "Deplacement" UZ du PTGENE est stocke dans XE2(3,1) (cf. PIOCAP)
  75.         IF (IFOUR.EQ.-3) THEN
  76.           IA = IA + 1
  77.           xddls2(ia)= XE2(3,1)
  78.         ENDIF
  79. C CAS 1D :
  80.       ELSE IF (IDIM.EQ.1) THEN
  81. CCC CAS 1D PLAN
  82.         IF (IFOUR.GE.3 .AND. IFOUR.LE.11) THEN
  83. C Rq : "Deplacement" UY du PTGENE est stocke dans XE2(2,1) (cf. PIOCAP)
  84.           IF (IFOUR.EQ.7 .OR. IFOUR.EQ.8 .OR. IFOUR.EQ.11) THEN
  85.             IA = IA + 1
  86.             xddls2(ia)= XE2(2,1)
  87.           ENDIF
  88. C Rq : "Deplacement" UZ du PTGENE est stocke dans XE2(3,1) (cf. PIOCAP)
  89. c*        IF (IFOUR.EQ.9 .OR. IFOUR.EQ.10 .OR. IFOUR.EQ.11) THEN
  90.           IF (IFOUR.GE.9) THEN
  91.             IA = IA + 1
  92.             xddls2(ia)= XE2(3,1)
  93.           ENDIF
  94. CCC CAS 1D AXIS
  95. C Rq : "Deplacement" UZ du PTGENE est stocke dans XE2(2,1) (cf. PIOCAP)
  96.         ELSE IF (IFOUR.EQ.14) THEN
  97.           IA = IA + 1
  98.           xddls2(ia)= XE2(2,1)
  99.         ENDIF
  100.       ENDIF
  101.  
  102. C Boucle sur les points d'intergration de l'element :
  103.       do 51 igau=1,nbptel
  104.  
  105. C Calcul du gradient du deplacment
  106.         CALL BGRMAS(iGau,mele,nbnn,LRE,IFOUR,NGRA,NHRM,XE1,
  107.      &              xXZero,SHPTOT,SHPWRK,BB,BGR,DJAC,IIPDPG)
  108.         CALL BGRDEP(BGR,NGRA,XDDLs2,LRE,GRADI)
  109.  
  110. C Calcul de F
  111.         IF (LADIM.EQ.3) THEN
  112.           gradi(1)=gradi(1)+1.D0
  113.           gradi(5)=gradi(5)+1.D0
  114.           gradi(9)=gradi(9)+1.D0
  115. C*      ELSE if (LADIM.EQ.2) then
  116.         ELSE
  117.           gradi(1)=gradi(1)+1.D0
  118.           gradi(4)=gradi(4)+1.D0
  119.         ENDIF
  120.  
  121.         CALL POLA2(gradi,R,U,LADIM)
  122.  
  123. *
  124.         GO TO (500,500,700),KCAS
  125. *
  126. *
  127. *     KCAS=1 OU 2  CAS DES CONTRAINTES OU DES DEFORMATIONS
  128. *     ----------------------------------------------------
  129. *
  130. 500     CONTINUE
  131.  
  132. * fait le rtens R.A.Rt on utilise u pour mettre Rt
  133. * et on met le tenseur dans le tableau tens
  134. * attention, vu le stockage R est en fait Rt
  135.         if (LAdim.eq.2) then
  136.           U(1)=r(1)
  137.           u(2)=r(3)
  138.           U(3)=R(2)
  139.           u(4)=R(4)
  140.           tens(1)=tab1(igau,1)
  141.           tens(2)=tab1(igau,4)*uxr
  142.           tens(3)=tens(2)
  143.           tens(4)=tab1(igau,2)
  144. c*      else if (LAdim.eq.3) then
  145.         else
  146.           U(1)=r(1)
  147.           u(2)=r(4)
  148.           U(3)=R(7)
  149.           u(4)=R(2)
  150.           u(5)=r(5)
  151.           u(6)=r(8)
  152.           u(7)=r(3)
  153.           u(8)=r(6)
  154.           u(9)=r(9)
  155.           tens(1)=tab1(igau,1)
  156.           tens(5)=tab1(igau,2)
  157.           tens(9)=tab1(igau,3)
  158.           IF (IFOUR.EQ.1.OR.IFOUR.EQ.2) THEN
  159.             tens(2)=tab1(igau,4)*uxr
  160.             tens(3)=tab1(igau,5)*uxr
  161.             tens(4)=tens(2)
  162.             tens(6)=tab1(igau,6)*uxr
  163.             tens(7)=tens(3)
  164.             tens(8)=tens(6)
  165.           ELSE IF (IFOUR.LE.0) THEN
  166. c*        ELSE IF (IFOUR.EQ.0.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3
  167. c*   &             IFOUR.EQ.-1) THEN
  168.             tens(2)=tab1(igau,4)*uxr
  169. *           tens(3)=xxzero
  170.             tens(4)=tens(2)
  171. *           tens(6)=xxzero
  172. *           tens(7)=tens(3)
  173. *           tens(8)=tens(6)
  174. *           tens(9)=tab1(igau,3)=xxzero pour IFOUR=-1
  175. * Modes de calcul 1D
  176. c         ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN
  177. *           tens(2)=xxzero
  178. *           tens(3)=xxzero
  179. *           tens(4)=tens(2)
  180. *           tens(6)=xxzero
  181. *           tens(7)=tens(3)
  182. *           tens(8)=tens(6)
  183.           ELSE
  184.             CALL ERREUR(19)
  185.             RETURN
  186.           ENDIF
  187.         endif
  188.         CALL MULMAT(tentra,tens,R,LADIM,LADIM,LADIM)
  189.         CALL MULMAT(tens,U,Tentra,LADIM,LADIM,LADIM)
  190.         if(ladim.eq.2) then
  191.           tab(igau,1)=tens(1)
  192.           tab(igau,2)=tens(4)
  193.           tab(igau,4)=tens(2)*xxr
  194.           tab(igau,3)=tab1(igau,3)
  195.         else
  196.           tab(igau,1)=tens(1)
  197.           tab(igau,2)=tens(5)
  198.           tab(igau,3)=tens(9)
  199.           IF (IFOUR.EQ.1.OR.IFOUR.EQ.2) THEN
  200.             tab(igau,4)=tens(2)*xxr
  201.             tab(igau,5)=tens(3)*xxr
  202.             tab(igau,6)=tens(6)*xxr
  203.           ELSE IF (IFOUR.LE.0) THEN
  204. c*        ELSE IF (IFOUR.EQ.0.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3
  205. c*   &             IFOUR.EQ.-1) THEN
  206.             tab(igau,4)=tens(2)*xxr
  207. * Modes de calcul 1D
  208. c*        ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN
  209.           ENDIF
  210.         endif
  211. *
  212.         GO TO 130
  213.  
  214. C
  215. C         KCAS=3  CAS DE LA MATRICE DE HOOKE
  216. C         ----------------------------------
  217. C
  218.   700   CONTINUE
  219. C
  220.       IJ=1
  221.       FACJ=1.
  222.       DO 710 JJ=1,LHOOK
  223.         IF(JJ.GT.3) FACJ=RAC2
  224.         DO 710 II=1,LHOOK
  225.           IF(II.GT.3) THEN
  226.              FACI=RAC2
  227.           ELSE
  228.              FACI=1. 
  229.           ENDIF
  230.           DDHOOK(II,JJ)=PRODDI(IGAU,IJ)*FACJ*FACI
  231.           IJ=IJ+1
  232.   710 CONTINUE
  233. *
  234.       IF(LADIM.EQ.2) THEN
  235.  
  236.         CALL ZERO(RM,6,6)
  237.         DO I=1,LADIM
  238.           IN=(I-1)*LADIM
  239.           DO J=1,LADIM
  240.             JJ =IN + J
  241.             RM(I,J)=R(JJ)*R(JJ)
  242.           ENDDO
  243.           RM(I,4)=RAC2*R(2*I-1)*R(2*I)
  244.           RM(4,I)=RAC2*R(I)*R(I+LADIM)
  245.         ENDDO
  246.         RM(3,3)=1.
  247.         RM(4,4)=R(1)*R(4)+R(2)*R(3)
  248.  
  249.       ELSE IF (LADIM.EQ.3) THEN
  250.  
  251.         DO I=1,LADIM
  252.           IN=(I-1)*LADIM
  253.           IP=(IDD(I)-1)*LADIM
  254.           DO J=1,LADIM
  255.             JJ =IN + J
  256.             J2 =IN + IDD(J)
  257.             J3 =IP + J
  258.             RM(I,J)=R(JJ)*R(JJ)
  259.             RM(I,J+LADIM)=RAC2*R(JJ)*R(J2)
  260.             RM(I+LADIM,J)=RAC2*R(JJ)*R(J3)
  261.             RM(I+LADIM,J+LADIM)=R(JJ)*R(IDD(J)+IP)+R(IDD(J)+IN)*R(J3)
  262.           ENDDO
  263.         ENDDO
  264.  
  265.       ENDIF
  266.  
  267. *
  268.         DO I=1,LHOOK
  269.           DO J=1,LHOOK
  270.             SM(I,J)=0.
  271.             DO K=1,LHOOK
  272.               SM(I,J)=SM(I,J)+DDHOOK(I,K)*RM(K,J)
  273.             ENDDO
  274.           ENDDO
  275.         ENDDO
  276. *
  277.         DO I=1,LHOOK
  278.           DO J=1,LHOOK
  279.             DDHOMU(I,J)=0.
  280.             DO K=1,LHOOK
  281.               DDHOMU(I,J)=DDHOMU(I,J)+RM(K,I)*SM(K,J)
  282.             ENDDO
  283.           ENDDO
  284.         ENDDO
  285. *
  286.       IJ=1
  287.       FACJ=1.
  288.       DO 780 JJ=1,LHOOK
  289.         IF(JJ.GT.3) FACJ=RAC2
  290.         DO 780 II=1,LHOOK
  291.           IF(II.GT.3) THEN
  292.              FACI=RAC2
  293.           ELSE
  294.              FACI=1. 
  295.           ENDIF
  296.           PRODDO(IGAU,IJ)=DDHOMU(II,JJ)/FACJ/FACI
  297.           IJ=IJ+1
  298.   780 CONTINUE
  299. *
  300. *
  301.   130 CONTINUE
  302.  
  303.    51 CONTINUE
  304.  
  305.       RETURN
  306.       END
  307.  
  308.  
  309.  
  310.  

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