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

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