Télécharger masse3.eso

Retour à la liste

Numérotation des lignes :

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

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