Télécharger masse3.eso

Retour à la liste

Numérotation des lignes :

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

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