Télécharger kcent2.eso

Retour à la liste

Numérotation des lignes :

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

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