Télécharger epsi4.eso

Retour à la liste

Numérotation des lignes :

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

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