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    JK148537  24/12/11    21:15:03     12096          
  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,WRK4
  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.         if (idim.eq.3.and.ifour.gt.0) then
  560.          do ii = 1,NBNN
  561.           jj=idimp1*(NUM(ii,IB)-1)
  562.           xel(1,ii) = xe(1,ii)
  563.           xel(2,ii) = xe(2,ii)
  564.           xel(3,ii) = xe(3,ii)
  565.           xe(2,ii) = xel(3,ii)
  566.           xe(3,ii) = XZero
  567.          enddo
  568.         endif
  569. C
  570.           MPTVAL=IVACAR
  571.           MELVAL=IVAL(1)
  572.           IBMN=MIN(IB,VELCHE(/2))
  573.           EP=VELCHE(1,IBMN)
  574.           IF(IFOUR.EQ.-2) THEN
  575.               MELVAL=IVAL(3)
  576.               IF(MELVAL.NE.0) THEN
  577.                   IBMN=MIN(IB,VELCHE(/2))
  578.                   DIM3=VELCHE(1,IBMN)
  579.               ELSE
  580.                   DIM3=1.D0
  581.               ENDIF
  582.           ENDIF
  583. C
  584.           MPTVAL=IVAMAT
  585.           DO 4044 IM=1,NMATT
  586.               MELVAL=IVAL(IM)
  587.               IBMN=MIN(IB,VELCHE(/2))
  588.               VALMAT(IM)=VELCHE(1,IBMN)
  589.  4044     CONTINUE
  590.           RHO=VALMAT(1)
  591. C
  592. C        APPEL A LA SUBROUTINE CALCULANT LA MATRICE MASSE
  593. C
  594.           CALL COQ2MA(XE,EP,DIM3,RHO,1,IFOUR,NIFOUR,LRE,REL,IARR,
  595.      +    XDPGE,YDPGE)
  596. C
  597. C        GESTION D'ERREUR
  598. C
  599.           IF(IARR.EQ.1) I255=IB
  600.           IF(IARR.EQ.2) I256=IB
  601. C
  602. C        REMPLISSAGE
  603. C
  604.           IF (ILUMP .EQ. 1) THEN
  605.               CALL LUMP5(REL,LRE,RE(1,1,ib),IFOUR)
  606.           ELSE
  607.               CALL REMPMT(REL,LRE,RE(1,1,ib))
  608.           ENDIF
  609.  3044 CONTINUE
  610. C
  611. C     IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR...
  612. C
  613.       IF(I255.NE.0) THEN
  614.           INTERR(1)=I255
  615.           CALL ERREUR(255)
  616.       ENDIF
  617.       IF(I256.NE.0) THEN
  618.           INTERR(1)=I256
  619.           CALL ERREUR(256)
  620.       ENDIF
  621.  
  622.       SEGSUP WRK1,WRK3,WRK4,MVELCH
  623.       GOTO 510
  624. C_______________________________________________________________________
  625. C
  626. C     SECTEUR DE CALCUL POUR LES COQ4
  627. C_______________________________________________________________________
  628. C
  629.    49 CONTINUE
  630.       NBNO=NBNN
  631.       NBBB=NBNN
  632.       SEGINI WRK1,WRK2,WRK4,WRK6
  633.       IG1=0
  634.       IG2=0
  635.       IG3=0
  636. C
  637. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  638. C
  639.       DO 3049 IB=1,NBELEM
  640. C
  641. C        ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  642. C
  643.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  644.           CALL ZERO (REL,LRE,LRE)
  645. C         REPERE LOCAL DU COQ4 ON NE DEMANDE PAS DE VERIFIER LA PLANéITé
  646.           CALL CQ4LOC(XE,XEL,BPSS,IERT,0)
  647. C
  648.           MPTVAL=IVACAR
  649.           MELVAL=IVAL(1)
  650.           IBMN=MIN(IB,VELCHE(/2))
  651.           EP=VELCHE(1,IBMN)
  652.           IF (IVAL(2).NE.0) THEN
  653.               MELVAL=IVAL(2)
  654.               IBMN=MIN(IB,VELCHE(/2))
  655.               EXCEN =VELCHE(1,IBMN)
  656.           ELSE
  657.               EXCEN=0.D0
  658.           ENDIF
  659. C
  660.           MPTVAL=IVAMAT
  661.           MELVAL=IVAL(1)
  662.           IBMN=MIN(IB,VELCHE(/2))
  663.           VALMAT(1)=VELCHE(1,IBMN)
  664.           RHO=VALMAT(1)
  665. C
  666. C        CALCUL  MATRICE MASSE
  667. C
  668.           CALL ZERO(RHOMAT,6,6)
  669.           RHOMAT( 1, 1)=RHO*EP
  670.           RHOMAT( 1, 5)=RHO*EP*EXCEN
  671.           RHOMAT( 5, 1)=RHOMAT(1,5)
  672.           RHOMAT( 2, 2)=RHO*EP
  673.           RHOMAT( 2, 4)=-RHO*EP*EXCEN
  674.           RHOMAT( 4, 2)=RHOMAT(2,4)
  675.           RHOMAT( 3, 3)=RHO*EP
  676.           RHOMAT( 4, 4)=RHO*EP**3/12.D0 + RHO*EP*EXCEN**2
  677.           RHOMAT( 5, 5)=RHOMAT(4,4)
  678.           NBPGAM=NBPGAU-1
  679.           DO 4049 IGAU=1,NBPGAM
  680.               CALL NCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,IERT)
  681. C           IERT=1 JACOBIANO=<0
  682.               IF(IERT.EQ.1) IG3=IB
  683.               DJAC=DJAC*POIGAU(IGAU)
  684.               CALL BDBST(BGENE,DJAC,RHOMAT,LRE,6,REL)
  685. 4049      CONTINUE
  686. C
  687. C         LA DIAGONALISATION éVENTUELLE A LIEU AVANT LE PASSAGE
  688. C         EN COORDONNéES GLOBALES
  689. C
  690.           IF ( ILUMP .EQ. 1) THEN
  691.               CALL LUMP4(REL)
  692.           ENDIF
  693. C
  694.           CALL TRANSK(REL,BPSS,24,4,0)
  695. C
  696. C        REMPLISSAGE
  697. C
  698.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  699.  
  700.  3049 CONTINUE
  701. C
  702. C     IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR...
  703. C
  704.       IF(IG1.NE.0) THEN
  705.           INTERR(1)=IG1
  706.           CALL ERREUR(323)
  707.       ENDIF
  708.       IF(IG2.NE.0) THEN
  709.           INTERR(1)=IG2
  710.           CALL ERREUR(322)
  711.       ENDIF
  712.       IF(IG3.NE.0) THEN
  713.           INTERR(1)=IG3
  714.           CALL ERREUR(321)
  715.       ENDIF
  716. C
  717.       SEGSUP WRK1,WRK2,WRK4,WRK6,MVELCH
  718.       GOTO 510
  719. C_______________________________________________________________________
  720. C
  721. C     SECTEUR DE CALCUL POUR L'ELEMENT DST
  722. C_______________________________________________________________________
  723. C
  724.    93 CONTINUE
  725.       NBNO=NBNN
  726.       NBBB=NBNN
  727.       SEGINI WRK1,WRK2,WRK4,WRK6
  728. C
  729. C     BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  730. C
  731.       DO 3093 IB=1,NBELEM
  732. C
  733. C        ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  734. C
  735.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  736.           CALL ZERO (REL,LRE,LRE)
  737.           CALL VPAST(XE,BPSS)
  738.           CALL VCORLC(XE,XEL,BPSS)
  739. C
  740. C        ACQUISITION DES EPAISSEURS
  741. C
  742.           EP=0.D0
  743.           EXCEN=0.D0
  744.           MPTVAL=IVACAR
  745.               MELVAL=IVAL(1)
  746.               IF (MELVAL.NE.0) THEN
  747.               DO IGAU=1,NBPGAU
  748.                   IGMN=MIN(IGAU,VELCHE(/1))
  749.                   IBMN=MIN(IB  ,VELCHE(/2))
  750.                   EP=EP+VELCHE(IGMN,IBMN)
  751.               ENDDO
  752.               ENDIF
  753. C
  754.               MELVAL=IVAL(2)
  755.               IF (MELVAL.NE.0) THEN
  756.               DO IGAU=1,NBPGAU
  757.                   IGMN=MIN(IGAU,VELCHE(/1))
  758.                   IBMN=MIN(IB  ,VELCHE(/2))
  759.                   EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  760.               ENDDO
  761.               ENDIF
  762.           EP=EP/NBPGAU
  763.           EXCEN=EXCEN/NBPGAU
  764. C
  765. C  BOULE SUR LES POINTS DE GAUSS
  766. C
  767.           DO 5093 IGAU=1,NBPGAU
  768. C
  769.               MPTVAL=IVAMAT
  770.               MELVAL=IVAL(1)
  771.               IBMN=MIN(IB,VELCHE(/2))
  772.               IGMN=MIN(IGAU,VELCHE(/1))
  773.               RHO=VELCHE(IGMN,IBMN)
  774. C
  775. C        CALCUL  MATRICE MASSE
  776. C
  777.               CALL ZERO(RHOMAT,6,6)
  778.               RHOMAT( 1, 1)=RHO*EP
  779.               RHOMAT( 1, 5)=RHO*EP*EXCEN
  780.               RHOMAT( 5, 1)=RHOMAT(1,5)
  781.               RHOMAT( 2, 2)=RHO*EP
  782.               RHOMAT( 2, 4)=-RHO*EP*EXCEN
  783.               RHOMAT( 4, 2)=RHOMAT(2,4)
  784.               RHOMAT( 3, 3)=RHO*EP
  785.               RHOMAT( 4, 4)=RHO*EP**3/12.D0 + RHO*EP*EXCEN**2
  786.               RHOMAT( 5, 5)=RHOMAT(4,4)
  787.               CALL NDST(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC)
  788.               DJAC=DJAC*POIGAU(IGAU)
  789.               CALL BDBST(BGENE,DJAC,RHOMAT,LRE,6,REL)
  790. 5093      CONTINUE
  791. C
  792. C    DIAGONALISATION DANS LE CAS DE L'OPéRATEUR LUMP
  793. C
  794. C      REL EST RANGé DANS L'ORDRE I NOEUD X(UX UY UZ RX RY RZ) ....
  795. C
  796.           IF ( ILUMP .EQ. 1 ) THEN
  797.               CALL LUMP3(REL)
  798.           ENDIF
  799. C
  800.           ICOM = 0
  801.           IF(ABS(EXCEN).GT.XPETIT.OR. MATE.EQ.4.AND.ILUMP.EQ.0)
  802.      &    ICOM=1
  803.           CALL TRANSK(REL,BPSS,18,3,ICOM)
  804. C
  805. C        REMPLISSAGE
  806. C
  807.           CALL REMPMT(REL,LRE,RE(1,1,ib))
  808.  
  809.  3093 CONTINUE
  810.       SEGSUP WRK1,WRK2,WRK4,WRK6,MVELCH
  811.       GOTO 510
  812. C_______________________________________________________________________
  813. *
  814.    99 CONTINUE
  815.       MOTERR(1:4)=NOMTP(MELE)
  816.       MOTERR(5:12)='MASSE3'
  817.       CALL ERREUR(86)
  818.  
  819.   510 CONTINUE
  820.  
  821.       RETURN
  822.       END
  823.  
  824.  
  825.  
  826.  

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