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

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