Télécharger amor4.eso

Retour à la liste

Numérotation des lignes :

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

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