Télécharger masse4.eso

Retour à la liste

Numérotation des lignes :

  1. C MASSE4 SOURCE GF238795 18/02/01 21:15:59 9724
  2. SUBROUTINE MASSE4(IPMAIL,LW,LRE,IVAMAT,NMATT,IVACAR,NCARR,
  3. &IVECT,NBPGAU,IPMINT,NDDL,MELE,MFR,IPMATR,ILUMP,
  4. &ISOUS,IIPDPG,IMOD)
  5. *---------------------------------------------------------------------*
  6. * ________________________________ *
  7. * | | *
  8. * | calcul de la matrice de masse | *
  9. * |________________________________| *
  10. * *
  11. * raccords liquide/massifs,raccords liquide/coque,barre,homogenise *
  12. * cerce,joints 2-3d *
  13. * *
  14. *---------------------------------------------------------------------*
  15. * *
  16. * entrees : *
  17. * ________ *
  18. * *
  19. * ipmail pointeur sur un segment meleme *
  20. * lw dimension du tableau de travail de l'element *
  21. * lre nombre de ddl dans la matrice de masse *
  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. * 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. * mele numero de l'element fini *
  33. * nbpgmi nombre de noeuds /element *
  34. * ilump =1 si l'op�ateur 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. -INC SMRIGID
  50. -INC SMCHAML
  51. -INC SMELEME
  52. -INC SMCOORD
  53. -INC SMINTE
  54. -INC SMMODEL
  55. -INC SMLMOTS
  56. c
  57. SEGMENT WRK1
  58. REAL*8 REL(LRE,LRE),XE(3,NBBB)
  59. ENDSEGMENT
  60. c
  61. SEGMENT WRK2
  62. REAL*8 SHPWRK(6,NBNO),BGENE(NDDL,LRE)
  63. ENDSEGMENT
  64. c
  65. SEGMENT WRK3
  66. REAL*8 WORK(LW)
  67. ENDSEGMENT
  68. *
  69. SEGMENT WRK4
  70. REAL*8 BPSS(3,3),XEL(3,NBBB)
  71. ENDSEGMENT
  72. *
  73. SEGMENT WRK5
  74. REAL*8 XGENE(NCOM,LRN)
  75. ENDSEGMENT
  76. *
  77. SEGMENT MVELCH
  78. REAL*8 VALMAT(NV1)
  79. ENDSEGMENT
  80. c
  81. SEGMENT MPTVAL
  82. INTEGER IPOS(NS),NSOF(NS)
  83. INTEGER IVAL(NCOSOU)
  84. CHARACTER*16 TYVAL(NCOSOU)
  85. ENDSEGMENT
  86.  
  87. CHARACTER*8 CMATE
  88. CHARACTER*4 lesinc(7),lesdua(7)
  89. DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/
  90. DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/
  91. INTEGER KERRE
  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. KERRE=0
  105. *
  106. * introduction du point autour duquel se fait le mouvement
  107. * de la section en defo plane generalisee
  108. *
  109. IF (IFOUR.EQ.-3.AND.MFR.NE.35) THEN
  110. IP=IIPDPG
  111. SEGACT MCOORD
  112. IREF=(IP-1)*(IDIM+1)
  113. XDPGE=XCOOR(IREF+1)
  114. YDPGE=XCOOR(IREF+2)
  115. ELSE
  116. XDPGE=0.D0
  117. YDPGE=0.D0
  118. ENDIF
  119. *
  120. NHRM=NIFOUR
  121. *
  122. MINTE=IPMINT
  123. *
  124. IMODEL = IMOD
  125. CMATE = CMATEE
  126. jmat = 0
  127. iinc=0
  128. idua=0
  129. DO imat = 1 , matmod(/2)
  130. if (matmod(imat).eq.'IMPEDANCE') then
  131. jmat = imat
  132. goto 45
  133. endif
  134. ENDDO
  135. IF (mfr.eq.28) THEN
  136. jgn = 4
  137. if (ifour.eq.2) then
  138. jgm = 6
  139. segini mlmots
  140. iinc = mlmots
  141. do igm = 1,jgm
  142. mots(igm) = lesinc(igm)
  143. enddo
  144. segini mlmots
  145. idua = mlmots
  146. do igm= 1,jgm
  147. mots(igm) = lesdua(igm)
  148. enddo
  149. else if (ifour.lt.0) then
  150. jgm = 4
  151. segini mlmots
  152. iinc = mlmots
  153. mots(1) = lesinc(1)
  154. mots(2) = lesinc(2)
  155. mots(3) = lesinc(4)
  156. mots(4) = lesinc(5)
  157. segini mlmots
  158. idua = mlmots
  159. mots(1) = lesdua(1)
  160. mots(2) = lesdua(2)
  161. mots(3) = lesdua(4)
  162. mots(4) = lesdua(5)
  163. else if (ifour.eq.0) then
  164. jgm = 3
  165. segini mlmots
  166. iinc = mlmots
  167. mots(1) = lesinc(7)
  168. mots(2) = lesinc(3)
  169. mots(3) = lesinc(6)
  170. segini mlmots
  171. idua = mlmots
  172. mots(1) = lesdua(7)
  173. mots(2) = lesdua(3)
  174. mots(3) = lesdua(6)
  175. else if (ifour.eq.1) then
  176. * a faire
  177. endif
  178. ENDIF
  179.  
  180. c
  181. c numero des etiquettes :
  182. c etiquettes de 1 a 98 pour traitement specifique a l element
  183. c dans la zone specifique a chaque element commencant par :
  184. c 5 continue
  185. c element 5 etiquettes 1005 2005 3005 4005 ...
  186. c 44 continue
  187. c element 44 etiquettes 1044 2044 3044 4044 ...
  188. c_______________________________________________________________________
  189. c
  190. * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  191. GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  192. * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  193. & , 12, 99, 99, 99, 99, 99, 18, 18, 99, 99, 99
  194. * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6
  195. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  196. * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  197. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  198. * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  199. & , 45, 46, 47, 99, 99, 99, 99, 99, 99, 99, 55
  200. * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  201. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  202. * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  203. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  204. * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  205. & , 99, 99, 99, 99, 99, 99, 99, 85, 99, 87, 88
  206. * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3
  207. & , 99, 99, 99, 92, 99, 94, 46, 99, 99, 12, 99
  208. * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  209. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  210. * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  211. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  212. * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  213. & , 99, 46, 124, 99, 126, 127, 99, 99, 99, 99, 99
  214. * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  215. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  216. * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  217. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  218. * TE56 PY91 TRH6
  219. & , 99, 99, 157),MELE
  220. *
  221. GOTO(168,169,170,171,172),MELE-167
  222. *
  223. * JOI1
  224. GOTO(265),MELE-264
  225.  
  226. c
  227.  
  228. GOTO 99
  229. c_______________________________________________________________________
  230. c
  231. c secteur de calcul pour les elements de raccord rac2 rac3 litu
  232. c liquide massif lineaire cas bidimensionnel
  233. c_______________________________________________________________________
  234. c
  235. 12 CONTINUE
  236. IF (ILUMP .EQ. 1) GOTO 99
  237. NBBB=NBNN
  238. IF (MELE.NE.98) LW=IDIM
  239. SEGINI WRK1,WRK3
  240. DO 3012 IB=1,NBELEM
  241. c
  242. c on cherche les coordonnees de l element ib
  243. c
  244. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  245. CALL ZERO(REL,LRE,LRE)
  246. c
  247. c calcul des coefficients de normalisation
  248. c
  249. MPTVAL=IVAMAT
  250. c
  251. IF (MELE.NE.98) THEN
  252. c
  253. DO 5012 IM=1,NMATT
  254. MELVAL=IVAL(IM)
  255. IBMN=MIN(IB,VELCHE(/2))
  256. VALMAT(IM)=VELCHE(1,IBMN)
  257. 5012 CONTINUE
  258. RHOREF=VALMAT(1)
  259. RLCAR = VALMAT(2)
  260. c
  261. CFPI= RHOREF*RLCAR
  262. c
  263. ELSE
  264. c
  265. c cas de l'element litu
  266. c
  267. DO 7012 IM=1,NMATT
  268. MELVAL=IVAL(IM)
  269. IBMN=MIN(IB,VELCHE(/2))
  270. WORK(IM+9)=VELCHE(1,IBMN)
  271. 7012 CONTINUE
  272. ENDIF
  273. c
  274. c lecture des caracteristiques dans work
  275. c
  276. MPTVAL=IVACAR
  277. DO 4012 IC=1,NCARR
  278. IF (IVAL(IC).NE.0) THEN
  279. MELVAL=IVAL(IC)
  280. IBMN=MIN(IB,VELCHE(/2))
  281. WORK(IC)=VELCHE(1,IBMN)
  282. ELSE
  283. WORK(IC)=0.D0
  284. ENDIF
  285. 4012 CONTINUE
  286. c
  287. c cas ou on a lu le mot vecteur
  288. c
  289. IF (IVECT.EQ.1) THEN
  290. IF (IVAL(NCARR).NE.0) THEN
  291. MELVAL=IVAL(NCARR)
  292. IBMN=MIN(IB,IELCHE(/2))
  293. IP=IELCHE(1,IBMN)
  294. IREF=(IP-1)*(IDIM+1)
  295. DO 6112 IC=1,IDIM
  296. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  297. 6112 CONTINUE
  298. ELSE
  299. DO 6212 IC=1,IDIM
  300. WORK(NCARR+IC-1)=0
  301. 6212 CONTINUE
  302. ENDIF
  303. ENDIF
  304. c
  305. c
  306. c
  307. IF (MELE.EQ.98) THEN
  308. CALL COUMAS(REL,LRE,WORK,XE,KERRE)
  309. ELSE
  310. CALL RACMAS(NBPGAU,IFOUR,NIFOUR,IDIM,NBNN,XE,CFPI,WORK,
  311. 1 POIGAU,SHPTOT,REL,LRE)
  312. ENDIF
  313. c
  314. * SEGINI XMATRI
  315. * IMATTT(IB)=XMATRI
  316. c
  317. c remplissage de xmatri
  318. c
  319. CALL REMPMT(REL,LRE,RE(1,1,ib))
  320. * SEGDES XMATRI
  321. 3012 CONTINUE
  322. SEGDES xMATRI
  323. SEGSUP WRK1,WRK3,MVELCH
  324. GOTO 510
  325. c_______________________________________________________________________
  326. c
  327. c secteur de calcul pour les elements de raccord lia3 lia4
  328. c liquide massif lineaire cas tridimensionnel
  329. c_______________________________________________________________________
  330. c
  331. 18 CONTINUE
  332. IF (ILUMP .EQ. 1) GOTO 99
  333. NBBB=NBNN
  334. LW=IDIM
  335. SEGINI WRK1,WRK3
  336. DO 3018 IB=1,NBELEM
  337. c
  338. c on cherche les coordonnees de l element ib
  339. c
  340. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  341. CALL ZERO(REL,LRE,LRE)
  342. c
  343. c calcul des coefficients de normalisation
  344. c
  345. MPTVAL=IVAMAT
  346. DO 5018 IM=1,NMATT
  347. MELVAL=IVAL(IM)
  348. IBMN=MIN(IB,VELCHE(/2))
  349. VALMAT(IM)=VELCHE(1,IBMN)
  350. 5018 CONTINUE
  351. RHOREF=VALMAT(1)
  352. RLCAR = VALMAT(2)
  353. c
  354. CFPI= RHOREF*RLCAR
  355. c
  356. MPTVAL=IVACAR
  357. DO 4018 IC=1,NCARR
  358. IF (IVAL(IC).NE.0) THEN
  359. MELVAL=IVAL(IC)
  360. IBMN=MIN(IB,VELCHE(/2))
  361. WORK(IC)=VELCHE(1,IBMN)
  362. ELSE
  363. WORK(IC)=0.D0
  364. ENDIF
  365. 4018 CONTINUE
  366. c
  367. CALL LIAMAS(NBPGAU,IDIM,NBNN,NDDL,XE,CFPI,WORK,POIGAU,
  368. 1 SHPTOT,REL,LRE,IER246)
  369. IF(IER246.NE.0) THEN
  370. CALL ERREUR(IER246)
  371. SEGSUP xMATRI
  372. SEGSUP WRK1,WRK3,MVELCH
  373. GOTO 510
  374. ENDIF
  375. * SEGINI XMATRI
  376. * IMATTT(IB)=XMATRI
  377. c
  378. c remplissage de xmatri
  379. c
  380. CALL REMPMT(REL,LRE,RE(1,1,ib))
  381. * SEGDES XMATRI
  382. 3018 CONTINUE
  383. SEGDES xMATRI
  384. SEGSUP WRK1,WRK3,MVELCH
  385. GOTO 510
  386. c_______________________________________________________________________
  387. c
  388. c impedance
  389. c_______________________________________________________________________
  390. c
  391. 45 CONTINUE
  392. IF (jmat.gt.0) THEN
  393. MPTVAL=IVAMAT
  394. MELVAL=IVAL(1)
  395. if (ival(/1).gt.1) then
  396. melva1 = ival(2)
  397. else
  398. melva1 = 0
  399. endif
  400. jddl = LRE/NBPGAU
  401. DO IB = 1,NBELEM
  402. JDIAG = 0
  403. if (melval.gt.0) IBMN=MIN(IB,VELCHE(/2))
  404. do IG = 1, NBPGAU
  405. if (melval.gt.0) igmn = MIN(IG,VELCHE(/1))
  406. XMASS = 0.D0
  407. if (melval.gt.0) XMASS=VELCHE(IGMN,IBMN)
  408. XINER = XMASS
  409. if (melva1.gt.0) then
  410. igmn = MIN(IG,melva1.VELCHE(/1))
  411. XINER = melva1.VELCHE(IGMN,IBMN)
  412. endif
  413. do idl = 1,jddl
  414. JDIAG = JDIAG + 1
  415. RE(JDIAG,JDIAG,ib) = XMASS
  416. if (idim.eq.3.and.idl.gt.3) RE(JDIAG,JDIAG,ib) = XINER
  417. if (idim.ne.3.and.idl.gt.2) RE(JDIAG,JDIAG,ib) = XINER
  418. enddo
  419. * enddo
  420. enddo
  421. ENDDO
  422. SEGDES XMATRI
  423. GOTO 510
  424. ENDIF
  425.  
  426. IF (MFR.EQ.26) THEN
  427. * MODAL (car goto 510 sous IMPEDANCE)
  428. DO IB = 1,NBELEM
  429. * SEGINI XMATRI
  430. * IMATTT(IB)=XMATRI
  431.  
  432. MPTVAL=IVAMAT
  433. MELVAL=IVAL(2)
  434. IBMN=MIN(IB,VELCHE(/2))
  435. XMASS=VELCHE(1,IBMN)
  436. RE(1,1,ib) = XMASS
  437. * SEGDES XMATRI
  438. ENDDO
  439. SEGDES xMATRI
  440. GOTO 510
  441. *
  442. ELSE IF (MFR.EQ.28) THEN
  443. * STATIQUE (car goto 510 sous IMPEDANCE)
  444. DO IB = 1,NBELEM
  445. * SEGINI XMATRI
  446. * IMATTT(IB)=XMATRI
  447.  
  448. MPTVAL=IVAMAT
  449. MELVAL=IVAL(1)
  450. IBMN=MIN(IB,IELCHE(/2))
  451. idepl=IELCHE(1,IBMN)
  452. MELVAL=IVAL(3)
  453. IBMN=MIN(IB,IELCHE(/2))
  454. imade=IELCHE(1,IBMN)
  455. CALL XTY1(idepl,imade,iinc,idua,X1)
  456. re(1,1,ib) = x1
  457. * SEGDES XMATRI
  458. ENDDO
  459. SEGDES xMATRI
  460. GOTO 510
  461. ENDIF
  462. *
  463. c_______________________________________________________________________
  464. c
  465. c element point (poi1) en defos planes generalisees
  466. c_______________________________________________________________________
  467. c
  468. IF(MELE.EQ.45.AND.IFOUR.NE.-3) GOTO 99
  469. NBBB=NBNN
  470. SEGINI WRK1,WRK3
  471. c
  472. c boucle de calcul pour les differents elements
  473. c
  474. DO 3045 IB=1,NBELEM
  475. c
  476. c on cherche les coordonnees de l element ib
  477. c
  478. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  479. c
  480. c on recherche rho et la section
  481. c
  482. MPTVAL=IVAMAT
  483. MELVAL=IVAL(1)
  484. IBMN=MIN(IB,VELCHE(/2))
  485. RR=VELCHE(1,IBMN)
  486. MPTVAL=IVACAR
  487. MELVAL=IVAL(1)
  488. IBMN=MIN(IB,VELCHE(/2))
  489. RR=RR*VELCHE(1,IBMN)
  490. c
  491. c on calcule la matrice de masse
  492. c
  493. CALL PO1MAS(XE,XDPGE,YDPGE,RR,LRE,REL)
  494. c
  495. * SEGINI XMATRI
  496. * IMATTT(IB)=XMATRI
  497. CALL REMPMT(REL,LRE,RE(1,1,ib))
  498. * SEGDES XMATRI
  499. 3045 CONTINUE
  500. SEGDES xMATRI
  501. SEGSUP WRK1,WRK3,MVELCH
  502. GO TO 510
  503. c_______________________________________________________________________
  504. c
  505. c elements barre et cerce
  506. c_______________________________________________________________________
  507. c
  508. 46 CONTINUE
  509. *
  510. IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) GOTO 99
  511. *
  512. NBBB=NBNN
  513. SEGINI WRK1,WRK3
  514. IF(MELE.EQ.123) THEN
  515. NCOM=NBNN
  516. LRN =LRE
  517. SEGINI WRK5
  518. ENDIF
  519. c
  520. c boucle de calcul pour les differents elements
  521. c
  522. DO 3046 IB=1,NBELEM
  523. c
  524. c on cherche les coordonnees de l element ib
  525. c
  526. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  527. c
  528. MPTVAL=IVAMAT
  529. MELVAL=IVAL(1)
  530. IBMN=MIN(IB,VELCHE(/2))
  531. RR=VELCHE(1,IBMN)
  532. MPTVAL=IVACAR
  533. MELVAL=IVAL(1)
  534. IBMN=MIN(IB,VELCHE(/2))
  535. RR=RR*VELCHE(1,IBMN)
  536. c
  537. c on calcule la matrice de masse
  538. c
  539. IF(MELE.EQ.46) CALL BARMAS(REL,LRE,RR,XE)
  540. IF(MELE.EQ.95) CALL CERMAS(REL,LRE,RR,XE)
  541. IF(MELE.EQ.123) CALL MASBA3(REL,LRE,RR,XE,XGENE,KERRE)
  542. IF(KERRE.NE.0) INTERR(1)=ISOUS
  543. IF(KERRE.NE.0) INTERR(2)=IB
  544. IF(MELE.EQ.123.AND.KERRE.EQ.1) CALL ERREUR(128)
  545. c
  546. * SEGINI XMATRI
  547. * IMATTT(IB)=XMATRI
  548. IF (ILUMP .EQ. 1) THEN
  549. CALL LUMP1(REL,LRE,RE(1,1,ib),IFOUR)
  550. ELSE
  551. CALL REMPMT(REL,LRE,RE(1,1,ib))
  552. ENDIF
  553. * SEGDES XMATRI
  554. 3046 CONTINUE
  555. SEGDES xMATRI
  556. SEGSUP WRK1,WRK3,MVELCH
  557. IF(MELE.EQ.123) SEGSUP WRK5
  558. GO TO 510
  559. c_______________________________________________________________________
  560. c
  561. c JOINT UNIDIMENSIONNEL JOI1
  562. c_______________________________________________________________________
  563. c
  564. 265 CONTINUE
  565. *
  566. NBBB=NBNN
  567. SEGINI WRK1,WRK3,WRK4
  568. *
  569. DO 3265 IB=1,NBELEM
  570. c
  571. MPTVAL=IVAMAT
  572. DO IC=1,NMATT
  573. IF(IVAL(IC).NE.0) THEN
  574. MELVAL=IVAL(IC)
  575. IBMN=MIN(IB,VELCHE(/2))
  576. WORK(IC)=VELCHE(1,IBMN)
  577. ELSE
  578. WORK(IC)=0.D0
  579. ENDIF
  580. END DO
  581. *
  582. CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  583. c
  584. c on calcule la matrice de masse localement
  585. c
  586. CALL JOIMAS(REL,LRE,WORK,NMATT,IDIM)
  587. c
  588. c on passe en repère global
  589. c
  590. IAW1=101
  591. IAW2=IAW1+LRE*LRE
  592. IAW3=IAW2+LRE*LRE
  593. IAW4=IAW3+LRE*LRE
  594. CALL JOIGLO(REL,BPSS,WORK(IAW1),WORK(IAW2),
  595. & WORK(IAW3),WORK(IAW4),LRE,IDIM)
  596. *
  597. IF (ILUMP .EQ. 1) THEN
  598. CALL LUMP1(REL,LRE,RE(1,1,ib),IFOUR)
  599. ELSE
  600. CALL REMPMT(REL,LRE,RE(1,1,ib))
  601. ENDIF
  602. 3265 CONTINUE
  603. SEGDES xMATRI
  604. SEGSUP WRK1,WRK3,WRK4,MVELCH
  605. GO TO 510
  606. c_______________________________________________________________________
  607. c
  608. c element barre 3d excentre (baex)
  609. c_______________________________________________________________________
  610. c
  611. 124 CONTINUE
  612. NBBB=NBNN
  613. NCOM=2
  614. LRN =LRE
  615. SEGINI WRK1,WRK3,WRK5
  616. c
  617. c boucle de calcul pour les differents elements
  618. c
  619. DO 3199 IB=1,NBELEM
  620. c
  621. c on recupere la section de l'element, ses excentrements et son
  622. c orientation. les caracteristiques sont rangees dans work
  623. c selon l'ordre suivant: sect excz excy vx vy vz
  624. c
  625. MPTVAL=IVACAR
  626. DO IC=1,NCARR
  627. IF(IVAL(IC).NE.0) THEN
  628. MELVAL=IVAL(IC)
  629. IBMN=MIN(IB,VELCHE(/2))
  630. WORK(IC)=VELCHE(1,IBMN)
  631. ELSE
  632. WORK(IC)=0.D0
  633. ENDIF
  634. END DO
  635. SECT=WORK(1)
  636. c
  637. c xgene stocke la matrice de passage de l'element excentre
  638. c
  639. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  640. CALL MAPAEX(XE,NBNN,WORK,AL,XGENE,LRE,KERRE)
  641. IF(KERRE.NE.0) INTERR(1)=ISOUS
  642. IF(KERRE.NE.0) INTERR(2)=IB
  643. IF(KERRE.EQ.1) CALL ERREUR(128)
  644. c
  645. MPTVAL=IVAMAT
  646. MELVAL=IVAL(1)
  647. IBMN=MIN(IB,VELCHE(/2))
  648. RR=VELCHE(1,IBMN)*SECT
  649. c
  650. c on calcule la matrice de masse
  651. c
  652. CALL BAMAEX(REL,LRE,RR,AL,XGENE)
  653. c
  654. * SEGINI XMATRI
  655. * IMATTT(IB)=XMATRI
  656. IF (ILUMP .EQ. 1) THEN
  657. CALL LUMP1(REL,LRE,RE(1,1,ib),IFOUR)
  658. ELSE
  659. CALL REMPMT(REL,LRE,RE(1,1,ib))
  660. ENDIF
  661. * SEGDES XMATRI
  662. 3199 CONTINUE
  663. SEGDES xMATRI
  664. SEGSUP WRK1,WRK3,WRK5,MVELCH
  665. GO TO 510
  666. c_______________________________________________________________________
  667. c
  668. c secteur de calcul pour les elements de raccord
  669. c liquide coque cas bidimensionnel
  670. c_______________________________________________________________________
  671. c
  672. 47 CONTINUE
  673. IF (ILUMP .EQ. 1) GOTO 99
  674. NBBB=NBNN
  675. LW=IDIM
  676. SEGINI WRK1,WRK3
  677. DO 3047 IB=1,NBELEM
  678. c
  679. c on cherche les coordonnees de l element ib
  680. c
  681. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  682. CALL ZERO(REL,LRE,LRE)
  683. c
  684. c calcul des coefficients de normalisation
  685. c
  686. MPTVAL=IVAMAT
  687. DO 5047 IM=1,NMATT
  688. MELVAL=IVAL(IM)
  689. IBMN=MIN(IB,VELCHE(/2))
  690. VALMAT(IM)=VELCHE(1,IBMN)
  691. 5047 CONTINUE
  692. RHOREF=VALMAT(1)
  693. RLCAR = VALMAT(2)
  694. c
  695. CFPI= RHOREF*RLCAR
  696. c
  697. MPTVAL=IVACAR
  698. DO 4047 IC=1,NCARR
  699. IF (IVAL(IC).NE.0) THEN
  700. MELVAL=IVAL(IC)
  701. IBMN=MIN(IB,VELCHE(/2))
  702. WORK(IC)=VELCHE(1,IBMN)
  703. ELSE
  704. WORK(IC)=0.D0
  705. ENDIF
  706. 4047 CONTINUE
  707. c
  708. CALL RACOMA(IFOUR,NIFOUR,IDIM,XE,CFPI,WORK,REL,LRE)
  709. c
  710. * SEGINI XMATRI
  711. * IMATTT(IB)=XMATRI
  712. c
  713. c remplissage de xmatri
  714. c
  715. CALL REMPMT(REL,LRE,RE(1,1,ib))
  716. * SEGDES XMATRI
  717. 3047 CONTINUE
  718. SEGDES xMATRI
  719. SEGSUP WRK3
  720. SEGSUP WRK1,MVELCH
  721. GOTO 510
  722. c_______________________________________________________________________
  723. c
  724. c secteur de calcul pour les elements de raccord
  725. c liquide coque 3 noeuds - cas tridimensionnel
  726. c_______________________________________________________________________
  727. c
  728. 55 CONTINUE
  729. IF (ILUMP .EQ. 1) GOTO 99
  730. NBBB=NBNN
  731. LW=IDIM
  732. SEGINI WRK1,WRK3
  733. DO 3055 IB=1,NBELEM
  734. c
  735. c on cherche les coordonnees de l element ib
  736. c
  737. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  738. CALL ZERO(REL,LRE,LRE)
  739. c
  740. c calcul des coefficients de normalisation
  741. c
  742. MPTVAL=IVAMAT
  743. DO 5055 IM=1,NMATT
  744. MELVAL=IVAL(IM)
  745. IBMN=MIN(IB,VELCHE(/2))
  746. VALMAT(IM)=VELCHE(1,IBMN)
  747. 5055 CONTINUE
  748. RHOREF=VALMAT(1)
  749. RLCAR = VALMAT(2)
  750. c
  751. CFPI= RHOREF*RLCAR
  752. c
  753. MPTVAL=IVACAR
  754. DO 4055 IC=1,NCARR
  755. IF (IVAL(IC).NE.0) THEN
  756. MELVAL=IVAL(IC)
  757. IBMN=MIN(IB,VELCHE(/2))
  758. WORK(IC)=VELCHE(1,IBMN)
  759. ELSE
  760. WORK(IC)=0.D0
  761. ENDIF
  762. 4055 CONTINUE
  763. c
  764. CALL LICOMA(NBPGAU,IDIM,NBNN,NDDL,XE,CFPI,WORK,POIGAU,
  765. 1 QSIGAU,ETAGAU,SHPTOT,REL,LRE,IER246)
  766. IF(IER246.NE.0) THEN
  767. CALL ERREUR(IER246)
  768. SEGSUP xMATRI
  769. SEGSUP WRK1,WRK3,MVELCH
  770. GOTO 510
  771. ENDIF
  772. * SEGINI XMATRI
  773. * IMATTT(IB)=XMATRI
  774. c
  775. c remplissage de xmatri
  776. c
  777. CALL REMPMT(REL,LRE,RE(1,1,ib))
  778. * SEGDES XMATRI
  779. 3055 CONTINUE
  780. SEGDES xMATRI
  781. SEGSUP WRK1,WRK3,MVELCH
  782. GOTO 510
  783. c_______________________________________________________________________
  784. c
  785. c secteur de calcul pour les elements joints joi2
  786. c_______________________________________________________________________
  787. c
  788. 85 CONTINUE
  789. IF (ILUMP .EQ. 1) GOTO 99
  790. NBNO=NBNN
  791. NBBB=NBNN
  792. SEGINI WRK1,WRK2,WRK4
  793. I195=0
  794. I259=0
  795. DO 3085 IB=1,NBELEM
  796. c
  797. c on cherche les coordonnees des noeuds de l element ib
  798. c
  799. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  800. CALL ZERO (REL,LRE,LRE)
  801. c
  802. c calcul des coordonnees locales de l'element
  803. c
  804. CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  805. c
  806. c boucle sur les points de gauss
  807. c
  808. ISDJC=0
  809. DO 4085 IGAU=1,NBPGAU
  810. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  811. 1 1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  812. *
  813. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  814. IF(DJAC.EQ.0.) I259=IB
  815. DJAC=ABS(DJAC)*POIGAU(IGAU)
  816. MPTVAL=IVAMAT
  817. IF (IVAL(1).NE.0) THEN
  818. MELVAL=IVAL(1)
  819. IGMN=MIN(IGAU,VELCHE(/1))
  820. IBMN=MIN(IB,VELCHE(/2))
  821. VALMAT(1)=VELCHE(IGMN,IBMN)
  822. ELSE
  823. VALMAT(1)=0.D0
  824. ENDIF
  825. CCCCCCCCCCC DJAC=DJAC*VALMAT(1)/3.0D0
  826. C
  827. C IL FAUT DIVISER PAR 4, CE QUI CORRESPOND PLUS EXACTEMENT A DIVISER
  828. C LE B PAR 2...
  829. C
  830. DJAC=DJAC*VALMAT(1)/4.0D0
  831. c
  832. c cas axisymetrique : multiplication par le rayon de courbure
  833. c
  834. IF (IFOUR.EQ.0) THEN
  835. RAYON = 0.D0
  836. NUMSUP=NBNO/2
  837. DO 4185 IRAY=1,NUMSUP
  838. RAYON=RAYON + ( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  839. 4185 CONTINUE
  840. DJAC=DJAC*RAYON
  841. ENDIF
  842. c
  843. CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  844. 4085 CONTINUE
  845. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  846. * SEGINI XMATRI
  847. * IMATTT(IB)=XMATRI
  848. c
  849. c remplissage de xmatri
  850. c
  851. CALL REMPMT(REL,LRE,RE(1,1,ib))
  852. * SEGDES XMATRI
  853. 3085 CONTINUE
  854. IF(I195.NE.0) INTERR(1)=I195
  855. IF(I195.NE.0) CALL ERREUR(195)
  856. IF(I259.NE.0) INTERR(1)=I259
  857. IF(I259.NE.0) CALL ERREUR(259)
  858. SEGDES xMATRI
  859. SEGSUP WRK1,WRK2,WRK4,MVELCH
  860. GOTO 510
  861. c_______________________________________________________________________
  862. c
  863. c secteur de calcul pour les elements joints jot3
  864. c_______________________________________________________________________
  865. c
  866. 87 CONTINUE
  867. IF (ILUMP .EQ. 1) GOTO 99
  868. NBNO=NBNN
  869. NBBB=NBNN
  870. SEGINI WRK1,WRK2,WRK4
  871. I195=0
  872. I259=0
  873. DO 3087 IB=1,NBELEM
  874. c
  875. c on cherche les coordonnees des noeuds de l element ib
  876. c
  877. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  878. CALL ZERO (REL,LRE,LRE)
  879. c
  880. c calcul des coordonnees locales de l'element
  881. c
  882. CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  883. c
  884. c boucle sur les points de gauss
  885. c
  886. ISDJC=0
  887. DO 4087 IGAU=1,NBPGAU
  888. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  889. 1 1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  890. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  891. IF(DJAC.EQ.0.) I259=IB
  892. DJAC=ABS(DJAC)*POIGAU(IGAU)
  893. MPTVAL=IVAMAT
  894. IF (IVAL(1).NE.0) THEN
  895. MELVAL=IVAL(1)
  896. IGMN=MIN(IGAU,VELCHE(/1))
  897. IBMN=MIN(IB,VELCHE(/2))
  898. VALMAT(1)=VELCHE(IGMN,IBMN)
  899. ELSE
  900. VALMAT(1)=0.D0
  901. ENDIF
  902. DJAC=DJAC*VALMAT(1)
  903. CCCCCCCCCCC DJAC=DJAC/3.0D0
  904. C IL FAUT DIVISER PAR 4, CE QUI CORRESPOND PLUS EXACTEMENT A DIVISER
  905. C LE B PAR 2...
  906. DJAC=DJAC/4.0D0
  907. CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  908. 4087 CONTINUE
  909. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  910. * SEGINI XMATRI
  911. * IMATTT(IB)=XMATRI
  912. c
  913. c remplissage de xmatri
  914. c
  915. CALL REMPMT(REL,LRE,RE(1,1,ib))
  916. * SEGDES XMATRI
  917. 3087 CONTINUE
  918. IF(I195.NE.0) INTERR(1)=I195
  919. IF(I195.NE.0) CALL ERREUR(195)
  920. IF(I259.NE.0) INTERR(1)=I259
  921. IF(I259.NE.0) CALL ERREUR(259)
  922. SEGDES xMATRI
  923. SEGSUP WRK1,WRK2,WRK4,MVELCH
  924. GOTO 510
  925. c_______________________________________________________________________
  926. c
  927. c secteur de calcul pour les elements joints joi4
  928. c_______________________________________________________________________
  929. c
  930. 88 CONTINUE
  931. IF (ILUMP .EQ. 1) GOTO 99
  932. NBNO=NBNN
  933. NBBB=NBNN
  934. SEGINI WRK1,WRK2,WRK4
  935. I195=0
  936. I259=0
  937. DO 3088 IB=1,NBELEM
  938. c
  939. c on cherche les coordonnees des noeuds de l element ib
  940. c
  941. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  942. CALL ZERO (REL,LRE,LRE)
  943. c
  944. c calcul des coordonnees locales de l'element
  945. c
  946. CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  947. c
  948. c boucle sur les points de gauss
  949. c
  950. ISDJC=0
  951. DO 4088 IGAU=1,NBPGAU
  952. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  953. 1 1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  954. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  955. IF(DJAC.EQ.0.) I259=IB
  956. DJAC=ABS(DJAC)*POIGAU(IGAU)
  957. MPTVAL=IVAMAT
  958. IF (IVAL(1).NE.0) THEN
  959. MELVAL=IVAL(1)
  960. IGMN=MIN(IGAU,VELCHE(/1))
  961. IBMN=MIN(IB,VELCHE(/2))
  962. VALMAT(1)=VELCHE(IGMN,IBMN)
  963. ELSE
  964. VALMAT(1)=0.D0
  965. ENDIF
  966. DJAC=DJAC*VALMAT(1)
  967. CCCCCCCCCCCC DJAC=DJAC/3.0D0
  968. C IL FAUT DIVISER PAR 4, CE QUI CORRESPOND PLUS EXACTEMENT A DIVISER
  969. C LE B PAR 2...
  970. DJAC=DJAC/4.0D0
  971. CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  972. 4088 CONTINUE
  973. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  974. * SEGINI XMATRI
  975. * IMATTT(IB)=XMATRI
  976. c
  977. c remplissage de xmatri
  978. c
  979. CALL REMPMT(REL,LRE,RE(1,1,ib))
  980. * SEGDES XMATRI
  981. 3088 CONTINUE
  982. IF(I195.NE.0) INTERR(1)=I195
  983. IF(I195.NE.0) CALL ERREUR(195)
  984. IF(I259.NE.0) INTERR(1)=I259
  985. IF(I259.NE.0) CALL ERREUR(259)
  986. SEGDES xMATRI
  987. SEGSUP WRK1,WRK2,WRK4,MVELCH
  988. GOTO 510
  989. c_______________________________________________________________________
  990. c
  991. c secteur de calcul pour les elements joints jgi2
  992. c_______________________________________________________________________
  993. c
  994. 170 CONTINUE
  995. IF (IFOUR.EQ.-3) NDDL=NDDL+1
  996. IF (ILUMP .EQ. 1) GOTO 99
  997. NBNO=NBNN
  998. NBBB=NBNN
  999. SEGINI WRK1,WRK2,WRK4
  1000. I195=0
  1001. I259=0
  1002. C
  1003. IG1=0
  1004. C
  1005. DO IB=1,NBELEM
  1006. c
  1007. c on cherche les coordonnees des noeuds de l element ib
  1008. c
  1009. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1010. CALL ZERO (REL,LRE,LRE)
  1011. c
  1012. c calcul des coordonnees locales de l'element
  1013. c
  1014. CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1015. c
  1016. c boucle sur les points de gauss
  1017. c
  1018. ISDJC=0
  1019. DO IGAU=1,NBPGAU
  1020. MPTVAL=IVAMAT
  1021. DO IM=1,NMATT
  1022. MELVAL=IVAL(IM)
  1023. IGMN=MIN(IGAU,VELCHE(/1))
  1024. IBMN=MIN(IB,VELCHE(/2))
  1025. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1026. ENDDO
  1027. C
  1028. EPAIST=VALMAT(2)
  1029. IF(EPAIST.EQ.0.D0)THEN
  1030. CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,
  1031. . SHPWRK,EPAIST,BGENE,DJAC,XDPGE,YDPGE,IERT)
  1032. IF(IERT.NE.0) IG1=IB
  1033. ENDIF
  1034. C
  1035. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  1036. 1 1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  1037. *
  1038. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  1039. IF(DJAC.EQ.0.) I259=IB
  1040. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1041. *
  1042. c valmat(1)=rho, valmat(2)=epai
  1043. c /4 correspnnd en fait a diviser les matrices B par 2
  1044. CCCCCCCCCCCC DJAC=DJAC*VALMAT(1)*VALMAT(2)/4.0D0
  1045. DJAC=DJAC*VALMAT(1)*EPAIST/4.0D0
  1046. c
  1047. c cas axisymetrique : multiplication par le rayon de courbure
  1048. c
  1049. IF (IFOUR.EQ.0) THEN
  1050. RAYON = 0.D0
  1051. NUMSUP=NBNO/2
  1052. DO IRAY=1,NUMSUP
  1053. RAYON=RAYON + ( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  1054. ENDDO
  1055. DJAC=DJAC*RAYON
  1056. ENDIF
  1057. c
  1058. CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  1059. ENDDO
  1060. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1061. * SEGINI XMATRI
  1062. * IMATTT(IB)=XMATRI
  1063. c
  1064. c remplissage de xmatri
  1065. c
  1066. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1067. * SEGDES XMATRI
  1068. ENDDO
  1069. C
  1070. IF(IG1.NE.0) INTERR(1)=IG1
  1071. IF(IG1.NE.0) CALL ERREUR (611)
  1072. C
  1073. IF(I195.NE.0) INTERR(1)=I195
  1074. IF(I195.NE.0) CALL ERREUR(195)
  1075. IF(I259.NE.0) INTERR(1)=I259
  1076. IF(I259.NE.0) CALL ERREUR(259)
  1077. SEGDES xMATRI
  1078. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1079. GOTO 510
  1080. C
  1081. c_______________________________________________________________________
  1082. c
  1083. c secteur de calcul pour les elements joints jct3 en 2D cisaillement
  1084. c_______________________________________________________________________
  1085. c
  1086. 168 CONTINUE
  1087. IF (ILUMP .EQ. 1) GOTO 99
  1088. NBNO=NBNN
  1089. NBBB=NBNN
  1090. SEGINI WRK1,WRK2,WRK4
  1091. I195=0
  1092. I259=0
  1093. DO IB=1,NBELEM
  1094. c
  1095. c on cherche les coordonnees des noeuds de l element ib
  1096. c
  1097. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1098. CALL ZERO (REL,LRE,LRE)
  1099. c
  1100. c calcul des coordonnees locales de l'element
  1101. c
  1102. CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1103. c
  1104. c boucle sur les points de gauss
  1105. c
  1106. ISDJC=0
  1107. DO IGAU=1,NBPGAU
  1108. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  1109. 1 1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  1110. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  1111. IF(DJAC.EQ.0.) I259=IB
  1112. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1113. MPTVAL=IVAMAT
  1114. IF (IVAL(1).NE.0) THEN
  1115. MELVAL=IVAL(1)
  1116. IGMN=MIN(IGAU,VELCHE(/1))
  1117. IBMN=MIN(IB,VELCHE(/2))
  1118. VALMAT(1)=VELCHE(IGMN,IBMN)
  1119. ELSE
  1120. VALMAT(1)=0.D0
  1121. ENDIF
  1122. DJAC=DJAC*VALMAT(1)
  1123. CCCCCCCCCC DJAC=DJAC/3.0D0
  1124. C Il faut diviser par 4, ce qui correspond plus exactement a diviser
  1125. C le B par 2...
  1126. DJAC=DJAC/4.0D0
  1127. CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  1128. ENDDO
  1129. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1130. * SEGINI XMATRI
  1131. * IMATTT(IB)=XMATRI
  1132. c
  1133. c remplissage de xmatri
  1134. c
  1135. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1136. SEGDES XMATRI
  1137. ENDDO
  1138. IF(I195.NE.0) INTERR(1)=I195
  1139. IF(I195.NE.0) CALL ERREUR(195)
  1140. IF(I259.NE.0) INTERR(1)=I259
  1141. IF(I259.NE.0) CALL ERREUR(259)
  1142. SEGDES xMATRI
  1143. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1144. GOTO 510
  1145. c_______________________________________________________________________
  1146. c
  1147. c secteur de calcul pour les elements joints jgt3 generalise
  1148. c_______________________________________________________________________
  1149. c
  1150. 171 CONTINUE
  1151. IF (ILUMP .EQ. 1) GOTO 99
  1152. NBNO=NBNN
  1153. NBBB=NBNN
  1154. SEGINI WRK1,WRK2,WRK4
  1155. I195=0
  1156. I259=0
  1157. C
  1158. IG1=0
  1159. C
  1160. DO IB=1,NBELEM
  1161. c
  1162. c on cherche les coordonnees des noeuds de l element ib
  1163. c
  1164. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1165. CALL ZERO (REL,LRE,LRE)
  1166. c
  1167. c calcul des coordonnees locales de l'element
  1168. c
  1169. CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1170. c
  1171. c boucle sur les points de gauss
  1172. c
  1173. ISDJC=0
  1174. DO IGAU=1,NBPGAU
  1175. MPTVAL=IVAMAT
  1176. DO IM=1,NMATT
  1177. MELVAL=IVAL(IM)
  1178. IGMN=MIN(IGAU,VELCHE(/1))
  1179. IBMN=MIN(IB,VELCHE(/2))
  1180. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1181. ENDDO
  1182. C
  1183. EPAIST=VALMAT(2)
  1184. IF(EPAIST.EQ.0.D0)THEN
  1185. CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,
  1186. . SHPWRK,EPAIST,BGENE,DJAC,IERT)
  1187. IF(IERT.NE.0) IG1=IB
  1188. ENDIF
  1189. C
  1190. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  1191. 1 1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  1192. *
  1193. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  1194. IF(DJAC.EQ.0.) I259=IB
  1195. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1196. *
  1197. c valmat(1)=rho, valmat(2)=epai
  1198. c /4 correspnnd en fait a diviser les matrices B par 2
  1199. CCCCCCCCCCCC DJAC=DJAC*VALMAT(1)*VALMAT(2)/4.0D0
  1200. DJAC=DJAC*VALMAT(1)*EPAIST/4.0D0
  1201. *
  1202. CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  1203. ENDDO
  1204. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1205. * SEGINI XMATRI
  1206. * IMATTT(IB)=XMATRI
  1207. c
  1208. c remplissage de xmatri
  1209. c
  1210. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1211. * SEGDES XMATRI
  1212. ENDDO
  1213. C
  1214. IF(IG1.NE.0) INTERR(1)=IG1
  1215. IF(IG1.NE.0) CALL ERREUR (611)
  1216. C
  1217. IF(I195.NE.0) INTERR(1)=I195
  1218. IF(I195.NE.0) CALL ERREUR(195)
  1219. IF(I259.NE.0) INTERR(1)=I259
  1220. IF(I259.NE.0) CALL ERREUR(259)
  1221. SEGDES xMATRI
  1222. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1223. GOTO 510
  1224. C
  1225. c_______________________________________________________________________
  1226. c
  1227. c secteur de calcul pour les elements joints jci4 en 2D cisaillement
  1228. c_______________________________________________________________________
  1229. c
  1230. 169 CONTINUE
  1231. IF (ILUMP .EQ. 1) GOTO 99
  1232. NBNO=NBNN
  1233. NBBB=NBNN
  1234. SEGINI WRK1,WRK2,WRK4
  1235. I195=0
  1236. I259=0
  1237. DO IB=1,NBELEM
  1238. c
  1239. c on cherche les coordonnees des noeuds de l element ib
  1240. c
  1241. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1242. CALL ZERO (REL,LRE,LRE)
  1243. c
  1244. c calcul des coordonnees locales de l'element
  1245. c
  1246. CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1247. c
  1248. c boucle sur les points de gauss
  1249. c
  1250. ISDJC=0
  1251. DO IGAU=1,NBPGAU
  1252. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  1253. 1 1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  1254. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  1255. IF(DJAC.EQ.0.) I259=IB
  1256. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1257. MPTVAL=IVAMAT
  1258. IF (IVAL(1).NE.0) THEN
  1259. MELVAL=IVAL(1)
  1260. IGMN=MIN(IGAU,VELCHE(/1))
  1261. IBMN=MIN(IB,VELCHE(/2))
  1262. VALMAT(1)=VELCHE(IGMN,IBMN)
  1263. ELSE
  1264. VALMAT(1)=0.D0
  1265. ENDIF
  1266. DJAC=DJAC*VALMAT(1)
  1267. CCCCCCCCCCC DJAC=DJAC/3.0D0
  1268. C Il faut diviser par 4, ce qui correspond plus exactement a diviser
  1269. C le B par 2...
  1270. DJAC=DJAC/4.0D0
  1271. CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  1272. ENDDO
  1273. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1274. * SEGINI XMATRI
  1275. * IMATTT(IB)=XMATRI
  1276. c
  1277. c remplissage de xmatri
  1278. c
  1279. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1280. * SEGDES XMATRI
  1281. ENDDO
  1282. IF(I195.NE.0) INTERR(1)=I195
  1283. IF(I195.NE.0) CALL ERREUR(195)
  1284. IF(I259.NE.0) INTERR(1)=I259
  1285. IF(I259.NE.0) CALL ERREUR(259)
  1286. SEGDES xMATRI
  1287. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1288. GOTO 510
  1289. c_______________________________________________________________________
  1290. c
  1291. c secteur de calcul pour les elements joints jgi4 generalise
  1292. c_______________________________________________________________________
  1293. c
  1294. 172 CONTINUE
  1295. IF (ILUMP .EQ. 1) GOTO 99
  1296. NBNO=NBNN
  1297. NBBB=NBNN
  1298. SEGINI WRK1,WRK2,WRK4
  1299. I195=0
  1300. I259=0
  1301. C
  1302. IG1=0
  1303. C
  1304. DO IB=1,NBELEM
  1305. c
  1306. c on cherche les coordonnees des noeuds de l element ib
  1307. c
  1308. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1309. CALL ZERO (REL,LRE,LRE)
  1310. c
  1311. c calcul des coordonnees locales de l'element
  1312. c
  1313. CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1314. c
  1315. c boucle sur les points de gauss
  1316. c
  1317. ISDJC=0
  1318. DO IGAU=1,NBPGAU
  1319. MPTVAL=IVAMAT
  1320. DO IM=1,NMATT
  1321. MELVAL=IVAL(IM)
  1322. IGMN=MIN(IGAU,VELCHE(/1))
  1323. IBMN=MIN(IB,VELCHE(/2))
  1324. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1325. ENDDO
  1326. C
  1327. EPAIST=VALMAT(2)
  1328. IF(EPAIST.EQ.0.D0)THEN
  1329. CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,
  1330. . BGENE,DJAC,IERT)
  1331. IF(IERT.NE.0) IG1=IB
  1332. ENDIF
  1333. C
  1334. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NDDL,
  1335. 1 1.D0,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  1336. *
  1337. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  1338. IF(DJAC.EQ.0.) I259=IB
  1339. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1340. *
  1341. c valmat(1)=rho, valmat(2)=epai
  1342. c /4 correspnnd en fait a diviser les matrices B par 2
  1343. CCCCCCCCCCCC DJAC=DJAC*VALMAT(1)*VALMAT(2)/4.0D0
  1344. DJAC=DJAC*VALMAT(1)*EPAIST/4.0D0
  1345. *
  1346. CALL NTNST(BGENE,DJAC,LRE,NDDL,REL)
  1347. ENDDO
  1348. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1349. * SEGINI XMATRI
  1350. * IMATTT(IB)=XMATRI
  1351. c
  1352. c remplissage de xmatri
  1353. c
  1354. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1355. * SEGDES XMATRI
  1356. ENDDO
  1357. C
  1358. IF(IG1.NE.0) INTERR(1)=IG1
  1359. IF(IG1.NE.0) CALL ERREUR (611)
  1360. C
  1361. IF(I195.NE.0) INTERR(1)=I195
  1362. IF(I195.NE.0) CALL ERREUR(195)
  1363. IF(I259.NE.0) INTERR(1)=I259
  1364. IF(I259.NE.0) CALL ERREUR(259)
  1365. SEGDES xMATRI
  1366. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1367. GOTO 510
  1368. C
  1369. c_______________________________________________________________________
  1370. c
  1371. c secteur de calcul pour les elements homogeneises
  1372. c (liquide solide) trih
  1373. c_______________________________________________________________________
  1374. c
  1375. 92 CONTINUE
  1376. IF (ILUMP .EQ. 1) GOTO 99
  1377. NBNO=NBNN
  1378. NBBB=NBNN
  1379. SEGINI WRK1,WRK2
  1380. I195=0
  1381. DO 3092 IB=1,NBELEM
  1382. c
  1383. c on cherche les coordonnees des noeuds de l element ib
  1384. c
  1385. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1386. CALL ZERO (REL,LRE,LRE)
  1387. c
  1388. c on cherche les caracteristiques du materiau de l element ib
  1389. c
  1390. MPTVAL=IVAMAT
  1391. DO 8092 IM=1,NMATT
  1392. MELVAL=IVAL(IM)
  1393. IBMN=MIN(IB,VELCHE(/2))
  1394. VALMAT(IM)=VELCHE(1,IBMN)
  1395. 8092 CONTINUE
  1396. B11 =VALMAT(1)
  1397. B22 =VALMAT(2)
  1398. B12 =VALMAT(3)
  1399. RHOF =VALMAT(4)
  1400. RHOS =VALMAT(5)
  1401. C =VALMAT(6)
  1402. RHOREF=VALMAT(7)
  1403. CREF =VALMAT(8)
  1404. RLCAR =VALMAT(9)
  1405. c
  1406. c on cherche les caracteristiques geometriques de l element ib
  1407. c
  1408. MPTVAL=IVACAR
  1409. IF (IFOUR.EQ.0.OR.IFOUR.EQ.1) THEN
  1410. MELVAL=IVAL(1)
  1411. IBMN=MIN(IB,VELCHE(/2))
  1412. SECT=VELCHE(1,IBMN)
  1413. MELVAL=IVAL(2)
  1414. IBMN=MIN(IB,VELCHE(/2))
  1415. SCEL=VELCHE(1,IBMN)
  1416. MELVAL=IVAL(3)
  1417. IBMN=MIN(IB,VELCHE(/2))
  1418. SFLU=VELCHE(1,IBMN)
  1419. MELVAL=IVAL(4)
  1420. IBMN=MIN(IB,VELCHE(/2))
  1421. EPS =VELCHE(1,IBMN)
  1422. ELSE
  1423. SECT=1.D0
  1424. MELVAL=IVAL(1)
  1425. IBMN=MIN(IB,VELCHE(/2))
  1426. SCEL=VELCHE(1,IBMN)
  1427. MELVAL=IVAL(2)
  1428. IBMN=MIN(IB,VELCHE(/2))
  1429. SFLU=VELCHE(1,IBMN)
  1430. MELVAL=IVAL(3)
  1431. IBMN=MIN(IB,VELCHE(/2))
  1432. EPS =VELCHE(1,IBMN)
  1433. MELVAL=IVAL(4)
  1434. IBMN=MIN(IB,VELCHE(/2))
  1435. F11 =VELCHE(1,IBMN)
  1436. MELVAL=IVAL(5)
  1437. IBMN=MIN(IB,VELCHE(/2))
  1438. F12 =VELCHE(1,IBMN)
  1439. ENDIF
  1440. c
  1441. c calcul de la masse m0/eps**2
  1442. c
  1443. RHOSS=RHOS*SECT/(EPS*EPS)
  1444. c
  1445. c calcul des coefficients de normalisation
  1446. c
  1447. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  1448. COEFPI=RHOREF*RLCAR
  1449. VKL12 =-(COEFPR*COEFPI*SFLU)/(RHOF*C*C*SCEL)
  1450. VKL22 =-(COEFPI*COEFPI)/(RHOF*SCEL)
  1451. VKL23 = COEFPI/SCEL
  1452. VKL33 = 1.D0/SCEL
  1453. IF(IFOUR.EQ.0.OR.IFOUR.EQ.1) THEN
  1454. VKL23 =COEFPI*0.5D0*(2.D0*SCEL-B11-B22)/SCEL
  1455. VKL33 =(RHOSS+RHOF*(SFLU-(B11+B22)/2.D0))/SCEL
  1456. c
  1457. c calcul des termes en pi*pi
  1458. c integration par nbpgau points de gauss
  1459. c
  1460. ISDJC=0
  1461. DO 4092 IGAU=1,NBPGAU
  1462. POIGA2=MINTE.POIGAU(IGAU)
  1463. CALL TRIHM1(IGAU,MELE,MFR,NBNO,XE,SHPTOT,SHPWRK,
  1464. # IFOUR,NHRM,B11,B22,SFLU,POIGA2,VKL22,LRE,REL,IRRT)
  1465. IF(IRRT.NE.1) GOTO 7092
  1466. c
  1467. c calcul du reste des termes de la matrice masse
  1468. c integration par nbpgau points de gauss
  1469. c
  1470. CALL TRIHM2(IGAU,MELE,MFR,NBNO,XE,MINTE.SHPTOT,SHPWRK
  1471. # ,IFOUR,NHRM,VKL12,VKL23,VKL33,POIGA2,ISDJC,LRE,REL,IRRT)
  1472. IF(IRRT.NE.1) GOTO 7092
  1473. 4092 CONTINUE
  1474. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1475. ELSE
  1476. c
  1477. c boucle sur les points de gauss
  1478. c cas plan
  1479. c
  1480. ISDJC=0
  1481. DO 6092 IGAU1=1,NBPGAU
  1482. POIGA1=MINTE.POIGAU(IGAU1)
  1483. CALL TRIHM3(IGAU1,MELE,NBNO,XE,SHPTOT,SHPWRK
  1484. # ,RHOSS,RHOF,
  1485. # B11,B22,B12,F11,F12,SFLU,SCEL,POIGA1,VKL12,VKL22,
  1486. # VKL23,VKL33,LRE,REL,ISDJC,IRRT)
  1487. IF(IRRT.NE.1) GOTO 7092
  1488. 6092 CONTINUE
  1489. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1490. ENDIF
  1491. * SEGINI XMATRI
  1492. * IMATTT(IB)=XMATRI
  1493. c
  1494. c remplissage de xmatri
  1495. c
  1496. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1497. * SEGDES XMATRI
  1498. 3092 CONTINUE
  1499. c
  1500. c impression d un eventuel message d erreur
  1501. c
  1502. IF(I195.NE.0) INTERR(1)=I195
  1503. IF(I195.NE.0) CALL ERREUR(195)
  1504. 7092 CONTINUE
  1505. IF(IRRT.EQ.0) THEN
  1506. MOTERR(1:4)=NOMTP(MELE)
  1507. CALL ERREUR(420)
  1508. ELSE
  1509. IF(IRRT.EQ.2) THEN
  1510. INTERR(1) = IB
  1511. CALL ERREUR(405)
  1512. ENDIF
  1513. ENDIF
  1514. IF(IRRT.EQ.3) CALL ERREUR(421)
  1515. IF(IRRT.EQ.4) CALL ERREUR(422)
  1516. SEGDES xMATRI
  1517. SEGSUP WRK1,WRK2,MVELCH
  1518. GOTO 510
  1519. c_______________________________________________________________________
  1520. c
  1521. c secteur de calcul pour les elements de raccord
  1522. c liquide coque 4 noeuds - cas tridimensionnel
  1523. c_______________________________________________________________________
  1524. c
  1525. 94 CONTINUE
  1526. IF (ILUMP .EQ. 1) GOTO 99
  1527. NBBB=NBNN
  1528. LW=IDIM
  1529. SEGINI WRK1,WRK3
  1530. DO 3094 IB=1,NBELEM
  1531. c
  1532. c on cherche les coordonnees de l element ib
  1533. c
  1534. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1535. CALL ZERO(REL,LRE,LRE)
  1536. c
  1537. c calcul des coefficients de normalisation
  1538. c
  1539. MPTVAL=IVAMAT
  1540. DO 5094 IM=1,NMATT
  1541. MELVAL=IVAL(IM)
  1542. IBMN=MIN(IB,VELCHE(/2))
  1543. VALMAT(IM)=VELCHE(1,IBMN)
  1544. 5094 CONTINUE
  1545. RHOREF=VALMAT(1)
  1546. RLCAR = VALMAT(2)
  1547. c
  1548. CFPI= RHOREF*RLCAR
  1549. c
  1550. MPTVAL=IVACAR
  1551. DO 4094 IC=1,NCARR
  1552. IF (IVAL(IC).NE.0) THEN
  1553. MELVAL=IVAL(IC)
  1554. IBMN=MIN(IB,VELCHE(/2))
  1555. WORK(IC)=VELCHE(1,IBMN)
  1556. ELSE
  1557. WORK(IC)=0.D0
  1558. ENDIF
  1559. 4094 CONTINUE
  1560. c
  1561. CALL LIC4MA(NBPGAU,IDIM,NBNN,NDDL,XE,CFPI,WORK,POIGAU,
  1562. 1 QSIGAU,ETAGAU,SHPTOT,REL,LRE,IER246)
  1563. IF(IER246.NE.0) THEN
  1564. CALL ERREUR(IER246)
  1565. SEGSUP xMATRI
  1566. SEGSUP WRK1,WRK3,MVELCH
  1567. GOTO 510
  1568. ENDIF
  1569. * SEGINI XMATRI
  1570. * IMATTT(IB)=XMATRI
  1571. c
  1572. c remplissage de xmatri
  1573. c
  1574. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1575. * SEGDES XMATRI
  1576. 3094 CONTINUE
  1577. SEGDES xMATRI
  1578. SEGSUP WRK1,WRK3,MVELCH
  1579. GOTO 510
  1580. c_______________________________________________________________________
  1581. c
  1582. c secteur de calcul pour les elements homogeneises
  1583. c (liquide solide) quah
  1584. c_______________________________________________________________________
  1585. c
  1586. 126 CONTINUE
  1587. c
  1588. IF (ILUMP .EQ. 1) GOTO 99
  1589. NBNO=NBNN
  1590. NBBB=NBNN
  1591. SEGINI WRK1,WRK2
  1592. I195=0
  1593. DO 3126 IB=1,NBELEM
  1594. c
  1595. c on cherche les coordonnees des noeuds de l element ib
  1596. c
  1597. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1598. CALL ZERO (REL,LRE,LRE)
  1599. c
  1600. c on cherche les caracteristiques du materiau de l element ib
  1601. c
  1602. MPTVAL=IVAMAT
  1603. DO 8126 IM=1,NMATT
  1604. MELVAL=IVAL(IM)
  1605. IBMN=MIN(IB,VELCHE(/2))
  1606. VALMAT(IM)=VELCHE(1,IBMN)
  1607. 8126 CONTINUE
  1608. B11 =VALMAT(1)
  1609. B22 =VALMAT(2)
  1610. B12 =VALMAT(3)
  1611. RHOF =VALMAT(4)
  1612. RHOS =VALMAT(5)
  1613. C =VALMAT(6)
  1614. RHOREF=VALMAT(7)
  1615. CREF =VALMAT(8)
  1616. RLCAR =VALMAT(9)
  1617. c
  1618. c on cherche les caracteristiques geometriques de l element ib
  1619. c
  1620. MPTVAL=IVACAR
  1621. MELVAL=IVAL(4)
  1622. IBMN=MIN(IB,VELCHE(/2))
  1623. SECT=VELCHE(1,IBMN)
  1624. c
  1625. MELVAL=IVAL(1)
  1626. IBMN=MIN(IB,VELCHE(/2))
  1627. SCEL=VELCHE(1,IBMN)
  1628. c
  1629. MELVAL=IVAL(2)
  1630. IBMN=MIN(IB,VELCHE(/2))
  1631. SFLU=VELCHE(1,IBMN)
  1632. c
  1633. MELVAL=IVAL(3)
  1634. IBMN=MIN(IB,VELCHE(/2))
  1635. EPS =VELCHE(1,IBMN)
  1636. c
  1637. c
  1638. c calcul de la masse m0/eps**2
  1639. c
  1640. RHOSS=RHOS*SECT/(EPS*EPS)
  1641. c
  1642. c calcul des coefficients de normalisation
  1643. c
  1644. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  1645. COEFPI=RHOREF*RLCAR
  1646. VKL12 =-(COEFPR*COEFPI*SFLU)/(RHOF*C*C*SCEL)
  1647. VKL22 =-(COEFPI*COEFPI)/(RHOF*SCEL)
  1648. VKL23 =COEFPI*0.5D0*(2.D0*SCEL-B11-B22)/SCEL
  1649. VKL33 =(RHOSS+RHOF*(SFLU-(B11+B22)/2.D0))/SCEL
  1650. c
  1651. c
  1652. c calcul des termes en pi*pi
  1653. c integration par nbpgau points de gauss
  1654. c
  1655. ISDJC=0
  1656. DO 4126 IGAU=1,NBPGAU
  1657. POIGA2=MINTE.POIGAU(IGAU)
  1658. CALL QUAHM1(IGAU,MELE,MFR,NBNO,XE,SHPTOT,SHPWRK,IFOUR
  1659. # ,NHRM,B11,B22,SFLU,POIGA2,VKL22,LRE,REL,IRRT)
  1660. IF(IRRT.NE.1) GOTO 7126
  1661. c
  1662. c calcul du reste des termes de la matrice masse
  1663. c integration par nbpgau points de gauss
  1664. c
  1665. CALL QUAHM2(IGAU,MELE,MFR,NBNO,XE,MINTE.SHPTOT,SHPWRK
  1666. # ,IFOUR,NHRM,VKL12,VKL23,VKL33,POIGA2,ISDJC,LRE,REL,IRRT)
  1667. IF(IRRT.NE.1) GOTO 7126
  1668. 4126 CONTINUE
  1669. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1670. c
  1671. * SEGINI XMATRI
  1672. * IMATTT(IB)=XMATRI
  1673. c
  1674. c remplissage de xmatri
  1675. c
  1676. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1677. * SEGDES XMATRI
  1678. 3126 CONTINUE
  1679. c
  1680. c impression d un eventuel message d erreur
  1681. c
  1682. IF(I195.NE.0) INTERR(1)=I195
  1683. IF(I195.NE.0) CALL ERREUR(195)
  1684. 7126 CONTINUE
  1685. IF(IRRT.EQ.0) THEN
  1686. MOTERR(1:4)=NOMTP(MELE)
  1687. CALL ERREUR(420)
  1688. ELSE
  1689. IF(IRRT.EQ.2) THEN
  1690. INTERR(1) = IB
  1691. CALL ERREUR(405)
  1692. ENDIF
  1693. ENDIF
  1694. IF(IRRT.EQ.3) CALL ERREUR(421)
  1695. IF(IRRT.EQ.4) CALL ERREUR(422)
  1696. SEGDES xMATRI
  1697. SEGSUP WRK1,WRK2,MVELCH
  1698. GOTO 510
  1699. c
  1700. c_______________________________________________________________________
  1701. c
  1702. c secteur de calcul pour les elements homogeneises
  1703. c (liquide solide) cubh
  1704. c_______________________________________________________________________
  1705. c
  1706. 127 CONTINUE
  1707. IF (ILUMP .EQ. 1) GOTO 99
  1708. NBNO=NBNN
  1709. NBBB=NBNN
  1710. LW=IDIM
  1711. SEGINI WRK1,WRK2
  1712. I195=0
  1713. DO 3127 IB=1,NBELEM
  1714. c
  1715. c on cherche les coordonnees des noeuds de l element ib
  1716. c
  1717. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1718. CALL ZERO (REL,LRE,LRE)
  1719. c
  1720. c on cherche les caracteristiques du materiau de l element ib
  1721. c
  1722. MPTVAL=IVAMAT
  1723. DO 8127 IM=1,NMATT
  1724. MELVAL=IVAL(IM)
  1725. IBMN=MIN(IB,VELCHE(/2))
  1726. VALMAT(IM)=VELCHE(1,IBMN)
  1727. 8127 CONTINUE
  1728. B11 =VALMAT(1)
  1729. B22 =VALMAT(2)
  1730. B12 =VALMAT(3)
  1731. RHOF =VALMAT(4)
  1732. RHOS =VALMAT(5)
  1733. C =VALMAT(6)
  1734. RHOREF=VALMAT(7)
  1735. CREF =VALMAT(8)
  1736. RLCAR =VALMAT(9)
  1737. c
  1738. c on cherche les caracteristiques geometriques de l element ib
  1739. c
  1740. MPTVAL=IVACAR
  1741. c
  1742. MELVAL=IVAL(1)
  1743. IBMN=MIN(IB,VELCHE(/2))
  1744. SCEL=VELCHE(1,IBMN)
  1745. c
  1746. MELVAL=IVAL(2)
  1747. IBMN=MIN(IB,VELCHE(/2))
  1748. SFLU=VELCHE(1,IBMN)
  1749. c
  1750. MELVAL=IVAL(3)
  1751. IBMN=MIN(IB,VELCHE(/2))
  1752. EPS =VELCHE(1,IBMN)
  1753. c
  1754. MELVAL=IVAL(4)
  1755. IBMN=MIN(IB,VELCHE(/2))
  1756. SECT =VELCHE(1,IBMN)
  1757. c
  1758. c calcul de la masse m0/eps**2
  1759. c
  1760. RHOSS=RHOS*SECT/(EPS*EPS)
  1761. c
  1762. c calcul des coefficients de normalisation
  1763. c
  1764. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  1765. COEFPI=RHOREF*RLCAR
  1766. c
  1767. c
  1768. VKL12 =-(COEFPR*COEFPI*SFLU)/(RHOF*C*C*SCEL)
  1769. VKL22 =-(COEFPI*COEFPI)/(RHOF*SCEL)
  1770. c
  1771. VKL23 = COEFPI/SCEL
  1772. VKL33 = 1.D0/SCEL
  1773. c
  1774. ISDJC=0
  1775. DO 6127 IGAU1=1,NBPGAU
  1776. POIGA1=MINTE.POIGAU(IGAU1)
  1777. CALL CUBHM1(IGAU1,MELE,NBNO,XE,SHPTOT,SHPWRK,
  1778. # RHOSS,RHOF,B11,B22,B12,SFLU,SCEL,POIGA1,VKL12,VKL22,VKL23,
  1779. # VKL33,LRE,REL,ISDJC,IRRT)
  1780. IF(IRRT.NE.1) GOTO 7127
  1781. 6127 CONTINUE
  1782. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1783. * SEGINI XMATRI
  1784. * IMATTT(IB)=XMATRI
  1785. c
  1786. c remplissage de xmatri
  1787. c
  1788. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1789. * SEGDES XMATRI
  1790. 3127 CONTINUE
  1791. c
  1792. c impression d un eventuel message d erreur
  1793. c
  1794. IF(I195.NE.0) INTERR(1)=I195
  1795. IF(I195.NE.0) CALL ERREUR(195)
  1796. 7127 CONTINUE
  1797. IF(IRRT.EQ.0) THEN
  1798. MOTERR(1:4)=NOMTP(MELE)
  1799. CALL ERREUR(420)
  1800. ELSE
  1801. IF(IRRT.EQ.2) THEN
  1802. INTERR(1) = IB
  1803. CALL ERREUR(405)
  1804. ENDIF
  1805. ENDIF
  1806. IF(IRRT.EQ.3) CALL ERREUR(421)
  1807. IF(IRRT.EQ.4) CALL ERREUR(422)
  1808. SEGDES xMATRI
  1809. SEGSUP WRK1,WRK2,MVELCH
  1810. GOTO 510
  1811. c_______________________________________________________________________
  1812. c
  1813. c secteur de calcul pour les elements homogeneises
  1814. c (liquide solide) trh6
  1815. c_______________________________________________________________________
  1816. c
  1817. 157 CONTINUE
  1818. IF (ILUMP .EQ. 1) GOTO 99
  1819. NBNO=NBNN
  1820. NBBB=NBNN
  1821. SEGINI WRK1,WRK2
  1822. I195=0
  1823. DO 3157 IB=1,NBELEM
  1824. c
  1825. c on cherche les coordonnees des noeuds de l element ib
  1826. c
  1827. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1828. CALL ZERO (REL,LRE,LRE)
  1829. c
  1830. c on cherche les caracteristiques du materiau de l element ib
  1831. c
  1832. MPTVAL=IVAMAT
  1833. DO 8157 IM=1,NMATT
  1834. MELVAL=IVAL(IM)
  1835. IBMN=MIN(IB,VELCHE(/2))
  1836. VALMAT(IM)=VELCHE(1,IBMN)
  1837. 8157 CONTINUE
  1838. B11 =VALMAT(1)
  1839. B22 =VALMAT(2)
  1840. B12 =VALMAT(3)
  1841. RHOF =VALMAT(4)
  1842. RHOS =VALMAT(5)
  1843. C =VALMAT(6)
  1844. RHOREF=VALMAT(7)
  1845. CREF =VALMAT(8)
  1846. RLCAR =VALMAT(9)
  1847. E111 =VALMAT(10)
  1848. E112 =VALMAT(11)
  1849. E121 =VALMAT(12)
  1850. E122 =VALMAT(13)
  1851. E221 =VALMAT(14)
  1852. E222 =VALMAT(15)
  1853. c
  1854. c on cherche les caracteristiques geometriques de l element ib
  1855. c
  1856. MPTVAL=IVACAR
  1857. IF (IFOUR.EQ.0.OR.IFOUR.EQ.1) THEN
  1858. MELVAL=IVAL(1)
  1859. IBMN=MIN(IB,VELCHE(/2))
  1860. SECT=VELCHE(1,IBMN)
  1861. MELVAL=IVAL(2)
  1862. IBMN=MIN(IB,VELCHE(/2))
  1863. SCEL=VELCHE(1,IBMN)
  1864. MELVAL=IVAL(3)
  1865. IBMN=MIN(IB,VELCHE(/2))
  1866. SFLU=VELCHE(1,IBMN)
  1867. MELVAL=IVAL(4)
  1868. IBMN=MIN(IB,VELCHE(/2))
  1869. EPS =VELCHE(1,IBMN)
  1870. ELSE
  1871. SECT=1.D0
  1872. MELVAL=IVAL(1)
  1873. IBMN=MIN(IB,VELCHE(/2))
  1874. SCEL=VELCHE(1,IBMN)
  1875. MELVAL=IVAL(2)
  1876. IBMN=MIN(IB,VELCHE(/2))
  1877. SFLU=VELCHE(1,IBMN)
  1878. MELVAL=IVAL(3)
  1879. IBMN=MIN(IB,VELCHE(/2))
  1880. EPS =VELCHE(1,IBMN)
  1881. MELVAL=IVAL(4)
  1882. IBMN=MIN(IB,VELCHE(/2))
  1883. F11 =VELCHE(1,IBMN)
  1884. MELVAL=IVAL(5)
  1885. IBMN=MIN(IB,VELCHE(/2))
  1886. F12 =VELCHE(1,IBMN)
  1887. ENDIF
  1888. c
  1889. c calcul de la masse m0/eps**2
  1890. c
  1891. RHOSS=RHOS*SECT/(EPS*EPS)
  1892. c
  1893. c calcul des coefficients de normalisation
  1894. c
  1895. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  1896. COEFPI=RHOREF*RLCAR
  1897. VKL12 =-(COEFPR*COEFPI*SFLU)/(RHOF*C*C*SCEL)
  1898. VKL22 =-(COEFPI*COEFPI)/(RHOF*SCEL)
  1899. VKL23 = COEFPI/SCEL
  1900. VKL33 = 1.D0/SCEL
  1901. VKL41 = EPS*EPS/2.D0/SCEL*(COEFPR*COEFPI)
  1902. VKL42 = EPS*EPS/2.D0/SCEL*COEFPI*COEFPI
  1903. VKL43 = EPS*EPS/2.D0/SCEL*COEFPI
  1904. VKL44 = EPS*EPS/2.D0/SCEL
  1905. c
  1906. c boucle sur les points de gauss
  1907. c cas plan
  1908. c
  1909. ISDJC=0
  1910. DO 6157 IGAU1=1,NBPGAU
  1911. POIGA1=MINTE.POIGAU(IGAU1)
  1912. CALL TRIHM31(IGAU1,MELE,NBNO,XE,SHPTOT,SHPWRK
  1913. # ,RHOSS,RHOF,
  1914. # B11,B22,B12,F11,F12,SFLU,SCEL,POIGA1,VKL12,VKL22,
  1915. # VKL23,VKL33,VKL42,VKL43,VKL44,E111,E112,E121,E122,
  1916. # E221,E222,LRE,REL,ISDJC,IRRT)
  1917. IF(IRRT.NE.1) GOTO 7092
  1918. 6157 CONTINUE
  1919. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  1920. * SEGINI XMATRI
  1921. * IMATTT(IB)=XMATRI
  1922. c
  1923. c remplissage de xmatri
  1924. c
  1925. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1926. * SEGDES XMATRI
  1927. 3157 CONTINUE
  1928. c
  1929. c impression d un eventuel message d erreur
  1930. c
  1931. IF(I195.NE.0) INTERR(1)=I195
  1932. IF(I195.NE.0) CALL ERREUR(195)
  1933. 7157 CONTINUE
  1934. IF(IRRT.EQ.0) THEN
  1935. MOTERR(1:4)=NOMTP(MELE)
  1936. CALL ERREUR(420)
  1937. ELSE
  1938. IF(IRRT.EQ.2) THEN
  1939. INTERR(1) = IB
  1940. CALL ERREUR(405)
  1941. ENDIF
  1942. ENDIF
  1943. IF(IRRT.EQ.3) CALL ERREUR(421)
  1944. IF(IRRT.EQ.4) CALL ERREUR(422)
  1945. SEGDES xMATRI
  1946. SEGSUP WRK1,WRK2,MVELCH
  1947. GOTO 510
  1948. c_______________________________________________________________________
  1949. *
  1950. 99 CONTINUE
  1951. MOTERR(1:4)=NOMTP(MELE)
  1952. MOTERR(5:12)='MASSE4'
  1953. CALL ERREUR(86)
  1954. *
  1955. 510 CONTINUE
  1956. if (CMATE.EQ.'STATIQUE') then
  1957. mlmots = iinc
  1958. if (iinc.gt.0) segsup mlmots
  1959. mlmots = idua
  1960. if (idua.gt.0) segsup mlmots
  1961. endif
  1962. RETURN
  1963. END
  1964.  
  1965.  
  1966.  
  1967.  
  1968.  
  1969.  
  1970.  
  1971.  
  1972.  
  1973.  
  1974.  

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