Télécharger la plaquette Cast3M


fr en

Télécharger tcoq8c.eso

Retour à la liste

Numérotation des lignes : 

tcoq8c

  1. C TCOQ8C    SOURCE    OF166741  23/12/04    21:15:10     11800          
  2.  
  3. ************************************************************************
  4. *
  5. *                             T C O Q 8 C
  6. *                             -----------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *     TRAITEMENT DU CAS DES ELEMENTS-FINIS  COQUE EPAISSE A 8
  11. *     OU A 6 NOEUDS
  12. *
  13. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
  14. * -----------
  15. *
  16. *     NEF     (E)  NUMERO DE L'ELEMENT-FINI DANS NOMTP (VOIR CCHAMP)
  17. *     IMAIL   (E)  NUMERO DU MAILLAGE ELEMENTAIRE CONSIDERE,DANS
  18. *                  L'OBJET MODELE
  19. *     IPMODE  (E)  POINTEUR SUR UN SEGMENT IMODEL
  20. *     IPCHEM  (E)  POINTEUR SUR LE CHAMELEM DE CARACTERISTIQUE
  21. *     IPRIGI (E/S) POINTEUR SUR L'OBJET RESULTAT,DE TYPE RIGIDITE
  22. *
  23. * VARIABLES:
  24. * ----------
  25. *
  26. *     NBNN     NOMBRE DE NOEUDS DANS L'ELEMENT CONSIDERE
  27. *     NEF      NUMERO DE L'ELEMENT FINI DANS NOMTP (VOIR CCHAMP)
  28. *     NBELEM   NOMBRE D'ELEMENTS DANS LE MAILLAGE ELEMENTAIRE
  29. *     NBPGAU   NOMBRE DE POINTS DE GAUSS DANS L'ELEMENT-FINI
  30. *     NDIM     NOMBRE DE LIGNES DE LA MATRICE GRADIENT
  31. *     CEL(3*NBNN,3*NBNN)  MATRICE DE CONDUCTIVITE ELEMENTAIRE
  32. *     XE(3,NBNN)      COORDONNEES DE L'ELEMENT DANS LE REPERE GLOBAL
  33. *     GRAD(NDIM,2*NBNN) MATRICE GRADIENT DES FONCTIONS DE FORME BIDIM.
  34. *     XK(3,NBPGAU) LES CONDUCTIVITES AUX POINTSDE GAUSS
  35. *     EP(NBPGAU)  LES EPAISSEURS AUX POINTS DE GAUSS
  36. *     TXR(3,3,NBNN)   LES AXES LOCAUX AUX NOEUDS
  37. ************************************************************************
  38.  
  39.       SUBROUTINE TCOQ8C (NEF,IPMAIL,IPINTE,IMATE,IVAMAT,NVAMAT,
  40.      &                   IPMATR,NLIGR)
  41.  
  42.       IMPLICIT INTEGER(I-N)
  43.       IMPLICIT REAL*8(A-H,O-Z)
  44.  
  45. -INC PPARAM
  46. -INC CCOPTIO
  47. -INC CCREEL
  48.  
  49. -INC SMCOORD
  50. -INC SMINTE
  51. -INC CCHAMP
  52. -INC SMRIGID
  53. -INC SMELEME
  54. -INC SMCHAML
  55.  
  56.       SEGMENT,MMAT1
  57.         REAL*8 EP(NBNN),XK(3,NBPGAU),TXR(3,3,NBNN),EXC(NBNN)
  58.         REAL*8 CEL(NLIGR,NLIGR),XE(3,NBNN),GRAD(NDIM,NLIGR)
  59.         REAL*8 COSA(NBPGAU),SINA(NBPGAU)
  60.         REAL*8 XJ(3,3),XJI(3,3),TT(9),YK(3,3)
  61.       ENDSEGMENT
  62. *
  63.       SEGMENT NOTYPE
  64.         CHARACTER*16 TYPE(NBTYPE)
  65.       ENDSEGMENT
  66. *
  67.       SEGMENT MPTVAL
  68.         INTEGER IPOS(NS)    ,NSOF(NS)
  69.         INTEGER      IVAL(NCOSOU)
  70.         CHARACTER*16 TYVAL(NCOSOU)
  71.       ENDSEGMENT
  72. *
  73.       PARAMETER (UN=1.D0,DEUX=2.D0)
  74. *
  75. *     RECUPERATION DES CARACTERISTIQUES GEOMETRIQUES DU MAILLAGE
  76. *     ELEMENTAIRE
  77. *
  78.       MELEME = IPMAIL
  79. c*    SEGACT,MELEME
  80.       NBNN   = NUM(/1)
  81.       NBELEM = NUM(/2)
  82. *
  83. *     RECUPERATION DES CARACTERISTIQUES D'INTEGRATION DE L'ELEMENT
  84. *     FINI LIE A NOTRE MAILLAGE
  85. *
  86.       MINTE = IPINTE
  87. C*    SEGACT,MINTE
  88.       NBPGAU=POIGAU(/1)
  89. *
  90.       CALL TSHAPE(NEF,'NOEUD',IPINT1)
  91.       IF (IERR.NE.0) RETURN
  92.       MINTE1 = IPINT1
  93.       SEGACT,MINTE1
  94. *
  95.       XMATRI= IPMATR
  96. c*    SEGACT,XMATRI*MOD
  97. *
  98.       MPTVAL = IVAMAT
  99.       IPMELV = IVAL(NVAMAT)
  100. * Verification de la constance de l'epaisseur :
  101. c*    CALL QUELCH(IPMELV,ICONS)
  102. c*    IF (ICONS.NE.0) THEN
  103. c*      CALL ERREUR(566)
  104. c*      GOTO 999
  105. c*    ENDIF
  106. *
  107.       NDIM = IDIM
  108.       SEGINI,MMAT1
  109. *
  110. *     BOUCLE SUR LES ELEMENTS DU MAILLAGE ELEMENTAIRE IMAIL
  111. *
  112.       DO 10 IEL = 1, NBELEM
  113. *
  114. *     MISE A ZERO DES TABLEAUX CEL ET GRAD ET EXC
  115. *
  116.         CALL ZERO(CEL,NLIGR,NLIGR)
  117.         CALL ZERO(EXC,NBNN,1)
  118. *
  119. *    ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IEL,
  120. *     DANS LE REPERE GLOBAL
  121. *
  122.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  123. *
  124. *    CALCUL DES AXES LOCAUX A TOUS LES NOEUDS DE L'ELEMENT
  125. *
  126.         CALL CQ8LOC (XE,NBNN,MINTE1.SHPTOT,TXR,IRR)
  127. *    ECHEC DANS LE CALCUL DES AXES LOCAUX
  128.         IF (IRR.EQ.0) THEN
  129.           CALL ERREUR (515)
  130.           GOTO 999
  131.         ENDIF
  132. *
  133. *        ON CHERCHE LES CONDUCTIVITES ET LES COSINUSDIRECTEURS
  134. *        DES AXES LOCAUX (CAS ORTHOTROPE) AUX POINTS DE GAUSS
  135. *
  136.         IF (IMATE.EQ.1) THEN
  137.           MELVAL = IVAL(1)
  138.           IBMN = MIN(IEL,VELCHE(/2))
  139.           DO IG = 1,NBPGAU
  140.             IGMN=MIN(IG,VELCHE(/1))
  141.             XK(1,IG) = VELCHE(IGMN,IBMN)
  142.           ENDDO
  143.         ELSE
  144.           DO IM = 1, 5
  145.             MELVAL = IVAL(IM)
  146.             IBMN = MIN(IEL,VELCHE(/2))
  147.             IF (IM.LE.3) THEN
  148.               DO IG = 1, NBPGAU
  149.                 IGMN = MIN(IG,VELCHE(/1))
  150.                 XK(IM,IG) = VELCHE(IGMN,IBMN)
  151.               ENDDO
  152.             ELSE IF (IM.EQ.4) THEN
  153.               DO IG = 1, NBPGAU
  154.                 IGMN = MIN(IG,VELCHE(/1))
  155.                 COSA(IG) = VELCHE(IGMN,IBMN)
  156.               ENDDO
  157.             ELSE
  158.               DO IG = 1,NBPGAU
  159.                 IGMN = MIN(IG,VELCHE(/1))
  160.                 SINA(IG) = VELCHE(IGMN,IBMN)
  161.               ENDDO
  162.             ENDIF
  163.           ENDDO
  164.         ENDIF
  165. *
  166. *      ON CHERCHE LES EPAISSEURS
  167.         MELVAL = IPMELV
  168.         IBMN = MIN(IEL,VELCHE(/2))
  169.         DO IG = 1, NBNN
  170.           IGMN = MIN(IG,VELCHE(/1))
  171.           EP(IG) = VELCHE(IGMN,IBMN)
  172. *
  173. *   L'ELEMENT (IEL) AU POINT DE GAUSS (IG)DE TYPE (NOMTP(NEF)) A
  174. *     UNE EPAISSEUR NULLE
  175.           IF (EP(IG).LE.XPETIT) THEN
  176.             INTERR(1)=IEL
  177.             INTERR(2)=IG
  178.             MOTERR(1:4)=NOMTP(NEF)
  179.             CALL ERREUR(355)
  180.             GOTO 999
  181.           ENDIF
  182.         ENDDO
  183. *
  184. *  BOUCLE SUR LES POINTS D ' INTEGRATION
  185. *
  186.         DO 40 IGAU = 1,NBPGAU
  187. *
  188. *        CALCUL DU JACOBIEN ET DE SON DETERMINENT EN CE POINT DE GAUSS
  189. *
  190.           CALL ZERO(GRAD,NDIM,NLIGR)
  191. *
  192.           E3 = DZEGAU(IGAU)
  193. *
  194.           CALL CQ8JCE(IGAU,NBNN,E3,XE,EP,EXC,TXR,SHPTOT,XJ,DJAC,IRR)
  195. *        JACOBIEN NUL DANS L'ELEMENT IEL
  196.           IF (IRR.LT.0)THEN
  197.             INTERR(1)=IEL
  198.             CALL ERREUR (405)
  199.             GOTO 999
  200.           ENDIF
  201. *
  202. *    INVERSION DU JACOBIEN
  203. *
  204.       DUM =UN/DJAC
  205.       XJI(1,1) = DUM*( XJ(2,2)*XJ(3,3) - XJ(2,3)*XJ(3,2))
  206.       XJI(2,1) = DUM*(-XJ(2,1)*XJ(3,3) + XJ(2,3)*XJ(3,1))
  207.       XJI(3,1) = DUM*( XJ(2,1)*XJ(3,2) - XJ(2,2)*XJ(3,1))
  208.       XJI(1,2) = DUM*(-XJ(1,2)*XJ(3,3) + XJ(1,3)*XJ(3,2))
  209.       XJI(2,2) = DUM*( XJ(1,1)*XJ(3,3) - XJ(1,3)*XJ(3,1))
  210.       XJI(3,2) = DUM*(-XJ(1,1)*XJ(3,2) + XJ(1,2)*XJ(3,1))
  211.       XJI(1,3) = DUM*( XJ(1,2)*XJ(2,3) - XJ(1,3)*XJ(2,2))
  212.       XJI(2,3) = DUM*(-XJ(1,1)*XJ(2,3) + XJ(1,3)*XJ(2,1))
  213.       XJI(3,3) = DUM*( XJ(1,1)*XJ(2,2) - XJ(1,2)*XJ(2,1))
  214. *
  215. *     TRAITEMENT SPECIFIQUE DU CAS ORTHOTROPE
  216.           IF (IMATE.EQ.2) THEN
  217. *
  218. *    DETERMINATION DES COSINUS DIRECTEURS DES AXES LOCAUX EN CE POINT
  219. *                COQ8       COQ6
  220.         IF(NEF.EQ.41.OR.NEF.EQ.56)THEN
  221. *
  222.          DO I=1,3
  223.            TT(I  ) = XJ(1,I)
  224.            TT(I+3) = XJ(2,I)
  225.          ENDDO
  226. *
  227. *    PRODUITS VECTORIELS ET NORMALISATIONS
  228. *
  229.          CALL CROSS2(TT(1),TT(4),TT(7),IRR1)
  230.          CALL CROSS2(TT(7),TT(1),TT(4),IRR1)
  231.          CALL CROSS2(TT(4),TT(7),TT(1),IRR1)
  232. *
  233.         ELSE
  234.          IF(IGAU.EQ.1)THEN
  235. *
  236. *         CALCUL DES AXES LOCAUX DE L 'ELEMENT COQ4
  237. *
  238.             CALL TQ4LOC(XE,TT,IRR1)
  239. *
  240.           ENDIF
  241.         ENDIF
  242.        IF(IRR1.EQ.0) THEN
  243. *       ECHEC DANS LE CALCUL DES AXES LOCAUX
  244.         CALL ERREUR(515)
  245.         GO TO 999
  246.        ENDIF
  247. *
  248. *    PRODUIT MATRICIEL TT TRANSPOSE * XJI
  249. *
  250.        DO I=1,3
  251.          IK = 3*(I-1)
  252.          DO J=1,3
  253.            r_z = XZERO
  254.            DO K=1,3
  255.              r_z = r_z + TT(IK+K)*XJI(K,J)
  256.            ENDDO
  257.            XJ(I,J) = r_z
  258.          ENDDO
  259.        ENDDO
  260. *
  261.       ENDIF
  262. *
  263. *     CALCUL DE LA MATRICE DE GRADIENT DES FONCTIONS DE FORME DANS LE
  264. *     REPERE  GLOBAL POUR LE CAS ISOTROPE ET DANS LE REPERE LOCAL
  265. *     POUR LE CAS ORTHOTROPE
  266. *
  267.       NBNN2=2*NBNN
  268.       DO K = 1,NLIGR
  269.        DO I = 1,3
  270.         r_z = XZERO
  271.         DO J = 1,3
  272.          JJ=J+1
  273.          IF(JJ.EQ.4)JJ=1
  274.          IF(K.LE.NBNN)THEN
  275.           KK=K
  276.           IF(J.LE.2)THEN
  277.            COEF=(E3/DEUX)*(E3-UN)
  278.           ELSE
  279.            COEF=E3-UN/DEUX
  280.           ENDIF
  281.          ELSEIF(K.GT.NBNN.AND.K.LE.NBNN2)THEN
  282.           KK=K-NBNN
  283.           IF(J.LE.2)THEN
  284.            COEF=UN-E3*E3
  285.           ELSE
  286.            COEF=-DEUX*E3
  287.           ENDIF
  288.          ELSE
  289.           KK=K-NBNN2
  290.           IF(J.LE.2)THEN
  291.            COEF=(E3/DEUX)*(E3+UN)
  292.           ELSE
  293.            COEF=E3+UN/DEUX
  294.           ENDIF
  295.          ENDIF
  296.          IF (IMATE.EQ.1) THEN
  297.           r_z = r_z + COEF*SHPTOT(JJ,KK,IGAU)*XJI(I,J)
  298.          ELSE
  299.           r_z = r_z + COEF*SHPTOT(JJ,KK,IGAU)*XJ(I,J)
  300.          ENDIF
  301.         ENDDO
  302.         GRAD(I,K) = r_z
  303.        ENDDO
  304.       ENDDO
  305. *
  306. *       ON MULTIPLIE LE DETERMINENT JACOBIEN PAR LE POIDS D' INTEG-
  307. *       RATION POUR LE POINT DE GAUSS CONSIDERE
  308. *
  309.         DJAC = DJAC*POIGAU(IGAU)
  310. *
  311.           IF (IMATE.EQ.1) THEN
  312. *
  313. *       CAS DU  MATERIAU ISOTROPE
  314.  
  315.             FACT = XK(1,IGAU)*DJAC
  316. *
  317. *       ON AJOUTE LE PRODUIT K*DJAC*TRANSPOSEE(GRAD)*GRAD POUR LE
  318. *       POINT DE GAUSS CONSIDERE
  319. *
  320.             CALL NTNST(GRAD,FACT,NLIGR,NDIM,CEL)
  321. *
  322. *      CAS ORTHOTROPE
  323.           ELSE
  324. *
  325. *       CALUL DE LA MATRICE DES COEFFICIENTS DE CONDUCTIVITES DANS LE
  326. *       PLAN,PAR RAPPORT AU REPERE  LOCAL DE L'ELEMANT
  327. *
  328.             IF (NEF.EQ.41.OR.NEF.EQ.56) THEN
  329.               IGAU2 = IGAU
  330.             ELSE
  331.               NBPGA1 = NBPGAU/2
  332.               IF (IGAU.LE.NBPGA1) THEN
  333.                 IGAU2 = IGAU
  334.               ELSE
  335.                 IGAU2 = IGAU-NBPGA1
  336.               ENDIF
  337.             ENDIF
  338. *
  339.             COS2 = COSA(IGAU2) * COSA(IGAU2)
  340.             SIN2 = SINA(IGAU2) * SINA(IGAU2)
  341.             SINCOS=SINA(IGAU2) * COSA(IGAU2)
  342.             YK(1,1)=COS2*XK(1,IGAU) + SIN2*XK(2,IGAU)
  343.             YK(2,1)=SINCOS*(XK(1,IGAU)-XK(2,IGAU))
  344.             YK(3,1)=XZERO
  345.             YK(1,2)=YK(2,1)
  346.             YK(2,2)=SIN2*XK(1,IGAU)+COS2*XK(2,IGAU)
  347.             YK(3,2)=XZERO
  348.             YK(1,3)=XZERO
  349.             YK(2,3)=XZERO
  350.             YK(3,3)=XK(3,IGAU)
  351. *
  352. *       ON AJOUTE LE PRODUIT DJAC*TRANSPOSEE(GRAD)*XK*GRAD POUR LE
  353. *       POINT DE GAUSS CONSIDERE A LA MATRICE CEL
  354. *
  355.             CALL BDBST(GRAD,DJAC,YK,NLIGR,NDIM,CEL)
  356. *
  357.           ENDIF
  358. *
  359.   40    CONTINUE
  360. *
  361. *        REMPLISSAGE DE XMATRI
  362. *
  363.         CALL REMPMT(CEL,NLIGR,RE(1,1,iel))
  364. *
  365.  10   CONTINUE
  366. *
  367. *     DESACTIVATION DES SEGMENTS
  368. *
  369.  999  CONTINUE
  370.       SEGDES,MINTE1
  371.       SEGSUP,MMAT1
  372. *
  373. c      RETURN
  374.       END
  375.  
  376.  
  377.  

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