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

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