Télécharger amor4.eso

Retour à la liste

Numérotation des lignes :

  1. C AMOR4 SOURCE PV 20/03/27 21:15:02 10564
  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. MELEME=IPMAIL
  114. NBNN=NUM(/1)
  115. NBELEM=NUM(/2)
  116. *
  117. NV1=NMATT
  118. SEGINI,MVELCH
  119. *
  120. XMATRI=IPMATR
  121. * LVAL = (LRE*(LRE+1))/2
  122. NLIGRP=LRE
  123. NLIGRD=LRE
  124. *
  125. * INTRODUCTION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT
  126. * DE LA SECTION EN DEFO PLANE GENERALISEE
  127. *
  128. * PPJ IF (IFOUR.EQ.-3)THEN
  129. IF (IFOUR.EQ.-3.AND.MFR.NE.35)THEN
  130. IP=IIPDPG
  131. SEGACT MCOORD
  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. DO 3029 IB=1,NBELEM
  295. C
  296. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  297. C
  298. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  299. C
  300. C CAS DE L'ELEMENT LITU OU LA MATRICE DE RIGIDITE EST NULLE
  301. C
  302. IF (MELE.EQ.98) THEN
  303. CALL ZERO(REL,LRE,LRE)
  304. GOTO 8029
  305. ENDIF
  306. C
  307. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  308. C SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION
  309. C
  310. NCARR1=NCARR
  311. IF(IVECT.EQ.1) NCARR1=NCARR-1
  312. CALL ZERO(WORK,NCARR1,1)
  313. DO 4030 IGAU=1,NBNN
  314. MPTVAL=IVACAR
  315. DO 6029 IC=1,NCARR1
  316. IF (IVAL(IC).NE.0) THEN
  317. MELVAL=IVAL(IC)
  318. IBMN=MIN(IB,VELCHE(/2))
  319. IGMN=MIN(IGAU,VELCHE(/1))
  320. WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  321. ELSE
  322. WORK(IC)=0.D0
  323. ENDIF
  324. IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  325. 6029 CONTINUE
  326. 4030 CONTINUE
  327. C
  328. C CAS OU ON A LU LE MOT VECTEUR
  329. C
  330. IF (IVECT.EQ.1) THEN
  331. IF (IVAL(NCARR).NE.0) THEN
  332. MELVAL=IVAL(NCARR)
  333. IBMN=MIN(IB,IELCHE(/2))
  334. IP=IELCHE(1,IBMN)
  335. IREF=(IP-1)*(IDIM+1)
  336. DO 6129 IC=1,IDIM
  337. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  338. 6129 CONTINUE
  339. ELSE
  340. DO 6229 IC=1,IDIM
  341. WORK(NCARR+IC-1)=0.D0
  342. 6229 CONTINUE
  343. ENDIF
  344. ENDIF
  345. C
  346. MPTVAL=IVAMAT
  347. C
  348. C AUTRES CAS ......
  349. C
  350. MELVAL=IVAL(1)
  351. *
  352. IF(CMATE.NE.'SECTION') THEN
  353. IBMN=MIN(IB,VELCHE(/2))
  354. VALMAT(1)=VELCHE(1,IBMN)
  355. YOUNG=VALMAT(1)
  356. C
  357. C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  358. C EQUIVALENTE
  359. IF(MELE.EQ.42) THEN
  360. IF (ICAS.EQ.2) WORK(10)=WORK(9)
  361. WORK(9)=WORK(8)
  362. WORK(8)=WORK(7)
  363. WORK(7)=WORK(6)
  364. EPAIS=WORK(1)
  365. REXT=WORK(2)
  366. RINT=REXT-EPAIS
  367. RACO=WORK(3)
  368. PRES=WORK(4)
  369. CISA=WORK(5)
  370. XIN=XPI*(REXT**4-RINT**4)*0.25D00
  371. WORK(1)=2.D00*XIN
  372. WORK(2)=XIN
  373. WORK(3)=XIN
  374. WORK(4)=XPI*(REXT**2-RINT**2)
  375. WORK(5)=WORK(4)*0.5D0*CISA
  376. WORK(6)=WORK(5)
  377. C
  378. C
  379. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  380. WORK(4)=VALMAT(1)
  381. AUX=VALMAT(2)
  382. WORK(5)=WORK(4)*0.5D0/(1.D0+AUX)
  383. ELSE
  384. C
  385. IF (ICAS.EQ.2) THEN
  386. WORK(11)=VALMAT(1)
  387. WORK(12)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2))
  388. ELSE
  389. WORK(10)=VALMAT(1)
  390. WORK(11)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2))
  391. ENDIF
  392. ENDIF
  393. ENDIF
  394. C
  395. C
  396. DO 9029 IM=1,NMATT
  397. IF (IVAL(IM).NE.0) THEN
  398. MELVAL=IVAL(IM)
  399. IBMN=MIN(IB,VELCHE(/2))
  400. VALMAT(IM)=VELCHE(1,IBMN)
  401. ELSE
  402. VALMAT(IM)=0.D0
  403. ENDIF
  404. C
  405. 9029 CONTINUE
  406. IF(MELE.EQ.84) THEN
  407. C
  408. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  409. CALL DOHTI2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  410. ELSE
  411. CALL DOHTIM(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  412. ENDIF
  413. ELSE
  414. C
  415. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  416. CALL DOHPT2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  417. ELSE
  418. CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  419. ENDIF
  420. ENDIF
  421. C-------------
  422. C PROVISOIRE
  423. C-------------
  424. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  425. WORK(4)=VALMAT(1)
  426. AUX=VALMAT(2)
  427. WORK(5)=WORK(4)*0.5D0/(1.D0+AUX)
  428. ELSE
  429. C
  430. IF (ICAS.EQ.2) THEN
  431. WORK(11)=VALMAT(1)
  432. WORK(12)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2))
  433. ELSE
  434. WORK(10)=VALMAT(1)
  435. WORK(11)=VALMAT(1)*(0.5D0)/((1.D0) + VALMAT(2))
  436. ENDIF
  437. ENDIF
  438. C-------------
  439. C ENDIF
  440. C-------------
  441. *
  442. * CAS DE LA FORMULATION SECTION
  443. *
  444. ELSE
  445. *
  446. * ON REGARDE SI ON A LA COMPOSANTE MAHO
  447. * SI OUI, ON LA PREND
  448. *
  449. C IF(IVAL(3).NE.0) THEN
  450. C MELVAL=IVAL(3)
  451. C IBMN=MIN(IB,IELCHE(/2))
  452. C MLREEL=IELCHE(1,IBMN)
  453. C SEGACT MLREEL
  454. C IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  455. C $ CALL DOHOOO(PROG,LHOOK,DDHOOK)
  456. C SEGDES MLREEL
  457. *
  458. C ELSE
  459. IBMN=MIN(IB,IELCHE(/2))
  460. IPMODL=IELCHE(1,IBMN)
  461. MELVAL=IVAL(2)
  462. IBMN=MIN(IB,IELCHE(/2))
  463. IPMAT=IELCHE(1,IBMN)
  464. CALL FAMORE(IPMODL,IPMAT,CRIGI,CMASS)
  465. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  466. $ CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  467. C ENDIF
  468. ENDIF
  469. C
  470. C
  471. C FIN TRAITEMENT DES DONNEES MATERIAUX
  472. C
  473. IF(MELE.EQ.97) THEN
  474. CALL ACORIG(REL,LRE,WORK,XE,KERRE)
  475. ELSE IF(MELE.EQ.84) THEN
  476. IF (ICAS.EQ.1) THEN
  477. C
  478. C Matrice d amortissement symetrique Timo
  479. C
  480. C
  481. IF(CMATE.NE.'SECTION') THEN
  482. C
  483. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  484. CALL TIMRI2(REL,LRE,WORK,XE,WORK(12),KERRE)
  485. ELSE
  486. CALL TIMRIG(REL,LRE,WORK,XE,WORK(12),KERRE)
  487. ENDIF
  488. *
  489. ELSE
  490. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  491. CALL TIFRI2(REL,LRE,XE,WORK(12),LHOOK,
  492. $ DDHOOK,KERRE)
  493. ELSE
  494. CALL TIFRIG(REL,LRE,WORK,XE,WORK(12),LHOOK,
  495. $ DDHOOK,KERRE)
  496. ENDIF
  497. ENDIF
  498. C
  499. ELSE
  500. C
  501. C Matrice de raideur antisymetrique Timo (seulement en 3D)
  502. C
  503. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  504. KERRE = 1
  505. ELSE
  506. C
  507. IF(CMATE.NE.'SECTION') THEN
  508. CALL TIMDH3(REL,WORK,XE,KERRE)
  509. ELSE
  510. C KERRE = 1
  511. C ENDIF
  512. C
  513. CALL TIFDH3(REL,WORK,XE,LHOOK,DDHOOK,KERRE)
  514. ENDIF
  515. ENDIF
  516. ENDIF
  517. ELSE
  518. C
  519. IF (ICAS.EQ.1) THEN
  520. C
  521. C Matrice d amortissement symetrique Poutre
  522.  
  523. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  524. CALL POURI2(REL,LRE,WORK,XE,WORK(12),KERRE)
  525. ELSE
  526. CALL POURIG(REL,LRE,WORK,XE,WORK(12),KERRE)
  527. ENDIF
  528. ELSE
  529. C
  530. C Matrice de raideur antisymetrique Poutre (seulement en 3D)
  531. C
  532. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  533. KERRE = 1
  534. ELSE
  535. CALL POUDH3(REL,WORK,XE,KERRE)
  536. ENDIF
  537. ENDIF
  538. ENDIF
  539. C
  540. IF(KERRE.NE.0) INTERR(1)=ISOUS
  541. IF(KERRE.NE.0) INTERR(2)=IB
  542. C
  543. 4029 CONTINUE
  544. 8029 CONTINUE
  545. * SEGINI XMATRI
  546. * IMATTT(IB)=XMATRI
  547. C
  548. C REMPLISSAGE DE XMATRI
  549. C
  550. DO 4028 IIIA=1,LRE
  551. DO 4028 IIIB=1,LRE
  552. RE(IIIA,IIIB,IB)=REL(IIIA,IIIB)
  553. 4028 CONTINUE
  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. SEGSUP WRK1,WRK3,MVELCH
  564. GOTO 510
  565.  
  566. C_______________________________________________________________________
  567. C
  568. C ELEMENT POI1
  569. C_______________________________________________________________________
  570. C
  571. 45 CONTINUE
  572. IF (jmat.gt.0) THEN
  573. MPTVAL=IVAMAT
  574. MELVAL=IVAL(1)
  575. if (ival(/1).gt.1) then
  576. melva1 = ival(2)
  577. else
  578. melva1 = 0
  579. endif
  580. jddl = LRE/NBPGAU
  581. DO IB = 1,NBELEM
  582. JDIAG = 0
  583. if (melval.gt.0) IBMN=MIN(IB,VELCHE(/2))
  584. do IG = 1, NBPGAU
  585. if (melval.gt.0) igmn = MIN(IG,VELCHE(/1))
  586. XAMOR = 0.D0
  587. if (melval.gt.0) XAMOR=VELCHE(IGMN,IBMN)
  588. XINAM = XAMOR
  589. if (melva1.gt.0) then
  590. igmn = MIN(IG,melva1.VELCHE(/1))
  591. XINAM = melva1.VELCHE(IGMN,IBMN)
  592. endif
  593. do idl = 1,jddl
  594. JDIAG = JDIAG + 1
  595. RE(JDIAG,JDIAG,ib) = XAMOR
  596. if (idim.eq.3.and.idl.gt.3) RE(JDIAG,JDIAG,ib) = XINAM
  597. if (idim.ne.3.and.idl.gt.2) RE(JDIAG,JDIAG,ib) = XINAM
  598. enddo
  599. * enddo
  600. enddo
  601. ENDDO
  602. GOTO 510
  603. ENDIF
  604.  
  605. IF (MFR.EQ.26) THEN
  606. * MODAL
  607. DO IB = 1,NBELEM
  608. * SEGINI XMATRI
  609. * IMATTT(IB)=XMATRI
  610.  
  611. MPTVAL=IVAMAT
  612. MELVAL=IVAL(1)
  613. IBMN=MIN(IB,VELCHE(/2))
  614. XFREQ=VELCHE(1,IBMN)
  615. MELVAL=IVAL(2)
  616. IBMN=MIN(IB,VELCHE(/2))
  617. XMASS=VELCHE(1,IBMN)
  618. MELVAL=IVAL(4)
  619. if (melval.gt.0) then
  620. IBMN=MIN(IB,VELCHE(/2))
  621. XAMOR=VELCHE(1,IBMN)
  622. else
  623. xamor = 0.
  624. endif
  625. OMEG = 2. * XPI * XFREQ
  626. RE(1,1,IB) = XMASS * OMEG * XAMOR
  627. ENDDO
  628. GOTO 510
  629. *
  630. ELSE IF (MFR.EQ.28) THEN
  631. * STATIQUE
  632. DO IB = 1,NBELEM
  633. * SEGINI XMATRI
  634. * IMATTT(IB)=XMATRI
  635.  
  636. MPTVAL=IVAMAT
  637. MELVAL=IVAL(4)
  638. IBMN=MIN(IB,VELCHE(/2))
  639. if (melval.gt.0) then
  640. segact melval
  641. XAMOR=VELCHE(1,IBMN)
  642. else
  643. re(1,1,IB) = 0.d0
  644. endif
  645. if (xamor.ne.0.d0) then
  646. MELVAL=IVAL(1)
  647. IBMN=MIN(IB,IELCHE(/2))
  648. idepl=IELCHE(1,IBMN)
  649. MELVAL=IVAL(2)
  650. IBMN=MIN(IB,IELCHE(/2))
  651. itreac=IELCHE(1,IBMN)
  652. CALL XTY1(idepl,itreac,iinc,idua,XR1)
  653. if (ierr.ne.0) return
  654. MELVAL=IVAL(3)
  655. IBMN=MIN(IB,IELCHE(/2))
  656. imade=IELCHE(1,IBMN)
  657. CALL XTY1(idepl,imade,iinc,idua,XM1)
  658. if (ierr.ne.0) return
  659. x1 = xm1 * xr1
  660. re(1,1,IB) = SQRT(ABS(x1))*xamor
  661. if (x1.lt.0.) re(1,1,IB) = re(1,1,IB) *(-1.d0)
  662. endif
  663. ENDDO
  664. GOTO 510
  665. ENDIF
  666. *
  667. C_______________________________________________________________________
  668. C
  669. C ELEMENTS BARRE ET CERCE
  670. C_______________________________________________________________________
  671. C
  672. 46 CONTINUE
  673. *
  674. IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  675. GO TO 99
  676. ENDIF
  677. NBBB=NBNN
  678. SEGINI WRK1,WRK3
  679. IF(MELE.EQ.123) THEN
  680. NSTN=NBNN
  681. LRN =LRE
  682. SEGINI WRK5
  683. ENDIF
  684. C
  685. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  686. C
  687. KERRE=0
  688. DO 3046 IB=1,NBELEM
  689. C
  690. C ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  691. C
  692. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  693. C
  694. C
  695. C ON RECUPERE LA SECTION DE L'ELEMENT
  696. C
  697. MPTVAL=IVACAR
  698. MELVAL=IVAL(1)
  699. IBMN=MIN(IB,VELCHE(/2))
  700. SECT=VELCHE(1,IBMN)
  701. C
  702. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  703. C
  704. MPTVAL=IVAMAT
  705. *
  706. DO 9046 IM=1,NMATT
  707. IF (IVAL(IM).NE.0) THEN
  708. MELVAL=IVAL(IM)
  709. IBMN=MIN(IB ,VELCHE(/2))
  710. VALMAT(IM)=VELCHE(1,IBMN)
  711. ELSE
  712. VALMAT(IM)=0.D0
  713. ENDIF
  714. 9046 CONTINUE
  715. CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  716. C
  717. IF(MELE.EQ.46) CALL BARRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
  718. IF(MELE.EQ.95) CALL CERRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
  719. IF(MELE.EQ.123)CALL BARIG3(REL,LRE,DDHOOK(1,1),XE,XGENE,KERRE,IB)
  720. IF(KERRE.NE.0) INTERR(1)=ISOUS
  721. IF(KERRE.NE.0) INTERR(2)=IB
  722. C
  723. * SEGINI XMATRI
  724. * IMATTT(IB)=XMATRI
  725. C
  726. C REMPLISSAGE DE XMATRI
  727. C
  728. CALL REMPMT(REL,LRE,RE(1,1,IB))
  729. 3046 CONTINUE
  730. IF(MELE.EQ.46.AND.KERRE.EQ.1) CALL ERREUR(128)
  731. IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601)
  732. IF(MELE.EQ.123.AND.KERRE.EQ.1) CALL ERREUR(128)
  733. IF(IRTD.EQ.0) THEN
  734. MOTERR(1:8)=CMATE
  735. MOTERR(9:16)=NOMFR(MFR/2+1)
  736. INTERR(1)=IFOUR
  737. CALL ERREUR(81)
  738. ENDIF
  739. SEGSUP WRK1,WRK3,MVELCH
  740. IF(MELE.EQ.123) SEGSUP WRK5
  741. GOTO 510
  742. C
  743. C_______________________________________________________________________
  744. C
  745. C ELEMENT BARRE 3D EXCENTRE (BAEX)
  746. C_______________________________________________________________________
  747. C
  748. 124 CONTINUE
  749. NBBB=NBNN
  750. NBNO=NBNN
  751. NSTRS1=NSTRS
  752. NSTRS=NBNN
  753. SEGINI WRK1,WRK2,WRK3
  754. C
  755. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  756. C
  757. KERRE=0
  758. DO 3108 IB=1,NBELEM
  759. C
  760. C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON
  761. C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK
  762. C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ
  763. C
  764. MPTVAL=IVACAR
  765. DO IC=1,NCARR
  766. IF(IVAL(IC).NE.0) THEN
  767. MELVAL=IVAL(IC)
  768. IBMN=MIN(IB,VELCHE(/2))
  769. WORK(IC)=VELCHE(1,IBMN)
  770. ELSE
  771. WORK(IC)=0.D0
  772. ENDIF
  773. END DO
  774. SECT=WORK(1)
  775. C
  776. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  777. C
  778. MPTVAL=IVAMAT
  779.  
  780. DO 9108 IM=1,NMATT
  781. IF (IVAL(IM).NE.0) THEN
  782. MELVAL=IVAL(IM)
  783. IBMN=MIN(IB ,VELCHE(/2))
  784. VALMAT(IM)=VELCHE(1,IBMN)
  785. ELSE
  786. VALMAT(IM)=0.D0
  787. ENDIF
  788. 9108 CONTINUE
  789. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  790. 1 CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  791. C
  792. C BGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE
  793. C
  794. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  795. CALL MAPAEX(XE,NBNN,WORK,AL,BGENE,LRE,KERRE)
  796. IF(KERRE.NE.0) INTERR(1)=ISOUS
  797. IF(KERRE.NE.0) INTERR(2)=IB
  798. IF(KERRE.EQ.1) CALL ERREUR(128)
  799. CALL RIGBEX(REL,LRE,DDHOOK(1,1),AL,BGENE)
  800. C
  801. * SEGINI XMATRI
  802. * IMATTT(IB)=XMATRI
  803. C
  804. C REMPLISSAGE DE XMATRI
  805. C
  806. CALL REMPMT(REL,LRE,RE(1,1,IB))
  807. 3108 CONTINUE
  808. NSTRS=NSTRS1
  809. SEGSUP WRK1,WRK2,WRK3,MVELCH
  810. GOTO 510
  811.  
  812. C
  813. *_______________________________________________________________________
  814. *
  815. 99 CONTINUE
  816. MOTERR(1:4)=NOMTP(MELE)
  817. MOTERR(9:12)='AMOR'
  818. CALL ERREUR(86)
  819. *
  820. 510 CONTINUE
  821. RETURN
  822. END
  823.  
  824.  
  825.  
  826.  
  827.  
  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.  

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