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

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