Télécharger la plaquette Cast3M


fr en

Télécharger masse2.eso

Retour à la liste

Numérotation des lignes : 

masse2

  1. C MASSE2    SOURCE    OF166741  25/02/21    21:17:56     12166          
  2.       SUBROUTINE MASSE2(IPMAIL,NDDL,LRE,NBPGAU,IPMINT,
  3.      &              MELE,MFR,IVAMAT,IVACAR,NMATT,IPMATR,ILUMP,IIPDPG)
  4. *---------------------------------------------------------------------*
  5. *        _________________________________                            *
  6. *        |                                |                           *
  7. *        |  calcul de la matrice de masse |                           *
  8. *        |________________________________|                           *
  9. *                                                                     *
  10. *        massif, liquide, 'surface libre ,incompressible              *
  11. *                                                                     *
  12. *---------------------------------------------------------------------*
  13. *                                                                     *
  14. *   entrees :                                                         *
  15. *   ________                                                          *
  16. *                                                                     *
  17. *        ipmail   pointeur sur un segment  meleme                     *
  18. *        nddl     nombre de degre de liberte /noeud                   *
  19. *        lre      nombre de ddl dans la matrice de masse              *
  20. *        nbpgau   nombre de point d'integration pour la masse         *
  21. *        ipmint   pointeur sur un segment minte                       *
  22. *        ipmin1   pointeur sur un segment minte (aux noeuds)          *
  23. *        mele     numero de l'element fini                            *
  24. *        mfr      numero de la formulation                            *                                    *
  25. *        ivamat   pointeur sur un segment mptval pour le materiau ou  *
  26. *                 pour une matrice de hooke                           *
  27. *        ivacar   pointeur sur un segment mptval pour les             *
  28. *                 caracteristiques                                    *
  29. *        nmatt    nombre de composante de materiau (imat=1)           *                       *
  30. *        ilump    =1 si l'opérateur LUMP est appelé
  31. *                                                                     *
  32. *   sorties :                                                         *
  33. *   ________                                                          *
  34. *                                                                     *
  35. *        ipmatr   pointeur sur la matrice de masse de la sous-zone    *
  36. *                                                                     *
  37. *---------------------------------------------------------------------*
  38.       IMPLICIT INTEGER(I-N)
  39.       IMPLICIT REAL*8(A-H,O-Z)
  40.  
  41. -INC PPARAM
  42. -INC CCOPTIO
  43. -INC CCHAMP
  44. -INC CCREEL
  45.  
  46. -INC SMCOORD
  47. -INC SMRIGID
  48. -INC SMCHAML
  49. -INC SMELEME
  50. -INC SMINTE
  51. -INC SMMODEL
  52.  
  53. -INC TMPTVAL
  54.  
  55.       SEGMENT WRK1
  56.         REAL*8 REL(LRE,LRE),XE(3,NBBB)
  57.       ENDSEGMENT
  58.  
  59.       SEGMENT WRK2
  60.         REAL*8 SHPWRK(6,NBNO),BGENE(NDDL,LRE)
  61.       ENDSEGMENT
  62.  
  63.       SEGMENT WRK5
  64.         REAL*8 BLX(NDDL,LRE),BLY(NDDL,LRE),BLZ(NDDL,LRE)
  65.         REAL*8 BLT(NDDL,LRE)
  66.       ENDSEGMENT
  67.  
  68.       SEGMENT WRK6
  69.         REAL*8 PROPEL(1)
  70.         REAL*8 OUT(5)
  71.         REAL*8 WORK1(24*24)
  72.       ENDSEGMENT
  73.  
  74.       SEGMENT MVELCH
  75.         REAL*8 VALMAT(NV1)
  76.       ENDSEGMENT
  77.  
  78.       dimension ddhook(3)
  79.  
  80.       MELEME=IPMAIL
  81.       NBNN=NUM(/1)
  82.       NBELEM=NUM(/2)
  83.  
  84.       xMATRI=IPMATR
  85.       NLIGRP=LRE
  86.       NLIGRD=LRE
  87.  
  88. *     introduction du point autour duquel se fait le mouvement
  89. *     de la section en defo plane generalisee
  90. *     En 1D : pas de rotation
  91.       IF (IFOUR.EQ.-3) THEN
  92.         IREF=(IIPDPG-1)*(IDIM+1)
  93.         XDPGE=XCOOR(IREF+1)
  94.         YDPGE=XCOOR(IREF+2)
  95.       ELSE
  96.         XDPGE=0.D0
  97.         YDPGE=0.D0
  98.       ENDIF
  99.  
  100.       NHRM=NIFOUR
  101.  
  102.       MINTE=IPMINT
  103.  
  104.       I195=0
  105.       I259=0
  106.  
  107.       DIM3=1.D0
  108.       NBNO=NBNN
  109.       NBBB=NBNN
  110.  
  111.       NV1=NMATT
  112.       SEGINI,MVELCH
  113.  
  114. c_______________________________________________________________________
  115. c
  116. c     numero des etiquettes      :
  117. c     etiquettes de 1 a 98 pour traitement specifique a l element
  118. c     dans la zone specifique a chaque element commencant par :
  119. c     5  continue
  120. c     element 5   etiquettes 1005 2005 3005 4005   ...
  121. c     44 continue
  122. c     element 44  etiquettes 1044 2044 3044 4044   ...
  123. c_______________________________________________________________________
  124. c
  125.       GOTO (99,99,99,4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  126.      199,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,35,35,35,35,35,35,
  127.      299,99,99,99,99,99,99,48,99,99,99,99,48,48,99,99,99,99,99,99,
  128.      399,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,99,99,
  129.      499,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  130.      599,99,99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
  131.      64, 4),MELE
  132. * BCN
  133.       IF ((MELE.eq.183).or.(MELE.eq.184)) GOTO 4
  134. * BCN
  135. C= Elements MECANIQUE 1D : M1Dx
  136.       IF (MELE.EQ.193.OR.MELE.EQ.194) GOTO 4
  137.       IF (MELE.EQ.260) GOTO 5
  138.  
  139. * Elements pyramides incompressibles BBAR :
  140.       IF (MELE.EQ.273.OR.MELE.EQ.274) GOTO 4
  141.  
  142.  99   CONTINUE
  143.       MOTERR(1:4)=NOMTP(MELE)
  144.       MOTERR(5:12)='MASSE2'
  145.       CALL ERREUR(86)
  146.       GOTO 510
  147.  
  148. c_______________________________________________________________________
  149. c
  150. c     secteur de calcul pour les elements massifs et elements incompressibles
  151. c_______________________________________________________________________
  152. c
  153.    4  CONTINUE
  154.       SEGINI WRK1,WRK2
  155.       DO 3004  IB=1,NBELEM
  156. c
  157. c        on cherche  les coordonnees des noeuds de l element ib
  158. c
  159.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  160.           CALL ZERO (REL,LRE,LRE)
  161. c
  162. c        boucle sur les points de gauss
  163. c
  164.           ISDJC=0
  165.           DO 4004  IGAU=1,NBPGAU
  166. c
  167. c   recuperation de l'epaisseur
  168. c
  169.               IF (IFOUR.EQ.-2)THEN
  170.                   IF (IVACAR.NE.0) THEN
  171.                       MPTVAL=IVACAR
  172.                       MELVAL=IVAL(1)
  173.                       IF (MELVAL.NE.0) THEN
  174.                           IGMN=MIN(IGAU,VELCHE(/1))
  175.                           IBMN=MIN(IB,VELCHE(/2))
  176.                           DIM3=VELCHE(IGMN,IBMN)
  177.                       ELSE
  178.                           DIM3=1.D0
  179.                       ENDIF
  180.                   ENDIF
  181.               ENDIF
  182. *
  183.               CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  184.      1        DIM3,XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  185.               IF(DJAC.LT.0.) ISDJC=ISDJC+1
  186.               IF(DJAC.EQ.0.) I259=IB
  187.               DJAC=ABS(DJAC)*POIGAU(IGAU)
  188.               MPTVAL=IVAMAT
  189.               MELVAL=IVAL(1)
  190.               IF (MELVAL.NE.0) THEN
  191.                   IGMN=MIN(IGAU,VELCHE(/1))
  192.                   IBMN=MIN(IB,VELCHE(/2))
  193.                   VALMAT(1)=VELCHE(IGMN,IBMN)
  194.               ELSE
  195.                   VALMAT(1)=0.D0
  196.               ENDIF
  197.               DJAC=DJAC*VALMAT(1)
  198.               CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  199.  4004     CONTINUE
  200.           IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  201. c
  202. c        remplissage de xmatri
  203. c
  204.           IF ( ILUMP .EQ. 0 ) THEN
  205.               CALL REMPMT(REL,LRE,RE(1,1,ib))
  206.           ELSE
  207. c
  208. c          cas de l'opérateur LUMP
  209. c
  210.              IF (MELE.EQ.4) THEN
  211. *               lumping par la méthode physique
  212.                CALL LUMP1(REL,LRE,RE(1,1,ib),IFOUR)
  213.              ELSE
  214. *               lumping par la méthode HRZ
  215.                CALL LUMP2(REL,LRE,RE(1,1,ib),IFOUR)
  216.              ENDIF
  217.           ENDIF
  218.  
  219.  3004 CONTINUE
  220.       SEGSUP WRK1,WRK2
  221.       GOTO 510
  222.  
  223. c_______________________________________________________________________
  224. c
  225. c     secteur de calcul pour element SHB8
  226. c_______________________________________________________________________
  227. c
  228.    5  CONTINUE
  229.       NBNO=NBNN
  230.       NBBB=NBNN
  231.       SEGINI WRK1,WRK2,WRK6
  232.  
  233.       VALMAT(1)=0.D0
  234.       MPTVAL=IVAMAT
  235.       MELVAL=IVAL(1)
  236.       IF (MELVAL.NE.0) THEN
  237.         NIBM = VELCHE(/2)
  238.       ENDIF
  239.  
  240.       DO 3005  IB=1,NBELEM
  241. c
  242. c        on cherche  les coordonnees des noeuds de l element ib
  243. c
  244.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  245.         CALL ZERO (REL,LRE,LRE)
  246. c
  247.         IF (MELVAL.NE.0) THEN
  248.           VALMAT(1) = melval.VELCHE(1,MIN(IB,NIBM))
  249.         ENDIF
  250. *
  251.         PROPEL(1)=VALMAT(1)
  252. C
  253. C  CALCUL DE LA MATRICE DE MASSE
  254. C
  255.         call SHB8 (3,XE,DDHOOK,PROPEL,WORK1,REL,OUT)
  256. C
  257. c remplissage de xmatri
  258. c
  259.         CALL REMPMT(REL,LRE,RE(1,1,ib))
  260.  
  261.  3005 CONTINUE
  262.  
  263.       SEGSUP WRK1,WRK2,WRK6
  264.       GOTO 510
  265.  
  266. c_______________________________________________________________________
  267. c
  268. c     secteur de calcul pour les elements liquides
  269. c_______________________________________________________________________
  270. c
  271.   35  CONTINUE
  272. c
  273. c      ces éléments n'ont pas été testé pour l'opérateur LUMP
  274. c
  275.       IF ( ILUMP .EQ. 1 ) GOTO 99
  276. c
  277.       DIM3=1.D0
  278.       NBNO=NBNN
  279.       NBBB=NBNN
  280.       SEGINI WRK1,WRK2,WRK5
  281.  
  282.       DO 3035  IB=1,NBELEM
  283. c
  284. c        on cherche  les coordonnees des noeuds de l element ib
  285. c
  286.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  287.           CALL ZERO (REL,LRE,LRE)
  288.  
  289. c
  290. c        calcul des termes en p*pi
  291.  
  292.           ISDJC=0
  293.           DO 4035  IGAU=1,NBPGAU
  294.  
  295. c        calcul des coefficients de normalisation et proprietes materielles
  296.             MPTVAL=IVAMAT
  297.             DO 6035 IM=1,NMATT
  298.              IF (IVAL(IM).NE.0) THEN
  299.                MELVAL=IVAL(IM)
  300.                IGMN=MIN(IGAU,VELCHE(/1))
  301.                IBMN=MIN(IB,VELCHE(/2))
  302.                VALMAT(IM)=VELCHE(IGMN,IBMN)
  303.              ELSE
  304.                VALMAT(IM)=0.D0
  305.              ENDIF
  306.  6035       CONTINUE
  307.            RHO   = VALMAT(1)
  308.            C     = VALMAT(2)
  309.            RHOREF= VALMAT(3)
  310.            CREF  = VALMAT(4)
  311.            RLCAR = VALMAT(5)
  312.  
  313.            COEFPR= (RHOREF*CREF**2)/RLCAR
  314.            COEFPI= RHOREF*RLCAR
  315.            VML12 =-(COEFPR*COEFPI)/(RHO*C**2)
  316.            VML22 =-(COEFPI**2)/RHO
  317.  
  318. c
  319. c   recuperation de l'epaisseur
  320. c
  321.               IF (IFOUR.EQ.-2)THEN
  322.                   MPTVAL=IVACAR
  323.                   IF (IVACAR.NE.0) THEN
  324.                       MELVAL=IVAL(1)
  325.                       IF (MELVAL.NE.0) THEN
  326.                           IGMN=MIN(IGAU,VELCHE(/1))
  327.                           IBMN=MIN(IB,VELCHE(/2))
  328.                           DIM3=VELCHE(IGMN,IBMN)
  329.                       ELSE
  330.                           DIM3=1.D0
  331.                       ENDIF
  332.                   ENDIF
  333.               ENDIF
  334.               CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  335.      1        DIM3,XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  336.               IF(DJAC.LT.0.) ISDJC=ISDJC+1
  337.               DJAC=ABS(DJAC)*POIGAU(IGAU)
  338.               CALL NMLNST(BGENE,DJAC,VML12,LRE,NDDL,REL)
  339. c
  340. c        calcul des termes en pi*pi
  341. c
  342.  
  343.               CALL BLMAST(IGAU,MFR,NBNN,LRE,IFOUR,NDDL,NHRM,
  344.      1        XE,SHPTOT,SHPWRK,BLX,BLY,BLZ,BLT,DJAC)
  345.               DJAC=ABS(DJAC)*POIGAU(IGAU)
  346.               CALL BMLBST(BLX,BLY,BLZ,BLT,DJAC,VML22,IFOUR,LRE,NDDL,REL)
  347.  4035     CONTINUE
  348.           IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  349. c
  350. c        remplissage de xmatri
  351. c
  352.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  353.  
  354.  3035 CONTINUE
  355.       SEGSUP WRK1,WRK2,WRK5
  356.       GOTO 510
  357. c_______________________________________________________________________
  358. c
  359. c     secteur de calcul pour les elements de surface libre
  360. c_______________________________________________________________________
  361. c
  362.   48  CONTINUE
  363. c
  364. c      ces éléments n'ont pas été testé pour l'opérateur LUMP
  365. c
  366.       IF ( ILUMP .EQ. 1 ) GOTO 99
  367. c
  368.       NBNO=NBNN
  369.       NBBB=NBNN
  370.       SEGINI WRK1,WRK2
  371.       DO 3048  IB=1,NBELEM
  372. c
  373. c        on cherche  les coordonnees des noeuds de l element ib
  374. c
  375.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  376.           CALL ZERO (REL,LRE,LRE)
  377. c
  378. c        calcul du coefficient de normalisation sur pi
  379. c
  380.           MPTVAL=IVAMAT
  381.           DO 5048 IM=1,NMATT
  382.               MELVAL=IVAL(IM)
  383.               IBMN=MIN(IB,VELCHE(/2))
  384.               VALMAT(IM)=VELCHE(1,IBMN)
  385.  5048     CONTINUE
  386.           RHOREF= VALMAT(1)
  387.           RLCAR = VALMAT(2)
  388.           COEFPI= RHOREF*RLCAR
  389.           VMS =-COEFPI
  390. c
  391. c        boucle sur les points de gauss
  392. c
  393.           ISDJC=0
  394.           DO 4048  IGAU=1,NBPGAU
  395.               CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  396.      1        1.D0,XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  397.               IF(DJAC.LT.0.) ISDJC=ISDJC+1
  398.               DJAC=ABS(DJAC)*POIGAU(IGAU)
  399.               CALL NMSNST(BGENE,DJAC,VMS,LRE,NDDL,REL)
  400.  4048     CONTINUE
  401.           IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  402. c
  403. c        remplissage de xmatri
  404. c
  405.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  406.  
  407.  3048 CONTINUE
  408.  
  409.       SEGSUP,WRK1,WRK2
  410.       GOTO 510
  411. c_______________________________________________________________________
  412.  
  413.   510 CONTINUE
  414.       IF (I195.NE.0) THEN
  415.         INTERR(1) = I195
  416.         CALL ERREUR(195)
  417.       ENDIF
  418.       IF (I259.NE.0) THEN
  419.         INTERR(1) = I259
  420.         CALL ERREUR(259)
  421.       ENDIF
  422.       SEGSUP,MVELCH
  423.  
  424. c      RETURN
  425.       END
  426.  
  427.  
  428.  

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