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

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