Télécharger la plaquette Cast3M


fr en

Télécharger rot3r.eso

Retour à la liste

Numérotation des lignes : 

rot3r

  1. C ROT3R     SOURCE    OF166741  25/02/21    21:18:23     12166          
  2.  
  3. ************************************************************************
  4. *
  5. *                             R O T 3 R
  6. *                             ---------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *     CALCUL DE LA MATRICE DE RESISTANCE POUR L'ELEMENT ROT3
  11. *
  12. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
  13. * -----------
  14. *     NEF     (E)  NUMERO DE L'ELEMENT-FINI DANS NOMTP (VOIR CCHAMP)
  15. *     IPMAIL  (E)  MAILLAGE ELEMENTAIRE CONSIDERE
  16. *     IPMODE  (E)  POINTEUR SUR UN SEGMENT IMODEL
  17. *     IPCHEM  (E)  POINTEUR SUR LE CHAMELEM DE CARACTERISTIQUE
  18. *     IPMATR (E/S)  MATRICE DE RIGIDITE ELEMENTAIRE XMATRI
  19. ************************************************************************
  20.  
  21.       SUBROUTINE ROT3R(NEF,IPMAIL,IPMODE,IPCHEM,IPMATR)
  22.  
  23.       IMPLICIT INTEGER(I-N)
  24.       IMPLICIT REAL*8 (A-H,O-Z)
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC CCREEL
  29. -INC CCHAMP
  30.  
  31. -INC SMCOORD
  32. -INC SMINTE
  33. -INC SMMODEL
  34. -INC SMRIGID
  35. -INC SMELEME
  36. -INC SMCHAML
  37.  
  38. -INC TMPTVAL
  39.  
  40.       SEGMENT NOTYPE
  41.         CHARACTER*16 TYPE(NBTYPE)
  42.       ENDSEGMENT
  43.  
  44.       SEGMENT,MMAT1
  45.         REAL*8 VALMAT(NMATR)
  46.         REAL*8 XE(3,NBNN),CEL1(NBNN,NBNN),XE1(3,NBNN)
  47.         REAL*8 SHP(6,NBNN),GRAD(NDIM,NBNN)
  48.       ENDSEGMENT
  49.  
  50.       REAL*8 COSD1(3),COSD2(3),COSD3(3),YK(2,2)
  51.  
  52.       CHARACTER*8 CNM
  53.       CHARACTER*(NCONCH) CONM
  54.       PARAMETER (NINF=3)
  55.       INTEGER INFOS(NINF)
  56.  
  57.       IMODEL = IPMODE
  58.       CONM   = imodel.CONMOD
  59.  
  60.       MELEME = IPMAIL
  61. c*      meleme = imodel.IMAMOD
  62.       NBNN   = meleme.NUM(/1)
  63.       NBELEM = meleme.NUM(/2)
  64.  
  65. *     RECUPERATION DES CARACTERISTIQUES D'INTEGRATION DE L'ELEMENT
  66. *     FINI LIE A NOTRE MAILLAGE
  67.       if (infmod(/1).lt.4) then
  68.         write(ioimp,*) 'rot3r infmod(/1)'
  69.         call erreur(5)
  70.       endif
  71.  
  72. *  INFORMATION SUR L'ELEMENT
  73.       MINTE = imodel.INFMOD(4)
  74.       NBPGAU = minte.POIGAU(/1)
  75.  
  76.       xMATRI = IPMATR
  77. c*      SEGACT,xMATRI*MOD
  78.       NLIGRP = NBNN
  79.       NLIGRD = NBNN
  80.  
  81. *  REMLIR LE TABLEAU INFOS (INFORMATIONS SUR ELEMENT)
  82.       INFOS(1)=0
  83.       INFOS(2)=0
  84.       INFOS(3)=NIFOUR
  85.  
  86. *  RECHERCHE LES POINTEURS DES SEGMENTS MELVAL QUI CORRESPONDENT
  87. *  AUX COMPOSANTES DE LA CONDUCTIVITE ET L'EPAISSEUR DES ELEMENT
  88.       CNM = imodel.CMATEE
  89. c*      INM = imodel.IMATEE
  90. c*      INT = imodel.INATUU
  91.  
  92.       nbrobl = 0
  93.       nbrfac = 0
  94.       nomid  = 0
  95.       MOMATR = nomid
  96.  
  97.       NBTYPE = 1
  98.       SEGINI,notype
  99.       TYPE(1) = 'REAL*8'
  100.       MOTYR8 = notype
  101.  
  102.       IF (CNM.EQ.'ISOTROPE') THEN
  103.         NBROBL=2
  104.         SEGINI,NOMID
  105.         LESOBL(1)='ETA '
  106.         LESOBL(2)='EPAI'
  107.       ELSE IF (CNM.EQ.'ORTHOTRO') THEN
  108.         NBROBL=5
  109.         SEGINI,NOMID
  110.         LESOBL(1)='ETA1'
  111.         LESOBL(2)='ETA2'
  112.         LESOBL(3)='EPAI'
  113.         LESOBL(4)='V1X '
  114.         LESOBL(5)='V1Y '
  115.       ELSE
  116.         CALL ERREUR(251)
  117.         RETURN
  118.       ENDIF
  119.       NMATO = nbrobl
  120.       NMATF = nbrfac
  121.       NMATR = NMATO + NMATF
  122.       MOMATR = nomid
  123.  
  124.       IVAMAT = 0
  125.       CALL KOMCHA(IPCHEM,IPMAIL,CONM,MOMATR,MOTYR8,1,INFOS,NINF,IVAMAT)
  126.       IF (IERR.NE.0) GOTO 990
  127.  
  128.       MPTVAL = IVAMAT
  129.       IF (CNM.EQ.'ISOTROPE')THEN
  130.         IPMELV = IVAL(2)
  131.       ELSE IF(CNM.EQ.'ORTHOTRO') THEN
  132.         IPMELV = IVAL(3)
  133.       ENDIF
  134.       CALL QUELCH(IPMELV,ICONS)
  135.       IF (ICONS.NE.0) THEN
  136.         CALL ERREUR(566)
  137.         GOTO 990
  138.       ENDIF
  139.  
  140.       NDIM = IDIM-1
  141.       NFIN = IDIM
  142.  
  143.       SEGINI,MMAT1
  144.  
  145. *   BOUCLE (10) SUR LES ELEMENTS DU MAILLAGE ELEMENTAIRE IMAIL
  146.  
  147.       DO IEL = 1, NBELEM
  148.  
  149. *     ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IEL,
  150. *     DANS LE REPERE GLOBAL
  151.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  152.  
  153. *     CALCUL DES COORDONNEES DES NOEUDS DANS LE REPERE LOCAL DE L'
  154. *     ELEMENT COQUE
  155.         COSD1(1) = XE(1,2)-XE(1,1)
  156.         COSD1(2) = XE(2,2)-XE(2,1)
  157.         COSD1(3) = XE(3,2)-XE(3,1)
  158.  
  159.         COSD2(1) = XE(1,3)-XE(1,1)
  160.         COSD2(2) = XE(2,3)-XE(2,1)
  161.         COSD2(3) = XE(3,3)-XE(3,1)
  162.  
  163.         COSD3(1) = COSD1(2)*COSD2(3)-COSD1(3)*COSD2(2)
  164.         COSD3(2) = COSD1(3)*COSD2(1)-COSD1(1)*COSD2(3)
  165.         COSD3(3) = COSD1(1)*COSD2(2)-COSD1(2)*COSD2(1)
  166.  
  167.         COSD1L = SQRT(COSD1(1)*COSD1(1)+COSD1(2)*COSD1(2)+
  168.      &                COSD1(3)*COSD1(3))
  169.  
  170.         COSD1(1)=COSD1(1)/COSD1L
  171.         COSD1(2)=COSD1(2)/COSD1L
  172.         COSD1(3)=COSD1(3)/COSD1L
  173.  
  174.         COSD3L = SQRT(COSD3(1)*COSD3(1)+COSD3(2)*COSD3(2)+
  175.      &                COSD3(3)*COSD3(3))
  176.  
  177.         COSD3(1)=COSD3(1)/COSD3L
  178.         COSD3(2)=COSD3(2)/COSD3L
  179.         COSD3(3)=COSD3(3)/COSD3L
  180.  
  181.         COSD2(1) = COSD3(2)*COSD1(3)-COSD3(3)*COSD1(2)
  182.         COSD2(2) = COSD3(3)*COSD1(1)-COSD3(1)*COSD1(3)
  183.         COSD2(3) = COSD3(1)*COSD1(2)-COSD3(2)*COSD1(1)
  184.  
  185.         DO NOE = 1, NBNN
  186.           XE1(1,NOE) =  XE(1,NOE)*COSD1(1) + XE(2,NOE)*COSD1(2)
  187.      &                + XE(3,NOE)*COSD1(3)
  188.           XE1(2,NOE) =  XE(1,NOE)*COSD2(1) + XE(2,NOE)*COSD2(2)
  189.      &                + XE(3,NOE)*COSD2(3)
  190.           XE1(3,NOE) = 0.D0
  191.         ENDDO
  192.  
  193. *     MISE A ZERO DU TABLEAU CEL1
  194.         CALL ZERO(CEL1,NBNN,NBNN)
  195.  
  196. *     BOUCLE (20) SUR LES POINTS DE GAUSS
  197.         IFOIS = 0
  198.         IFOI2 = 0
  199.  
  200.         DO IGAU=1,NBPGAU
  201.  
  202. *       CALCUL DE LA MATRCIE GRADIENT DES FONCTIONS DE FORME ET
  203. *       DU JACOBIEN(DANS LE PLAN), EN UN POINT DE GAUSS
  204.           DO NOE = 1, NBNN
  205.             DO I = 1, NFIN
  206.               SHP(I,NOE) = SHPTOT(I,NOE,IGAU)
  207.             ENDDO
  208.           ENDDO
  209.  
  210. *       DERIVES DES FONCTIONS DE FORME DANS LA GEOMETRIE REELLE
  211. *       ET LE JACOBIEN
  212.           CALL JACOBI(XE1,SHP,NDIM,NBNN,DJAC)
  213.  
  214.           IF (DJAC.LT.XZERO) IFOIS=IFOIS+1
  215.           IF (ABS(DJAC).LT.XPETIT) IFOI2=IFOI2+1
  216.           DJAC=ABS(DJAC)*POIGAU(IGAU)
  217.  
  218.           DO NOE = 1, NBNN
  219.             DO I = 1, NDIM
  220.               GRAD(I,NOE) = SHP(I+1,NOE)
  221.             ENDDO
  222.           ENDDO
  223.  
  224. *       ON CHERCHE LES VALEURS DE COMPOSANTES DE LA RESISTIVITE
  225. *       ET L'EPAISSEUR DE LA COQUE
  226.           MPTVAL=IVAMAT
  227.           DO IM=1,NMATR
  228.             MELVAL=IVAL(IM)
  229.             IF (MELVAL.NE.0)THEN
  230.               IBMN=MIN(IEL,VELCHE(/2))
  231.               IGMN=MIN(IGAU,VELCHE(/1))
  232.               VALMAT(IM)=VELCHE(IGMN,IBMN)
  233.             ELSE
  234.              VALMAT(IM)=0.D0
  235.             ENDIF
  236.           ENDDO
  237.  
  238. *       MATERIAU ISOTROPE
  239.           IF (CNM.EQ.'ISOTROPE') THEN
  240.             EP = VALMAT(2)
  241. *   L'ELEMENT (IEL) AU POINT DE GAUSS (IGAU) A UNE EPAISSEUR NULLE
  242.             IF (EP.LE.XPETIT) THEN
  243.               INTERR(1)=IEL
  244.               INTERR(2)=IGAU
  245.               MOTERR(1:4)=NOMTP(NEF)
  246.               CALL ERREUR(355)
  247.               GO TO 999
  248.             ENDIF
  249.             XK = VALMAT(1)*DJAC/EP
  250. *        ON AJOUTE LE PRODUIT K*DJAC*TRANSPOSEE(GRAD)*GRAD
  251. *        POUR LE POINT DE GAUSS CONSIDERE,A LA MATRICE CEL1
  252.             CALL NTNST(GRAD,XK,NBNN,NDIM,CEL1)
  253.  
  254. *        CAS ORTHOTROPE
  255.           ELSE
  256. c*            IF (CNM.EQ.'ORTHOTRO')THEN
  257.  
  258.             EP = VALMAT(3)
  259. *   L'ELEMENT (IEL) AU POINT DE GAUSS (IGAU) A UNE EPAISSEUR NULLE
  260.             IF (EP.LE.XPETIT) THEN
  261.               INTERR(1)=IEL
  262.               INTERR(2)=IGAU
  263.               MOTERR(1:4)=NOMTP(NEF)
  264.               CALL ERREUR(355)
  265.               GO TO 999
  266.             ENDIF
  267.             XK1 = VALMAT(1) / EP
  268.             XK2 = VALMAT(2) / EP
  269.  
  270.             COSA =  VALMAT(4)
  271.             SINA = -VALMAT(5)
  272.  
  273. *   CALCUL DE LA MATRICE DES COEFFICIENTS DE RESISTIVITE DANS LE
  274. *   PLAN,PAR RAPPORT AU REPERE  LOCAL DE L'ELEMENT
  275.             COS2 = COSA*COSA
  276.             SIN2 = SINA*SINA
  277.             SICO = SINA*COSA
  278.             YK(1,1) = COS2*XK1 + SIN2*XK2
  279.             YK(1,2) = SICO*(XK1-XK2)
  280.             YK(2,1) = YK(1,2)
  281.             YK(2,2) = SIN2*XK1 + COS2*XK2
  282.  
  283. *    ON AJOUTE LE PRODUIT DJAC*TRANSPOSEE(GRAD)*YK*GRAD
  284. *    POUR LE POINT DE GAUSS CONSIDERE,A LA MATRICE CEL1
  285.             CALL BDBST (GRAD,DJAC,YK,NBNN,NDIM,CEL1)
  286.  
  287.           ENDIF
  288.  
  289.         ENDDO
  290. *     FIN BOUCLE (20) SUR LES POINTS DE GAUSS
  291.  
  292. *     LE JACOBIEN EST NEGATIF ,MAILLAGE INCORRECT
  293.         IF (IFOIS.NE.0.AND.IFOIS.NE.NBPGAU) THEN
  294.           INTERR(1) = IEL
  295.           CALL ERREUR(195)
  296. *     CAS OU LE JACOBIEN EST TRES PETIT
  297.         ELSE IF (IFOI2.EQ.NBPGAU) THEN
  298.           INTERR(1) = IEL
  299.           CALL ERREUR (259)
  300.         ENDIF
  301.         IF (IERR.NE.0) GO TO 999
  302.  
  303. *     REMPLISSAGE DE XMATRI
  304.  
  305.         CALL REMPMT(CEL1,NBNN,RE(1,1,IEL))
  306.  
  307.       ENDDO
  308. *   FIN BOUCLE (10) SUR LES ELEMENTS
  309.  
  310. *  DESACTIVATION DES SEGMENTS
  311.  
  312.  999  CONTINUE
  313.       SEGSUP,MMAT1
  314.  990  CONTINUE
  315.       mptval = IVAMAT
  316.       IF (mptval.NE.0) SEGSUP,mptval
  317.  
  318.       nomid = MOMATR
  319.       SEGSUP,nomid
  320.       notype = MOTYR8
  321.       SEGSUP,notype
  322.  
  323. c      return
  324.       END
  325.  
  326.  
  327.  

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