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    CB215821  24/04/12    21:17:12     11897          
  2.       SUBROUTINE ROT3R(NEF,IMAIL,IPMODE,IPCHEM,IPRIGI)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. ************************************************************************
  6. *
  7. *                             R O T 3 R
  8. *                             ---------
  9. *
  10. * FONCTION:
  11. * ---------
  12. *     CALCUL DE LA MATRICE DE RESISTANCE POUR L'ELEMENT ROT3
  13. *
  14. * MODULES UTILISES:
  15. * -----------------
  16. *
  17.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20. -INC CCREEL
  21. *-
  22. -INC SMCOORD
  23. -INC SMINTE
  24. -INC CCHAMP
  25. -INC SMMODEL
  26. -INC SMRIGID
  27. -INC SMELEME
  28. -INC SMCHAML
  29. *
  30. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
  31. * -----------
  32. *
  33. *     NEF     (E)  NUMERO DE L'ELEMENT-FINI DANS NOMTP (VOIR CCHAMP)
  34. *     IMAIL   (E)  NUMERO DU MAILLAGE ELEMENTAIRE CONSIDERE,DANS
  35. *                  L'OBJET MODELE
  36. *     IPMODE  (E)  POINTEUR SUR UN SEGMENT IMODEL
  37. *     IPCHEM  (E)  POINTEUR SUR LE CHAMELEM DE CARACTERISTIQUE
  38. *    +XCOOR   (E)  VOIR SMCOORD
  39. *    +IDIM    (E)  VOIR CCOPTIO
  40. *    +IFOMOD  (E)  VOIR CCOPTIO
  41. *    +XZERO   (E)  VOIR CCREEL
  42. *     IPRIGI (E/S) POINTEUR SUR L'OBJET RESULTAT,DE TYPE RIGIDITE
  43. *
  44. * VARIABLES:
  45. * ----------
  46. *
  47. *     NBNN     NOMBRE DE NOEUDS DANS L'ELEMENT CONSIDERE
  48. *     NEF      NUMERO DE L'ELEMENT FINI DANS NOMTP (VOIR CCHAMP)
  49. *     NBELEM   NOMBRE D'ELEMENTS DANS LE MAILLAGE ELEMENTAIRE
  50. *     NBPGAU   NOMBRE DE POINTS DE GAUSS DANS L'ELEMENT-FINI
  51. *     NDIM     NOMBRE DE LIGNES DE LA MATRICE GRADIENT
  52. *     CEL(2*NBNN,2*NBNN)  MATRICE DE CONDUCTIVITE ELEMENTAIRE
  53. *     XE(3,NBNN)      COORDONNEES DE L'ELEMENT DANS LE REPERE GLOBAL
  54. *     SHP(6,NBNN)     TABLEAU DE TRAVAIL
  55. *     GRAD(NDIM,NBNN) MATRICE GRADIENT DES FONCTIONS DE FORME BIDIM.
  56. *     VALMAT(NMATR)  TABLEAU DE TRAVAIL
  57. *
  58.       SEGMENT,MMAT1
  59.          REAL*8 VALMAT(NMATR)
  60.          REAL*8 XE(3,NBNN),CEL1(NBNN,NBNN),XE1(3,NBNN)
  61.          REAL*8 SHP(6,NBNN),GRAD(NDIM,NBNN)
  62.       ENDSEGMENT
  63. *
  64.       SEGMENT NOTYPE
  65.         CHARACTER*16 TYPE(NBTYPE)
  66.       ENDSEGMENT
  67. *
  68.       SEGMENT MPTVAL
  69.         INTEGER IPOS(NS)    ,NSOF(NS)
  70.         INTEGER      IVAL(NCOSOU)
  71.         CHARACTER*16 TYVAL(NCOSOU)
  72.       ENDSEGMENT
  73. *
  74.       SEGMENT INFO
  75.         INTEGER INFELL(JG)
  76.       ENDSEGMENT
  77. *
  78.       REAL*8 COSD1(3),COSD2(3),COSD3(3),YK(2,2)
  79.       CHARACTER*8 CNM
  80.       CHARACTER*(NCONCH) CONM
  81.       PARAMETER (NINF=3)
  82.       INTEGER INFOS(NINF)
  83. *
  84. *
  85. *
  86. * AUTEUR, DATE DE CREATION:
  87. * -------------------------
  88. *
  89. *     YANN STEPHAN , JANVIER 1997 (COPIE DE TCOQ3C)
  90. *
  91. * LANGAGE:
  92. * --------
  93. *
  94. *     ESOPE + FORTRAN77
  95. *
  96. ************************************************************************
  97. *
  98. *     RECUPERATION DES CARACTERISTIQUES GEOMETRIQUES DU MAILLAGE
  99. *     ELEMENTAIRE
  100. *
  101.       IMODEL=IPMODE
  102.       CONM  =CONMOD
  103.       IPMAIL=IMAMOD
  104.       MELEME=IMAMOD
  105.       SEGACT,MELEME
  106.       NBNN=NUM(/1)
  107.       NBELEM=NUM(/2)
  108.       MRIGID=IPRIGI
  109.       SEGACT,MRIGID
  110. *
  111. *     RECUPERATION DES CARACTERISTIQUES D'INTEGRATION DE L'ELEMENT
  112. *     FINI LIE A NOTRE MAILLAGE
  113. *
  114.       if(infmod(/1).lt.4) then
  115.       CALL ELQUOI(NEF,0,2,IPINF,IMODEL)
  116.       IF(IERR.NE.0) RETURN
  117.       INFO=IPINF
  118.       IPINTE=INFELL(11)
  119.       else
  120.       ipinte=infmod(4)
  121.       endif
  122. *
  123. *     INFORMATION SUR L'ELEMENT
  124. *
  125.       MINTE=IPINTE
  126.       SEGACT,MINTE
  127.       NBPGAU=POIGAU(/1)
  128. *
  129.       xMATRI=IRIGEL(4,IMAIL)
  130.       SEGACT,xMATRI*MOD
  131.       NLIGRP=NBNN
  132.       NLIGRD=NBNN
  133. *
  134. *     RECHERCHE LES POINTEURS DES SEGMENTS MELVAL QUI CORRESPONDENT
  135. *     AUX COMPOSANTES DE LA CONDUCTIVITE ET L'EPAISSEUR DES ELEMENT
  136. *
  137.       NFOR=FORMOD(/2)
  138.       NMAT=MATMOD(/2)
  139.       CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CNM,INM,INT)
  140.       IF (IERR.NE.0) RETURN
  141. *
  142. *     REMLIR LE TABLEAU INFOS (INFORMATIONS SUR ELEMENT)
  143.       INFOS(1)=0
  144.       INFOS(2)=0
  145.       INFOS(3)=NIFOUR
  146. *
  147.       NBROBL=0
  148.       NBRFAC=0
  149.       IF(CNM.EQ.'ISOTROPE')THEN
  150.         NBROBL=2
  151.         SEGINI NOMID
  152.         MOMATR=NOMID
  153.         LESOBL(1)='ETA '
  154.         LESOBL(2)='EPAI'
  155.         NMATR=2
  156.         NMATF=0
  157.       ELSE IF(CNM.EQ.'ORTHOTRO') THEN
  158.         NBROBL=5
  159.         SEGINI NOMID
  160.         MOMATR=NOMID
  161.         LESOBL(1)='ETA1'
  162.         LESOBL(2)='ETA2'
  163.         LESOBL(3)='EPAI'
  164.         LESOBL(4)='V1X '
  165.         LESOBL(5)='V1Y '
  166.         NMATR=5
  167.         NMATF=0
  168.       ELSE
  169.         CALL ERREUR(251)
  170.         RETURN
  171.       ENDIF
  172. *
  173.       NBTYPE=1
  174.       SEGINI NOTYPE
  175.       MOTYPE=NOTYPE
  176.       TYPE(1)='REAL*8'
  177. *
  178.       CALL KOMCHA(IPCHEM,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  179.       SEGSUP NOTYPE
  180.       IF(IERR.NE.0)RETURN
  181. *
  182.       MPTVAL=IVAMAT
  183.       IF(CNM.EQ.'ISOTROPE')THEN
  184.          IPMELV=IVAL(2)
  185.       ELSE IF(CNM.EQ.'ORTHOTRO') THEN
  186.          IPMELV=IVAL(3)
  187.       ENDIF
  188.       CALL QUELCH(IPMELV,ICONS)
  189.       IF(ICONS.NE.0)THEN
  190.           CALL ERREUR(566)
  191.           RETURN
  192.       ENDIF
  193. *
  194. *
  195.       NDIM=IDIM-1
  196.       SEGINI,MMAT1
  197. *
  198. *     BOUCLE SUR LES ELEMENTS DU MAILLAGE ELEMENTAIRE IMAIL
  199. *
  200.       DO 10 IEL=1,NBELEM
  201. *
  202. *        MISE A ZERO DES TABLEAUX CEL1 ET XE1
  203. *
  204.          CALL ZERO(CEL1,NBNN,NBNN)
  205.          CALL ZERO (XE1,3,NBNN)
  206. *
  207. *        ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IEL,
  208. *        DANS LE REPERE GLOBAL
  209. *
  210.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  211. *
  212. *       CALCUL DES COORDONNEES DES NOEUDS DANS LE REPERE LOCAL DE L'
  213. *       ELEMENT COQUE
  214. *
  215.         DO 60 I=1,3
  216.         COSD1(I)=XE(I,2)-XE(I,1)
  217.         COSD2(I)=XE(I,3)-XE(I,1)
  218.   60    CONTINUE
  219. *
  220.         COSD3(1)=COSD1(2)*COSD2(3)-COSD1(3)*COSD2(2)
  221.         COSD3(2)=COSD1(3)*COSD2(1)-COSD1(1)*COSD2(3)
  222.         COSD3(3)=COSD1(1)*COSD2(2)-COSD1(2)*COSD2(1)
  223. *
  224.         COSD1L=SQRT(COSD1(1)*COSD1(1)+COSD1(2)*COSD1(2)+
  225.      .               COSD1(3)*COSD1(3))
  226.         COSD3L=SQRT(COSD3(1)*COSD3(1)+COSD3(2)*COSD3(2)+
  227.      .              COSD3(3)*COSD3(3))
  228. *
  229.         DO 70 I=1,3
  230.         COSD1(I)=COSD1(I)/COSD1L
  231.         COSD3(I)=COSD3(I)/COSD3L
  232.    70   CONTINUE
  233. *
  234.         COSD2(1)=COSD3(2)*COSD1(3)-COSD3(3)*COSD1(2)
  235.         COSD2(2)=COSD3(3)*COSD1(1)-COSD3(1)*COSD1(3)
  236.         COSD2(3)=COSD3(1)*COSD1(2)-COSD3(2)*COSD1(1)
  237. *
  238.         DO 80 NOE=1,NBNN
  239.         DO 80  I=1,3
  240.         XE1(1,NOE)=XE1(1,NOE)+XE(I,NOE)*COSD1(I)
  241.         XE1(2,NOE)=XE1(2,NOE)+XE(I,NOE)*COSD2(I)
  242.    80   CONTINUE
  243. *
  244. *
  245. *        BOUCLE SUR LES POINTS DE GAUSS
  246. *
  247.          IFOIS=0
  248.          IFOI2=0
  249.          DO 20 IGAU=1,NBPGAU
  250. *
  251. *        CALCUL DE LA MATRCIE GRADIENT DES FONCTIONS DE FORME ET
  252. *        DU JACOBIEN(DANS LE PLAN), EN UN POINT DE GAUSS
  253. *
  254.          NFIN=NDIM+1
  255.          DO 90 NP=1,NBNN
  256.          DO 90  I=1,NFIN
  257.          SHP(I,NP)=SHPTOT(I,NP,IGAU)
  258.   90     CONTINUE
  259. *
  260. *        DERIVES DES FONCTIONS DE FORME DANS LA GEOMETRIE REELLE
  261. *        ET LE JACOBIEN
  262.          CALL JACOBI(XE1,SHP,NDIM,NBNN,DJAC)
  263. *
  264.          DO 100 NP=1,NBNN
  265.          DO 100 I= 1,NDIM
  266.          GRAD(I,NP)=SHP(I+1,NP)
  267.   100    CONTINUE
  268.          IF(DJAC.LT.XZERO)IFOIS=IFOIS+1
  269.          IF(ABS(DJAC).LT.XPETIT)IFOI2=IFOI2 +1
  270. *
  271. *        ON MULTIPLIE LE JACOBIEN PAR LE POIDS D'INTEGRATION,POUR LE
  272. *        POINT DE GAUSS CONSIDERE
  273. *
  274.          DJAC=ABS(DJAC)*POIGAU(IGAU)
  275. *
  276. *        ON CHERCHE LES VALEURS DE COMPOSANTES DE LA RESISTIVITE
  277. *        ET L'EPAISSEUR DE LA COQUE
  278. *
  279.          MPTVAL=IVAMAT
  280.          DO  30 IM=1,NMATR
  281.          IF(IVAL(IM).NE.0)THEN
  282.            MELVAL=IVAL(IM)
  283.            IBMN=MIN(IEL,VELCHE(/2))
  284.            IGMN=MIN(IGAU,VELCHE(/1))
  285.            VALMAT(IM)=VELCHE(IGMN,IBMN)
  286.          ELSE
  287.           VALMAT(IM)=0
  288.          ENDIF
  289.    30    CONTINUE
  290. *
  291. *        MATERIAU ISOTROPE
  292. *
  293.          IF(CNM.NE.'ORTHOTRO')THEN
  294. *
  295.             EP=VALMAT(2)
  296.             IF(EP.LE.XPETIT)THEN
  297. *   L'ELEMENT (IEL) AU POINT DE GAUSS (IGAU)DE TYPE (NOMTP(NEF)) A
  298. *     UNE EPAISSEUR NULLE
  299.               INTERR(1)=IEL
  300.               INTERR(2)=IGAU
  301.               MOTERR(1:4)=NOMTP(NEF)
  302.               CALL ERREUR(355)
  303.               SEGSUP,MRIGID,xMATRI
  304.               GO TO 999
  305.             ENDIF
  306.             XK=VALMAT(1)*DJAC/EP
  307. *
  308. *        ON AJOUTE LE PRODUIT K*DJAC*TRANSPOSEE(GRAD)*GRAD
  309. *        POUR LE POINT DE GAUSS CONSIDERE,A LA MATRICE CEL1
  310. *
  311.             CALL NTNST (GRAD,XK,NBNN,NDIM,CEL1)
  312. *
  313. *
  314.        ELSE
  315. *
  316. *        CAS ORTHOTROPE
  317. *
  318.         EP=VALMAT(3)
  319.         IF(EP.LE.XPETIT)THEN
  320. *   L'ELEMENT (IEL) AU POINT DE GAUSS (IGAU)DE TYPE (NOMTP(NEF)) A
  321. *     UNE EPAISSEUR NULLE
  322.           INTERR(1)=IEL
  323.           INTERR(2)=IGAU
  324.           MOTERR(1:4)=NOMTP(NEF)
  325.           CALL ERREUR(355)
  326.           SEGSUP,MRIGID,xMATRI
  327.           GO TO 999
  328.         ENDIF
  329.         XK1=VALMAT(1)/EP
  330.         XK2=VALMAT(2)/EP
  331. *
  332.         COSA=VALMAT(4)
  333.         SINA=-VALMAT(5)
  334. *       CALCUL DE LA MATRICE DES COEFFICIENTS DE RESISTIVITE DANS LE
  335. *       PLAN,PAR RAPPORT AU REPERE  LOCAL DE L'ELEMENT
  336. *
  337.         COS2=COSA*COSA
  338.         SIN2=SINA*SINA
  339.         SINCOS=SINA*COSA
  340.         YK(1,1)=COS2*XK1+SIN2*XK2
  341.         YK(1,2)=SINCOS*(XK1-XK2)
  342.         YK(2,1)=YK(1,2)
  343.         YK(2,2)=SIN2*XK1+COS2*XK2
  344.  
  345. *
  346. *        ON AJOUTE LE PRODUIT DJAC*TRANSPOSEE(GRAD)*YK*GRAD
  347. *        POUR LE POINT DE GAUSS CONSIDERE,A LA MATRICE CEL1
  348. *
  349.          CALL BDBST (GRAD,DJAC,YK,NBNN,NDIM,CEL1)
  350. *
  351.        ENDIF
  352. *
  353.   20  CONTINUE
  354. *
  355. *
  356.        IF(IFOIS.NE.0.AND.IFOIS.NE.NBPGAU)THEN
  357. *
  358. *      LE JACOBIEN EST NEGATIF ,MAILLAGE INCORRECT
  359.         INTERR(1)=IEL
  360.         CALL ERREUR(195)
  361.         SEGSUP,xMATRI,MRIGID
  362.         GO TO 999
  363.        ELSEIF(IFOI2.EQ.NBPGAU)THEN
  364. *
  365. *      CAS OU LE JACOBIEN EST TRES PETIT
  366. *
  367.         INTERR(1)=IEL
  368.         CALL ERREUR (259)
  369.         SEGSUP,xMATRI,MRIGID
  370.         GO TO 999
  371.        ENDIF
  372. *
  373. *         SEGINI,XMATRI
  374. *         IMATTT(IEL)=XMATRI
  375. *
  376. *        REMPLISSAGE DE XMATRI
  377. *
  378.          CALL REMPMT(CEL1,NBNN,RE(1,1,iel))
  379. *         SEGDES,XMATRI
  380.  10   CONTINUE
  381. *     END DO
  382. *
  383. *     DESACTIVATION DES SEGMENTS
  384. *
  385.       SEGDES,xMATRI,MRIGID
  386.  999  CONTINUE
  387.       SEGSUP,MMAT1
  388.  99   CONTINUE
  389. *      SEGDES,INFO
  390. *
  391.       MPTVAL=IVAMAT
  392.       SEGSUP MPTVAL
  393.       NOMID=MOMATR
  394.       SEGSUP NOMID
  395.       END
  396.  
  397.  
  398.  
  399.  

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