Télécharger amor2.eso

Retour à la liste

Numérotation des lignes :

  1. C AMOR2 SOURCE BP208322 17/03/01 21:15:03 9325
  2. SUBROUTINE AMOR2(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,
  3. & IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,NMATT,
  4. & IPORE,NDDL,IPMATR,IIPDPG,NCAR1)
  5. *---------------------------------------------------------------------*
  6. * _________________________________________ *
  7. * | | *
  8. * | CALCUL DE LA MATRICE D AMORTISSEMENT | *
  9. * |_______________________________________| *
  10. * *
  11. * massif *
  12. * *
  13. *---------------------------------------------------------------------*
  14. * *
  15. * ENTREES : *
  16. * ________ *
  17. * *
  18. * MATE Numero du materiau *
  19. * MELE Numero de l'element fini *
  20. * IPMAIL Pointeur sur un segment MELEME *
  21. * IPMINT Pointeur sur un segment MINTE *
  22. * NBPGAU Nombre de point d'integration pour la rigidite *
  23. * LRE Nombre de ddl dans la matrice de rigidite *
  24. * NSTRS Nombre de composante de contraintes/deformations *
  25. * IVAMAT Pointeur sur un segment MPTVAL pour le materiau ou *
  26. * pour une matrice de hooke *
  27. * IVACAR Pointeur sur un segment MPTVAL de caractéristiques *
  28. * CMATE Nom du materiau *
  29. * MFR Numero de la formulation element fini *
  30. * NBGMAT Taille maxi des melval du materiau (pt de gauss) *
  31. * NELMAT Taille maxi des melval du materiau (No d'element) *
  32. * IMAT (2 il y a une matrice de HOOKE,1 non ) *
  33. * NMATT Nombre de composante de materiau (IMAT=1) *
  34. * LHOOK Dimension de la matrice de Hooke *
  35. * IPORE Nombre de fonctions de forme *
  36. * NDDL Nombre de degre de liberte *
  37. * *
  38. * SORTIES : *
  39. * ________ *
  40. * *
  41. * IPMATR pointeur sur la rigidite de la sous-zone *
  42. * *
  43. *---------------------------------------------------------------------*
  44. IMPLICIT INTEGER(I-N)
  45. IMPLICIT REAL*8(A-H,O-Z)
  46. *
  47. -INC CCOPTIO
  48. -INC CCHAMP
  49. -INC CCREEL
  50. -INC SMCHAML
  51. -INC SMINTE
  52. -INC SMELEME
  53. -INC SMRIGID
  54. -INC SMCOORD
  55. -INC SMLREEL
  56. *
  57. SEGMENT,MWRK1
  58. REAL*8 DDHOOK(LHOOK,LHOOK) ,DDHOMU(LHOOK,LHOOK)
  59. REAL*8 REL(LRE,LRE) ,RINT(LRE,LRE) , XE(3,NBBB)
  60. ENDSEGMENT
  61. *
  62. SEGMENT,MWRK2
  63. REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE)
  64. ENDSEGMENT
  65. *
  66. SEGMENT,MWRK8
  67. REAL*8 XLOC(3,3),XGLOB(3,3),TXR(IDIM,IDIM)
  68. REAL*8 D1HO(LHOOK,LHOOK),ROTH(LHOOK,LHOOK)
  69. ENDSEGMENT
  70. *
  71. SEGMENT,MVELCH
  72. REAL*8 VALMAT(NV1)
  73. ENDSEGMENT
  74. *
  75. segment,mwrk67
  76. real*8 valcar(nca1)
  77. endsegment
  78. *
  79. SEGMENT MPTVAL
  80. INTEGER IPOS(NS) ,NSOF(NS)
  81. INTEGER IVAL(NCOSOU)
  82. CHARACTER*16 TYVAL(NCOSOU)
  83. ENDSEGMENT
  84. *
  85. CHARACTER*8 CMATE,CELEM
  86.  
  87. DIMENSION A(4,60),BB(3,60),xatef1(3,3)
  88. logical drend,BDPGE
  89. *
  90. * WRITE (*,*) 'Entrée dans AMOR2.'
  91. C*? SEGACT MCOORD
  92. MELEME=IPMAIL
  93. NBNN=NUM(/1)
  94. NBELEM=NUM(/2)
  95. *
  96. NV1=NMATT
  97. SEGINI,MVELCH
  98. *
  99. XMATRI=IPMATR
  100. NLIGRP=LRE
  101. NLIGRD=LRE
  102. *
  103. * INTRODUCTION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT
  104. * DE LA SECTION EN DEFO PLANE GENERALISEE
  105. * En 1D : pas de rotation
  106. IF (IFOUR.EQ.-3) THEN
  107. BDPGE=.TRUE.
  108. IREF=(IIPDPG-1)*(IDIM+1)
  109. XDPGE=XCOOR(IREF+1)
  110. YDPGE=XCOOR(IREF+2)
  111. ELSE IF ((IFOUR.GE.7.AND.IFOUR.LE.11).OR.IFOUR.EQ.14) THEN
  112. BDPGE=.TRUE.
  113. XDPGE=XZero
  114. YDPGE=XZero
  115. ELSE
  116. BDPGE=.FALSE.
  117. XDPGE=0.D0
  118. YDPGE=0.D0
  119. ENDIF
  120. *
  121. NHRM=NIFOUR
  122. *
  123. MINTE=IPMINT
  124. C_______________________________________________________________________
  125. C
  126. C NUMERO DES ETIQUETTES :
  127. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  128. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  129. C 5 CONTINUE
  130. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  131. C 44 CONTINUE
  132. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  133. C_______________________________________________________________________
  134. C
  135. GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  136. 1 99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  137. 2 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  138. 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4,99,99, 4,99,99,99,99,
  139. 4 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  140. 5 99,99,99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
  141. 6 4, 4),MELE
  142. *
  143. IF (MELE.EQ.183.OR.MELE.EQ.184.OR.
  144. . MELE.EQ.193.OR.MELE.EQ.194) GOTO 4
  145.  
  146. GOTO 99
  147. C_______________________________________________________________________
  148. C
  149. C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET ELEMENTS INCOMPRESSIBLES
  150. C_______________________________________________________________________
  151. C
  152. 4 CONTINUE
  153. DIM3=1.D0
  154. IRTD=1
  155. *
  156. * CAS ORTHOTROPE ( 2) ANISOTROPE ( 3) UNIDIRECTIONNEL (4)
  157. *
  158. IPMIN2=0
  159. IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)
  160. 1 .AND.IMAT.EQ.1)THEN
  161. * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE DE
  162. * L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
  163. NLG=NUMGEO(MELE)
  164. CALL RESHPT(1,NBNN,NLG,MELE,0,IPMIN2,IRT1)
  165. MINTE2=IPMIN2
  166. SEGACT MINTE2
  167. SEGINI,MWRK8
  168. ENDIF
  169. NBNO=NBNN
  170. NBBB=NBNN
  171. SEGINI,MWRK1,MWRK2
  172.  
  173. DO 3004 IB=1,NBELEM
  174. C
  175. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  176. C
  177. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  178. C
  179. C CALCUL DES AXES LOCAUX DANS LE CAS DES MATERIAUX ORTHOTROPE ,
  180. C ANISOTROPE ET UNIDIRECTIONNEL
  181. C
  182. C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)
  183. C* 1 .AND.IMAT.EQ.1)THEN
  184. IF (IPMIN2.NE.0) THEN
  185. NBSH=MINTE2.SHPTOT(/2)
  186. CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  187. if (nbsh.eq.-1) then
  188. call erreur(525)
  189. GOTO 4999
  190. endif
  191. ENDIF
  192. C
  193. CALL ZERO (RINT,LRE,LRE)
  194. C
  195. C CALCUL DES COEFF DE MODIFICATION DE LA MATRICE B-BARRE
  196. C (Uniquement en cas d'elements incompressibles)
  197. IF (MFR.EQ.31) THEN
  198. * WRITE (*,*) 'Appel de BBCALC - IFOUR = ',IFOUR
  199. CALL BBCALC(XE,MELE,NBNN,IDIM,NBPGAU,POIGAU,
  200. 1 QSIGAU,ETAGAU,DZEGAU,NSTRS,
  201. 2 LRE,IFOUR,A,BB,NHRM,SHPTOT,SHPWRK,XDPGE,YDPGE)
  202. ENDIF
  203. C
  204. C BOUCLE SUR LES POINTS DE GAUSS
  205. C
  206. ISDJC=0
  207. DO 4004 IGAU=1,NBPGAU
  208. C
  209. C RECUPERATION DE L'EPAISSEUR
  210. C
  211. IF (IFOUR.EQ.-2)THEN
  212. MPTVAL=IVACAR
  213. IF (IVACAR.NE.0) THEN
  214. MELVAL=IVAL(1)
  215. IF (MELVAL.NE.0) THEN
  216. IGMN=MIN(IGAU,VELCHE(/1))
  217. IBMN=MIN(IB,VELCHE(/2))
  218. DIM3=VELCHE(IGMN,IBMN)
  219. ELSE
  220. DIM3=1.D0
  221. ENDIF
  222. ENDIF
  223. ENDIF
  224. *
  225. CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  226. 1 MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,XE,
  227. 2 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  228. IF (DJAC.EQ.0.D0) THEN
  229. INTERR(1)=IB
  230. CALL ERREUR(259)
  231. GOTO 4999
  232. ENDIF
  233. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  234. DJAC=ABS(DJAC)*POIGAU(IGAU)
  235.  
  236. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  237. IF (MFR.EQ.31) THEN
  238. CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  239. & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  240. ENDIF
  241. C
  242. MPTVAL=IVAMAT
  243. IF(IMAT.EQ.2) THEN
  244. MELVAL=IVAL(1)
  245. IBMN=MIN(IB ,IELCHE(/2))
  246. IGMN=MIN(IGAU,IELCHE(/1))
  247. MLREEL=IELCHE(IGMN,IBMN)
  248. SEGACT MLREEL
  249. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  250. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  251. SEGDES MLREEL
  252. ELSE IF (IMAT.EQ.1) THEN
  253. DO 9004 IM=1,NMATT
  254. IF (IVAL(IM).NE.0) THEN
  255. MELVAL=IVAL(IM)
  256. IBMN=MIN(IB ,VELCHE(/2))
  257. IGMN=MIN(IGAU,VELCHE(/1))
  258. VALMAT(IM)=VELCHE(IGMN,IBMN)
  259. ELSE
  260. VALMAT(IM)=0.D0
  261. ENDIF
  262. 9004 CONTINUE
  263. IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)THEN
  264. IF (IGAU.LE.NBGMAT)
  265. 1 CALL DOHMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
  266. 2 ROTH,DDHOOK,LHOOK,1,IRTD)
  267. ELSE
  268. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  269. 1 CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  270. ENDIF
  271. IF (IRTD.EQ.0) THEN
  272. MOTERR(1:8)=CMATE
  273. MOTERR(9:16)=NOMFR(MFR/2+1)
  274. INTERR(1)=IFOUR
  275. CALL ERREUR(81)
  276. GOTO 510
  277. ENDIF
  278. ENDIF
  279. C
  280. C CHOIX POUR BDB/DEFO PLANE GENE --- PRODUIT MATRICIEL NORMAL
  281. C /MASSIF ------------ PRODUIT PAR BLOC
  282. C
  283. * initialise
  284. CALL ZERO (REL,LRE,LRE)
  285. * calcul rigidite elementaire
  286. C** IF (IFOUR.EQ.-3) THEN
  287. IF (BDPGE) THEN
  288. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  289. ELSE
  290. CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL,MFR,IFOUR,MATE,
  291. 1 IGAU,IMAT,0.D0)
  292. ENDIF
  293. * matrice d'efficacite
  294. drend = .false.
  295. MPTVAL=IVACAR
  296. IF (IVACAR.GT.0) THEN
  297. segact mptval
  298. nca1 = ival(/1)
  299. segini,mwrk67
  300. celem = 'MASSIF '
  301. IF(IVAL(NCAR1).GT.0.OR.IVAL(NCAR1+1).GT.0) THEN
  302. DO 9008 IM= 1,IVAL(/1)
  303. IF (IVAL(IM).GT.0) THEN
  304. MELVAL=IVAL(IM)
  305. IF (TYVAL(IM).EQ.'REAL*8') THEN
  306. IBMN=MIN(IB ,VELCHE(/2))
  307. IGMN=MIN(IGAU,VELCHE(/1))
  308. VALCAR(IM)=VELCHE(IGMN,IBMN)
  309. ELSE
  310. IBMN=MIN(IB ,IELCHE(/2))
  311. IGMN=MIN(IGAU,IELCHE(/1))
  312. VALCAR(IM)=IELCHE(IGMN,IBMN)
  313. ENDIF
  314. ELSE
  315. VALCAR(IM)=0.D0
  316. ENDIF
  317. 9008 CONTINUE
  318. nstep = 2
  319. if (ifour.eq.2) nstep = 3
  320. if (ival(ncar1).gt.0.and.tyval(ncar1).eq.'REAL*8') then
  321. drend = .true.
  322. do i = 1,nstep
  323. do j = 1, nstep
  324. xatef1(i,j) = 0.d0
  325. enddo
  326. xatef1(i,i) = valcar(ncar1)
  327. enddo
  328. endif
  329. if (ival(ncar1).eq.0.and.tyval(ncar1+1).eq.'REAL*8') then
  330. drend = .false.
  331. do i = 1,nstep
  332. do j = 1, nstep
  333. xatef1(i,j) = 0.d0
  334. enddo
  335. xatef1(1,1) = valcar(ncar1+7)
  336. xatef1(2,2) = valcar(ncar1+8)
  337. if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9)
  338. enddo
  339. endif
  340. call effi2(valcar,tyval,nca1,ncar1,rel,lre,ib,igau,xatef1,
  341. & nstep,drend,celem)
  342. ENDIF
  343. ENDIF
  344. * stocke
  345. do ii = 1,LRE
  346. do jj = 1,LRE
  347. rint(ii,jj) = rint(ii,jj) + rel(ii,jj)
  348. enddo
  349. enddo
  350. *
  351. 4004 CONTINUE
  352. C
  353. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  354. INTERR(1) = IB
  355. CALL ERREUR(195)
  356. GOTO 4999
  357. ENDIF
  358. C
  359. C REMPLISSAGE DE XMATRI
  360. C
  361. c CALL REMPMT(RINT,LRE,RE)
  362. C+DC
  363. C IF (ICAS.NE.3) THEN
  364. DO 4100 IAK=1,LRE
  365. DO 4100 IBK=1,LRE
  366. RE(IAK,IBK,IB)=RINT(IAK,IBK)
  367. 4100 CONTINUE
  368. C ELSE
  369. C DO 4110 IAK=1,LRE/2
  370. C DO 4110 IBK=1,LRE/2
  371. C IF
  372. C RE(2*IAK-1,2*IBK-1)=RINT(IAK,IBK)
  373. C 4110 CONTINUE
  374. C ENDIF
  375. 3004 CONTINUE
  376.  
  377. C Fin du traitement - Menage
  378. 4999 CONTINUE
  379. IF (IPMIN2.NE.0) THEN
  380. C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)
  381. C* 1 .AND.IMAT.EQ.1)THEN
  382. SEGDES MINTE2
  383. SEGSUP,MWRK8
  384. ENDIF
  385. SEGSUP,MWRK1,MWRK2
  386. GOTO 510
  387. *
  388. 99 CONTINUE
  389. MOTERR(1:4)=NOMTP(MELE)
  390. MOTERR(5:12)='AMOR2 '
  391. CALL ERREUR(86)
  392. *
  393. 510 CONTINUE
  394. SEGSUP,MVELCH
  395. * SEGDES XMATRI
  396. * WRITE (*,*) 'Sortie de AMOR2.'
  397. RETURN
  398. END
  399.  
  400.  
  401.  
  402.  
  403.  

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