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

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