Télécharger epsi4.eso

Retour à la liste

Numérotation des lignes :

  1. C EPSI4 SOURCE CB215821 17/09/18 21:15:00 9550
  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. NYD2=2
  637. SEGINI WRK1,WRK3,WRK5,WRK6
  638. C
  639. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  640. C
  641. DO 3108 IB=1,NBELEM
  642. C
  643. C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON
  644. C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK
  645. C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ
  646. C
  647. MPTVAL=IVACAR
  648. DO IC=1,NCARR
  649. IF(IVAL(IC).NE.0) THEN
  650. MELVAL=IVAL(IC)
  651. IBMN=MIN(IB,VELCHE(/2))
  652. WORK(IC)=VELCHE(1,IBMN)
  653. ELSE
  654. WORK(IC)=0.D0
  655. ENDIF
  656. END DO
  657. C SECT=WORK(1)
  658. C
  659. C XGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE
  660. C
  661. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  662. CALL MAPAEX(XE,NBNN,WORK,AL,XGENE,LRE,KERRE)
  663. IF(KERRE.NE.0) INTERR(1)=ISOUS
  664. IF(KERRE.NE.0) INTERR(2)=IB
  665. IF(KERRE.EQ.1) CALL ERREUR(128)
  666. C
  667. C ON CHERCHE LES DEPLACEMENTS
  668. C
  669. IE=1
  670. MPTVAL=IVADEP
  671. DO 4108 IGAU=1,NBNN
  672. DO 4108 ICOMP=1,NDEP
  673. MELVAL=IVAL(ICOMP)
  674. IGMN=MIN(IGAU,VELCHE(/1))
  675. IBMN=MIN(IB ,VELCHE(/2))
  676. XDDL(IE)=VELCHE(IGMN,IBMN)
  677. IE=IE+1
  678. 4108 CONTINUE
  679. C
  680. C ON CALCULE LES DEFORMATIONS
  681. C
  682. CALL BAEPEX(XDDL,XGENE,AL,YDDL,LRE)
  683. C
  684. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATION
  685. C
  686. ID=1
  687. MPTVAL=IVAEPS
  688. DO 7108 IGAU=1,NBPTEL
  689. DO 7108 ICOMP=1,NSTRS
  690. MELVAL=IVAL(ICOMP)
  691. IBMN=MIN(IB ,VELCHE(/2))
  692. VELCHE(IGAU,IBMN)=YDDL(ID)
  693. ID=ID+1
  694. 7108 CONTINUE
  695. C
  696. 3108 CONTINUE
  697. SEGSUP WRK1,WRK3,WRK5
  698. GOTO 510
  699. C_______________________________________________________________________
  700. C
  701. C LIA2 : element de liaison a 2 noeuds (6 ddl par
  702. C noeuds)
  703. C_______________________________________________________________________
  704. C
  705. 125 CONTINUE
  706. NBBB=NBNN
  707. NSTN=3
  708. LRN =3
  709. SEGINI WRK1,WRK3,WRK5
  710. C
  711. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  712. C
  713. DO 3109 IB=1,NBELEM
  714. C
  715. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  716. C
  717. MPTVAL=IVACAR
  718. DO IC=1,NCARR
  719. IF(IVAL(IC).NE.0) THEN
  720. MELVAL=IVAL(IC)
  721. IBMN=MIN(IB,VELCHE(/2))
  722. WORK(IC)=VELCHE(1,IBMN)
  723. ELSE
  724. WORK(IC)=0.D0
  725. ENDIF
  726. END DO
  727. C
  728. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  729. CALL MAPALI(XE,NBNN,WORK,XGENE,KERRE)
  730. IF(KERRE.NE.0) INTERR(1)=ISOUS
  731. IF(KERRE.NE.0) INTERR(2)=IB
  732. IF(KERRE.EQ.1) CALL ERREUR(128)
  733. C
  734. C ON CHERCHE LES DEPLACEMENTS
  735. C
  736. IE=1
  737. DO 4109 IGAU=1,NBNN
  738. MPTVAL=IVADEP
  739. DO 4109 ICOMP=1,NDEP
  740. MELVAL=IVAL(ICOMP)
  741. IGMN=MIN(IGAU,VELCHE(/1))
  742. IBMN=MIN(IB ,VELCHE(/2))
  743. XDDL(IE)=VELCHE(IGMN,IBMN)
  744. IE=IE+1
  745. 4109 CONTINUE
  746. C
  747. CALL ZERO(XSTRS,NSTRS,1)
  748. C
  749. C ON CALCULE LES DEFORMATIONS !!! a completer
  750. C pour le moment on ne met rien dans les deformations
  751. C
  752. CCC CALL DEFLIA(XGENE,XDDL,WORK,LRE,NBNN,XSTRS)
  753. C
  754. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  755. C
  756. ID=1
  757. DO 7109 IGAU=1,NBPTEL
  758. MPTVAL=IVAEPS
  759. DO 7109 ICOMP=1,NSTRS
  760. MELVAL=IVAL(ICOMP)
  761. IBMN=MIN(IB ,VELCHE(/2))
  762. VELCHE(IGAU,IBMN)=XSTRS(ID)
  763. ID=ID+1
  764. 7109 CONTINUE
  765. C
  766. 3109 CONTINUE
  767. SEGSUP WRK1,WRK3,WRK5
  768. GOTO 510
  769. C_______________________________________________________________________
  770. C
  771. C JOI1 : element de liaison a 2 noeuds (6 ddl par noeuds)
  772. C_______________________________________________________________________
  773. C
  774. 265 CONTINUE
  775. NBBB=NBNN
  776. NSTN=3
  777. LRN =3
  778. SEGINI WRK1,WRK3,WRK4
  779. C
  780. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  781. C
  782. DO 3110 IB=1,NBELEM
  783. C
  784. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  785. C
  786. MPTVAL=IVAMAT
  787. DO IC=1,NMATT
  788. IF(IVAL(IC).NE.0) THEN
  789. MELVAL=IVAL(IC)
  790. IBMN=MIN(IB,VELCHE(/2))
  791. WORK(IC)=VELCHE(1,IBMN)
  792. ELSE
  793. WORK(IC)=0.D0
  794. ENDIF
  795. END DO
  796. C
  797. CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  798. C
  799. C ON CHERCHE LES DEPLACEMENTS
  800. C
  801. IE=1
  802. DO 4110 IGAU=1,NBNN
  803. MPTVAL=IVADEP
  804. DO 4110 ICOMP=1,NDEP
  805. MELVAL=IVAL(ICOMP)
  806. IGMN=MIN(IGAU,VELCHE(/1))
  807. IBMN=MIN(IB ,VELCHE(/2))
  808. XDDL(IE)=VELCHE(IGMN,IBMN)
  809. IE=IE+1
  810. 4110 CONTINUE
  811. C
  812. C CALCUL DES DEPLACEMENTS LOCAUX
  813. C
  814. IAW1 = 101
  815. IAW2 = IAW1 + LRE
  816. CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM)
  817. C
  818. CALL ZERO(XSTRS,NSTRS,1)
  819. C
  820. C ON CALCULE LES DEFORMATIONS
  821. C
  822. CALL DEFJOI(XDDL,LRE,XSTRS,NDEP)
  823. C
  824. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  825. C
  826. ID=1
  827. DO 7110 IGAU=1,NBPTEL
  828. MPTVAL=IVAEPS
  829. DO 7110 ICOMP=1,NSTRS
  830. MELVAL=IVAL(ICOMP)
  831. IBMN=MIN(IB ,VELCHE(/2))
  832. VELCHE(IGAU,IBMN)=XSTRS(ID)
  833. ID=ID+1
  834. 7110 CONTINUE
  835. C
  836. 3110 CONTINUE
  837. SEGSUP WRK1,WRK3,WRK4
  838. GOTO 510
  839. C_______________________________________________________________________
  840. C
  841. C ELEMENT TUYO
  842. C_______________________________________________________________________
  843. C
  844. 96 CONTINUE
  845. SEGINI WRK1,WRK3
  846. C
  847. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  848. C
  849. DO 3096 IB=1,NBELEM
  850. C
  851. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  852. C
  853. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  854. C
  855. C ON CHERCHE LES DEPLACEMENTS
  856. C
  857. IE=1
  858. DO 4096 IGAU=1,NBNN
  859. MPTVAL=IVADEP
  860. DO 4096 ICOMP=1,NDEP
  861. MELVAL=IVAL(ICOMP)
  862. IGMN=MIN(IGAU,VELCHE(/1))
  863. IBMN=MIN(IB ,VELCHE(/2))
  864. XDDL(IE)=VELCHE(IGMN,IBMN)
  865. IE=IE+1
  866. 4096 CONTINUE
  867. C
  868. C ON CHERCHE LES CARACTERISTIQUES DE L ELEMENT IB
  869. C
  870. MPTVAL=IVACAR
  871. DO 6096 IC=1,NCARR
  872. IF(IVAL(IC).NE.0) THEN
  873. MELVAL=IVAL(IC)
  874. IBMN=MIN(IB,VELCHE(/2))
  875. WORK(IC)=VELCHE(1,IBMN)
  876. ELSE
  877. WORK(IC)=0
  878. ENDIF
  879. 6096 CONTINUE
  880. C
  881. C CAS OU ON A LU LE MOT VECTEUR
  882. C
  883. IF (IVECT.EQ.1) THEN
  884. IF (IVAL(NCARR).NE.0) THEN
  885. MELVAL=IVAL(NCARR)
  886. IBMN=MIN(IB,IELCHE(/2))
  887. IP=IELCHE(1,IBMN)
  888. IREF=(IP-1)*(IDIM+1)
  889. DO 6196 IC=1,IDIM
  890. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  891. 6196 CONTINUE
  892. ELSE
  893. DO 6296 IC=1,IDIM
  894. WORK(NCARR+IC-1)=0.
  895. 6296 CONTINUE
  896. ENDIF
  897. ENDIF
  898. C
  899. C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  900. C EQUIVALENTE
  901. IF(MELE.EQ.42) THEN
  902. CISA=WORK(4)
  903. VX=WORK(5)
  904. VY=WORK(6)
  905. VZ=WORK(7)
  906. CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,2)
  907. ENDIF
  908. C
  909. C ON CALCULE LES DEFORMATIONS
  910. C
  911. youbid=0.d0
  912. xnubid=1.
  913. CALL POUEPS(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2,youbid,
  914. $ xnubid)
  915. C
  916. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  917. C
  918. ID=12
  919. MPTVAL=IVAEPS
  920. DO 7096 IGAU=1,NBPTEL
  921. DO 7096 ICOMP=1,NSTRS
  922. MELVAL=IVAL(ICOMP)
  923. IBMN=MIN(IB ,VELCHE(/2))
  924. VELCHE(IGAU,IBMN)=WORK(ID)
  925. ID=ID+1
  926. 7096 CONTINUE
  927. C
  928. 3096 CONTINUE
  929. SEGSUP WRK1,WRK3
  930. GOTO 510
  931. C_______________________________________________________________________
  932. C
  933. C ELEMENTS ZONE_COHESIVE ZOC2,ZOC3,ZOC4
  934. C_______________________________________________________________________
  935. C
  936. 266 CONTINUE
  937.  
  938. NBNO=NBNN
  939. SEGINI WRK1,WRK2,WRK4
  940. C
  941. DO 3266 IB=1,NBELEM
  942. C
  943. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  944. C
  945. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  946. C
  947. C
  948. C ON CHERCHE LES DEPLACEMENTS
  949. C
  950. MPTVAL=IVADEP
  951. IE=1
  952. DO 2266 IGAU=1,NBNN
  953. DO 2266 ICOMP=1,NDEP
  954. MELVAL=IVAL(ICOMP)
  955. IGMN=MIN(IGAU,VELCHE(/1))
  956. IBMN=MIN(IB ,VELCHE(/2))
  957. XDDL(IE)=VELCHE(IGMN,IBMN)
  958. IE=IE+1
  959. 2266 CONTINUE
  960. C
  961. C BOUCLE SUR LES POINTS DE GAUSS
  962. C
  963. DO 4266 IGAU=1,NBPGAU
  964. C
  965. CALL ZCOLOC(XE,SHPTOT,NBNN,MELE,IFOUR,IGAU,BPSS)
  966. C
  967. CALL BZCO(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,
  968. . NSTRS,NBNO,LRE,MELE,SHPWRK,BGENE,DJAC,IRRT)
  969. C IRRT.NE.0 JACOBIEN <= 0
  970. IF(IRRT.NE.0) THEN
  971. INTERR(1)=IB
  972. CALL ERREUR(612)
  973. GOTO 99266
  974. ENDIF
  975. C
  976. CALL BST(BGENE,XDDL,LRE,NSTRS,XSTRS)
  977. C
  978. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  979. C
  980. MPTVAL=IVAEPS
  981. DO 9266 ICOMP=1,NSTRS
  982. MELVAL=IVAL(ICOMP)
  983. IGMN=MIN(IGAU,VELCHE(/1))
  984. IBMN=MIN(IB ,VELCHE(/2))
  985. VELCHE(IGMN,IBMN)=XSTRS(ICOMP)
  986. 9266 CONTINUE
  987. 4266 CONTINUE
  988. 3266 CONTINUE
  989. C
  990. 99266 CONTINUE
  991. SEGSUP WRK1,WRK2,WRK4
  992. GOTO 510
  993. C____________________________________________________________________
  994. 99 CONTINUE
  995. MOTERR(1:4)=NOMTP(MELE)
  996. MOTERR(9:12)='EPSI'
  997. CALL ERREUR(86)
  998. C
  999. 510 CONTINUE
  1000. RETURN
  1001. END
  1002.  
  1003.  

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