Télécharger kcent2.eso

Retour à la liste

Numérotation des lignes :

kcent2
  1. C KCENT2 SOURCE BP208322 20/03/11 21:15:11 10550
  2. SUBROUTINE KCENT2(IPMAIL,LRE,LW,MELE,IVAMAT,NMATT,IVACAR,
  3. &NCARR,IVECT,ISOUS,NBPGAU,IPMINT,IPMIN2,NDDL,MATE,CMATE,
  4. &LHOOK,IPMATR,VROT,IIPDPG)
  5. *---------------------------------------------------------------------*
  6. * _________________________________________________ *
  7. * | | *
  8. * | calcul de la matrice de raideur centrifuge | *
  9. * |________________________________________________| *
  10. * *
  11. * barr,poutre,timo,tuyau,dkt,coq4,coq8,coq2,dst,cerc *
  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. * iprota vecteur vitesse de rotation *
  36. * *
  37. * sorties : *
  38. * ________ *
  39. * *
  40. * ipmatr pointeur sur la matrice de raideur *
  41. * de la sous-zone *
  42. * *
  43. * Didier COMBESCURE mars 2003 *
  44. *---------------------------------------------------------------------*
  45. IMPLICIT INTEGER(I-N)
  46. IMPLICIT REAL*8(A-H,O-Z)
  47.  
  48. -INC PPARAM
  49. -INC CCOPTIO
  50. -INC CCHAMP
  51. -INC CCREEL
  52. *-
  53. -INC SMRIGID
  54. -INC SMCHAML
  55. -INC SMELEME
  56. -INC SMCOORD
  57. -INC SMINTE
  58. -INC SMMODEL
  59. C
  60. SEGMENT WRK1
  61. REAL*8 REL(LRE,LRE),XE(3,NBBB)
  62. ENDSEGMENT
  63. C
  64. SEGMENT WRK2
  65. REAL*8 SHPWRK(6,NBNO),BGENE(NDDL,LRE)
  66. ENDSEGMENT
  67. C
  68. SEGMENT WRK3
  69. REAL*8 DDHOOK(LHOOK,LHOOK)
  70. REAL*8 WORK(LW)
  71. ENDSEGMENT
  72. C
  73. SEGMENT WRK4
  74. REAL*8 BPSS(3,3),XEL(3,NBBB)
  75. ENDSEGMENT
  76. C
  77. SEGMENT WRK6
  78. REAL*8 RHOMAT(6,6)
  79. ENDSEGMENT
  80. C
  81. SEGMENT MVELCH
  82. REAL*8 VALMAT(NV1)
  83. ENDSEGMENT
  84. C
  85. SEGMENT MPTVAL
  86. INTEGER IPOS(NS),NSOF(NS)
  87. INTEGER IVAL(NCOSOU)
  88. CHARACTER*16 TYVAL(NCOSOU)
  89. ENDSEGMENT
  90. *
  91. cbp,2020 DIMENSION CRIGI(12),CMASS(12),VROT(3),ROMEB(6,6),VROTL(3)
  92. REAL*8 CRIGI(12),CMASS(12),VROT(3),VROTL(3)
  93. CHARACTER*8 CMATE
  94. *
  95. MELEME=IPMAIL
  96. NBNN=NUM(/1)
  97. NBELEM=NUM(/2)
  98. *
  99. NV1=NMATT
  100. SEGINI,MVELCH
  101. *
  102. xMATRI=IPMATR
  103. LVAL = (LRE*(LRE+1))/2
  104. NLIGRP=LRE
  105. NLIGRD=LRE
  106. *
  107. NHRM=NIFOUR
  108. *
  109. MINTE=IPMINT
  110. MINTE2=IPMIN2
  111. C
  112. cbp,2020: ci-dessous, pas utilise, pourtant bonne idee a priori
  113. c car sorti de la boucle sur les elements
  114. c DO 10 IM=1,6
  115. c DO 11 IN=1,6
  116. c ROMEB(IN,IM) = 0.D0
  117. c 11 CONTINUE
  118. c 10 CONTINUE
  119. c C
  120. c ROMEB(1,1) = (-1.)*((VROT(2)**2) + (VROT(3)**2))
  121. c ROMEB(2,2) = (-1.)*((VROT(1)**2) + (VROT(3)**2))
  122. c ROMEB(3,3) = (-1.)*((VROT(1)**2) + (VROT(2)**2))
  123. c ROMEB(1,2) = VROT(1)*VROT(2)
  124. c ROMEB(1,3) = VROT(1)*VROT(3)
  125. c ROMEB(2,3) = VROT(2)*VROT(3)
  126. c ROMEB(2,1) = ROMEB(1,2)
  127. c ROMEB(3,1) = ROMEB(1,3)
  128. c ROMEB(3,2) = ROMEB(2,3)
  129.  
  130. C_______________________________________________________________________
  131. C
  132. C NUMERO DES ETIQUETTES :
  133. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  134. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  135. C 5 CONTINUE
  136. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  137. C 44 CONTINUE
  138. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  139. C_______________________________________________________________________
  140. C
  141. * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  142. GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  143. * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  144. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  145. * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6
  146. & , 99, 99, 99, 99, 93, 93, 21, 99, 99, 99, 99
  147. * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  148. & , 99, 99, 99, 99, 99, 99, 99, 41, 21, 99, 44
  149. * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  150. & , 99, 21, 99, 99, 51, 99, 99, 99, 99, 99, 99
  151. * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  152. & , 41, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  153. * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  154. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  155. * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  156. & , 99, 99, 99, 99, 99, 99, 21, 99, 99, 99, 99
  157. * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3
  158. & , 99, 99, 99, 99, 93, 99, 21, 99, 99, 99, 99
  159. * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  160. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  161. * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  162. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  163. * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  164. & , 99, 21, 99, 99, 99, 99, 99, 99, 99, 99, 99
  165. * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  166. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  167. * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  168. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  169. * TE56 PY91 TRH6
  170. & , 99, 99, 99),MELE
  171. C GOTO(99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  172. C 1 27,99,99,99,99,99,27,99,27,99,99,99,99,99,99,99,99,99,99,99,
  173. C 2 99,27,99,99,99,27,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  174. C 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  175. C 4 99,99,99,27,99,99,99,99,99,99,99,99,99,99,99,99,99),MELE
  176. GOTO 99
  177. C_______________________________________________________________________
  178. C_______________________________________________________________________
  179. C
  180. C ELEMENTS POUTRES et BARRES
  181. C_______________________________________________________________________
  182. C
  183. 21 CONTINUE
  184. C
  185. C CAS DES POUTRES - TUYAUX
  186. C
  187. NBBB=NBNN
  188. SEGINI WRK1,WRK3
  189. *
  190. * cas du materiau section
  191. *
  192. NBGMAT = 0
  193. NELMAT = 0
  194. IF(CMATE.EQ.'SECTION') THEN
  195. MPTVAL=IVAMAT
  196. DO IM=1,NMATT
  197. IF(IVAL(IM).NE.0)THEN
  198. MELVAL=IVAL(IM)
  199. NBGMAT=MAX(NBGMAT,IELCHE(/1))
  200. NELMAT=MAX(NELMAT,IELCHE(/2))
  201. END IF
  202. END DO
  203. ENDIF
  204. C
  205. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  206. C
  207. DO 2027 IB=1,NBELEM
  208. C
  209. C ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  210. C
  211. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  212. C
  213. C ON STOCKE DES CARACTERISTIQUES GEOMETRIQUES ET MATERIELLES DANS WORK
  214. C
  215. C
  216. C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB ( GEOMETRIE ET MASSE
  217. C
  218. C
  219. NCARR1=NCARR
  220. IF(IVECT.EQ.1) NCARR1=NCARR-1
  221. CALL ZERO(WORK,NCARR1,1)
  222. DO 2129 IGAU=1,NBNN
  223. MPTVAL=IVACAR
  224. DO 2229 IC=1,NCARR1
  225. MELVAL=IVAL(IC)
  226. IF (IVAL(IC).NE.0) THEN
  227. IBMN=MIN(IB,VELCHE(/2))
  228. IGMN=MIN(IGAU,VELCHE(/1))
  229. WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  230. ELSE
  231. WORK(IC)=0.D0
  232. ENDIF
  233. IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  234. 2229 CONTINUE
  235. 2129 CONTINUE
  236. C
  237. C CAS OU ON A LU LE MOT VECTEUR
  238. C
  239. IF (IVECT.EQ.1) THEN
  240. IF (IVAL(NCARR).NE.0) THEN
  241. MELVAL=IVAL(NCARR)
  242. IBMN=MIN(IB,IELCHE(/2))
  243. IP=IELCHE(1,IBMN)
  244. IREF=(IP-1)*(IDIM+1)
  245. DO 2329 IC=1,IDIM
  246. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  247. 2329 CONTINUE
  248. ELSE
  249. DO 2429 IC=1,IDIM
  250. WORK(NCARR+IC-1)=0.
  251. 2429 CONTINUE
  252. ENDIF
  253. ENDIF
  254. C
  255. MPTVAL=IVAMAT
  256. MELVAL=IVAL(1)
  257. C
  258. C
  259. 2529 CONTINUE
  260. C
  261. C CAS DES POUTRES ET TUYAU
  262. C
  263. IF(CMATE.NE.'SECTION') THEN
  264. IBMN=MIN(IB,VELCHE(/2))
  265. C
  266. IF((MELE.EQ.46).OR.(MELE.EQ.95)) THEN
  267. WORK(2)=VELCHE(1,IBMN)
  268. ELSE
  269. WORK(11)=VELCHE(1,IBMN)
  270. ENDIF
  271. C
  272. C
  273. C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  274. C -------------- EQUIVALENTE
  275. C
  276. IF(MELE.EQ.42) CALL TUYCAG(WORK,KERRE,1)
  277. ELSE
  278. *
  279. * cas formulation section
  280. *
  281. IBMN=MIN(IB,IELCHE(/2))
  282. IPMODL=IELCHE(1,IBMN)
  283. MELVAL=IVAL(2)
  284. IBMN=MIN(IB,IELCHE(/2))
  285. IPMAT=IELCHE(1,IBMN)
  286. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)THEN
  287. CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS)
  288. CALL DOHTIF(CMASS,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  289. ENDIF
  290. ENDIF
  291. C
  292. 2000 CONTINUE
  293. C**************************************************
  294. C ON CALCULE LA MATRICE DE RAIDEUR CENTRIFUGE
  295. C**************************************************
  296. IF (MELE.EQ.46) THEN
  297. C
  298. C Cas de la barre
  299. C
  300. CALL BARKCE(REL,LRE,WORK,XE,VROT,WORK(12),KERRE)
  301. ELSEIF (MELE.EQ.95) THEN
  302. C
  303. C Cas de CERC
  304. C
  305. CALL CERKCE(REL,LRE,WORK,XE,VROT,KERRE)
  306. ELSEIF (MELE.EQ.84) THEN
  307. C
  308. C Cas du Timo
  309. C
  310. IF(CMATE.NE.'SECTION') THEN
  311. CALL TIMKCE(REL,LRE,WORK,XE,VROT,WORK(12),KERRE)
  312. ELSE
  313. CALL TIFKCE(REL,LRE,WORK,XE,VROT,WORK(12),LHOOK,
  314. & DDHOOK,KERRE)
  315. ENDIF
  316. ELSEIF ((MELE.EQ.29).OR.(MELE.EQ.42)) THEN
  317. C
  318. C Cas de la poutre
  319. C
  320. CALL POUKCE(REL,LRE,WORK,XE,VROT,WORK(12),KERRE)
  321. C
  322. ENDIF
  323. C
  324. IF(KERRE.EQ.0) GO TO 2127
  325. INTERR(1)=ISOUS
  326. INTERR(2)=IB
  327. SEGSUP WRK1,WRK3,MVELCH
  328. CALL ERREUR(128)
  329. SEGSUP xMATRI
  330. GO TO 510
  331. C
  332. c
  333. c remplissage de xmatri
  334. c
  335. 2127 CONTINUE
  336. * SEGINI XMATRI
  337. * IMATTT(IB)=XMATRI
  338. CALL REMPMT(REL,LRE,RE(1,1,ib))
  339. * SEGDES XMATRI
  340. 2027 CONTINUE
  341. SEGDES xMATRI
  342. SEGSUP WRK1,WRK3,MVELCH
  343. GO TO 510
  344. C_______________________________________________________________________
  345. C
  346. C SECTEUR DE CALCUL POUR LES COQ2
  347. C_______________________________________________________________________
  348. C
  349. 44 CONTINUE
  350. DIM3=1.D0
  351. NBNO=NBNN
  352. NBBB=NBNN
  353. SEGINI WRK1,WRK3
  354. I255=0
  355. I256=0
  356. C
  357. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  358. C
  359. DO 3044 IB=1,NBELEM
  360. C
  361. C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  362. C
  363. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  364. C
  365. MPTVAL=IVACAR
  366. MELVAL=IVAL(1)
  367. IBMN=MIN(IB,VELCHE(/2))
  368. EP=VELCHE(1,IBMN)
  369. IF(IFOUR.EQ.-2) THEN
  370. MELVAL=IVAL(3)
  371. IF(MELVAL.NE.0) THEN
  372. IBMN=MIN(IB,VELCHE(/2))
  373. DIM3=VELCHE(1,IBMN)
  374. ELSE
  375. DIM3=1.D0
  376. ENDIF
  377. ENDIF
  378. C
  379. MPTVAL=IVAMAT
  380. DO 4044 IM=1,NMATT
  381. MELVAL=IVAL(IM)
  382. IBMN=MIN(IB,VELCHE(/2))
  383. VALMAT(IM)=VELCHE(1,IBMN)
  384. 4044 CONTINUE
  385. RHO=VALMAT(1)
  386. C
  387. C APPEL A LA SUBROUTINE CALCULANT LA MATRICE KC
  388. C
  389. CALL COQ2KC(XE,EP,DIM3,RHO,1,IFOUR,NIFOUR,LRE,REL,IARR,
  390. + XDPGE,YDPGE,VROT)
  391. C
  392. C GESTION D'ERREUR
  393. C
  394. IF(IARR.EQ.1) I255=IB
  395. IF(IARR.EQ.2) I256=IB
  396. C
  397. C REMPLISSAGE
  398. C
  399. C
  400. * SEGINI XMATRI
  401. * IMATTT(IB)=XMATRI
  402. CALL REMPMT(REL,LRE,RE(1,1,ib))
  403. * SEGDES XMATRI
  404. 3044 CONTINUE
  405. C
  406. C IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR...
  407. C
  408. IF(I255.NE.0) THEN
  409. INTERR(1)=I255
  410. CALL ERREUR(255)
  411. ENDIF
  412. IF(I256.NE.0) THEN
  413. INTERR(1)=I256
  414. CALL ERREUR(256)
  415. ENDIF
  416. C
  417. SEGDES xMATRI
  418. SEGSUP WRK1,WRK3,MVELCH
  419. GOTO 510
  420. C_______________________________________________________________________
  421. C
  422. C SECTEUR DE CALCUL POUR LES ELEMENTS DST, DKT ET COQ3
  423. C ADAPTE DE LA MATRICE DE MASSE DES ELEMENTS DST
  424. C CAR PROBLEME AVEC DKT ET COQ3
  425. C_______________________________________________________________________
  426. C
  427. 93 CONTINUE
  428. NBNO=NBNN
  429. NBBB=NBNN
  430. SEGINI WRK1,WRK2,WRK4,WRK6
  431. C
  432. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  433. C
  434. DO 9300 IB=1,NBELEM
  435. C
  436. C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  437. C
  438. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  439. CALL ZERO (REL,LRE,LRE)
  440. CALL VPAST(XE,BPSS)
  441. CALL VCORLC(XE,XEL,BPSS)
  442. C
  443. C ACQUISITION DES EPAISSEURS
  444. C
  445. EP=0.D0
  446. EXCEN=0.D0
  447. MPTVAL=IVACAR
  448. MELVAL=IVAL(1)
  449. IF (MELVAL.NE.0) THEN
  450. DO IGAU=1,NBPGAU
  451. IGMN=MIN(IGAU,VELCHE(/1))
  452. IBMN=MIN(IB ,VELCHE(/2))
  453. EP=EP+VELCHE(IGMN,IBMN)
  454. ENDDO
  455. ENDIF
  456. C
  457. MELVAL=IVAL(2)
  458. IF (MELVAL.NE.0) THEN
  459. DO IGAU=1,NBPGAU
  460. IGMN=MIN(IGAU,VELCHE(/1))
  461. IBMN=MIN(IB ,VELCHE(/2))
  462. EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  463. ENDDO
  464. ENDIF
  465. EP=EP/NBPGAU
  466. EXCEN=EXCEN/NBPGAU
  467. C
  468. C BOULE SUR LES POINTS DE GAUSS
  469. C
  470. DO 9310 IGAU=1,NBPGAU
  471. C
  472. MPTVAL=IVAMAT
  473. MELVAL=IVAL(1)
  474. IBMN=MIN(IB,VELCHE(/2))
  475. IGMN=MIN(IGAU,VELCHE(/1))
  476. RHO=VELCHE(IGMN,IBMN)
  477. C
  478. C CALCUL MATRICE MASSE
  479. C
  480. CALL ZERO(RHOMAT,6,6)
  481. C
  482. VROTL(1)= BPSS(1,1)*VROT(1)+BPSS(1,2)*VROT(2)
  483. . +BPSS(1,3)*VROT(3)
  484. VROTL(2)= BPSS(2,1)*VROT(1)+BPSS(2,2)*VROT(2)
  485. . +BPSS(2,3)*VROT(3)
  486. VROTL(3)= BPSS(3,1)*VROT(1)+BPSS(3,2)*VROT(2)
  487. . +BPSS(3,3)*VROT(3)
  488. C
  489. RHOMAT( 1, 1)=RHO*EP*(-1.)*((VROTL(2)**2) + (VROTL(3)**2))
  490. RHOMAT( 1, 2)=RHO*EP*VROTL(1)*VROTL(2)
  491. RHOMAT( 1, 3)=RHO*EP*VROTL(1)*VROTL(3)
  492. RHOMAT( 2, 1)=RHOMAT( 1, 2)
  493. RHOMAT( 2, 2)=RHO*EP*(-1.)*((VROTL(1)**2) + (VROTL(3)**2))
  494. RHOMAT( 2, 3)=RHO*EP*VROTL(2)*VROTL(3)
  495. RHOMAT( 3, 1)=RHO*EP*RHOMAT( 1, 3)
  496. RHOMAT( 3, 2)=RHO*EP*RHOMAT( 2, 3)
  497. RHOMAT( 3, 3)=RHO*EP*(-1.)*((VROTL(1)**2) + (VROTL(2)**2))
  498. C
  499. RHOMAT( 1, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(1)*VROTL(3)
  500. RHOMAT( 1, 5)=(-1.D0)*RHO*EP*EXCEN*(VROTL(2)**2+VROTL(3)**2)
  501. RHOMAT( 2, 4)=RHO*EP*EXCEN*(VROTL(1)**2+VROTL(3)**2)
  502. RHOMAT( 2, 5)=RHO*EP*EXCEN*VROTL(1)*VROTL(2)
  503. RHOMAT( 3, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(2)*VROTL(3)
  504. RHOMAT( 3, 5)=RHO*EP*EXCEN*VROTL(1)*VROTL(3)
  505. C
  506. RHOMAT( 4, 1)=RHOMAT( 1, 4)
  507. RHOMAT( 5, 1)=RHOMAT( 1, 5)
  508. RHOMAT( 4, 2)=RHOMAT( 2, 4)
  509. RHOMAT( 5, 2)=RHOMAT( 2, 5)
  510. RHOMAT( 4, 3)=RHOMAT( 3, 4)
  511. RHOMAT( 5, 3)=RHOMAT( 3, 5)
  512. C
  513. CALL NDST(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC)
  514. DJAC=DJAC*POIGAU(IGAU)
  515. CALL BDBST(BGENE,DJAC,RHOMAT,LRE,6,REL)
  516. 9310 CONTINUE
  517. C
  518. C
  519. C
  520. ICOM = 0
  521. IF(ABS(EXCEN).GT.XPETIT.OR. MATE.EQ.4)
  522. & ICOM=1
  523. CALL TRANSK(REL,BPSS,18,3,ICOM)
  524. C
  525. C REMPLISSAGE
  526. C
  527. * SEGINI XMATRI
  528. * IMATTT(IB)=XMATRI
  529. CALL REMPMT(REL,LRE,RE(1,1,ib))
  530. C
  531. * SEGDES XMATRI
  532. 9300 CONTINUE
  533. SEGDES xMATRI
  534. SEGSUP WRK1,WRK2,WRK4,WRK6,MVELCH
  535. GOTO 510
  536. C_______________________________________________________________________
  537. C
  538. C ELEMENT COQ6 COQ8
  539. C_______________________________________________________________________
  540. C
  541. 41 CONTINUE
  542. NBBB=NBNN
  543. SEGINI WRK1,WRK3
  544. C
  545. DO 4041 IB=1,NBELEM
  546. c coordonnees XE
  547. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  548.  
  549. cbp,2020 : COQ8KC attend des valeurs constantes par element (probablement
  550. c car le support du materiau n'est pas forcement celui de la masse)
  551. c ==> on prend la moyenne (et pas seulement le 1er point de Gauss!)
  552. c WORK n'est pas utilise ==> on ne le remplit pas !
  553. c
  554. C MASSE VOLUMIQUE
  555. MPTVAL=IVAMAT
  556. MELVAL=IVAL(1)
  557. NGAU=VELCHE(/1)
  558. IBMN=MIN(IB,VELCHE(/2))
  559. IF(NGAU.EQ.1) THEN
  560. RHO=VELCHE(1,IBMN)
  561. ELSE
  562. RHO=0.D0
  563. DO IGAU=1,NGAU
  564. RHO=RHO+VELCHE(IGAU,IBMN)
  565. ENDDO
  566. RHO=RHO/NGAU
  567. ENDIF
  568. c VALMAT(1)=RHO
  569. C
  570. C EPAISSEUR ET EXCENREMENT
  571. MPTVAL=IVACAR
  572. IF (IVAL(1).NE.0) THEN
  573. MELVAL=IVAL(1)
  574. c DO IGAU=1,NBPGAU
  575. c IGMN=MIN(IGAU,VELCHE(/1))
  576. c IBMN=MIN(IB ,VELCHE(/2))
  577. c WORK(IGAU)=VELCHE(IGMN,IBMN)
  578. c ENDDO
  579. c RR=VALMAT(1)*VELCHE(1,IBMN)
  580. NGAU=VELCHE(/1)
  581. IF(NGAU.EQ.1) THEN
  582. EPAI=VELCHE(1,IBMN)
  583. ELSE
  584. EPAI=0.D0
  585. DO IGAU=1,NGAU
  586. EPAI=EPAI+VELCHE(IGAU,IBMN)
  587. ENDDO
  588. EPAI=EPAI/NGAU
  589. ENDIF
  590. ELSE
  591. c on ne devrait pas passer par la
  592. c WORK(IGAU)=0
  593. CALL ERREUR(5)
  594. ENDIF
  595. IF (IVAL(2).NE.0) THEN
  596. MELVAL=IVAL(2)
  597. c DO IGAU=1,NBPGAU
  598. c IGMN=MIN(IGAU,VELCHE(/1))
  599. c IBMN=MIN(IB ,VELCHE(/2))
  600. c WORK(IGAU+10)=VELCHE(IGMN,IBMN)
  601. c ENDDO
  602. NGAU=VELCHE(/1)
  603. IF(NGAU.EQ.1) THEN
  604. EXENT=VELCHE(1,IBMN)
  605. ELSE
  606. EXENT=0.D0
  607. DO IGAU=1,NGAU
  608. EXENT=EXENT+VELCHE(IGAU,IBMN)
  609. ENDDO
  610. EXENT=EXENT/NGAU
  611. ENDIF
  612. ELSE
  613. c WORK(IGAU+10)=0
  614. EXENT=0.D0
  615. ENDIF
  616. C
  617. c RHO=VALMAT(1)
  618. c EPAI = WORK(1)
  619. c EXENT= WORK(11)
  620. cnewparadigm SEGDES WRK1,WRK3
  621. cnewparadigm SEGDES MINTE
  622. CALL COQ8KC(NBNN,RHO,NBPGAU,EPAI,EXENT,WRK1,
  623. . MINTE,MINTE2,VROT)
  624. cnewparadigm SEGACT WRK1,WRK3*MOD
  625. cnewparadigm SEGACT MINTE
  626. * SEGINI XMATRI
  627. * IMATTT(IB)=XMATRI
  628. CALL REMPMT(REL,LRE,RE(1,1,ib))
  629. * SEGDES XMATRI
  630. 4041 CONTINUE
  631. SEGDES xMATRI
  632. SEGSUP WRK1,WRK3,MVELCH
  633. GOTO 510
  634. C_______________________________________________________________________
  635. C
  636. C SECTEUR DE CALCUL POUR LES COQ4
  637. C_______________________________________________________________________
  638. C
  639. 51 CONTINUE
  640. NBNO=NBNN
  641. NBBB=NBNN
  642. SEGINI WRK1,WRK2,WRK4,WRK6
  643. IG1=0
  644. IG2=0
  645. IG3=0
  646. C
  647. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  648. C
  649. DO 5149 IB=1,NBELEM
  650. c
  651. C
  652. C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  653. C
  654. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  655. CALL ZERO (REL,LRE,LRE)
  656. C REPERE LOCAL DU COQ4 ON NE DEMANDE PAS DE VERIFIER LA PLANéITé
  657. CALL CQ4LOC(XE,XEL,BPSS,IERT,0)
  658. C
  659. MPTVAL=IVACAR
  660. MELVAL=IVAL(1)
  661. IBMN=MIN(IB,VELCHE(/2))
  662. EP=VELCHE(1,IBMN)
  663. IF (IVAL(2).NE.0) THEN
  664. MELVAL=IVAL(2)
  665. IBMN=MIN(IB,VELCHE(/2))
  666. EXCEN =VELCHE(1,IBMN)
  667. ELSE
  668. EXCEN=0.D0
  669. ENDIF
  670. C
  671. MPTVAL=IVAMAT
  672. MELVAL=IVAL(1)
  673. IBMN=MIN(IB,VELCHE(/2))
  674. VALMAT(1)=VELCHE(1,IBMN)
  675. RHO=VALMAT(1)
  676. C
  677. C
  678. CALL ZERO(RHOMAT,6,6)
  679. C
  680. VROTL(1)= BPSS(1,1)*VROT(1)+BPSS(1,2)*VROT(2)
  681. . +BPSS(1,3)*VROT(3)
  682. VROTL(2)= BPSS(2,1)*VROT(1)+BPSS(2,2)*VROT(2)
  683. . +BPSS(2,3)*VROT(3)
  684. VROTL(3)= BPSS(3,1)*VROT(1)+BPSS(3,2)*VROT(2)
  685. . +BPSS(3,3)*VROT(3)
  686. C
  687. RHOMAT( 1, 1)=RHO*EP*(-1.)*((VROTL(2)**2) + (VROTL(3)**2))
  688. RHOMAT( 1, 2)=RHO*EP*VROTL(1)*VROTL(2)
  689. RHOMAT( 1, 3)=RHO*EP*VROTL(1)*VROTL(3)
  690. RHOMAT( 2, 1)=RHOMAT( 1, 2)
  691. RHOMAT( 2, 2)=RHO*EP*(-1.)*((VROTL(1)**2) + (VROTL(3)**2))
  692. RHOMAT( 2, 3)=RHO*EP*VROTL(2)*VROTL(3)
  693. RHOMAT( 3, 1)=RHOMAT( 1, 3)
  694. RHOMAT( 3, 2)=RHOMAT( 2, 3)
  695. RHOMAT( 3, 3)=RHO*EP*(-1.)*((VROTL(1)**2) + (VROTL(2)**2))
  696. C
  697. RHOMAT( 1, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(1)*VROTL(3)
  698. RHOMAT( 1, 5)=(-1.D0)*RHO*EP*EXCEN*(VROTL(2)**2+VROTL(3)**2)
  699. RHOMAT( 2, 4)=RHO*EP*EXCEN*(VROTL(1)**2+VROTL(3)**2)
  700. RHOMAT( 2, 5)=RHO*EP*EXCEN*VROTL(1)*VROTL(2)
  701. RHOMAT( 3, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(2)*VROTL(3)
  702. RHOMAT( 3, 5)=RHO*EP*EXCEN*VROTL(1)*VROTL(3)
  703. C
  704. RHOMAT( 4, 1)=RHOMAT( 1, 4)
  705. RHOMAT( 5, 1)=RHOMAT( 1, 5)
  706. RHOMAT( 4, 2)=RHOMAT( 2, 4)
  707. RHOMAT( 5, 2)=RHOMAT( 2, 5)
  708. RHOMAT( 4, 3)=RHOMAT( 3, 4)
  709. RHOMAT( 5, 3)=RHOMAT( 3, 5)
  710. C
  711. NBPGAM=NBPGAU-1
  712. DO 5049 IGAU=1,NBPGAM
  713. CALL NCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,IERT)
  714. C IERT=1 JACOBIANO=<0
  715. IF(IERT.EQ.1) IG3=IB
  716. DJAC=DJAC*POIGAU(IGAU)
  717. CALL BDBST(BGENE,DJAC,RHOMAT,LRE,6,REL)
  718. 5049 CONTINUE
  719. C
  720. C PASSAGE EN COORDONNéES GLOBALES
  721. C
  722. CALL TRANSK(REL,BPSS,24,4,0)
  723. C
  724. C REMPLISSAGE
  725. C
  726. * SEGINI XMATRI
  727. * IMATTT(IB)=XMATRI
  728. CALL REMPMT(REL,LRE,RE(1,1,ib))
  729. * SEGDES XMATRI
  730. 5149 CONTINUE
  731. C
  732. C IMPRESSION D'UN EVENTUEL MESSAGE D'ERREUR...
  733. C
  734. IF(IG1.NE.0) THEN
  735. INTERR(1)=IG1
  736. CALL ERREUR(323)
  737. ENDIF
  738. IF(IG2.NE.0) THEN
  739. INTERR(1)=IG2
  740. CALL ERREUR(322)
  741. ENDIF
  742. IF(IG3.NE.0) THEN
  743. INTERR(1)=IG3
  744. CALL ERREUR(321)
  745. ENDIF
  746. C
  747. SEGDES xMATRI
  748. SEGSUP WRK1,WRK2,WRK4,WRK6,MVELCH
  749. GOTO 510
  750. C_______________________________________________________________________
  751. *
  752. 99 CONTINUE
  753. MOTERR(1:4)=NOMTP(MELE)
  754. MOTERR(5:12)='KCEN'
  755. CALL ERREUR(86)
  756. *
  757. 510 CONTINUE
  758. RETURN
  759. END
  760. C
  761.  
  762.  
  763.  
  764.  
  765.  
  766.  
  767.  
  768.  

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