Télécharger la plaquette Cast3M


fr en

Télécharger sore2.eso

Retour à la liste

Numérotation des lignes : 

sore2

  1. C SORE2     SOURCE    CB215821  24/04/12    21:17:15     11897          
  2.  
  3. ************************************************************************
  4. *
  5. *                             SORE2
  6. *                             ------
  7. *         CREATION DE LA MATRICE DE CONDUCTIVITE   N DIV(GRAD T)
  8. *                        ( EFFET SORET)
  9. *
  10. * FONCTION:
  11. * ---------
  12. *     TRAITEMENT DU CAS DES ELEMENTS-FINIS MASSIFS A INTEGRATION
  13. *     NUMERIQUE,POUR UN MAILLAGE ELEMENTAIRE
  14. *
  15.  
  16. *
  17. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
  18. * -----------
  19. *
  20. *     NEF     (E)  NUMERO DE L'ELEMENT-FINI DANS NOMTP (VOIR CCHAMP)
  21. *     IMAIL   (E)  NUMERO DU MAILLAGE ELEMENTAIRE CONSIDERE,DANS
  22. *                  L'OBJET MODELE
  23. *     IPMODE  (E)  POINTEUR SUR UN SEGMENT IMODEL
  24. *     IPCHEM  (E)  POINTEUR SUR UN CHAMELEM (GRAD T aux PTS de GAUSS)
  25. *     IPCHE1  (E)  POINTEUR SUR UN CHAMELEM MATERIAU
  26. *     IPCHE4  (E)  POINTEUR SUR UN CHAMELEM  FACTEUR DE GRAD T
  27. *
  28. *     IPRIGI (E/S) POINTEUR SUR L'OBJET RESULTAT,DE TYPE RIGIDITE
  29. *
  30. * VARIABLES:
  31. * ----------
  32. *
  33. *     NBNN     NOMBRE DE NOEUDS DANS L'ELEMENT CONSIDERE
  34. *     NEF      NUMERO DE L'ELEMENT FINI DANS NOMTP (VOIR CCHAMP)
  35. *     NBELEM   NOMBRE D'ELEMENTS DANS LE MAILLAGE ELEMENTAIRE
  36. *     NBPGAU   NOMBRE DE POINTS DE GAUSS DANS L'ELEMENT-FINI
  37. *     NDIM     NOMBRE DE LIGNES DE LA MATRICE GRADIENT
  38. *     CEL(NBNN,NBNN)  MATRICE DE CONDUCTIVITE ELEMENTAIRE NON SYMETRIQUE
  39. *     XE(3,NBNN)      COORDONNEES DE L'ELEMENT DANS LE REPERE GLOBAL
  40. *     SHP(6,NBNN)     TABLEAU DE TRAVAIL
  41. *     GRAD(NDIM,NBNN) MATRICE GRADIENT DES FONCTIONS DE FORME
  42. *
  43. *
  44. *
  45. * AUTEUR, DATE DE CREATION:
  46. * -------------------------
  47. *
  48. *     J.M.BAZE   AVRIL 97
  49. *
  50. * LANGAGE:
  51. * --------
  52. *
  53. *     ESOPE + FORTRAN77
  54. *
  55. ************************************************************************  *
  56.       SUBROUTINE SORE2(NEF,IMAIL,IPMODE,IPCHE1,IPCHEM,IPCHE4,IPRIGI)
  57.  
  58.       IMPLICIT INTEGER(I-N)
  59.       IMPLICIT REAL*8(A-H,O-Z)
  60. *
  61.  
  62. -INC PPARAM
  63. -INC CCOPTIO
  64. -INC CCREEL
  65. *-
  66. -INC SMCOORD
  67. -INC SMINTE
  68. C-INC CCHAMP
  69. -INC SMMODEL
  70. -INC SMRIGID
  71. -INC SMELEME
  72. -INC SMCHAML
  73. *
  74.       SEGMENT MPTVAL
  75.         INTEGER IPOS(NS)    ,NSOF(NS)
  76.         INTEGER      IVAL(NCOSOU)
  77.         CHARACTER*16 TYVAL(NCOSOU)
  78.       ENDSEGMENT
  79. *
  80.       SEGMENT,MAXE
  81.         REAL*8 XLOC(3,3),XGLOB(3,3),TXR(IDIM,IDIM)
  82.       ENDSEGMENT
  83. *
  84.       SEGMENT,MMAT1
  85.         REAL*8 CEL(NBNN,NBNN),XE(3,NBNN)
  86.         REAL*8 SHP(6,NBNN),GRAD(NDIM,NBNN)
  87.         REAL*8 CMAT(NDIM,NDIM),CMAT1(IDIM,IDIM)
  88.       ENDSEGMENT
  89. *
  90.       SEGMENT NOTYPE
  91.         CHARACTER*16 TYPE(NBTYPE)
  92.       ENDSEGMENT
  93. *
  94.       SEGMENT,MVELCH
  95.         REAL*8 GDT(IDIM),VALMAT(NV1), GDTL(IDIM)
  96.       ENDSEGMENT
  97. *
  98. *NU      CHARACTER*8 CNM
  99.       CHARACTER*(NCONCH) CONM
  100.       PARAMETER(NINF=3)
  101.       INTEGER INFOS(NINF)
  102.       LOGICAL lsupma
  103. *
  104. *     RECUPERATION DES CARACTERISTIQUES GEOMETRIQUES DU MAILLAGE
  105. *     ELEMENTAIRE
  106. *
  107.       IMODEL=IPMODE
  108. c*      SEGACT,IMODEL
  109.       CONM   =  imodel.CONMOD
  110.       IPMAIL = imodel.IMAMOD
  111.  
  112. *NU      CNM = imodel.CMATEE
  113.       INM = imodel.IMATEE
  114. *NU      INT = imodel.INATUU
  115.  
  116.       MELEME = imodel.IMAMOD
  117. c*      SEGACT,MELEME
  118.       NBNN   = meleme.NUM(/1)
  119.       NBELEM = meleme.NUM(/2)
  120.  
  121.       MRIGID = IPRIGI
  122. c*      SEGACT,MRIGID
  123.       xMATRI = IRIGEL(4,IMAIL)
  124. c*      SEGACT,xMATRI*MOD
  125.  
  126. *--------------------------
  127. *     RECHERCHE  POINTEUR DU SEGMENTS MELVAL  CONTENANT
  128. *              LA DIFFUSIVITE
  129. *
  130. *     REMLIR LE TABLEAU INFOS (INFORMATIONS SUR ELEMENT)
  131.       INFOS(1)=0
  132.       INFOS(1)=0
  133.       INFOS(2)=0
  134.       INFOS(3)=NIFOUR
  135. *
  136.       if (lnomid(6).ne.0) then
  137.         lsupma = .false.
  138.         nomid = imodel.lnomid(6)
  139.         SEGACT,nomid
  140.         MOMATR = nomid
  141.         NMATR = lesobl(/2)
  142.         NMATF = lesfac(/2)
  143.       else
  144.         MFR = 1
  145.         lsupma = .true.
  146.         CALL IDMATR(MFR,IMODEL,MOMATR,NMATR,NMATF)
  147.       endif
  148.       NMATT = NMATR
  149.       NV1   = NMATT
  150. *
  151.       NBTYPE = 1
  152.       SEGINI,notype
  153.       notype.TYPE(1) = 'REAL*8'
  154.       MOTYPE=notype
  155. *
  156.       CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  157.  
  158.       nomid = MOMATR
  159.       SEGDES,nomid
  160.       IF (lsupma) SEGSUP,nomid
  161.       SEGSUP,NOTYPE
  162.  
  163.       IF (IERR.NE.0)THEN
  164.         IPRIGI = 0
  165.         RETURN
  166.       ENDIF
  167. *
  168. *     RECUPERATION DES CARACTERISTIQUES D'INTEGRATION DE L'ELEMENT
  169. *     FINI LIE A NOTRE MAILLAGE
  170.       CALL TSHAPE(NEF,'GAUSS',IPINTE)
  171.       IF (IERR.NE.0) THEN
  172.         IPRIGI = 0
  173.         RETURN
  174.       ENDIF
  175.       MINTE = IPINTE
  176.       SEGACT,MINTE
  177.       NBPGAU = minte.POIGAU(/1)
  178.  
  179. *     RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE
  180. *     DE L'ELEMENT POUR LE CALCUL  DES AXES LOCAUX
  181. *
  182.       NLG=NUMGEO(NEF)
  183.       CALL RESHPT(1,NBNN,NLG,NEF,0,IPT1,IRT1)
  184.       MINTE1 = IPT1
  185.       SEGACT,MINTE1
  186. *
  187. *----------------------------
  188.  
  189. *  recuperation des MELVAL composantes du gradient aux pts de Gauss
  190. *           et   de leurs multiplicateurs
  191.       MCHEL1=IPCHEM
  192.       MCHEL2=IPCHE4
  193.       SEGACT,MCHEL1,MCHEL2
  194.  
  195.       MCHAM1 = MCHEL1.ICHAML(1)
  196.       MCHAM2 = MCHEL2.ICHAML(1)
  197.       SEGACT,MCHAM1,MCHAM2
  198.       SEGDES,MCHEL1,MCHEL2
  199. *
  200.       MELVA1=MCHAM1.IELVAL(1)
  201.       MELVA2=MCHAM1.IELVAL(2)
  202.       SEGACT,MELVA1,MELVA2
  203.       IF(IDIM.EQ.3) THEN
  204.         MELVA3=MCHAM1.IELVAL(3)
  205.         SEGACT,MELVA3
  206.       ENDIF
  207.       MELVA4 =MCHAM2.IELVAL(1)
  208.       SEGACT,MELVA4
  209. *
  210.       NDIM=IDIM
  211.       SEGINI,MMAT1,MVELCH,MAXE
  212. *
  213. *     BOUCLE SUR LES ELEMENTS DU MAILLAGE ELEMENTAIRE IMAIL
  214. *
  215.       DO 10 IEL=1,NBELEM
  216. *
  217. *        MISE A ZERO DU TABLEAU CEL
  218. *
  219.         CALL ZERO(CEL,NBNN,NBNN)
  220.  
  221. *        ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IEL,
  222. *        DANS LE REPERE GLOBAL
  223. *
  224.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  225. *
  226. *         CALCUL DES AXES LOCAUX DANS LE CAS ORTHO
  227. *
  228.         IF (INM.EQ.2)THEN
  229.           NBSH = MINTE1.SHPTOT(/2)
  230.           CALL RLOCAL(XE,MINTE1.SHPTOT,NBSH,NBNN,TXR)
  231.           if (nbsh.eq.-1) then
  232.             call erreur(525)
  233.             IPRIGI = 0
  234.             GOTO 99
  235.           endif
  236.         ENDIF
  237.  
  238. *        BOUCLE SUR LES POINTS DE GAUSS
  239. *
  240.         IFOIS=0
  241.         IFOI2=0
  242.  
  243.         DO 20 IGAU=1,NBPGAU
  244. *
  245. *           CALCUL DE LA MATRICE GRADIENT DES FONCTIONS DE FORME ET
  246. *           DU JACOBIEN,EN UN POINT DE GAUSS
  247.  
  248.           CALL TCOND5(IGAU,NBNN,NDIM,XE,SHPTOT,SHP,GRAD,DJAC)
  249. *  SI IFOMOD = 0  axi DJAC CONTITNT DEJA LE MULTIPLICATEUR 2*XPI*R
  250.  
  251.           IF (IERR.NE.0) THEN
  252.             IPRIGI = 0
  253.             GOTO 99
  254.           ENDIF
  255.             IF (DJAC.LT.XZERO) THEN
  256.                IFOIS=IFOIS+1
  257.             ENDIF
  258.             IF (ABS(DJAC).LT.XPETIT) THEN
  259.                IFOI2=IFOI2+1
  260.             ENDIF
  261. *
  262. *           ON MULTIPLIE LE JACOBIEN PAR LE POIDS D'INTEGRATION,
  263. *           POUR LE POINT DE GAUSS CONSIDERE
  264. *
  265.           DJAC=ABS(DJAC)*POIGAU(IGAU)
  266.  
  267. *    VALEURS DES COMPOSANTES DES GRADIENTS
  268.           DO  29 IM=1,IDIM
  269.              MELVAL=MCHAM1.IELVAL(IM)
  270.              IBMN=MIN(IEL,VELCHE(/2))
  271.              IGMN=MIN(IGAU,VELCHE(/1))
  272.              GDT(IM)=VELCHE(IGMN,IBMN)
  273.  29       CONTINUE
  274. *           FACTEUR DE GRAD T
  275.           IBMN=MIN(IEL,MELVA4.VELCHE(/2))
  276.           IGMN=MIN(IGAU,MELVA4.VELCHE(/1))
  277.           RMUL = MELVA4.VELCHE(IGMN,IBMN)
  278. *
  279. *     DIFFUSIVITE  DANS LE REPERE LOCAL
  280. *
  281.           MPTVAL=IVAMAT
  282.           DO  30 IM=1,NMATT
  283.             IF(IVAL(IM).NE.0)THEN
  284.               MELVAL=IVAL(IM)
  285.               IBMN=MIN(IEL,VELCHE(/2))
  286.               IGMN=MIN(IGAU,VELCHE(/1))
  287.               VALMAT(IM)=VELCHE(IGMN,IBMN)
  288.             ELSE
  289.               VALMAT(IM)=0.D0
  290.             ENDIF
  291.  30       CONTINUE
  292. *
  293.             IF (INM.EQ.1) THEN
  294. *------------------------ MATERIAU ISOTROPE ----------------------------
  295. *
  296. *     INTEGRATION DES TERMES  N VI B
  297. *
  298.                RK = VALMAT(1)*DJAC*RMUL
  299.                DO 700 K=1,IDIM
  300.                   XK = GDT(K)*RK
  301.                   DO 300 I=1,NBNN
  302.                      R_Z = SHP(1,I) * XK
  303.                      DO 400 J = 1, NBNN
  304.                         CEL(J,I) = CEL(J,I) + R_Z * GRAD(K,J)
  305.  400                 CONTINUE
  306.  300              CONTINUE
  307.  700           CONTINUE
  308. *
  309.             ELSE
  310. *-------------------  MATERIAU ORTHOTROPE -----------------
  311.                CALL ZERO(CMAT,NDIM,NDIM)
  312.                CALL ZERO(CMAT1,IDIM,IDIM)
  313.                CALL ZERO(XGLOB,IDIM,IDIM)
  314.                IF(IDIM.EQ.2) THEN
  315. *----------BIDIM
  316.  
  317. *             MATERIAU ORTHOTROPE
  318.  
  319.                   XLOC(1,1)=VALMAT(3)
  320.                   XLOC(2,1)=VALMAT(4)
  321.                   XLOC(1,2)=-VALMAT(4)
  322.                   XLOC(2,2)=VALMAT(3)
  323.  
  324. *           CALCUL DES COS.DIRECTEURS DES AXES ORTH. /REPERE GLOBAL
  325. *           XGLOB=TXR*XLOC
  326. *
  327.                   DO 40 K=1,IDIM
  328.                      DO 409 J=1,IDIM
  329.                         DO 4099 I=1,IDIM
  330.                            XGLOB(K,J)=TXR(J,I)*XLOC(I,K)+XGLOB(K,J)
  331.  4099                   CONTINUE
  332.  409                 CONTINUE
  333.  40               CONTINUE
  334. *
  335.                   DO 51 I = 1,IDIM
  336.                      CMAT1(I,I) = VALMAT(I)
  337.  51               CONTINUE
  338. *
  339. *              RETOUR DANS LE REPERE GLOBAL
  340.                   CALL PRODT(CMAT,CMAT1,XGLOB,IDIM,IDIM)
  341.                   DO 41 I= 1, IDIM
  342.                      GDTL(I) = 0.D0
  343.                      DO 411 J= 1, IDIM
  344.                         GDTL(I) = GDTL(I) + CMAT(I,J)*GDT(J)
  345.  411                 CONTINUE
  346.  41               CONTINUE
  347. *
  348.                ELSE
  349. *----------TRIDIM   MATERIAU ORTHOTROPE -------------------
  350.  
  351.                   XLOC(1,1)=VALMAT(4)
  352.                   XLOC(2,1)=VALMAT(5)
  353.                   XLOC(3,1)=VALMAT(6)
  354.                   XLOC(1,2)=VALMAT(7)
  355.                   XLOC(2,2)=VALMAT(8)
  356.                   XLOC(3,2)=VALMAT(9)
  357.                   CALL  CROSS2 (XLOC(1,1),XLOC(1,2),XLOC(1,3),IRR)
  358.                   DO 45 K=1,IDIM
  359.                      DO 451 J=1,IDIM
  360.                         DO 452 I=1,IDIM
  361.                            XGLOB(K,J)=TXR(J,I)*XLOC(I,K)+XGLOB(K,J)
  362.  452                    CONTINUE
  363.  451                 CONTINUE
  364.  45               CONTINUE
  365. *
  366.                   DO 52 I = 1,IDIM
  367.                      CMAT1(I,I) = VALMAT(I)
  368.  52               CONTINUE
  369. *
  370. *             RETOUR DANS  LE REPERE GLOBAL
  371.                   CALL PRODT(CMAT,CMAT1,XGLOB,IDIM,IDIM)
  372.  
  373.                   DO 53 I= 1, IDIM
  374.                      GDTL(I) = 0.D0
  375.                      DO 531 J= 1, IDIM
  376.                         GDTL(I) = GDTL(I) + CMAT(I,J)*GDT(J)
  377.  531                 CONTINUE
  378.  53               CONTINUE
  379. *
  380.                ENDIF
  381.  
  382. *     INTEGRATION DES TERMES  N VI B
  383. *
  384.                DO   701 K=1,IDIM
  385.                   XK = GDTL(K)*DJAC*RMUL
  386.                   DO   301 I=1,NBNN
  387.                      DO   401 J=1,NBNN
  388.                         CEL(J,I) = CEL(J,I) + SHP(1,I)*GRAD(K,J)*XK
  389.  401                 CONTINUE
  390.  301              CONTINUE
  391.  701           CONTINUE
  392.             ENDIF
  393. *
  394. *  FIN DE LA BOUCLE SUR LES POINTS DE GAUSS
  395. *
  396.  20      CONTINUE
  397. *        END DO
  398.          IF (IFOIS.NE.0.AND.IFOIS.NE.NBPGAU) THEN
  399. *
  400. *           LE JACOBIEN EST NEGATIF,MAILLAGE INCORRECT
  401. *
  402.             INTERR(1)=IEL
  403.             CALL ERREUR(195)
  404.             IPRIGI = 0
  405.             GOTO 99
  406.          ENDIF
  407.          IF (IFOI2.EQ.NBPGAU) THEN
  408. *
  409. *           CAS OU LE JACOBIEN EST TRES PETIT
  410. *
  411.             INTERR(1)=IEL
  412.             CALL ERREUR(259)
  413.             IPRIGI = 0
  414.             GOTO 99
  415.          ENDIF
  416.  
  417. *        REMPLISSAGE DE XMATRI
  418. *
  419.          DO 100 IA=1,NBNN
  420.             DO 1001 IB=1,NBNN
  421.                xmatri.RE(IA,IB,iel) = CEL(IA,IB)
  422.  1001       CONTINUE
  423.  100     CONTINUE
  424.  
  425. *         SEGDES,XMATRI
  426.  10   CONTINUE
  427. *     END DO
  428. *
  429. *     DESACTIVATION DES SEGMENTS
  430. *
  431.  99   CONTINUE
  432.       SEGSUP,MMAT1,MVELCH
  433.       SEGDES,MINTE,MINTE1
  434.       SEGDES,MELVA4
  435.       DO 550 I=1,IDIM
  436.         MELVAL=MCHAM1.IELVAL(I)
  437.         SEGDES,MELVAL
  438.  550  CONTINUE
  439.       SEGDES,MCHAM1
  440.  
  441.       CALL DTMVAL(IVAMAT,1)
  442.  
  443.       RETURN
  444.       END
  445.  
  446.  
  447.  
  448.  

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