Télécharger amor4.eso

Retour à la liste

Numérotation des lignes :

  1. C AMOR4 SOURCE CB215821 16/04/21 21:15:08 8920
  2. SUBROUTINE AMOR4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,
  3. & IVAMAT,IVACAR,IVECT,CMATE,MFR,ICAS,NBGMAT,NELMAT,
  4. & LHOOK,NMATT,NCARR,ISOUS,LW,IPORE,IPMATR,IIPDPG,IMOD)
  5. *---------------------------------------------------------------------*
  6. * ________________________________________ *
  7. * | | *
  8. * | CALCUL DE L AMORTISSEMENT STRUCTUREL | *
  9. * |_______________________________________| *
  10. * *
  11. * poutre,tuyau,barre
  12. * *
  13. * *
  14. *---------------------------------------------------------------------*
  15. * *
  16. * *
  17. * ENTREES : *
  18. * ________ *
  19. * *
  20. * MATE Numero du materiau *
  21. * MELE Numero de l'element fini *
  22. * IPMAIL Pointeur sur un segment MELEME *
  23. * IPMINT Pointeur sur un segment MINTE *
  24. * NBPGAU Nombre de point d'integration pour la rigidite *
  25. * LRE Nombre de ddl dans la matrice de rigidite *
  26. * NSTRS Nombre de composante de contraintes/deformations *
  27. * IVAMAT Pointeur sur un segment MPTVAL pour le materiau ou *
  28. * pour une matrice de hooke *
  29. * IVACAR Pointeur sur un segment MPTVAL pour les caracteri- *
  30. * stiques *
  31. * IVECT FLAG INDIQUANT SI ON A ENTRE UN VECTEUR LOCAL *
  32. * CMATE Nom du materiau *
  33. * MFR Numero de la formulation element fini *
  34. * NBGMAT Taille maxi des melval du materiau (pt de gauss) *
  35. * NELMAT Taille maxi des melval du materiau (No d'element) *
  36. * NMATT Nombre de composantes de materiau (IMAT=1) *
  37. * NCARR Nombre de caracteristiques geometriques *
  38. * ISOUS NUMERO DE LA SOUS-ZONE *
  39. * LW Dimension du tableau de travail *
  40. * IPORE nombre de fonctions de forme *
  41. * ICAS 1 si amortissement *
  42. * 2 si rigidite antisymetrique *
  43. * *
  44. * *
  45. * SORTIES : *
  46. * ________ *
  47. * *
  48. * IPMATR pointeur sur la rigidite de la sous-zone *
  49. * *
  50. * *
  51. *---------------------------------------------------------------------*
  52. IMPLICIT INTEGER(I-N)
  53. IMPLICIT REAL*8(A-H,O-Z)
  54. *
  55. -INC CCOPTIO
  56. -INC CCHAMP
  57. -INC CCREEL
  58. *-
  59. -INC SMCHAML
  60. -INC SMINTE
  61. -INC SMELEME
  62. -INC SMRIGID
  63. -INC SMMODEL
  64. -INC SMCOORD
  65. -INC SMLREEL
  66. -INC SMLMOTS
  67. *
  68. SEGMENT WRK1
  69. REAL*8 DDHOOK(NSTRS,NSTRS) ,DDHOMU(NSTRS,NSTRS)
  70. REAL*8 REL(LRE,LRE) , XE(3,NBBB)
  71. ENDSEGMENT
  72. *
  73. SEGMENT WRK2
  74. REAL*8 SHPWRK(6,NBNO) ,BGENE(NSTRS,LRE)
  75. ENDSEGMENT
  76. *
  77. SEGMENT WRK3
  78. REAL*8 WORK(LW)
  79. ENDSEGMENT
  80. *
  81. SEGMENT WRK4
  82. REAL*8 BPSS(3,3),XEL(3,NBBB)
  83. ENDSEGMENT
  84. *
  85. SEGMENT WRK5
  86. REAL*8 XGENE(NSTN,LRN)
  87. ENDSEGMENT
  88. *
  89. SEGMENT WRK6
  90. REAL*8 PSS(3,3)
  91. ENDSEGMENT
  92. *
  93. SEGMENT,MVELCH
  94. REAL*8 VALMAT(NV1)
  95. ENDSEGMENT
  96. *
  97. SEGMENT MPTVAL
  98. INTEGER IPOS(NS) ,NSOF(NS)
  99. INTEGER IVAL(NCOSOU)
  100. CHARACTER*16 TYVAL(NCOSOU)
  101. ENDSEGMENT
  102. *
  103. CHARACTER*4 lesinc(7),lesdua(7)
  104. DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/
  105. DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/
  106. *
  107. DIMENSION CRIGI(12),CMASS(12)
  108. CHARACTER*4 CMOT
  109. CHARACTER*8 CMATE
  110. *
  111. MELEME=IPMAIL
  112. NBNN=NUM(/1)
  113. NBELEM=NUM(/2)
  114. *
  115. NV1=NMATT
  116. SEGINI,MVELCH
  117. *
  118. XMATRI=IPMATR
  119. * LVAL = (LRE*(LRE+1))/2
  120. NLIGRP=LRE
  121. NLIGRD=LRE
  122. *
  123. * INTRODUCTION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT
  124. * DE LA SECTION EN DEFO PLANE GENERALISEE
  125. *
  126. * PPJ IF (IFOUR.EQ.-3)THEN
  127. IF (IFOUR.EQ.-3.AND.MFR.NE.35)THEN
  128. IP=IIPDPG
  129. SEGACT MCOORD
  130. IREF=(IP-1)*(IDIM+1)
  131. XDPGE=XCOOR(IREF+1)
  132. YDPGE=XCOOR(IREF+2)
  133. ELSE
  134. XDPGE=0.D0
  135. YDPGE=0.D0
  136. ENDIF
  137. *
  138. NHRM=NIFOUR
  139. *
  140. MINTE=IPMINT
  141. IRTD=1
  142. *
  143. IF (mfr.eq.28) THEN
  144. jgn = 4
  145. if (ifour.eq.2) then
  146. jgm = 6
  147. segini mlmots
  148. iinc = mlmots
  149. do igm = 1,jgm
  150. mots(igm) = lesinc(igm)
  151. enddo
  152. segini mlmots
  153. idua = mlmots
  154. do igm= 1,jgm
  155. mots(igm) = lesdua(igm)
  156. enddo
  157. else if (ifour.lt.0) then
  158. jgm = 4
  159. segini mlmots
  160. iinc = mlmots
  161. mots(1) = lesinc(1)
  162. mots(2) = lesinc(2)
  163. mots(3) = lesinc(4)
  164. mots(4) = lesinc(5)
  165. segini mlmots
  166. idua = mlmots
  167. mots(1) = lesdua(1)
  168. mots(2) = lesdua(2)
  169. mots(3) = lesdua(4)
  170. mots(4) = lesdua(5)
  171. else if (ifour.eq.0) then
  172. jgm = 3
  173. segini mlmots
  174. iinc = mlmots
  175. mots(1) = lesinc(7)
  176. mots(2) = lesinc(3)
  177. mots(3) = lesinc(6)
  178. segini mlmots
  179. idua = mlmots
  180. mots(1) = lesdua(7)
  181. mots(2) = lesdua(3)
  182. mots(3) = lesdua(6)
  183. else if (ifour.eq.1) then
  184. * a faire
  185. endif
  186. ENDIF
  187.  
  188. IMODEL = IMOD
  189. jmat = 0
  190. DO imat = 1 , matmod(/2)
  191. if (matmod(imat).eq.'IMPEDANCE') then
  192. jmat = imat
  193. * goto 29
  194. endif
  195. ENDDO
  196. C
  197. C_______________________________________________________________________
  198. C
  199. C NUMERO DES ETIQUETTES :
  200. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  201. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  202. C 5 CONTINUE
  203. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  204. C 44 CONTINUE
  205. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  206. C_______________________________________________________________________
  207. C
  208.  
  209. * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  210. GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  211. * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  212. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  213. * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6
  214. & , 99, 99, 99, 99, 99, 99, 29, 99, 99, 99, 99
  215. * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  216. & , 99, 99, 99, 99, 99, 99, 99, 99, 29, 99, 99
  217. * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  218. & , 45, 46, 99, 99, 99, 99, 99, 99, 99, 99, 99
  219. * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  220. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  221. * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  222. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  223. * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  224. & , 99, 99, 99, 99, 99, 99, 29, 99, 99, 99, 99
  225. * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3
  226. & , 99, 99, 99, 99, 99, 99, 46, 99, 99, 99, 99
  227. * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  228. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  229. * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  230. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  231. * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  232. & , 99, 46, 124, 99, 99, 99, 99, 99, 99, 99, 99
  233. * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  234. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  235. * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  236. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  237. * TE56 PY91 TRH6
  238. & , 99, 99, 99),MELE
  239. C
  240. C GOTO(168,169,170,171,172),MELE-167
  241. C
  242. GOTO 99
  243. C_______________________________________________________________________
  244. C
  245. C IMPEDANCE
  246. C_______________________________________________________________________
  247. C
  248. 2 CONTINUE
  249. IF (jmat.gt.0) THEN
  250. MPTVAL=IVAMAT
  251. MELVAL=IVAL(1)
  252. if (ival(/1).gt.1) then
  253. melva1 = ival(2)
  254. else
  255. melva1 = 0
  256. endif
  257. jddl = LRE/NBPGAU
  258. DO IB = 1,NBELEM
  259. JDIAG = 0
  260. IBMN=MIN(IB,VELCHE(/2))
  261. do IG = 1, NBPGAU
  262. igmn = MIN(IG,VELCHE(/1))
  263. XAMOR=VELCHE(IGMN,IBMN)
  264. XINAM = XAMOR
  265. if (melva1.gt.0) then
  266. igmn = MIN(IG,melva1.VELCHE(/1))
  267. XINAM = melva1.VELCHE(IGMN,IBMN)
  268. endif
  269. do idl = 1,jddl
  270. JDIAG = JDIAG + 1
  271. RE(JDIAG,JDIAG,ib) = XAMOR
  272. if (idim.eq.3.and.idl.gt.3) RE(JDIAG,JDIAG,ib) = XINAM
  273. if (idim.ne.3.and.idl.gt.2) RE(JDIAG,JDIAG,ib) = XINAM
  274. enddo
  275. enddo
  276. ENDDO
  277. SEGDES XMATRI
  278. GOTO 510
  279. ENDIF
  280. C_______________________________________________________________________
  281. C
  282. C ELEMENTS POUTRE TUYAU ET POUTRE TIMOSCHENKO
  283. C_______________________________________________________________________
  284. C
  285. 29 CONTINUE
  286.  
  287. NBBB=NBNN
  288. SEGINI WRK1,WRK3
  289. C
  290. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  291. C
  292. KERRE=0
  293. DO 3029 IB=1,NBELEM
  294. C
  295. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  296. C
  297. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  298. C
  299. C CAS DE L'ELEMENT LITU OU LA MATRICE DE RIGIDITE EST NULLE
  300. C
  301. IF (MELE.EQ.98) THEN
  302. CALL ZERO(REL,LRE,LRE)
  303. GOTO 8029
  304. ENDIF
  305. C
  306. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  307. C SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION
  308. C
  309. NCARR1=NCARR
  310. IF(IVECT.EQ.1) NCARR1=NCARR-1
  311. CALL ZERO(WORK,NCARR1,1)
  312. DO 4030 IGAU=1,NBNN
  313. MPTVAL=IVACAR
  314. DO 6029 IC=1,NCARR1
  315. IF (IVAL(IC).NE.0) THEN
  316. MELVAL=IVAL(IC)
  317. IBMN=MIN(IB,VELCHE(/2))
  318. IGMN=MIN(IGAU,VELCHE(/1))
  319. WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  320. ELSE
  321. WORK(IC)=0.D0
  322. ENDIF
  323. IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  324. 6029 CONTINUE
  325. 4030 CONTINUE
  326. C
  327. C CAS OU ON A LU LE MOT VECTEUR
  328. C
  329. IF (IVECT.EQ.1) THEN
  330. IF (IVAL(NCARR).NE.0) THEN
  331. MELVAL=IVAL(NCARR)
  332. IBMN=MIN(IB,IELCHE(/2))
  333. IP=IELCHE(1,IBMN)
  334. IREF=(IP-1)*(IDIM+1)
  335. DO 6129 IC=1,IDIM
  336. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  337. 6129 CONTINUE
  338. ELSE
  339. DO 6229 IC=1,IDIM
  340. WORK(NCARR+IC-1)=0.D0
  341. 6229 CONTINUE
  342. ENDIF
  343. ENDIF
  344. C
  345. MPTVAL=IVAMAT
  346. C
  347. C AUTRES CAS ......
  348. C
  349. MELVAL=IVAL(1)
  350. *
  351. IF(CMATE.NE.'SECTION') THEN
  352. IBMN=MIN(IB,VELCHE(/2))
  353. VALMAT(1)=VELCHE(1,IBMN)
  354. YOUNG=VALMAT(1)
  355. C
  356. C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  357. C EQUIVALENTE
  358. IF(MELE.EQ.42) THEN
  359. IF (ICAS.EQ.2) WORK(10)=WORK(9)
  360. WORK(9)=WORK(8)
  361. WORK(8)=WORK(7)
  362. WORK(7)=WORK(6)
  363. EPAIS=WORK(1)
  364. REXT=WORK(2)
  365. RINT=REXT-EPAIS
  366. RACO=WORK(3)
  367. PRES=WORK(4)
  368. CISA=WORK(5)
  369. XIN=XPI*(REXT**4-RINT**4)*0.25D00
  370. WORK(1)=2.D00*XIN
  371. WORK(2)=XIN
  372. WORK(3)=XIN
  373. WORK(4)=XPI*(REXT**2-RINT**2)
  374. WORK(5)=WORK(4)*0.5D0*CISA
  375. WORK(6)=WORK(5)
  376. C
  377. C
  378. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  379. WORK(4)=VALMAT(1)
  380. AUX=VALMAT(2)
  381. WORK(5)=WORK(4)*0.5D0/(1.D0+AUX)
  382. ELSE
  383. C
  384. IF (ICAS.EQ.2) THEN
  385. WORK(11)=VALMAT(1)
  386. WORK(12)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2))
  387. ELSE
  388. WORK(10)=VALMAT(1)
  389. WORK(11)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2))
  390. ENDIF
  391. ENDIF
  392. ENDIF
  393. C
  394. C
  395. DO 9029 IM=1,NMATT
  396. IF (IVAL(IM).NE.0) THEN
  397. MELVAL=IVAL(IM)
  398. IBMN=MIN(IB,VELCHE(/2))
  399. VALMAT(IM)=VELCHE(1,IBMN)
  400. ELSE
  401. VALMAT(IM)=0.D0
  402. ENDIF
  403. C
  404. 9029 CONTINUE
  405. IF(MELE.EQ.84) THEN
  406. C
  407. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  408. CALL DOHTI2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  409. ELSE
  410. CALL DOHTIM(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  411. ENDIF
  412. ELSE
  413. C
  414. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  415. CALL DOHPT2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  416. ELSE
  417. CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  418. ENDIF
  419. ENDIF
  420. C-------------
  421. C PROVISOIRE
  422. C-------------
  423. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  424. WORK(4)=VALMAT(1)
  425. AUX=VALMAT(2)
  426. WORK(5)=WORK(4)*0.5D0/(1.D0+AUX)
  427. ELSE
  428. C
  429. IF (ICAS.EQ.2) THEN
  430. WORK(11)=VALMAT(1)
  431. WORK(12)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2))
  432. ELSE
  433. WORK(10)=VALMAT(1)
  434. WORK(11)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2))
  435. ENDIF
  436. ENDIF
  437. C-------------
  438. C ENDIF
  439. C-------------
  440. *
  441. * CAS DE LA FORMULATION SECTION
  442. *
  443. ELSE
  444. *
  445. * ON REGARDE SI ON A LA COMPOSANTE MAHO
  446. * SI OUI, ON LA PREND
  447. *
  448. C IF(IVAL(3).NE.0) THEN
  449. C MELVAL=IVAL(3)
  450. C IBMN=MIN(IB,IELCHE(/2))
  451. C MLREEL=IELCHE(1,IBMN)
  452. C SEGACT MLREEL
  453. C IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  454. C $ CALL DOHOOO(PROG,LHOOK,DDHOOK)
  455. C SEGDES MLREEL
  456. *
  457. C ELSE
  458. IBMN=MIN(IB,IELCHE(/2))
  459. IPMODL=IELCHE(1,IBMN)
  460. MELVAL=IVAL(2)
  461. IBMN=MIN(IB,IELCHE(/2))
  462. IPMAT=IELCHE(1,IBMN)
  463. CALL FAMORE(IPMODL,IPMAT,CRIGI,CMASS)
  464. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  465. $ CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  466. C ENDIF
  467. ENDIF
  468. C
  469. C
  470. C FIN TRAITEMENT DES DONNEES MATERIAUX
  471. C
  472. IF(MELE.EQ.97) THEN
  473. CALL ACORIG(REL,LRE,WORK,XE,KERRE)
  474. ELSE IF(MELE.EQ.84) THEN
  475. IF (ICAS.EQ.1) THEN
  476. C
  477. C Matrice d amortissement symetrique Timo
  478. C
  479. C
  480. IF(CMATE.NE.'SECTION') THEN
  481. C
  482. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  483. CALL TIMRI2(REL,LRE,WORK,XE,WORK(12),KERRE)
  484. ELSE
  485. CALL TIMRIG(REL,LRE,WORK,XE,WORK(12),KERRE)
  486. ENDIF
  487. *
  488. ELSE
  489. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  490. CALL TIFRI2(REL,LRE,XE,WORK(12),LHOOK,
  491. $ DDHOOK,KERRE)
  492. ELSE
  493. CALL TIFRIG(REL,LRE,WORK,XE,WORK(12),LHOOK,
  494. $ DDHOOK,KERRE)
  495. ENDIF
  496. ENDIF
  497. C
  498. ELSE
  499. C
  500. C Matrice de raideur antisymetrique Timo (seulement en 3D)
  501. C
  502. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  503. KERRE = 1
  504. ELSE
  505. C
  506. IF(CMATE.NE.'SECTION') THEN
  507. CALL TIMDH3(REL,WORK,XE,KERRE)
  508. ELSE
  509. C KERRE = 1
  510. C ENDIF
  511. C
  512. CALL TIFDH3(REL,WORK,XE,LHOOK,DDHOOK,KERRE)
  513. ENDIF
  514. ENDIF
  515. ENDIF
  516. ELSE
  517. C
  518. IF (ICAS.EQ.1) THEN
  519. C
  520. C Matrice d amortissement symetrique Poutre
  521.  
  522. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  523. CALL POURI2(REL,LRE,WORK,XE,WORK(12),KERRE)
  524. ELSE
  525. CALL POURIG(REL,LRE,WORK,XE,WORK(12),KERRE)
  526. ENDIF
  527. ELSE
  528. C
  529. C Matrice de raideur antisymetrique Poutre (seulement en 3D)
  530. C
  531. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  532. KERRE = 1
  533. ELSE
  534. CALL POUDH3(REL,WORK,XE,KERRE)
  535. ENDIF
  536. ENDIF
  537. ENDIF
  538. C
  539. IF(KERRE.NE.0) INTERR(1)=ISOUS
  540. IF(KERRE.NE.0) INTERR(2)=IB
  541. C
  542. 4029 CONTINUE
  543. 8029 CONTINUE
  544. * SEGINI XMATRI
  545. * IMATTT(IB)=XMATRI
  546. C
  547. C REMPLISSAGE DE XMATRI
  548. C
  549. DO 4028 IIIA=1,LRE
  550. DO 4028 IIIB=1,LRE
  551. RE(IIIA,IIIB,IB)=REL(IIIA,IIIB)
  552. 4028 CONTINUE
  553. * SEGDES XMATRI
  554. 3029 CONTINUE
  555. IF(KERRE.EQ.1) CALL ERREUR(128)
  556. IF(KERRE.EQ.2) CALL ERREUR(138)
  557. IF(IRTD.EQ.0) THEN
  558. MOTERR(1:8)=CMATE
  559. MOTERR(9:16)=NOMFR(MFR/2+1)
  560. INTERR(1)=IFOUR
  561. CALL ERREUR(81)
  562. ENDIF
  563. SEGDES XMATRI
  564. SEGSUP WRK1,WRK3,MVELCH
  565. GOTO 510
  566.  
  567. C_______________________________________________________________________
  568. C
  569. C ELEMENT POI1
  570. C_______________________________________________________________________
  571. C
  572. 45 CONTINUE
  573. IF (jmat.gt.0) THEN
  574. MPTVAL=IVAMAT
  575. MELVAL=IVAL(1)
  576. if (ival(/1).gt.1) then
  577. melva1 = ival(2)
  578. else
  579. melva1 = 0
  580. endif
  581. jddl = LRE/NBPGAU
  582. DO IB = 1,NBELEM
  583. JDIAG = 0
  584. if (melval.gt.0) IBMN=MIN(IB,VELCHE(/2))
  585. do IG = 1, NBPGAU
  586. if (melval.gt.0) igmn = MIN(IG,VELCHE(/1))
  587. XAMOR = 0.D0
  588. if (melval.gt.0) XAMOR=VELCHE(IGMN,IBMN)
  589. XINAM = XAMOR
  590. if (melva1.gt.0) then
  591. igmn = MIN(IG,melva1.VELCHE(/1))
  592. XINAM = melva1.VELCHE(IGMN,IBMN)
  593. endif
  594. do idl = 1,jddl
  595. JDIAG = JDIAG + 1
  596. RE(JDIAG,JDIAG,ib) = XAMOR
  597. if (idim.eq.3.and.idl.gt.3) RE(JDIAG,JDIAG,ib) = XINAM
  598. if (idim.ne.3.and.idl.gt.2) RE(JDIAG,JDIAG,ib) = XINAM
  599. enddo
  600. * enddo
  601. enddo
  602. ENDDO
  603. SEGDES XMATRI
  604. GOTO 510
  605. ENDIF
  606.  
  607. IF (MFR.EQ.26) THEN
  608. * MODAL
  609. DO IB = 1,NBELEM
  610. * SEGINI XMATRI
  611. * IMATTT(IB)=XMATRI
  612.  
  613. MPTVAL=IVAMAT
  614. MELVAL=IVAL(1)
  615. IBMN=MIN(IB,VELCHE(/2))
  616. XFREQ=VELCHE(1,IBMN)
  617. MELVAL=IVAL(2)
  618. IBMN=MIN(IB,VELCHE(/2))
  619. XMASS=VELCHE(1,IBMN)
  620. MELVAL=IVAL(4)
  621. if (melval.gt.0) then
  622. IBMN=MIN(IB,VELCHE(/2))
  623. XAMOR=VELCHE(1,IBMN)
  624. else
  625. xamor = 0.
  626. endif
  627. OMEG = 2. * XPI * XFREQ
  628. RE(1,1,IB) = XMASS * OMEG * XAMOR
  629. * SEGDES XMATRI
  630. ENDDO
  631. SEGDES XMATRI
  632. GOTO 510
  633. *
  634. ELSE IF (MFR.EQ.28) THEN
  635. * STATIQUE
  636. DO IB = 1,NBELEM
  637. * SEGINI XMATRI
  638. * IMATTT(IB)=XMATRI
  639.  
  640. MPTVAL=IVAMAT
  641. MELVAL=IVAL(4)
  642. IBMN=MIN(IB,VELCHE(/2))
  643. if (melval.gt.0) then
  644. segact melval
  645. XAMOR=VELCHE(1,IBMN)
  646. else
  647. re(1,1,IB) = 0.d0
  648. endif
  649. if (xamor.ne.0.d0) then
  650. MELVAL=IVAL(1)
  651. IBMN=MIN(IB,IELCHE(/2))
  652. idepl=IELCHE(1,IBMN)
  653. MELVAL=IVAL(2)
  654. IBMN=MIN(IB,IELCHE(/2))
  655. itreac=IELCHE(1,IBMN)
  656. CALL XTY1(idepl,itreac,iinc,idua,XR1)
  657. if (ierr.ne.0) return
  658. MELVAL=IVAL(3)
  659. IBMN=MIN(IB,IELCHE(/2))
  660. imade=IELCHE(1,IBMN)
  661. CALL XTY1(idepl,imade,iinc,idua,XM1)
  662. if (ierr.ne.0) return
  663. x1 = xm1 * xr1
  664. re(1,1,IB) = SQRT(ABS(x1))*xamor
  665. if (x1.lt.0.) re(1,1,IB) = re(1,1,IB) *(-1.d0)
  666. endif
  667. * SEGDES XMATRI
  668. ENDDO
  669. SEGDES XMATRI
  670. GOTO 510
  671. ENDIF
  672. *
  673. C_______________________________________________________________________
  674. C
  675. C ELEMENTS BARRE ET CERCE
  676. C_______________________________________________________________________
  677. C
  678. 46 CONTINUE
  679. *
  680. IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  681. GO TO 99
  682. ENDIF
  683. NBBB=NBNN
  684. SEGINI WRK1,WRK3
  685. IF(MELE.EQ.123) THEN
  686. NSTN=NBNN
  687. LRN =LRE
  688. SEGINI WRK5
  689. ENDIF
  690. C
  691. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  692. C
  693. KERRE=0
  694. DO 3046 IB=1,NBELEM
  695. C
  696. C ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  697. C
  698. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  699. C
  700. C
  701. C ON RECUPERE LA SECTION DE L'ELEMENT
  702. C
  703. MPTVAL=IVACAR
  704. MELVAL=IVAL(1)
  705. IBMN=MIN(IB,VELCHE(/2))
  706. SECT=VELCHE(1,IBMN)
  707. C
  708. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  709. C
  710. MPTVAL=IVAMAT
  711. *
  712. DO 9046 IM=1,NMATT
  713. IF (IVAL(IM).NE.0) THEN
  714. MELVAL=IVAL(IM)
  715. IBMN=MIN(IB ,VELCHE(/2))
  716. VALMAT(IM)=VELCHE(1,IBMN)
  717. ELSE
  718. VALMAT(IM)=0.D0
  719. ENDIF
  720. 9046 CONTINUE
  721. CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  722. C
  723. IF(MELE.EQ.46) CALL BARRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
  724. IF(MELE.EQ.95) CALL CERRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
  725. IF(MELE.EQ.123)CALL BARIG3(REL,LRE,DDHOOK(1,1),XE,XGENE,KERRE,IB)
  726. IF(KERRE.NE.0) INTERR(1)=ISOUS
  727. IF(KERRE.NE.0) INTERR(2)=IB
  728. C
  729. * SEGINI XMATRI
  730. * IMATTT(IB)=XMATRI
  731. C
  732. C REMPLISSAGE DE XMATRI
  733. C
  734. CALL REMPMT(REL,LRE,RE(1,1,IB))
  735. * SEGDES XMATRI
  736. 3046 CONTINUE
  737. IF(MELE.EQ.46.AND.KERRE.EQ.1) CALL ERREUR(128)
  738. IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601)
  739. IF(MELE.EQ.123.AND.KERRE.EQ.1) CALL ERREUR(128)
  740. IF(IRTD.EQ.0) THEN
  741. MOTERR(1:8)=CMATE
  742. MOTERR(9:16)=NOMFR(MFR/2+1)
  743. INTERR(1)=IFOUR
  744. CALL ERREUR(81)
  745. ENDIF
  746. SEGDES XMATRI
  747. SEGSUP WRK1,WRK3,MVELCH
  748. IF(MELE.EQ.123) SEGSUP WRK5
  749. GOTO 510
  750. C
  751. C_______________________________________________________________________
  752. C
  753. C ELEMENT BARRE 3D EXCENTRE (BAEX)
  754. C_______________________________________________________________________
  755. C
  756. 124 CONTINUE
  757. NBBB=NBNN
  758. NBNO=NBNN
  759. NSTRS1=NSTRS
  760. NSTRS=NBNN
  761. SEGINI WRK1,WRK2,WRK3
  762. C
  763. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  764. C
  765. KERRE=0
  766. DO 3108 IB=1,NBELEM
  767. C
  768. C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON
  769. C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK
  770. C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ
  771. C
  772. MPTVAL=IVACAR
  773. DO IC=1,NCARR
  774. IF(IVAL(IC).NE.0) THEN
  775. MELVAL=IVAL(IC)
  776. IBMN=MIN(IB,VELCHE(/2))
  777. WORK(IC)=VELCHE(1,IBMN)
  778. ELSE
  779. WORK(IC)=0.D0
  780. ENDIF
  781. END DO
  782. SECT=WORK(1)
  783. C
  784. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  785. C
  786. MPTVAL=IVAMAT
  787.  
  788. DO 9108 IM=1,NMATT
  789. IF (IVAL(IM).NE.0) THEN
  790. MELVAL=IVAL(IM)
  791. IBMN=MIN(IB ,VELCHE(/2))
  792. VALMAT(IM)=VELCHE(1,IBMN)
  793. ELSE
  794. VALMAT(IM)=0.D0
  795. ENDIF
  796. 9108 CONTINUE
  797. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  798. 1 CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  799. C
  800. C BGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE
  801. C
  802. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  803. CALL MAPAEX(XE,NBNN,WORK,AL,BGENE,LRE,KERRE)
  804. IF(KERRE.NE.0) INTERR(1)=ISOUS
  805. IF(KERRE.NE.0) INTERR(2)=IB
  806. IF(KERRE.EQ.1) CALL ERREUR(128)
  807. CALL RIGBEX(REL,LRE,DDHOOK(1,1),AL,BGENE)
  808. C
  809. * SEGINI XMATRI
  810. * IMATTT(IB)=XMATRI
  811. C
  812. C REMPLISSAGE DE XMATRI
  813. C
  814. CALL REMPMT(REL,LRE,RE(1,1,IB))
  815. * SEGDES XMATRI
  816. 3108 CONTINUE
  817. NSTRS=NSTRS1
  818. SEGDES XMATRI
  819. SEGSUP WRK1,WRK2,WRK3,MVELCH
  820. GOTO 510
  821.  
  822. C
  823. *_______________________________________________________________________
  824. *
  825. 99 CONTINUE
  826. MOTERR(1:4)=NOMTP(MELE)
  827. MOTERR(9:12)='AMOR'
  828. CALL ERREUR(86)
  829. *
  830. 510 CONTINUE
  831. RETURN
  832. END
  833.  
  834.  
  835.  
  836.  
  837.  
  838.  
  839.  
  840.  
  841.  
  842.  
  843.  
  844.  
  845.  
  846.  
  847.  
  848.  
  849.  
  850.  
  851.  
  852.  
  853.  
  854.  
  855.  
  856.  
  857.  
  858.  
  859.  
  860.  
  861.  
  862.  
  863.  
  864.  
  865.  
  866.  
  867.  

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