Télécharger la plaquette Cast3M


fr en

Télécharger masse3.eso

Retour à la liste

Numérotation des lignes : 

masse3

  1. C MASSE3    SOURCE    CB215821  24/04/12    21:16:39     11897          
  2.       SUBROUTINE MASSE3(IPMAIL,LRE,LW,MELE,IVAMAT,NMATT,IVACAR,
  3.      &NCARR,IVECT,ISOUS,NBPGAU,IPMINT,IPMIN2,NDDL,MATE,CMATE,
  4.      &LHOOK,IPMATR,ILUMP,IIPDPG,IMOD)
  5. *---------------------------------------------------------------------*
  6. *        _________________________________                            *
  7. *        |                                |                           *
  8. *        |  calcul de la matrice de masse |                           *
  9. *        |________________________________|                           *
  10. *                                                                     *
  11. *      coq3/poutre,dkt,coq4,coq8,coq2,dst                             *
  12. *                                                                     *
  13. *---------------------------------------------------------------------*
  14. *                                                                     *
  15. *   entrees :                                                         *
  16. *   ________                                                          *
  17. *                                                                     *
  18. *        ipmail   pointeur sur un segment  meleme                     *
  19. *        lre      nombre de ddl dans la matrice de masse              *
  20. *        lw       dimension du tableau de travail de l'element        *
  21. *        mele     numero de l'element fini                            *
  22. *        ivamat   pointeur sur un segment mptval pour le materiau     *
  23. *        nmatt    nombre de composante de materiau (imat=1)           *
  24. *        ivacar   pointeur sur un segment mptval pour les caracteri-  *
  25. *                 stiques                                             *
  26. *        ncarr    nombre de caracteristiques geometriques             *
  27. *        ivect    flag indiquant si on a entree les axes locaux       *
  28. *        isous     numero de la sous-zone                             *
  29. *        nbpgau   nombre de point d'integration pour la masse         *
  30. *        ipmint   pointeur sur un segment minte                       *
  31. *        ipmin1   pointeur sur un segment minte (aux noeuds)          *
  32. *        nddl     nombre de degre de liberte /noeud                   *
  33. *        mate     numero du materiau                                  *
  34. *       cmate     nom du materiau                                     *
  35. *        ilump    =1 si l'opérateur lump est appelé                   *
  36. *                                                                     *
  37. *   sorties :                                                         *
  38. *   ________                                                          *
  39. *                                                                     *
  40. *        ipmatr   pointeur sur la matrice de masse de la sous-zone    *
  41. *                                                                     *
  42. *---------------------------------------------------------------------*
  43.       IMPLICIT INTEGER(I-N)
  44.       IMPLICIT REAL*8(A-H,O-Z)
  45.  
  46. -INC PPARAM
  47. -INC CCOPTIO
  48. -INC CCHAMP
  49. -INC CCREEL
  50. *-
  51. -INC SMRIGID
  52. -INC SMCHAML
  53. -INC SMELEME
  54. -INC SMCOORD
  55. -INC SMINTE
  56. -INC SMMODEL
  57. C
  58.       SEGMENT WRK1
  59.       REAL*8 REL(LRE,LRE),XE(3,NBBB)
  60.       ENDSEGMENT
  61. C
  62.       SEGMENT WRK2
  63.       REAL*8 SHPWRK(6,NBNO),BGENE(NDDL,LRE)
  64.       ENDSEGMENT
  65. C
  66. C
  67.       SEGMENT WRK3
  68.       REAL*8 DDHOOK(LHOOK,LHOOK)
  69.       REAL*8 WORK(LW)
  70.       ENDSEGMENT
  71. C
  72.       SEGMENT WRK4
  73.       REAL*8 BPSS(3,3),XEL(3,NBBB)
  74.       ENDSEGMENT
  75. C
  76.       SEGMENT WRK6
  77.       REAL*8 RHOMAT(6,6)
  78.       ENDSEGMENT
  79. C
  80.       SEGMENT MVELCH
  81.       REAL*8 VALMAT(NV1)
  82.       ENDSEGMENT
  83. C
  84.       SEGMENT MPTVAL
  85.       INTEGER IPOS(NS),NSOF(NS)
  86.       INTEGER IVAL(NCOSOU)
  87.       CHARACTER*16 TYVAL(NCOSOU)
  88.       ENDSEGMENT
  89. *
  90.       DIMENSION CRIGI(12),CMASS(12)
  91.       CHARACTER*8 CMATE
  92. *
  93.       MELEME=IPMAIL
  94.       NBNN=NUM(/1)
  95.       NBELEM=NUM(/2)
  96. *
  97.       NV1=NMATT
  98.       SEGINI,MVELCH
  99. *
  100.       xMATRI=IPMATR
  101.       LVAL  = (LRE*(LRE+1))/2
  102.       NLIGRP=LRE
  103.       NLIGRD=LRE
  104. *
  105. *     introduction du point autour duquel se fait le mouvement
  106. *     de la section en defo plane generalisee
  107. *
  108.       IF (IFOUR.EQ.-3)THEN
  109.           IP=IIPDPG
  110.           SEGACT MCOORD
  111.           IREF=(IP-1)*(IDIM+1)
  112.           XDPGE=XCOOR(IREF+1)
  113.           YDPGE=XCOOR(IREF+2)
  114.       ELSE
  115.           XDPGE=0.D0
  116.           YDPGE=0.D0
  117.       ENDIF
  118. *
  119.       NHRM=NIFOUR
  120. *
  121.       MINTE=IPMINT
  122.       MINTE2=IPMIN2
  123.  
  124.       IMODEL = IMOD
  125.       jmat = 0
  126.         DO imat = 1 , matmod(/2)
  127.          if (matmod(imat).eq.'IMPEDANCE') then
  128.            jmat = imat
  129.          endif
  130.         ENDDO
  131. C_______________________________________________________________________
  132. C
  133. C     NUMERO DES ETIQUETTES      :
  134. C     ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  135. C     DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  136. C     5  CONTINUE
  137. C     ELEMENT 5   ETIQUETTES 1005 2005 3005 4005   ...
  138. C     44 CONTINUE
  139. C     ELEMENT 44  ETIQUETTES 1044 2044 3044 4044   ...
  140. C_______________________________________________________________________
  141. C
  142.       GOTO(99,2,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  143.      199,99,99,99,99,99,2,28,2,99,99,99,99,99,99,99,99,99,99,99,
  144.      241,27,99,44,2,99,99,99,49,99,99,99,99,99,99,41,99,99,99,99,
  145.      399,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  146.      499,99,99,27,99,99,99,99,99,99,99,99,93,99,99,99,27),MELE
  147.       GOTO 99
  148. C_______________________________________________________________________
  149. C_______________________________________________________________________
  150. C
  151. C     IMPEDANCE
  152. C_______________________________________________________________________
  153. C
  154.   2   CONTINUE
  155.       IF (jmat.gt.0) THEN
  156.           MPTVAL=IVAMAT
  157.           MELVAL=IVAL(1)
  158.         if (ival(/1).gt.1) then
  159.           melva1 = ival(2)
  160.         else
  161.           melva1 = 0
  162.         endif
  163.           jddl = LRE/NBPGAU
  164.          DO IB = 1,NBELEM
  165.           JDIAG = 0
  166.           IBMN=MIN(IB,VELCHE(/2))
  167.          do IG = 1, NBPGAU
  168.            igmn = MIN(IG,VELCHE(/1))
  169.           XMASS=VELCHE(IGMN,IBMN)
  170.           XINER = XMASS
  171.               if (melva1.gt.0) then
  172.                 igmn = MIN(IG,melva1.VELCHE(/1))
  173.                 XINER = melva1.VELCHE(IGMN,IBMN)
  174.               endif
  175.              do idl = 1,jddl
  176.               JDIAG = JDIAG + 1
  177.               RE(JDIAG,JDIAG,ib) = XMASS
  178.               if (idim.eq.3.and.idl.gt.3) RE(JDIAG,JDIAG,ib) = XINER
  179.               if (idim.ne.3.and.idl.gt.2) RE(JDIAG,JDIAG,ib) = XINER
  180.              enddo
  181.          enddo
  182.         ENDDO
  183.         SEGDES XMATRI
  184.         GOTO 510
  185.       ENDIF
  186.  
  187. C_______________________________________________________________________
  188. C
  189. C     ELEMENTS COQ3 ET POUTRES
  190. C_______________________________________________________________________
  191. C
  192.   27  CONTINUE
  193.  
  194.       IF (ILUMP .EQ. 1 ) THEN
  195. C           LUMP NE FONCTIONNE PAS POUR L'éLéMENT LSE2
  196.           IF (MELE.EQ.97) GOTO 99
  197. C           LUMP NE FONCTIONNE PAS POUR L'éLéMENT TIMO SECTION
  198.           IF (MELE .EQ. 84 .AND. CMATE.EQ.'SECTION') GOTO 99
  199.       ENDIF
  200. C
  201. C  CAS DES COQUES - POUTRES - TUYAUX - ACOUSTIQUE PURE
  202. C
  203.       NBBB=NBNN
  204.       SEGINI WRK1,WRK3
  205. *
  206. *  cas du materiau section
  207. *
  208.       NBGMAT = 0
  209.       NELMAT = 0
  210.       IF(CMATE.EQ.'SECTION') THEN
  211.           MPTVAL=IVAMAT
  212.           DO IM=1,NMATT
  213.           IF(IVAL(IM).NE.0)THEN
  214.               MELVAL=IVAL(IM)
  215.               NBGMAT=MAX(NBGMAT,IELCHE(/1))
  216.               NELMAT=MAX(NELMAT,IELCHE(/2))
  217.           END IF
  218.           END DO
  219.       ENDIF
  220. C
  221. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  222. C
  223.       DO 3027 IB=1,NBELEM
  224. C
  225. C     ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  226. C
  227.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  228. C
  229.           IF(MELE.EQ.29.OR.MELE.EQ.42.OR.MELE.EQ.97.
  230.      $    OR.MELE.EQ.84) GO TO 5029
  231. C
  232. C       CAS DU COQ3
  233. C       -----------
  234.           MPTVAL=IVAMAT
  235.           MELVAL=IVAL(1)
  236.           IBMN=MIN(IB,VELCHE(/2))
  237.           RR=VELCHE(1,IBMN)
  238.           MPTVAL=IVACAR
  239.           MELVAL=IVAL(1)
  240.           IBMN=MIN(IB,VELCHE(/2))
  241.           RR=RR*VELCHE(1,IBMN)
  242. C
  243.           CALL COQ3MA(XE,RR,WORK,REL,ILUMP)
  244.           GOTO 4027
  245. C
  246. C        CAS DES POUTRES ET DU TUYAU ACOUSTIQUE PURE
  247. C        -------------------------------------------
  248. C  ON STOCKE DES CARACTERISTIQUES GEOMETRIQUES ET MATERIELLES DANS WORK
  249. C
  250.  5029     CONTINUE
  251. C
  252. C  ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB ( GEOMETRIE ET MASSE
  253. C
  254.           NCARR1=NCARR
  255. *****     IF(IVECT.EQ.1) NCARR1=NCARR-1
  256.           CALL ZERO(WORK,NCARR1,1)
  257.           DO 4029 IGAU=1,NBNN
  258.               MPTVAL=IVACAR
  259.               DO 6029 IC=1,NCARR1
  260.                   MELVAL=IVAL(IC)
  261.                   IF (IVAL(IC).NE.0) THEN
  262.                       IBMN=MIN(IB,VELCHE(/2))
  263.                       IGMN=MIN(IGAU,VELCHE(/1))
  264.                       WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  265.                   ELSE
  266.                       WORK(IC)=0.D0
  267.                   ENDIF
  268.                   IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  269.  6029         CONTINUE
  270.  4029     CONTINUE
  271. C
  272. C
  273.           MPTVAL=IVAMAT
  274. C
  275. C CAS DE L'ACOUSTIQUE PURE
  276. C
  277.           IF (MELE.EQ.97) THEN
  278.               DO 7029 IM=1,NMATT
  279.                   MELVAL=IVAL(IM)
  280.                   IBMN=MIN(IB,VELCHE(/2))
  281.                   WORK(IM+9)=VELCHE(1,IBMN)
  282.  7029         CONTINUE
  283. C
  284. C CAS DES POUTRES ET TUYAU
  285. C
  286.           ELSE
  287.               MELVAL=IVAL(1)
  288.               IF(CMATE.NE.'SECTION') THEN
  289.                   IBMN=MIN(IB,VELCHE(/2))
  290. C
  291.               IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  292.                   WORK(4)=VELCHE(1,IBMN)
  293.               ELSE
  294.                   WORK(10)=VELCHE(1,IBMN)
  295.               ENDIF
  296. C
  297. C  CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  298. C  --------------   EQUIVALENTE
  299. C
  300.                   IF(MELE.EQ.42)THEN
  301.                     CISA=WORK(4)
  302.                     VX=WORK(5)
  303.                     VY=WORK(6)
  304.                     VZ=WORK(7)
  305.                     CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,1)
  306.                   ENDIF
  307.               ELSE
  308. *
  309. *       cas formulation section
  310. *
  311.                   IBMN=MIN(IB,IELCHE(/2))
  312.                   IPMODL=IELCHE(1,IBMN)
  313.                   MELVAL=IVAL(2)
  314.                   IBMN=MIN(IB,IELCHE(/2))
  315.                   IPMAT=IELCHE(1,IBMN)
  316.                   IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)THEN
  317.                       CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS)
  318.                       CALL DOHTIF(CMASS,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  319.                   ENDIF
  320.               ENDIF
  321.           ENDIF
  322. C
  323. C  ON CALCULE LA MATRICE DE MASSE
  324. C
  325.           IF (MELE.EQ.97) THEN
  326.               CALL ACOMAS(REL,LRE,WORK,XE,KERRE)
  327.           ELSE IF (MELE.EQ.84) THEN
  328.               IF(CMATE.NE.'SECTION') THEN
  329.                 IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  330.                   CALL TIMMA2(REL,LRE,WORK,XE,WORK(11),KERRE)
  331.                 ELSE
  332.                   CALL TIMMAS(REL,LRE,WORK,XE,WORK(11),KERRE)
  333.                 ENDIF
  334.               ELSE
  335.                IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  336.                 CALL TIFMA2(REL,LRE,XE,WORK(11),LHOOK,
  337.      &          DDHOOK,KERRE)
  338.                ELSE
  339.                 CALL TIFMAS(REL,LRE,WORK,XE,WORK(11),LHOOK,
  340.      &          DDHOOK,KERRE)
  341.                ENDIF
  342.               ENDIF
  343.           ELSE
  344.                 IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  345.                  CALL POUMA2(REL,LRE,WORK,XE,WORK(11),KERRE)
  346.                 ELSE
  347.                  CALL POUMAS(REL,LRE,WORK,XE,WORK(11),KERRE)
  348.                 ENDIF
  349.           ENDIF
  350. C
  351.           IF(KERRE.EQ.0) GO TO 4027
  352.           INTERR(1)=ISOUS
  353.           INTERR(2)=IB
  354.           SEGSUP WRK1,WRK3,MVELCH
  355.           CALL ERREUR(128)
  356.           SEGSUP xMATRI
  357.           GO TO 510
  358. C
  359.  4027     CONTINUE
  360. *          SEGINI XMATRI
  361. *          IMATTT(IB)=XMATRI
  362.           IF (ILUMP.EQ. 1) THEN
  363.               IF (MELE.EQ.27) THEN
  364. *              call lump3(rel)
  365.                   CALL REMPMT(REL,LRE,RE(1,1,ib))
  366.               ELSE
  367.                   CALL LUMP6(REL,LRE,RE(1,1,ib))
  368. C               CALL LUMP3(REL)
  369.               ENDIF
  370.           ELSE
  371.               CALL REMPMT(REL,LRE,RE(1,1,ib))
  372.           ENDIF
  373. *          SEGDES XMATRI
  374.  3027 CONTINUE
  375.       SEGDES xMATRI
  376.       SEGSUP WRK1,WRK3,MVELCH
  377.       GO TO 510
  378. C_______________________________________________________________________
  379. C
  380. C     ELEMENT DKT
  381. C_______________________________________________________________________
  382. C
  383.    28 CONTINUE
  384.       NBNO=NBNN
  385.       NBBB=NBNN
  386.       NDDL=3
  387.       SEGINI WRK1,WRK2,WRK4
  388. C
  389. C     PLACE DE LA MASSE VOLUMIQUE DANS LE CHAMP DE MATERIAU:
  390. C
  391. C
  392.       DO 3028 IB=1,NBELEM
  393. C
  394. C        ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  395. C
  396.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  397.           CALL ZERO(REL,LRE,LRE)
  398.           CALL VPAST(XE,BPSS)
  399.           CALL VCORLC(XE,XEL,BPSS)
  400. C
  401. C        ACQUISITION DES EPAISSEURS
  402. C
  403.           EPAIST=0.D0
  404.           EXCEN=0.D0
  405.           MPTVAL=IVACAR
  406.           MELVAL=IVAL(1)
  407.           IF (MELVAL.NE.0) THEN
  408.           DO IGAU=1,NBPGAU
  409.                   IGMN=MIN(IGAU,VELCHE(/1))
  410.                   IBMN=MIN(IB  ,VELCHE(/2))
  411.                   EPAIST=EPAIST+VELCHE(IGMN,IBMN)
  412.           ENDDO
  413.           ENDIF
  414. C
  415.           MELVAL=IVAL(2)
  416.           IF (MELVAL.NE.0) THEN
  417.           DO IGAU=1,NBPGAU
  418.                   IGMN=MIN(IGAU,VELCHE(/1))
  419.                   IBMN=MIN(IB  ,VELCHE(/2))
  420.                   EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  421.           ENDDO
  422.           ENDIF
  423.           EPAIST=EPAIST/NBPGAU
  424.           EXCEN=EXCEN/NBPGAU
  425. C
  426. C        BOUCLE SUR LES POINTS DE GAUSS
  427. C
  428.           MPTVAL=IVAMAT
  429.           MELVAL=IVAL(1)
  430.           DO 5028 IGAU=1,NBPGAU
  431.               IGMN=MIN(IGAU,VELCHE(/1))
  432.               IBMN=MIN(IB,VELCHE(/2))
  433.               CALL NDKT (IGAU,XEL,EXCEN,SHPTOT,SHPWRK,BGENE,DJAC)
  434.               DJAC=DJAC*POIGAU(IGAU)*EPAIST
  435.               DJAC=DJAC*VELCHE(IGMN,IBMN)
  436.               CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  437.  5028     CONTINUE
  438. C
  439. C
  440. C    DIAGONALISATION DANS LE CAS DE L'OPéRATEUR LUMP
  441. C
  442. C      REL EST RANGé DANS L'ORDRE I NOEUD X(UX UY UZ RX RY RZ) ....
  443. C
  444.           IF ( ILUMP .EQ. 1 ) THEN
  445.               CALL LUMP3(REL)
  446.           ENDIF
  447. C
  448. C
  449. C
  450.           ICOM = 0
  451.           IF(ABS(EXCEN).GT.XPETIT.OR. MATE.EQ.4.AND.ILUMP.EQ.0)
  452.      &    ICOM=1
  453.           CALL TRANSK(REL,BPSS,LRE,3,ICOM)
  454. *          SEGINI XMATRI
  455. *          IMATTT(IB)=XMATRI
  456. C
  457. C        REMPLISSAGE DE XMATRI
  458. C
  459.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  460. *         SEGDES XMATRI
  461.  3028 CONTINUE
  462.       SEGSUP WRK1,WRK2,WRK4,MVELCH
  463.           segdes xmatri
  464.       GOTO 510
  465. C_______________________________________________________________________
  466. C
  467. C     ELEMENT COQ6 COQ8
  468. C_______________________________________________________________________
  469. C
  470.   41  CONTINUE
  471.       NBBB=NBNN
  472.       SEGINI WRK1,WRK3
  473. C
  474.       DO 3041 IB=1,NBELEM
  475. c         coordonnees XE
  476.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  477.  
  478. cbp,2020 : COQ8MA attend des valeurs constantes par element (probablement 
  479. c         car le support du materiau n'est pas forcement celui de la masse)
  480. c         ==> on prend la moyenne (et pas seulement le 1er point de Gauss!)
  481. c         WORK n'est pas utilise ==> on ne le remplit pas !
  482. c
  483. C         MASSE VOLUMIQUE
  484.           MPTVAL=IVAMAT
  485.           MELVAL=IVAL(1)
  486.           NGAU=VELCHE(/1)
  487.           IBMN=MIN(IB,VELCHE(/2))
  488.           IF(NGAU.EQ.1) THEN
  489.             RHO=VELCHE(1,IBMN)
  490.           ELSE
  491.             RHO=0.D0 
  492.             DO IGAU=1,NGAU
  493.               RHO=RHO+VELCHE(IGAU,IBMN)
  494.             ENDDO
  495.             RHO=RHO/NGAU
  496.           ENDIF
  497. c           VALMAT(1)=RHO
  498. C
  499. C         EPAISSEUR ET EXCENREMENT
  500.           MPTVAL=IVACAR
  501.           IF (IVAL(1).NE.0) THEN
  502.             MELVAL=IVAL(1)
  503. c             DO IGAU=1,NBPGAU
  504. c                 IGMN=MIN(IGAU,VELCHE(/1))
  505. c                 IBMN=MIN(IB  ,VELCHE(/2))
  506. c                 WORK(IGAU)=VELCHE(IGMN,IBMN)
  507. c             ENDDO           
  508. c           RR=VALMAT(1)*VELCHE(1,IBMN)
  509.             NGAU=VELCHE(/1)
  510.             IF(NGAU.EQ.1) THEN
  511.               EPAI=VELCHE(1,IBMN)
  512.             ELSE
  513.               EPAI=0.D0
  514.               DO IGAU=1,NGAU
  515.                 EPAI=EPAI+VELCHE(IGAU,IBMN)
  516.               ENDDO
  517.               EPAI=EPAI/NGAU
  518.             ENDIF
  519.           ELSE
  520. c           on ne devrait pas passer par la          
  521. c             WORK(IGAU)=0
  522.             CALL ERREUR(5)
  523.           ENDIF
  524.           IF (IVAL(2).NE.0) THEN
  525.             MELVAL=IVAL(2)
  526. c             DO IGAU=1,NBPGAU
  527. c                 IGMN=MIN(IGAU,VELCHE(/1))
  528. c                 IBMN=MIN(IB  ,VELCHE(/2))
  529. c                 WORK(IGAU+10)=VELCHE(IGMN,IBMN)
  530. c             ENDDO
  531.             NGAU=VELCHE(/1)
  532.             IF(NGAU.EQ.1) THEN
  533.               EXENT=VELCHE(1,IBMN)
  534.             ELSE
  535.               EXENT=0.D0
  536.               DO IGAU=1,NGAU
  537.                 EXENT=EXENT+VELCHE(IGAU,IBMN)
  538.               ENDDO
  539.               EXENT=EXENT/NGAU
  540.             ENDIF
  541.           ELSE
  542. c              WORK(IGAU+10)=0
  543.              EXENT=0.D0
  544.           ENDIF
  545. C
  546. c           RHO=VALMAT(1)
  547. c           EPAI = WORK(1)
  548. c           EXENT= WORK(11)
  549. cnewparadigm           SEGDES WRK1,WRK3
  550. cnewparadigm          SEGDES MINTE
  551.           CALL COQ8MA(NBNN,RHO,NBPGAU,EPAI,EXENT,WRK1,MINTE,MINTE2)
  552. cnewparadigm          SEGACT WRK1,WRK3*MOD
  553. cnewparadigm          SEGACT MINTE
  554. *          SEGINI XMATRI
  555. *          IMATTT(IB)=XMATRI
  556.           IF (ILUMP .EQ. 1) THEN
  557.               CALL LUMP7(REL,LRE,RE,NBNN)
  558.           ELSE
  559.               CALL REMPMT(REL,LRE,RE(1,1,ib))
  560.           ENDIF
  561. *          SEGDES XMATRI
  562.  3041 CONTINUE
  563.       SEGDES xMATRI
  564.       SEGSUP WRK1,WRK3,MVELCH
  565.       GOTO 510
  566. C_______________________________________________________________________
  567. C
  568. C     SECTEUR DE CALCUL POUR LES COQ2
  569. C_______________________________________________________________________
  570. C
  571.    44 CONTINUE
  572.       DIM3=1.D0
  573.       NBNO=NBNN
  574.       NBBB=NBNN
  575.       SEGINI WRK1,WRK3
  576.       I255=0
  577.       I256=0
  578. C
  579. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  580. C
  581.       DO 3044 IB=1,NBELEM
  582. C
  583. C        ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  584. C
  585.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  586. C
  587.           MPTVAL=IVACAR
  588.           MELVAL=IVAL(1)
  589.           IBMN=MIN(IB,VELCHE(/2))
  590.           EP=VELCHE(1,IBMN)
  591.           IF(IFOUR.EQ.-2) THEN
  592.               MELVAL=IVAL(3)
  593.               IF(MELVAL.NE.0) THEN
  594.                   IBMN=MIN(IB,VELCHE(/2))
  595.                   DIM3=VELCHE(1,IBMN)
  596.               ELSE
  597.                   DIM3=1.D0
  598.               ENDIF
  599.           ENDIF
  600. C
  601.           MPTVAL=IVAMAT
  602.           DO 4044 IM=1,NMATT
  603.               MELVAL=IVAL(IM)
  604.               IBMN=MIN(IB,VELCHE(/2))
  605.               VALMAT(IM)=VELCHE(1,IBMN)
  606.  4044     CONTINUE
  607.           RHO=VALMAT(1)
  608. C
  609. C        APPEL A LA SUBROUTINE CALCULANT LA MATRICE MASSE
  610. C
  611.           CALL COQ2MA(XE,EP,DIM3,RHO,1,IFOUR,NIFOUR,LRE,REL,IARR,
  612.      +    XDPGE,YDPGE)
  613. C
  614. C        GESTION D'ERREUR
  615. C
  616.           IF(IARR.EQ.1) I255=IB
  617.           IF(IARR.EQ.2) I256=IB
  618. C
  619. C        REMPLISSAGE
  620. C
  621. C
  622. *          SEGINI XMATRI
  623. *          IMATTT(IB)=XMATRI
  624.           IF (ILUMP .EQ. 1) THEN
  625.               CALL LUMP5(REL,LRE,RE(1,1,ib),IFOUR)
  626.           ELSE
  627.               CALL REMPMT(REL,LRE,RE(1,1,ib))
  628.           ENDIF
  629. *          SEGDES XMATRI
  630.  3044 CONTINUE
  631. C
  632. C     IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR...
  633. C
  634.       IF(I255.NE.0) THEN
  635.           INTERR(1)=I255
  636.           CALL ERREUR(255)
  637.       ENDIF
  638.       IF(I256.NE.0) THEN
  639.           INTERR(1)=I256
  640.           CALL ERREUR(256)
  641.       ENDIF
  642. C
  643.       SEGDES xMATRI
  644.       SEGSUP WRK1,WRK3,MVELCH
  645.       GOTO 510
  646. C_______________________________________________________________________
  647. C
  648. C     SECTEUR DE CALCUL POUR LES COQ4
  649. C_______________________________________________________________________
  650. C
  651.    49 CONTINUE
  652.       NBNO=NBNN
  653.       NBBB=NBNN
  654.       SEGINI WRK1,WRK2,WRK4,WRK6
  655.       IG1=0
  656.       IG2=0
  657.       IG3=0
  658. C
  659. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  660. C
  661.       DO 3049 IB=1,NBELEM
  662. C
  663. C        ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  664. C
  665.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  666.           CALL ZERO (REL,LRE,LRE)
  667. C         REPERE LOCAL DU COQ4 ON NE DEMANDE PAS DE VERIFIER LA PLANéITé
  668.           CALL CQ4LOC(XE,XEL,BPSS,IERT,0)
  669. C
  670.           MPTVAL=IVACAR
  671.           MELVAL=IVAL(1)
  672.           IBMN=MIN(IB,VELCHE(/2))
  673.           EP=VELCHE(1,IBMN)
  674.           IF (IVAL(2).NE.0) THEN
  675.               MELVAL=IVAL(2)
  676.               IBMN=MIN(IB,VELCHE(/2))
  677.               EXCEN =VELCHE(1,IBMN)
  678.           ELSE
  679.               EXCEN=0.D0
  680.           ENDIF
  681. C
  682.           MPTVAL=IVAMAT
  683.           MELVAL=IVAL(1)
  684.           IBMN=MIN(IB,VELCHE(/2))
  685.           VALMAT(1)=VELCHE(1,IBMN)
  686.           RHO=VALMAT(1)
  687. C
  688. C        CALCUL  MATRICE MASSE
  689. C
  690.           CALL ZERO(RHOMAT,6,6)
  691.           RHOMAT( 1, 1)=RHO*EP
  692.           RHOMAT( 1, 5)=RHO*EP*EXCEN
  693.           RHOMAT( 5, 1)=RHOMAT(1,5)
  694.           RHOMAT( 2, 2)=RHO*EP
  695.           RHOMAT( 2, 4)=-RHO*EP*EXCEN
  696.           RHOMAT( 4, 2)=RHOMAT(2,4)
  697.           RHOMAT( 3, 3)=RHO*EP
  698.           RHOMAT( 4, 4)=RHO*EP**3/12.D0 + RHO*EP*EXCEN**2
  699.           RHOMAT( 5, 5)=RHOMAT(4,4)
  700.           NBPGAM=NBPGAU-1
  701.           DO 4049 IGAU=1,NBPGAM
  702.               CALL NCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,IERT)
  703. C           IERT=1 JACOBIANO=<0
  704.               IF(IERT.EQ.1) IG3=IB
  705.               DJAC=DJAC*POIGAU(IGAU)
  706.               CALL BDBST(BGENE,DJAC,RHOMAT,LRE,6,REL)
  707. 4049      CONTINUE
  708. C
  709. C         LA DIAGONALISATION éVENTUELLE A LIEU AVANT LE PASSAGE
  710. C         EN COORDONNéES GLOBALES
  711. C
  712.           IF ( ILUMP .EQ. 1) THEN
  713.               CALL LUMP4(REL)
  714.           ENDIF
  715. C
  716.           CALL TRANSK(REL,BPSS,24,4,0)
  717. C
  718. C        REMPLISSAGE
  719. C
  720. *          SEGINI XMATRI
  721. *          IMATTT(IB)=XMATRI
  722.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  723. *          SEGDES XMATRI
  724.  3049 CONTINUE
  725. C
  726. C     IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR...
  727. C
  728.       IF(IG1.NE.0) THEN
  729.           INTERR(1)=IG1
  730.           CALL ERREUR(323)
  731.       ENDIF
  732.       IF(IG2.NE.0) THEN
  733.           INTERR(1)=IG2
  734.           CALL ERREUR(322)
  735.       ENDIF
  736.       IF(IG3.NE.0) THEN
  737.           INTERR(1)=IG3
  738.           CALL ERREUR(321)
  739.       ENDIF
  740. C
  741.       SEGDES xMATRI
  742.       SEGSUP WRK1,WRK2,WRK4,WRK6,MVELCH
  743.       GOTO 510
  744. C_______________________________________________________________________
  745. C
  746. C     SECTEUR DE CALCUL POUR L'ELEMENT DST
  747. C_______________________________________________________________________
  748. C
  749.    93 CONTINUE
  750.       NBNO=NBNN
  751.       NBBB=NBNN
  752.       SEGINI WRK1,WRK2,WRK4,WRK6
  753. C
  754. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  755. C
  756.       DO 3093 IB=1,NBELEM
  757. C
  758. C        ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  759. C
  760.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  761.           CALL ZERO (REL,LRE,LRE)
  762.           CALL VPAST(XE,BPSS)
  763.           CALL VCORLC(XE,XEL,BPSS)
  764. C
  765. C        ACQUISITION DES EPAISSEURS
  766. C
  767.           EP=0.D0
  768.           EXCEN=0.D0
  769.           MPTVAL=IVACAR
  770.               MELVAL=IVAL(1)
  771.               IF (MELVAL.NE.0) THEN
  772.               DO IGAU=1,NBPGAU
  773.                   IGMN=MIN(IGAU,VELCHE(/1))
  774.                   IBMN=MIN(IB  ,VELCHE(/2))
  775.                   EP=EP+VELCHE(IGMN,IBMN)
  776.               ENDDO
  777.               ENDIF
  778. C
  779.               MELVAL=IVAL(2)
  780.               IF (MELVAL.NE.0) THEN
  781.               DO IGAU=1,NBPGAU
  782.                   IGMN=MIN(IGAU,VELCHE(/1))
  783.                   IBMN=MIN(IB  ,VELCHE(/2))
  784.                   EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  785.               ENDDO
  786.               ENDIF
  787.           EP=EP/NBPGAU
  788.           EXCEN=EXCEN/NBPGAU
  789. C
  790. C  BOULE SUR LES POINTS DE GAUSS
  791. C
  792.           DO 5093 IGAU=1,NBPGAU
  793. C
  794.               MPTVAL=IVAMAT
  795.               MELVAL=IVAL(1)
  796.               IBMN=MIN(IB,VELCHE(/2))
  797.               IGMN=MIN(IGAU,VELCHE(/1))
  798.               RHO=VELCHE(IGMN,IBMN)
  799. C
  800. C        CALCUL  MATRICE MASSE
  801. C
  802.               CALL ZERO(RHOMAT,6,6)
  803.               RHOMAT( 1, 1)=RHO*EP
  804.               RHOMAT( 1, 5)=RHO*EP*EXCEN
  805.               RHOMAT( 5, 1)=RHOMAT(1,5)
  806.               RHOMAT( 2, 2)=RHO*EP
  807.               RHOMAT( 2, 4)=-RHO*EP*EXCEN
  808.               RHOMAT( 4, 2)=RHOMAT(2,4)
  809.               RHOMAT( 3, 3)=RHO*EP
  810.               RHOMAT( 4, 4)=RHO*EP**3/12.D0 + RHO*EP*EXCEN**2
  811.               RHOMAT( 5, 5)=RHOMAT(4,4)
  812.               CALL NDST(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC)
  813.               DJAC=DJAC*POIGAU(IGAU)
  814.               CALL BDBST(BGENE,DJAC,RHOMAT,LRE,6,REL)
  815. 5093      CONTINUE
  816. C
  817. C    DIAGONALISATION DANS LE CAS DE L'OPéRATEUR LUMP
  818. C
  819. C      REL EST RANGé DANS L'ORDRE I NOEUD X(UX UY UZ RX RY RZ) ....
  820. C
  821.           IF ( ILUMP .EQ. 1 ) THEN
  822.               CALL LUMP3(REL)
  823.           ENDIF
  824. C
  825. C
  826. C
  827.           ICOM = 0
  828.           IF(ABS(EXCEN).GT.XPETIT.OR. MATE.EQ.4.AND.ILUMP.EQ.0)
  829.      &    ICOM=1
  830.           CALL TRANSK(REL,BPSS,18,3,ICOM)
  831. C
  832. C        REMPLISSAGE
  833. C
  834. *          SEGINI XMATRI
  835. *          IMATTT(IB)=XMATRI
  836.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  837. *          SEGDES XMATRI
  838.  3093 CONTINUE
  839.       SEGDES xMATRI
  840.       SEGSUP WRK1,WRK2,WRK4,WRK6,MVELCH
  841.       GOTO 510
  842. C_______________________________________________________________________
  843. *
  844.    99 CONTINUE
  845.       MOTERR(1:4)=NOMTP(MELE)
  846.       MOTERR(5:12)='MASSE3'
  847.       CALL ERREUR(86)
  848. *
  849.   510 CONTINUE
  850.       RETURN
  851.       END
  852. C
  853.  
  854.  
  855.  
  856.  
  857.  
  858.  
  859.  
  860.  
  861.  
  862.  
  863.  
  864.  

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