Télécharger corio2.eso

Retour à la liste

Numérotation des lignes :

corio2
  1. C CORIO2 SOURCE BP208322 15/06/22 21:16:44 8543
  2. SUBROUTINE CORIO2(IPMAIL,LRE,LW,MELE,IVAMAT,NMATT,IVACAR,
  3. &NCARR,IVECT,ISOUS,NBPGAU,IPMINT,IPMIN2,NDDL,MATE,CMATE,
  4. &LHOOK,IPMATR,VROT,NUMLIS,IIPDPG)
  5. *---------------------------------------------------------------------*
  6. * _________________________________________________ *
  7. * | | *
  8. * | calcul de la matrice de couplage gyroscopique | *
  9. * | dans le repère tournant | *
  10. * |________________________________________________| *
  11. * *
  12. * barr,poutre,timo,tuyau *
  13. * coq3,dkt,coq4,coq8,dst *
  14. *---------------------------------------------------------------------*
  15. * *
  16. * entrees : *
  17. * ________ *
  18. * *
  19. * ipmail pointeur sur un segment meleme *
  20. * lre nombre de ddl dans la matrice de masse *
  21. * lw dimension du tableau de travail de l'element *
  22. * mele numero de l'element fini *
  23. * ivamat pointeur sur un segment mptval pour le materiau *
  24. * nmatt nombre de composante de materiau (imat=1) *
  25. * ivacar pointeur sur un segment mptval pour les caracteri- *
  26. * stiques *
  27. * ncarr nombre de caracteristiques geometriques *
  28. * ivect flag indiquant si on a entree les axes locaux *
  29. * isous numero de la sous-zone *
  30. * nbpgau nombre de point d'integration pour la masse *
  31. * ipmint pointeur sur un segment minte *
  32. * ipmin1 pointeur sur un segment minte (aux noeuds) *
  33. * nddl nombre de degre de liberte /noeud *
  34. * mate numero du materiau *
  35. * cmate nom du materiau *
  36. * vrot vecteur vitesse de rotation *
  37. * *
  38. * sorties : *
  39. * ________ *
  40. * *
  41. * ipmatr pointeur sur la matrice d'amortissement *
  42. * de la sous-zone *
  43. * *
  44. * Didier COMBESCURE mars 2003 *
  45. *---------------------------------------------------------------------*
  46. IMPLICIT INTEGER(I-N)
  47. IMPLICIT REAL*8(A-H,O-Z)
  48.  
  49. -INC PPARAM
  50. -INC CCOPTIO
  51. -INC CCHAMP
  52. -INC CCREEL
  53. *-
  54. -INC SMRIGID
  55. -INC SMCHAML
  56. -INC SMELEME
  57. -INC SMCOORD
  58. -INC SMINTE
  59. -INC SMMODEL
  60. C
  61. SEGMENT WRK1
  62. REAL*8 REL(LRE,LRE),XE(3,NBBB)
  63. ENDSEGMENT
  64. C
  65. SEGMENT WRK2
  66. REAL*8 SHPWRK(6,NBNO),BGENE(NDDL,LRE)
  67. ENDSEGMENT
  68. C
  69. SEGMENT WRK3
  70. REAL*8 DDHOOK(LHOOK,LHOOK)
  71. REAL*8 WORK(LW)
  72. ENDSEGMENT
  73. C
  74. SEGMENT WRK4
  75. REAL*8 BPSS(3,3),XEL(3,NBBB)
  76. ENDSEGMENT
  77. C
  78. SEGMENT WRK6
  79. REAL*8 RHOMAT(6,6)
  80. ENDSEGMENT
  81.  
  82. SEGMENT WRK7
  83. REAL*8 XJI(3,3),TXR(3,3,NBNO),FINT(3,LRE),XJ(3,3),B(3,3)
  84. REAL*8 TH(NBNO),EXC(NBNO),H(NBNO)
  85. REAL*8 ROME(3,3),REWO(LRE,LRE)
  86. ENDSEGMENT
  87. C
  88. SEGMENT MVELCH
  89. REAL*8 VALMAT(NV1)
  90. ENDSEGMENT
  91. C
  92. SEGMENT MPTVAL
  93. INTEGER IPOS(NS),NSOF(NS)
  94. INTEGER IVAL(NCOSOU)
  95. CHARACTER*16 TYVAL(NCOSOU)
  96. ENDSEGMENT
  97. *
  98. DIMENSION VROT(*)
  99.  
  100. DIMENSION CRIGI(12),CMASS(12),VROTL(3)
  101. CHARACTER*8 CMATE
  102. *
  103. MELEME=IPMAIL
  104. c* SEGACT,IPMAIL
  105. NBNN=NUM(/1)
  106. NBELEM=NUM(/2)
  107. *
  108. NV1=NMATT
  109. SEGINI,MVELCH
  110. *
  111. xMATRI=IPMATR
  112. c* SEGACT,xMATRI*MOD
  113. c* NLIGRP=LRE
  114. c* NLIGRD=LRE
  115. *
  116. NHRM=NIFOUR
  117. *
  118. MINTE =IPMINT
  119. c* SEGACT,MINTE
  120. c
  121. C_______________________________________________________________________
  122. C
  123. C NUMERO DES ETIQUETTES :
  124. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  125. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  126. C 5 CONTINUE
  127. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  128. C 44 CONTINUE
  129. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  130. C_______________________________________________________________________
  131. C
  132. * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  133. GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  134. * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  135. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  136. * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6
  137. & , 99, 99, 99, 99, 93, 93, 21, 99, 99, 99, 99
  138. * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  139. & , 99, 99, 99, 99, 99, 99, 99, 41, 21, 99, 44
  140. * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  141. & , 99, 21, 99, 99, 51, 99, 99, 99, 99, 99, 99
  142. * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  143. & , 41, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  144. * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  145. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  146. * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  147. & , 99, 99, 99, 99, 99, 99, 21, 99, 99, 99, 99
  148. * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3
  149. & , 99, 99, 99, 99, 93, 99, 99, 99, 99, 99, 99
  150. * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  151. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  152. * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  153. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  154. * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  155. & , 99, 21, 99, 99, 99, 99, 99, 99, 99, 99, 99
  156. * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  157. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  158. * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  159. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  160. * TE56 PY91 TRH6
  161. & , 99, 99, 99),MELE
  162. C
  163. C_______________________________________________________________________
  164. C
  165. C ELEMENTS POUTRES
  166. C_______________________________________________________________________
  167. C
  168. 21 CONTINUE
  169. C
  170. C CAS DES POUTRES - TUYAUX
  171. C
  172. NBBB=NBNN
  173. SEGINI WRK1,WRK3
  174. *
  175. * cas du materiau section
  176. *
  177. NBGMAT = 0
  178. NELMAT = 0
  179. IF(CMATE.EQ.'SECTION') THEN
  180. MPTVAL=IVAMAT
  181. DO IM=1,NMATT
  182. IF(IVAL(IM).NE.0)THEN
  183. MELVAL=IVAL(IM)
  184. NBGMAT=MAX(NBGMAT,IELCHE(/1))
  185. NELMAT=MAX(NELMAT,IELCHE(/2))
  186. END IF
  187. END DO
  188. ENDIF
  189. C
  190. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  191. C
  192. DO 2027 IB=1,NBELEM
  193. C
  194. C ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  195. C
  196. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  197. C
  198. C CAS DES POUTRES
  199. C --------------
  200. C ON STOCKE DES CARACTERISTIQUES GEOMETRIQUES ET MATERIELLES DANS WORK
  201. C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB ( GEOMETRIE ET MASSE
  202. C
  203. NCARR1=NCARR
  204. IF(IVECT.EQ.1) NCARR1=NCARR-1
  205.  
  206. MPTVAL=IVACAR
  207.  
  208. DO 2429 IC=1,NCARR1
  209. WORK(IC)=0.D0
  210. IF (IVAL(IC).NE.0) THEN
  211. MELVAL=IVAL(IC)
  212. IBMN=MIN(IB,VELCHE(/2))
  213. DO 2029 IGAU=1,NBNN
  214. IGMN=MIN(IGAU,VELCHE(/1))
  215. WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  216. 2029 CONTINUE
  217. WORK(IC)=WORK(IC)/NBNN
  218. ENDIF
  219. 2429 CONTINUE
  220. C
  221. C CAS OU ON A LU LE MOT VECTEUR
  222. C
  223. IF (IVECT.EQ.1) THEN
  224. IF (IVAL(NCARR).NE.0) THEN
  225. MELVAL=IVAL(NCARR)
  226. IBMN=MIN(IB,IELCHE(/2))
  227. IP=IELCHE(1,IBMN)
  228. IREF=(IP-1)*(IDIM+1)
  229. DO 2129 IC=1,IDIM
  230. WORK(NCARR1+IC)=XCOOR(IREF+IC)
  231. 2129 CONTINUE
  232. ELSE
  233. DO 2229 IC=1,IDIM
  234. WORK(NCARR1+IC)=0.
  235. 2229 CONTINUE
  236. ENDIF
  237. ENDIF
  238. C
  239. MPTVAL=IVAMAT
  240. C
  241. C CAS DES POUTRES ET TUYAU
  242. C
  243. MELVAL=IVAL(1)
  244. IF(CMATE.NE.'SECTION') THEN
  245. IBMN=MIN(IB,VELCHE(/2))
  246. C
  247. IF(MELE.EQ.46) THEN
  248. WORK(2)=VELCHE(1,IBMN)
  249. ELSE
  250. WORK(11)=VELCHE(1,IBMN)
  251. ENDIF
  252. C
  253. C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  254. C -------------- EQUIVALENTE
  255. C
  256. IF(MELE.EQ.42) CALL TUYCAG(WORK,KERRE,1)
  257. ELSE
  258. *
  259. * cas formulation section
  260. *
  261. IBMN=MIN(IB,IELCHE(/2))
  262. IPMODL=IELCHE(1,IBMN)
  263. MELVAL=IVAL(2)
  264. IBMN=MIN(IB,IELCHE(/2))
  265. IPMAT=IELCHE(1,IBMN)
  266. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)THEN
  267. CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS)
  268. CALL DOHTIF(CMASS,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  269. ENDIF
  270. ENDIF
  271. C
  272. C ON CALCULE LA MATRICE DE COUPLAGE GYROSCOPIQUE
  273. C
  274. IF (MELE.EQ.46) THEN
  275. CALL BARCOR(REL,LRE,WORK,XE,VROT,WORK(12),KERRE)
  276. ELSEIF (MELE.EQ.84) THEN
  277. IF(CMATE.NE.'SECTION') THEN
  278. CALL POUCOR(REL,LRE,WORK,XE,VROT,WORK(12),KERRE)
  279. ELSE
  280. CALL TIFCOR(REL,LRE,WORK,XE,VROT,WORK(12),LHOOK,
  281. & DDHOOK,KERRE)
  282. ENDIF
  283. ELSE
  284. CALL POUCOR(REL,LRE,WORK,XE,VROT,WORK(12),KERRE)
  285. ENDIF
  286. C
  287. IF (KERRE.NE.0) THEN
  288. INTERR(1)=ISOUS
  289. INTERR(2)=IB
  290. CALL ERREUR(128)
  291. GOTO 9027
  292. ENDIF
  293.  
  294. DO 2128 IIIA=1,LRE
  295. DO 2128 IIIB=1,LRE
  296. RE(IIIA,IIIB,ib)=REL(IIIA,IIIB)
  297. 2128 CONTINUE
  298. *
  299. 2027 CONTINUE
  300.  
  301. 9027 CONTINUE
  302. SEGSUP,WRK1,WRK3
  303. GOTO 510
  304.  
  305. C_______________________________________________________________________
  306. C
  307. C SECTEUR DE CALCUL POUR LES ELEMENTS DST, DKT ET COQ3
  308. C ADAPTE DE LA MATRICE DE MASSE DES ELEMENTS DST
  309. C CAR PROBLEME AVEC DKT ET COQ3
  310. C_______________________________________________________________________
  311. C
  312. 93 CONTINUE
  313. NBNO=NBNN
  314. NBBB=NBNN
  315. SEGINI WRK1,WRK2,WRK4,WRK6
  316. C
  317. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  318. C
  319. DO 9300 IB=1,NBELEM
  320. C
  321. C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  322. C
  323. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  324. CALL ZERO (REL,LRE,LRE)
  325. CALL VPAST(XE,BPSS)
  326. CALL VCORLC(XE,XEL,BPSS)
  327. C
  328. MPTVAL=IVACAR
  329. C
  330. C ACQUISITION DES EPAISSEURS
  331. C
  332. EP=0.D0
  333. MELVAL=IVAL(1)
  334. IF (MELVAL.NE.0) THEN
  335. DO IGAU=1,NBPGAU
  336. IGMN=MIN(IGAU,VELCHE(/1))
  337. IBMN=MIN(IB ,VELCHE(/2))
  338. EP=EP+VELCHE(IGMN,IBMN)
  339. ENDDO
  340. EP=EP/NBPGAU
  341. ENDIF
  342. C
  343. EXCEN=0.D0
  344. MELVAL=IVAL(2)
  345. IF (MELVAL.NE.0) THEN
  346. DO IGAU=1,NBPGAU
  347. IGMN=MIN(IGAU,VELCHE(/1))
  348. IBMN=MIN(IB ,VELCHE(/2))
  349. EXCEN=EXCEN+VELCHE(IGMN,IBMN)
  350. ENDDO
  351. EXCEN=EXCEN/NBPGAU
  352. ENDIF
  353. C
  354. C BOULE SUR LES POINTS DE GAUSS
  355. C
  356. DO 9310 IGAU=1,NBPGAU
  357. C
  358. MPTVAL=IVAMAT
  359. MELVAL=IVAL(1)
  360. IBMN=MIN(IB,VELCHE(/2))
  361. IGMN=MIN(IGAU,VELCHE(/1))
  362. RHO=VELCHE(IGMN,IBMN)
  363. C
  364. CALL ZERO(RHOMAT,6,6)
  365. C
  366. VROTL(1)= BPSS(1,1)*VROT(1)+BPSS(1,2)*VROT(2)
  367. . +BPSS(1,3)*VROT(3)
  368. VROTL(2)= BPSS(2,1)*VROT(1)+BPSS(2,2)*VROT(2)
  369. . +BPSS(2,3)*VROT(3)
  370. VROTL(3)= BPSS(3,1)*VROT(1)+BPSS(3,2)*VROT(2)
  371. . +BPSS(3,3)*VROT(3)
  372. C
  373. RHOMAT( 1, 2)=(-1.D0)*RHO*EP*VROTL(3)
  374. RHOMAT( 1, 3)=RHO*EP*VROTL(2)
  375. RHOMAT( 2, 1)=(-1.D0)*RHOMAT( 1, 2)
  376. RHOMAT( 2, 3)=(-1.D0)*RHO*EP*VROTL(1)
  377. RHOMAT( 3, 1)=(-1.D0)*RHOMAT( 1, 3)
  378. RHOMAT( 3, 2)=(-1.D0)*RHOMAT( 2, 3)
  379. C
  380. RHOMAT( 1, 4)=RHO*EP*EXCEN*VROTL(3)
  381. RHOMAT( 2, 5)=RHO*EP*EXCEN*VROTL(3)
  382. RHOMAT( 3, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(1)
  383. RHOMAT( 3, 5)=(-1.D0)*RHO*EP*EXCEN*VROTL(2)
  384. C
  385. RHOMAT( 4, 1)=(-1.D0)*RHOMAT( 1, 4)
  386. RHOMAT( 5, 2)=(-1.D0)*RHOMAT( 2, 5)
  387. RHOMAT( 4, 3)=(-1.D0)*RHOMAT( 3, 4)
  388. RHOMAT( 5, 3)=(-1.D0)*RHOMAT( 3, 5)
  389. C
  390. CALL NDST(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC)
  391. DJAC=DJAC*POIGAU(IGAU)
  392. CALL BDBSTA(BGENE,DJAC,RHOMAT,LRE,6,REL)
  393. 9310 CONTINUE
  394. C
  395. ICOM = 0
  396. IF(ABS(EXCEN).GT.XPETIT.OR. MATE.EQ.4) ICOM=1
  397. CALL TRANSG(REL,BPSS,18,3,ICOM)
  398. C
  399. C REMPLISSAGE
  400. C
  401. DO 9311 I2=1,LRE
  402. DO 9311 I1=1,LRE
  403. RE(I1,I2,ib) = REL(I1,I2)
  404. 9311 CONTINUE
  405. C
  406. 9300 CONTINUE
  407. SEGSUP WRK1,WRK2,WRK4,WRK6
  408. GOTO 510
  409. C_______________________________________________________________________
  410. C
  411. C ELEMENT COQ6 COQ8
  412. C_______________________________________________________________________
  413. C
  414. 41 CONTINUE
  415. NBBB=NBNN
  416. NBNO = NBNN
  417. SEGINI WRK1,WRK7
  418.  
  419. c Debut du remplissage WRK7
  420. ROME(1,1) = 0.D0
  421. ROME(1,2) = (-1.)*VROT(3)
  422. ROME(1,3) = VROT(2)
  423. ROME(2,1) = VROT(3)
  424. ROME(2,2) = 0.D0
  425. ROME(2,3) = (-1.)*VROT(1)
  426. ROME(3,1) = (-1.)*VROT(2)
  427. ROME(3,2) = VROT(1)
  428. ROME(3,3) = 0.D0
  429.  
  430. MINTE2=IPMIN2
  431. SEGACT,MINTE2
  432. C
  433. DO 4041 IB=1,NBELEM
  434. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  435.  
  436. MPTVAL=IVAMAT
  437. MELVAL=IVAL(1)
  438. IBMN=MIN(IB,VELCHE(/2))
  439. VALMAT(1)=VELCHE(1,IBMN)
  440. RHO = VALMAT(1)
  441. C
  442. C CALCUL DE L'EPAISSEUR ET DE L'EXCENTREMENT (MOYENS)
  443. C
  444. MPTVAL=IVACAR
  445. MELVAL=IVAL(1)
  446. IBMN=MIN(IB,VELCHE(/2))
  447. C
  448. EPAI = 0.D0
  449. IF (IVAL(1).NE.0) THEN
  450. MELVAL=IVAL(1)
  451. IBMN=MIN(IB ,VELCHE(/2))
  452. DO IGAU=1,NBPGAU
  453. IGMN=MIN(IGAU,VELCHE(/1))
  454. EPAI = EPAI + VELCHE(IGMN,IBMN)
  455. ENDDO
  456. EPAI = EPAI / NBPGAU
  457. ENDIF
  458. EXENT = 0.D0
  459. IF (IVAL(2).NE.0) THEN
  460. MELVAL=IVAL(2)
  461. IBMN=MIN(IB ,VELCHE(/2))
  462. DO IGAU=1,NBPGAU
  463. IGMN=MIN(IGAU,VELCHE(/1))
  464. EXENT = EXENT + VELCHE(IGMN,IBMN)
  465. ENDDO
  466. EXENT = EXENT / NBPGAU
  467. ENDIF
  468. C
  469. DO igau = 1, NBNO
  470. TH(igau) = EPAI
  471. EXC(igau) = EXENT
  472. ENDDO
  473. C
  474. CALL COQ8GY(NBNN,RHO,NBPGAU,WRK1,MINTE,MINTE2,WRK7)
  475. C
  476. DO 4128 IIIB=1,LRE
  477. DO 4128 IIIA=1,LRE
  478. RE(IIIA,IIIB,ib)=REL(IIIA,IIIB)
  479. 4128 CONTINUE
  480.  
  481. 4041 CONTINUE
  482.  
  483. SEGSUP,WRK1,WRK7
  484. SEGDES,MINTE2
  485.  
  486. GOTO 510
  487. C_______________________________________________________________________
  488. C
  489. C SECTEUR DE CALCUL POUR LES COQ2
  490. C_______________________________________________________________________
  491. C+DC: d apres la matrice de massse
  492. 44 CONTINUE
  493. NBNO=NBNN
  494. NBBB=NBNN
  495. SEGINI WRK1
  496.  
  497. XDPGE = 0.D0
  498. YDPGE = 0.D0
  499. C
  500. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  501. C
  502. DO 3044 IB=1,NBELEM
  503. C
  504. C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  505. C
  506. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  507. CALL ZERO (REL,LRE,LRE)
  508. C
  509. MPTVAL=IVACAR
  510. MELVAL=IVAL(1)
  511. IBMN=MIN(IB,VELCHE(/2))
  512. EP=VELCHE(1,IBMN)
  513. C
  514. MPTVAL=IVAMAT
  515. DO 4044 IM=1,NMATT
  516. MELVAL=IVAL(IM)
  517. IBMN=MIN(IB,VELCHE(/2))
  518. VALMAT(IM)=VELCHE(1,IBMN)
  519. 4044 CONTINUE
  520. RHO=VALMAT(1)
  521. C
  522. C APPEL A LA SUBROUTINE CALCULANT LA MATRICE DE CORIOLIS
  523. C
  524. IF (NUMLIS.EQ.1) THEN
  525. C Cas d'une matrice utilsé en calcul harmonique (symétrique)
  526. CALL COQ2CH(XE,EP,RHO,1,IFOUR,NIFOUR,LRE,REL,IARR,
  527. + XDPGE,YDPGE,VROT)
  528. ELSE
  529. C Cas de la matrice utilisé en temporel (antisymétrique)
  530. CALL COQ2CO(XE,EP,RHO,1,IFOUR,NIFOUR,LRE,REL,IARR,
  531. + XDPGE,YDPGE,VROT)
  532. ENDIF
  533. C
  534. C GESTION D'ERREUR
  535. C
  536. IF(IARR.NE.0) THEN
  537. INTERR(1)=IB
  538. IF(IARR.EQ.1) CALL ERREUR(195)
  539. IF(IARR.EQ.2) CALL ERREUR(259)
  540. GOTO 9044
  541. ENDIF
  542. C
  543. C REMPLISSAGE
  544. C
  545. DO 3043 I2=1,LRE
  546. DO 3043 I1=1,LRE
  547. RE(I1,I2,ib) = REL(I1,I2)
  548. 3043 CONTINUE
  549. C
  550. 3044 CONTINUE
  551. C
  552. 9044 CONTINUE
  553. SEGSUP,WRK1
  554. GOTO 510
  555.  
  556. C_______________________________________________________________________
  557. C
  558. C SECTEUR DE CALCUL POUR LES COQ4
  559. C_______________________________________________________________________
  560. C
  561. 51 CONTINUE
  562. NBNO=NBNN
  563. NBBB=NBNN
  564. SEGINI WRK1,WRK2,WRK4,WRK6
  565. C
  566. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  567. C
  568. DO 5149 IB=1,NBELEM
  569. c
  570. C
  571. C ON CHERCHE LES COORDONNEES DE L'ELEMENT IB
  572. C
  573. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  574. CALL ZERO (REL,LRE,LRE)
  575. C REPERE LOCAL DU COQ4 ON NE DEMANDE PAS DE VERIFIER LA PLANéITé
  576. CALL CQ4LOC(XE,XEL,BPSS,IERT,0)
  577. C
  578. MPTVAL=IVACAR
  579. MELVAL=IVAL(1)
  580. IBMN=MIN(IB,VELCHE(/2))
  581. EP=VELCHE(1,IBMN)
  582. IF (IVAL(2).NE.0) THEN
  583. MELVAL=IVAL(2)
  584. IBMN=MIN(IB,VELCHE(/2))
  585. EXCEN =VELCHE(1,IBMN)
  586. ELSE
  587. EXCEN=0.D0
  588. ENDIF
  589. C
  590. MPTVAL=IVAMAT
  591. MELVAL=IVAL(1)
  592. IBMN=MIN(IB,VELCHE(/2))
  593. VALMAT(1)=VELCHE(1,IBMN)
  594. RHO=VALMAT(1)
  595. C
  596. CALL ZERO(RHOMAT,6,6)
  597. C
  598. VROTL(1)= BPSS(1,1)*VROT(1)+BPSS(1,2)*VROT(2)
  599. . +BPSS(1,3)*VROT(3)
  600. VROTL(2)= BPSS(2,1)*VROT(1)+BPSS(2,2)*VROT(2)
  601. . +BPSS(2,3)*VROT(3)
  602. VROTL(3)= BPSS(3,1)*VROT(1)+BPSS(3,2)*VROT(2)
  603. . +BPSS(3,3)*VROT(3)
  604. C
  605. RHOMAT( 1, 2)=(-1.D0)*RHO*EP*VROTL(3)
  606. RHOMAT( 1, 3)=RHO*EP*VROTL(2)
  607. RHOMAT( 2, 1)=(-1.D0)*RHOMAT( 1, 2)
  608. RHOMAT( 2, 3)=(-1.D0)*RHO*EP*VROTL(1)
  609. RHOMAT( 3, 1)=(-1.D0)*RHOMAT( 1, 3)
  610. RHOMAT( 3, 2)=(-1.D0)*RHOMAT( 2, 3)
  611. C
  612. RHOMAT( 1, 4)=RHO*EP*EXCEN*VROTL(3)
  613. RHOMAT( 2, 5)=RHO*EP*EXCEN*VROTL(3)
  614. RHOMAT( 3, 4)=(-1.D0)*RHO*EP*EXCEN*VROTL(1)
  615. RHOMAT( 3, 5)=(-1.D0)*RHO*EP*EXCEN*VROTL(2)
  616. C
  617. RHOMAT( 4, 1)=(-1.D0)*RHOMAT( 1, 4)
  618. RHOMAT( 5, 2)=(-1.D0)*RHOMAT( 2, 5)
  619. RHOMAT( 4, 3)=(-1.D0)*RHOMAT( 3, 4)
  620. RHOMAT( 5, 3)=(-1.D0)*RHOMAT( 3, 5)
  621. C
  622. NBPGAM=NBPGAU-1
  623. DO 5049 IGAU=1,NBPGAM
  624. CALL NCOQ4(IGAU,XEL,SHPTOT,SHPWRK,BGENE,DJAC,IERT)
  625. C IERT=1 JACOBIANO=<0
  626. IF (IERT.EQ.1) THEN
  627. INTERR(1)=IB
  628. CALL ERREUR(321)
  629. GOTO 9051
  630. ENDIF
  631. C
  632. DJAC=DJAC*POIGAU(IGAU)
  633. CALL BDBSTA(BGENE,DJAC,RHOMAT,LRE,6,REL)
  634. 5049 CONTINUE
  635. C
  636. C PASSAGE EN COORDONNéES GLOBALES
  637. C
  638. CALL TRANSG(REL,BPSS,24,4,0)
  639. C
  640. C REMPLISSAGE ET ON BOULEVERSE LA MATRICE DE COUPLAGE
  641. C
  642. DO 5050 I1=1,LRE
  643. DO 5050 I2=1,LRE
  644. RE(I1,I2,ib) = REL(I1,I2)
  645. 5050 CONTINUE
  646.  
  647. 5149 CONTINUE
  648. C
  649. 9051 CONTINUE
  650. SEGSUP WRK1,WRK2,WRK4,WRK6
  651. GOTO 510
  652. C_______________________________________________________________________
  653. C
  654. 99 CONTINUE
  655. MOTERR(1:4)=NOMTP(MELE)
  656. MOTERR(5:12)='CORI'
  657. CALL ERREUR(86)
  658. *
  659. 510 CONTINUE
  660. SEGSUP,MVELCH
  661.  
  662. RETURN
  663. END
  664.  
  665.  
  666.  
  667.  

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