Télécharger corio2.eso

Retour à la liste

Numérotation des lignes :

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

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