Télécharger epsi4.eso

Retour à la liste

Numérotation des lignes :

  1. C EPSI4 SOURCE FANDEUR 16/01/07 21:15:17 8756
  2. SUBROUTINE EPSI4(IPMAIL,IVADEP,NDEP,IVAMAT,NMATT,IVACAR,NCARR,
  3. & IPMINT,IVECT,MELE,LHOOK,IREPS2,NBPTEL,NSTRS,MFR,
  4. & NBPGAU,LRE,LW,IVAEPS,UZDPG,RYDPG,RXDPG,ISOUS,IIPDPG,CMATE)
  5. C---------------------------------------------------------------------*
  6. C *
  7. C CALCUL DES DEFORMATIONS *
  8. C *
  9. C linespring,tuyau fissure,barre,cerce,tuyo,poi1 *
  10. C *
  11. C---------------------------------------------------------------------*
  12. C *
  13. C ENTREES : *
  14. C ________ *
  15. C *
  16. C IPMAIL Pointeur sur un segment MELEME *
  17. C IVADEP Pointeur sur le chamelem de deplacements *
  18. C NDEP Nombre de composantes de deplacements *
  19. C IVACAR Pointeur sur les chamelems de caracteristiques *
  20. C NCARR Nombre de caracteristiques geometriques *
  21. C IVECT Flag indiquant si on a entre les axes locaux *
  22. C MELE Numero de l'element fini *
  23. C LHOOK Dimension de la matrice de Hooke *
  24. C IRESP2 Flag pour indiquer si on veut les contraintes *
  25. C de Piola-Kirchhoff *
  26. C NBPTEL Nombre de points par element *
  27. C NSTRS Nombre de composante de contraintes/deformations *
  28. C MFR Numero de formulation de l'element fini *
  29. C pour une matrice de hooke *
  30. C NBPGAU Nombre de point d'integration pour la rigidite *
  31. C LRE Nombre de ddl dans la matrice de rigidite *
  32. C LW Dimension du tableau de travail de l'element *
  33. C *
  34. C SORTIES : *
  35. C ________ *
  36. C *
  37. C IVAEPS pointeur sur un segment MPTVAL contenant les *
  38. C les melvals de deformations *
  39. C *
  40. C---------------------------------------------------------------------*
  41. IMPLICIT INTEGER(I-N)
  42. IMPLICIT REAL*8(A-H,O-Z)
  43. C
  44. -INC CCOPTIO
  45. -INC CCHAMP
  46. -INC SMCHAML
  47. -INC SMCHPOI
  48. -INC SMELEME
  49. -INC SMCOORD
  50. -INC SMMODEL
  51. -INC SMINTE
  52. -INC SMLREEL
  53. C
  54. C
  55. SEGMENT WRK1
  56. REAL*8 DDHOOK(NSTRS,NSTRS) ,XDDL(LRE) ,XSTRS(NSTRS)
  57. REAL*8 XE(3,NBBB),DDHOMU(NSTRS,NSTRS)
  58. ENDSEGMENT
  59. C
  60. SEGMENT WRK2
  61. REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE)
  62. ENDSEGMENT
  63. C
  64. SEGMENT WRK4
  65. REAL*8 BPSS(3,3), XEL(3,NBBB), XFOLO(LRE)
  66. ENDSEGMENT
  67. C
  68. SEGMENT WRK5
  69. REAL*8 XGENE(NSTN,LRN)
  70. ENDSEGMENT
  71. C
  72. SEGMENT WRK3
  73. REAL*8 WORK(LW)
  74. ENDSEGMENT
  75. C
  76. SEGMENT WRK6
  77. REAL*8 YDDL(NYD2)
  78. ENDSEGMENT
  79. C
  80. SEGMENT NOTYPE
  81. CHARACTER*16 TYPE(NBTYPE)
  82. ENDSEGMENT
  83. C
  84. SEGMENT MPTVAL
  85. INTEGER IPOS(NS),NSOF(NS)
  86. INTEGER IVAL(NCOSOU)
  87. CHARACTER*16 TYVAL(NCOSOU)
  88. ENDSEGMENT
  89. POINTEUR MPTVA1.MPTVAL
  90. C
  91. CHARACTER*(NCONCH) CONM
  92. CHARACTER*8 CMATE
  93. C PARAMETER (NINF=3)
  94. C INTEGER INFOS(NINF)
  95. logical dcmat2
  96. C
  97. C INITIALISATION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT
  98. C DE LA SECTION EN DEFO PLANE GENERALISEE
  99. C
  100. C <- Ici test equivalent a IF (IIPDPG.GT.0) THEN
  101. IF (IFOUR.EQ.-3)THEN
  102. C* SEGACT MCOORD
  103. IREF=(IIPDPG-1)*(IDIM+1)
  104. XDPGE=XCOOR(IREF+1)
  105. YDPGE=XCOOR(IREF+2)
  106. ELSE
  107. XDPGE=0.D0
  108. YDPGE=0.D0
  109. ENDIF
  110. C
  111. MELEME=IPMAIL
  112. NBNN=NUM(/1)
  113. NBELEM=NUM(/2)
  114. C
  115. C NHRM=NIFOUR
  116. MINTE=IPMINT
  117. NBBB=NBNN
  118. dcmat2 = .false.
  119. C_______________________________________________________________________
  120. C
  121. C NUMERO DES ETIQUETTES :
  122. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  123. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  124. C 5 CONTINUE
  125. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  126. C 44 CONTINUE
  127. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  128. C_______________________________________________________________________
  129. C
  130. IF (MELE.LE.100)
  131. &GOTO (99,2,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  132. 1 99,99,99,99,99,99,99,99,2,30,99,99,99,99,99,99,99,99,99,99,
  133. 2 99,99,43,99,45,46,99,99,99,30,99,99,99,99,99,99,99,99,99,99,
  134. 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  135. 4 99,99,99,99,99,99,99,99,99,99,99,99,99,99,46,96,99,99,99,99
  136. 5 ),MELE
  137. IF (MELE.LE.200)
  138. &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  139. 1 99,99,46,124,125,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  140. 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  141. 3 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  142. 4 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  143. 5 34),MELE-100
  144. IF (MELE.LE.300)
  145. &GOTO (34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  146. 1 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  147. 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  148. 3 34,34,34,34,265,266,266,266,99,99,271,272),MELE-200
  149. C
  150. 34 CONTINUE
  151. GOTO 99
  152. C____________________________________________________________________
  153. C
  154. C ELEMENT SEG2 (pour IMPEDANCE)
  155. C____________________________________________________________________
  156. C
  157. 2 CONTINUE
  158. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  159. C
  160. C detecte une impedance hybridant des ddl
  161. MPTVAL=IVADEP
  162. if (ival(/1).eq.ndep*2) dcmat2 = .true.
  163. NYD2 = NBNN*NDEP
  164. segini wrk6
  165. DO 310 IB=1,NBELEM
  166. C
  167. C ON CHERCHE LES DEPLACEMENTS
  168. C
  169. IE=1
  170. DO 410 IGAU=1,NBNN
  171. ico1 = 1
  172. ico2 = ndep
  173. if (dcmat2) then
  174. if (igau.eq.2) then
  175. ico1 = ndep + 1
  176. ico2 = ndep*2
  177. endif
  178. endif
  179. DO 410 ICOMP=ico1,ico2
  180. MELVAL=IVAL(ICOMP)
  181. IGMN=MIN(IGAU,VELCHE(/1))
  182. IBMN=MIN(IB ,VELCHE(/2))
  183. YDDL(IE)=VELCHE(IGMN,IBMN)
  184. IE=IE+1
  185. 410 CONTINUE
  186.  
  187. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  188. C
  189. MPTVAL=IVAEPS
  190. ID=1
  191. DO 710 IGAU=1,NBPTEL
  192. DO 710 ICOMP=1,NSTRS
  193. MELVAL=IVAL(ICOMP)
  194. IBMN=MIN(IB ,VELCHE(/2))
  195. if (igau.lt.2) then
  196. VELCHE(IGAU,IBMN)= YDDL(ID) - YDDL(ID+NDEP)
  197. else
  198. VELCHE(IGAU,IBMN)= YDDL(ID) - YDDL(ID-NDEP)
  199. endif
  200. ID=ID+1
  201. 710 CONTINUE
  202. C
  203. 310 CONTINUE
  204. segsup wrk6
  205. GOTO 510
  206. C
  207. C____________________________________________________________________
  208. C
  209. C ELEMENT LINESPRING LISP ET LISM
  210. C____________________________________________________________________
  211. C
  212. 30 CONTINUE
  213. NSTR=NSTRS
  214. NSTRS=2
  215. C ATTENTION ON NE SERT PAS DE XSTRS(NSTRS) DS WRK1
  216. C
  217. SEGINI WRK1,WRK3
  218. C
  219. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  220. C
  221. DO 3030 IB=1,NBELEM
  222. C
  223. C ON CHERCHE LES DEPLACEMENTS
  224. C
  225. IE=1
  226. DO 4030 IGAU=1,NBNN
  227. MPTVAL=IVADEP
  228. DO 4030 ICOMP=1,NDEP
  229. MELVAL=IVAL(ICOMP)
  230. IGMN=MIN(IGAU,VELCHE(/1))
  231. IBMN=MIN(IB ,VELCHE(/2))
  232. XDDL(IE)=VELCHE(IGMN,IBMN)
  233. IE=IE+1
  234. 4030 CONTINUE
  235. C
  236. C ON CHERCHE LES COORDONNEES DES NOEUDS ET ON REACTUALISE
  237. C
  238. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  239. C
  240. C ON CHERCHE LES CARACTERISTIQUES ON OUBLIE LE 2 IEME PT DE GAUSS
  241. C
  242. IE=1
  243. DO 7030 IC=1,3,2
  244. MPTVAL=IVACAR
  245. DO 7030 ICOMP=1,NCARR
  246. MELVAL=IVAL(ICOMP)
  247. IF (MELVAL.NE.0) THEN
  248. IGMN=MIN(IC,VELCHE(/1))
  249. IBMN=MIN(IB,VELCHE(/2))
  250. WORK(IE)=VELCHE(IGMN,IBMN)
  251. ELSE
  252. WORK(IE)=0.D0
  253. ENDIF
  254. IE=IE+1
  255. 7030 CONTINUE
  256. C
  257. C CALCUL DES DEFORMATIONS
  258. C
  259. CALL LISPEP(XE,WORK,XDDL,WORK(11),WORK(20),
  260. 1 WORK(29),NBPGAU,WORK(53))
  261. C
  262. IE=1
  263. DO 8030 IGAU=1,NBPTEL
  264. MPTVAL=IVAEPS
  265. DO 8030 ICOMP=1,NSTR
  266. MELVAL=IVAL(ICOMP)
  267. IBMN=MIN(IB ,VELCHE(/2))
  268. VELCHE(IGAU,IBMN)=WORK(52+IE)
  269. IE=IE+1
  270. 8030 CONTINUE
  271. 3030 CONTINUE
  272. SEGSUP WRK1,WRK3
  273. GOTO 510
  274. C_______________________________________________________________________
  275. C
  276. C TUYAU FISSURE
  277. C_______________________________________________________________________
  278. C
  279. 43 CONTINUE
  280. SEGINI WRK1,WRK3
  281. C
  282. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  283. C
  284. DO 3043 IB=1,NBELEM
  285. C
  286. C ON CHERCHE LES DEPLACEMENTS
  287. C
  288. IE=1
  289. DO 4043 IGAU=1,NBNN
  290. MPTVAL=IVADEP
  291. DO 4043 ICOMP=1,NDEP
  292. MELVAL=IVAL(ICOMP)
  293. IGMN=MIN(IGAU,VELCHE(/1))
  294. IBMN=MIN(IB ,VELCHE(/2))
  295. XDDL(IE)=VELCHE(IGMN,IBMN)
  296. IE=IE+1
  297. 4043 CONTINUE
  298. C
  299. C ON CHERCHE LES CARACTERISTIQUES
  300. C
  301. MPTVAL=IVACAR
  302. DO 7043 IC=1,9
  303. MELVAL=IVAL(IC)
  304. IF (MELVAL.NE.0) THEN
  305. IBMN=MIN(IB,VELCHE(/2))
  306. WORK(IC)=VELCHE(1,IBMN)
  307. ELSE
  308. WORK(IC)=0
  309. ENDIF
  310. 7043 CONTINUE
  311. C
  312. C ON CALCULE LES DEFORMATIONS
  313. C
  314. CALL TUFEPS(XDDL,WORK,WORK(31),KERRE)
  315. IF(KERRE.NE.0) THEN
  316. INTERR(1)=IB
  317. IF(KERRE.EQ.1) CALL ERREUR(137)
  318. IF(KERRE.EQ.2) CALL ERREUR(123)
  319. IF(KERRE.EQ.3) CALL ERREUR(266)
  320. GOTO 5043
  321. ENDIF
  322. C
  323. C ON REMPLIT LES DEFORMATIONS
  324. C
  325. MPTVAL=IVAEPS
  326. DO 6043 ICOMP=1,NSTRS
  327. MELVAL=IVAL(ICOMP)
  328. IBMN=MIN(IB,VELCHE(/2))
  329. VELCHE(1,IBMN)=WORK(30+ICOMP)
  330. 6043 CONTINUE
  331. C
  332. 3043 CONTINUE
  333. 5043 CONTINUE
  334. SEGSUP WRK1,WRK3
  335. GOTO 510
  336. C_______________________________________________________________________
  337. C
  338. C ELEMENT POI1 / materiau IMPEDANCE
  339. C_______________________________________________________________________
  340. C
  341. 45 CONTINUE
  342. IF ((CMATE.EQ.'IMPELAST').OR.(CMATE.EQ.'IMPVOIGT').OR.
  343. & (CMATE.eq.'IMPREUSS').OR.(CMATE.eq.'IMPCOMPL').OR.
  344. & (MFR.EQ.26.OR.MFR.EQ.28)) THEN
  345. mptva1 = ivadep
  346. mptval = ivaeps
  347. numstr = ival(/1)
  348. do iv = 1,ival(/1)
  349. melva1 = mptva1.ival(iv)
  350. melval = ival(iv)
  351.  
  352.  
  353. Ctc les lignes ci dessous sont pour le compilateur
  354. if( .not. dcmat2 ) then
  355. melva2=melva1
  356. inmbid=0
  357. ICC2=1
  358. else
  359. inmbid=numstr
  360. icc2=2
  361. endif
  362. C
  363. C ON CHERCHE LES DEPLACEMENTS
  364. C
  365. DO IB=1,NBELEM
  366. IGAU = 1
  367. IGMN= 1
  368. IBMN=MIN(IB ,MELVA1.VELCHE(/2))
  369. valalf = MELVA1.VELCHE(IGMN,IBMN)
  370. VELCHE(IGMN,IBMN) = valalf
  371. ENDDO
  372.  
  373. enddo
  374. GOTO 510
  375. ENDIF
  376.  
  377. IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN
  378. GO TO 99
  379. ENDIF
  380. C
  381. SEGINI WRK1,WRK3
  382. C
  383. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  384. C
  385. DO 3045 IB=1,NBELEM
  386. KERRE=0
  387. C
  388. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  389. C
  390. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  391. C
  392. C ON CALCULE LES DEFORMATIONS
  393. C
  394. CALL PO1EPS(XE,UZDPG,RYDPG,RXDPG,XDPGE,YDPGE,WORK)
  395. C
  396. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  397. C
  398. ID=1
  399. DO 7045 IGAU=1,NBPTEL
  400. MPTVAL=IVAEPS
  401. DO 7045 ICOMP=1,NSTRS
  402. MELVAL=IVAL(ICOMP)
  403. IBMN=MIN(IB ,VELCHE(/2))
  404. VELCHE(IGAU,IBMN)=WORK(ID)
  405. ID=ID+1
  406. 7045 CONTINUE
  407. 3045 CONTINUE
  408. SEGSUP WRK1,WRK3
  409. GOTO 510
  410. C_______________________________________________________________________
  411. C
  412. C BARRE ET CERCE
  413. C_______________________________________________________________________
  414.  
  415. C
  416. 46 CONTINUE
  417. C
  418. IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  419. GO TO 99
  420. ENDIF
  421. C
  422. SEGINI WRK1,WRK3
  423. C
  424. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  425. C
  426. DO 3046 IB=1,NBELEM
  427. KERRE=0
  428. C
  429. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  430. C
  431. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  432. C
  433. C ON CHERCHE LES DEPLACEMENTS
  434. C
  435. NDDD=NDEP
  436. IF (IFOUR.EQ.-3.AND.MELE.EQ.46) NDDD=NDEP-3
  437. IE=1
  438. DO 4046 IGAU=1,NBNN
  439. MPTVAL=IVADEP
  440. DO 4046 ICOMP=1,NDDD
  441. MELVAL=IVAL(ICOMP)
  442. IGMN=MIN(IGAU,VELCHE(/1))
  443. IBMN=MIN(IB ,VELCHE(/2))
  444. XDDL(IE)=VELCHE(IGMN,IBMN)
  445. IE=IE+1
  446. 4046 CONTINUE
  447. C
  448. C ON CALCULE LES DEFORMATIONS
  449. C
  450. IF(MELE.EQ.46) CALL BAREPS(XE,XDDL,WORK,IREPS2)
  451. IF(MELE.EQ.95) CALL CEREPS(XE,XDDL,WORK,IREPS2,KERRE)
  452. IF(MELE.EQ.123) CALL BAREP3(XE,XDDL,WORK,QSIGAU,POIGAU,
  453. & NBPGAU,IB)
  454. IF(KERRE.EQ.1) THEN
  455. CALL ERREUR(601)
  456. GO TO 3046
  457. ENDIF
  458. C
  459. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  460. C
  461. ID=1
  462. DO 7046 IGAU=1,NBPTEL
  463. MPTVAL=IVAEPS
  464. DO 7046 ICOMP=1,NSTRS
  465. MELVAL=IVAL(ICOMP)
  466. IBMN=MIN(IB ,VELCHE(/2))
  467. VELCHE(IGAU,IBMN)=WORK(ID)
  468. ID=ID+1
  469. 7046 CONTINUE
  470. C
  471. 3046 CONTINUE
  472. SEGSUP WRK1,WRK3
  473. GOTO 510
  474. C
  475. C element coaxial COS2 (3D pour liaison acier-beton)
  476. C
  477. 271 continue
  478. lW=20
  479. SEGINI WRK1,WRK3,wrk4
  480. DO 2711 IB=1,NBELEM
  481. KERRE=0
  482. C
  483. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  484. C
  485. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  486. C
  487. C ON CHERCHE LES DEPLACEMENTS
  488. C
  489. NDDD=NDEP
  490. IE=1
  491. DO 2712 IGAU=1,NBNN
  492. MPTVAL=IVADEP
  493. DO 2712 ICOMP=1,NDDD
  494. MELVAL=IVAL(ICOMP)
  495. IGMN=MIN(IGAU,VELCHE(/1))
  496. IBMN=MIN(IB ,VELCHE(/2))
  497. XDDL(IE)=VELCHE(IGMN,IBMN)
  498. IE=IE+1
  499. 2712 CONTINUE
  500. C call chloc ( xe,nbnn,BPSS,idim,kerre)
  501. CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
  502. ii = 0
  503. do ia=1,4
  504. xa=0.d0
  505. xb=0.d0
  506. xc=0.d0
  507. do iu=1,idim
  508. ii = ii + 1
  509. C write(6,*) 'xddl',ib,ii,xddl(ii)
  510. xa =xa+ xddl(ia*idim - idim +iu)* bpss( 1,iu)
  511. xb= xb+ xddl(ia*idim - idim +iu)* bpss( 2,iu)
  512. if(idim.eq.3) xc=xc+xddl(ia*idim - idim +iu)* bpss( 3,iu)
  513. enddo
  514. xddl(ia*idim - idim +1)=xa
  515. xddl(ia*idim - idim +2)=xb
  516. if(idim.eq.3) xddl(ia*idim - idim +3)=xc
  517. enddo
  518. g11 = xddl(1) - xddl(3*idim +1)
  519. g21 = xddl(idim+1 ) - xddl( 2*idim + 1 )
  520. ag = 1.d0-0.5773502691896257645d0
  521. g1 = g11 + (g21 - g11)*ag/2.d0
  522. g2 = g21 + (g11 - g21)*ag/2.d0
  523. g12 = xddl(3*idim + 2) - xddl(2)
  524. g22 = xddl(2*idim + 2) - xddl(idim+2 )
  525. g3 =g12 + (g22 - g12)*ag/2.d0
  526. g4 =g22 + (g12 - g22)*ag/2.d0
  527. C
  528. if (idim.eq.3) then
  529. g13 =xddl(3) - xddl(3*idim +3)
  530. g23 =xddl(idim+3 ) - xddl( 2*idim + 3 )
  531. g5 = g13 + (g23 - g13)*ag/2.d0
  532. g6 = g23 + (g13 - g23)*ag/2.d0
  533. endif
  534. C write(6,*) 'gliss 1',ib,g1,g3,g5
  535. C write(6,*) 'gliss 2',ib,g2,g4,g6
  536. C
  537. mptval= ivaeps
  538. melval=ival(1)
  539. IBMN=MIN(IB ,VELCHE(/2))
  540. VELCHE(1,IBMN)= g1
  541. velche(2,ibmn)= g2
  542. C
  543. melval=ival(2)
  544. IBMN=MIN(IB ,VELCHE(/2))
  545. VELCHE(1,IBMN)= g3
  546. velche(2,ibmn)= g4
  547. C
  548. melval=ival(3)
  549. IBMN=MIN(IB ,VELCHE(/2))
  550. if (idim.eq.3) then
  551. VELCHE(1,IBMN)= g5
  552. velche(2,ibmn)= g6
  553. endif
  554. C
  555. 2711 continue
  556. segsup WRK1,WRK3,wrk4
  557. GOTO 510
  558.  
  559. C_______________________________________________________________________
  560. C
  561. C ELEMENT COAXIAL (COA2)
  562. C_______________________________________________________________________
  563. C
  564. 272 continue
  565. NBNO=NBNN
  566. SEGINI WRK1,WRK2,WRK4
  567. C
  568. DO 2721 IB=1,NBELEM
  569. C
  570. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  571. C
  572. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  573. C
  574. CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
  575. C
  576. C ON CHERCHE LES DEPLACEMENTS
  577. C
  578. MPTVAL=IVADEP
  579. IE=1
  580. DO 2722 IGAU=1,NBNN
  581. DO 2722 ICOMP=1,NDEP
  582. MELVAL=IVAL(ICOMP)
  583. IGMN=MIN(IGAU,VELCHE(/1))
  584. IBMN=MIN(IB ,VELCHE(/2))
  585. XDDL(IE)=VELCHE(IGMN,IBMN)
  586. IE=IE+1
  587. 2722 CONTINUE
  588. C
  589. C BOUCLE SUR LES POINTS DE GAUSS
  590. C
  591. DO 2723 IGAU=1,NBPGAU
  592. C
  593. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  594. C
  595. CALL BCO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  596. . BGENE,DJAC,IRRT,IDIM)
  597. IF(IRRT.NE.0) THEN
  598. INTERR(1)=IB
  599. CALL ERREUR(764)
  600. GOTO 9985
  601. ENDIF
  602. DO i=1,NSTRS
  603. cc=0.D0
  604. DO j=1,LRE
  605. cc= cc + (XDDL(j) * BGENE(i,j))
  606. C write(6,*) 'xddl b',ib,igau,i,j,xddl(j),bgene(i,j)
  607. ENDDO
  608. XSTRS(i) = cc
  609. C write(6,*) 'gliss',ib,igau,i,xstrs(i)
  610. ENDDO
  611. C
  612. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  613. C
  614. MPTVAL=IVAEPS
  615. DO 2724 ICOMP=1,NSTRS
  616. MELVAL=IVAL(ICOMP)
  617. IGMN=MIN(IGAU,VELCHE(/1))
  618. IBMN=MIN(IB ,VELCHE(/2))
  619. VELCHE(IGMN,IBMN)=XSTRS(ICOMP)
  620. 2724 CONTINUE
  621. 2723 CONTINUE
  622. 2721 CONTINUE
  623. C
  624. 9985 CONTINUE
  625. SEGSUP WRK1,WRK2,WRK4
  626. GOTO 510
  627. C____________________________________________________________________
  628. C
  629. C ELEMENT BARRE 3D EXCENTRE (BAEX)
  630. C____________________________________________________________________
  631. C
  632. 124 CONTINUE
  633. NBBB=NBNN
  634. NSTN=NBNN
  635. LRN =LRE
  636. SEGINI WRK1,WRK3,WRK5
  637. C
  638. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  639. C
  640. DO 3108 IB=1,NBELEM
  641. C
  642. C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON
  643. C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK
  644. C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ
  645. C
  646. MPTVAL=IVACAR
  647. DO IC=1,NCARR
  648. IF(IVAL(IC).NE.0) THEN
  649. MELVAL=IVAL(IC)
  650. IBMN=MIN(IB,VELCHE(/2))
  651. WORK(IC)=VELCHE(1,IBMN)
  652. ELSE
  653. WORK(IC)=0.D0
  654. ENDIF
  655. END DO
  656. C SECT=WORK(1)
  657. C
  658. C XGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE
  659. C
  660. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  661. CALL MAPAEX(XE,NBNN,WORK,AL,XGENE,LRE,KERRE)
  662. IF(KERRE.NE.0) INTERR(1)=ISOUS
  663. IF(KERRE.NE.0) INTERR(2)=IB
  664. IF(KERRE.EQ.1) CALL ERREUR(128)
  665. C
  666. C ON CHERCHE LES DEPLACEMENTS
  667. C
  668. IE=1
  669. DO 4108 IGAU=1,NBNN
  670. MPTVAL=IVADEP
  671. DO 4108 ICOMP=1,NDEP
  672. MELVAL=IVAL(ICOMP)
  673. IGMN=MIN(IGAU,VELCHE(/1))
  674. IBMN=MIN(IB ,VELCHE(/2))
  675. XDDL(IE)=VELCHE(IGMN,IBMN)
  676. IE=IE+1
  677. 4108 CONTINUE
  678. C
  679. C ON CALCULE LES DEFORMATIONS
  680. C
  681. CALL BAEPEX(XDDL,XGENE,AL,XSTRS,LRE)
  682. C
  683. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATION
  684. C
  685. ID=1
  686. DO 7108 IGAU=1,NBPTEL
  687. MPTVAL=IVAEPS
  688. DO 7108 ICOMP=1,NSTRS
  689. MELVAL=IVAL(ICOMP)
  690. IBMN=MIN(IB ,VELCHE(/2))
  691. VELCHE(IGAU,IBMN)=XSTRS(ID)
  692. ID=ID+1
  693. 7108 CONTINUE
  694. C
  695. 3108 CONTINUE
  696. SEGSUP WRK1,WRK3,WRK5
  697. GOTO 510
  698. C_______________________________________________________________________
  699. C
  700. C LIA2 : element de liaison a 2 noeuds (6 ddl par
  701. C noeuds)
  702. C_______________________________________________________________________
  703. C
  704. 125 CONTINUE
  705. NBBB=NBNN
  706. NSTN=3
  707. LRN =3
  708. SEGINI WRK1,WRK3,WRK5
  709. C
  710. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  711. C
  712. DO 3109 IB=1,NBELEM
  713. C
  714. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  715. C
  716. MPTVAL=IVACAR
  717. DO IC=1,NCARR
  718. IF(IVAL(IC).NE.0) THEN
  719. MELVAL=IVAL(IC)
  720. IBMN=MIN(IB,VELCHE(/2))
  721. WORK(IC)=VELCHE(1,IBMN)
  722. ELSE
  723. WORK(IC)=0.D0
  724. ENDIF
  725. END DO
  726. C
  727. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  728. CALL MAPALI(XE,NBNN,WORK,XGENE,KERRE)
  729. IF(KERRE.NE.0) INTERR(1)=ISOUS
  730. IF(KERRE.NE.0) INTERR(2)=IB
  731. IF(KERRE.EQ.1) CALL ERREUR(128)
  732. C
  733. C ON CHERCHE LES DEPLACEMENTS
  734. C
  735. IE=1
  736. DO 4109 IGAU=1,NBNN
  737. MPTVAL=IVADEP
  738. DO 4109 ICOMP=1,NDEP
  739. MELVAL=IVAL(ICOMP)
  740. IGMN=MIN(IGAU,VELCHE(/1))
  741. IBMN=MIN(IB ,VELCHE(/2))
  742. XDDL(IE)=VELCHE(IGMN,IBMN)
  743. IE=IE+1
  744. 4109 CONTINUE
  745. C
  746. CALL ZERO(XSTRS,NSTRS,1)
  747. C
  748. C ON CALCULE LES DEFORMATIONS !!! a completer
  749. C pour le moment on ne met rien dans les deformations
  750. C
  751. CCC CALL DEFLIA(XGENE,XDDL,WORK,LRE,NBNN,XSTRS)
  752. C
  753. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  754. C
  755. ID=1
  756. DO 7109 IGAU=1,NBPTEL
  757. MPTVAL=IVAEPS
  758. DO 7109 ICOMP=1,NSTRS
  759. MELVAL=IVAL(ICOMP)
  760. IBMN=MIN(IB ,VELCHE(/2))
  761. VELCHE(IGAU,IBMN)=XSTRS(ID)
  762. ID=ID+1
  763. 7109 CONTINUE
  764. C
  765. 3109 CONTINUE
  766. SEGSUP WRK1,WRK3,WRK5
  767. GOTO 510
  768. C_______________________________________________________________________
  769. C
  770. C JOI1 : element de liaison a 2 noeuds (6 ddl par noeuds)
  771. C_______________________________________________________________________
  772. C
  773. 265 CONTINUE
  774. NBBB=NBNN
  775. NSTN=3
  776. LRN =3
  777. SEGINI WRK1,WRK3,WRK4
  778. C
  779. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  780. C
  781. DO 3110 IB=1,NBELEM
  782. C
  783. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  784. C
  785. MPTVAL=IVAMAT
  786. DO IC=1,NMATT
  787. IF(IVAL(IC).NE.0) THEN
  788. MELVAL=IVAL(IC)
  789. IBMN=MIN(IB,VELCHE(/2))
  790. WORK(IC)=VELCHE(1,IBMN)
  791. ELSE
  792. WORK(IC)=0.D0
  793. ENDIF
  794. END DO
  795. C
  796. CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  797. C
  798. C ON CHERCHE LES DEPLACEMENTS
  799. C
  800. IE=1
  801. DO 4110 IGAU=1,NBNN
  802. MPTVAL=IVADEP
  803. DO 4110 ICOMP=1,NDEP
  804. MELVAL=IVAL(ICOMP)
  805. IGMN=MIN(IGAU,VELCHE(/1))
  806. IBMN=MIN(IB ,VELCHE(/2))
  807. XDDL(IE)=VELCHE(IGMN,IBMN)
  808. IE=IE+1
  809. 4110 CONTINUE
  810. C
  811. C CALCUL DES DEPLACEMENTS LOCAUX
  812. C
  813. IAW1 = 101
  814. IAW2 = IAW1 + LRE
  815. CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM)
  816. C
  817. CALL ZERO(XSTRS,NSTRS,1)
  818. C
  819. C ON CALCULE LES DEFORMATIONS
  820. C
  821. CALL DEFJOI(XDDL,LRE,XSTRS,NDEP)
  822. C
  823. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  824. C
  825. ID=1
  826. DO 7110 IGAU=1,NBPTEL
  827. MPTVAL=IVAEPS
  828. DO 7110 ICOMP=1,NSTRS
  829. MELVAL=IVAL(ICOMP)
  830. IBMN=MIN(IB ,VELCHE(/2))
  831. VELCHE(IGAU,IBMN)=XSTRS(ID)
  832. ID=ID+1
  833. 7110 CONTINUE
  834. C
  835. 3110 CONTINUE
  836. SEGSUP WRK1,WRK3,WRK4
  837. GOTO 510
  838. C_______________________________________________________________________
  839. C
  840. C ELEMENT TUYO
  841. C_______________________________________________________________________
  842. C
  843. 96 CONTINUE
  844. SEGINI WRK1,WRK3
  845. C
  846. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  847. C
  848. DO 3096 IB=1,NBELEM
  849. C
  850. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  851. C
  852. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  853. C
  854. C ON CHERCHE LES DEPLACEMENTS
  855. C
  856. IE=1
  857. DO 4096 IGAU=1,NBNN
  858. MPTVAL=IVADEP
  859. DO 4096 ICOMP=1,NDEP
  860. MELVAL=IVAL(ICOMP)
  861. IGMN=MIN(IGAU,VELCHE(/1))
  862. IBMN=MIN(IB ,VELCHE(/2))
  863. XDDL(IE)=VELCHE(IGMN,IBMN)
  864. IE=IE+1
  865. 4096 CONTINUE
  866. C
  867. C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
  868. C
  869. MPTVAL=IVACAR
  870. DO 6096 IC=1,NCARR
  871. IF(IVAL(IC).NE.0) THEN
  872. MELVAL=IVAL(IC)
  873. IBMN=MIN(IB,VELCHE(/2))
  874. WORK(IC)=VELCHE(1,IBMN)
  875. ELSE
  876. WORK(IC)=0
  877. ENDIF
  878. 6096 CONTINUE
  879. C
  880. C CAS OU ON A LU LE MOT VECTEUR
  881. C
  882. IF (IVECT.EQ.1) THEN
  883. IF (IVAL(NCARR).NE.0) THEN
  884. MELVAL=IVAL(NCARR)
  885. IBMN=MIN(IB,IELCHE(/2))
  886. IP=IELCHE(1,IBMN)
  887. IREF=(IP-1)*(IDIM+1)
  888. DO 6196 IC=1,IDIM
  889. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  890. 6196 CONTINUE
  891. ELSE
  892. DO 6296 IC=1,IDIM
  893. WORK(NCARR+IC-1)=0.
  894. 6296 CONTINUE
  895. ENDIF
  896. ENDIF
  897. C
  898. C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  899. C EQUIVALENTE
  900. IF(MELE.EQ.42) THEN
  901. CISA=WORK(4)
  902. VX=WORK(5)
  903. VY=WORK(6)
  904. VZ=WORK(7)
  905. CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2)
  906. ENDIF
  907. C
  908. C ON CALCULE LES DEFORMATIONS
  909. C
  910. youbid=0.d0
  911. xnubid=1.
  912. CALL POUEPS(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2,youbid,
  913. $ xnubid)
  914. C
  915. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  916. C
  917. ID=12
  918. MPTVAL=IVAEPS
  919. DO 7096 IGAU=1,NBPTEL
  920. DO 7096 ICOMP=1,NSTRS
  921. MELVAL=IVAL(ICOMP)
  922. IBMN=MIN(IB ,VELCHE(/2))
  923. VELCHE(IGAU,IBMN)=WORK(ID)
  924. ID=ID+1
  925. 7096 CONTINUE
  926. C
  927. 3096 CONTINUE
  928. SEGSUP WRK1,WRK3
  929. GOTO 510
  930. C_______________________________________________________________________
  931. C
  932. C ELEMENTS ZONE_COHESIVE ZOC2,ZOC3,ZOC4
  933. C_______________________________________________________________________
  934. C
  935. 266 CONTINUE
  936.  
  937. NBNO=NBNN
  938. SEGINI WRK1,WRK2,WRK4
  939. C
  940. DO 3266 IB=1,NBELEM
  941. C
  942. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  943. C
  944. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  945. C
  946. C
  947. C ON CHERCHE LES DEPLACEMENTS
  948. C
  949. MPTVAL=IVADEP
  950. IE=1
  951. DO 2266 IGAU=1,NBNN
  952. DO 2266 ICOMP=1,NDEP
  953. MELVAL=IVAL(ICOMP)
  954. IGMN=MIN(IGAU,VELCHE(/1))
  955. IBMN=MIN(IB ,VELCHE(/2))
  956. XDDL(IE)=VELCHE(IGMN,IBMN)
  957. IE=IE+1
  958. 2266 CONTINUE
  959. C
  960. C BOUCLE SUR LES POINTS DE GAUSS
  961. C
  962. DO 4266 IGAU=1,NBPGAU
  963. C
  964. CALL ZCOLOC(XE,SHPTOT,NBNN,MELE,IFOUR,IGAU,BPSS)
  965. C
  966. CALL BZCO(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,
  967. . NSTRS,NBNO,LRE,MELE,SHPWRK,BGENE,DJAC,IRRT)
  968. C IRRT.NE.0 JACOBIEN <= 0
  969. IF(IRRT.NE.0) THEN
  970. INTERR(1)=IB
  971. CALL ERREUR(612)
  972. GOTO 99266
  973. ENDIF
  974. C
  975. CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  976. C
  977. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  978. C
  979. MPTVAL=IVAEPS
  980. DO 9266 ICOMP=1,NSTRS
  981. MELVAL=IVAL(ICOMP)
  982. IGMN=MIN(IGAU,VELCHE(/1))
  983. IBMN=MIN(IB ,VELCHE(/2))
  984. VELCHE(IGMN,IBMN)=XSTRS(ICOMP)
  985. 9266 CONTINUE
  986. 4266 CONTINUE
  987. 3266 CONTINUE
  988. C
  989. 99266 CONTINUE
  990. SEGSUP WRK1,WRK2,WRK4
  991. GOTO 510
  992. C____________________________________________________________________
  993. 99 CONTINUE
  994. MOTERR(1:4)=NOMTP(MELE)
  995. MOTERR(9:12)='EPSI'
  996. CALL ERREUR(86)
  997. C
  998. 510 CONTINUE
  999. RETURN
  1000. END
  1001.  
  1002.  
  1003.  

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