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

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