Télécharger bsigm3.eso

Retour à la liste

Numérotation des lignes :

bsigm3
  1. C BSIGM3 SOURCE CB215821 20/11/25 13:18:52 10792
  2. SUBROUTINE BSIGM3(IPMAIL,LRE,NSTRS,LW,IVACAR,NCARR,IVECT,
  3. & MELE,CMATE,IVASTR,ISOUS,NBPGAU,NBPTEL,IPMINT,NFOR,IVAFOR
  4. & ,ADPG,BDPG,CDPG,IIPDPG,IVAMAT,NMATT,MFR,dcmate)
  5. *----------------------------------------------------------------------
  6. * _______________________________ *
  7. * | | *
  8. * | calcul des forces aux noeuds| *
  9. * |______________________________| *
  10. * *
  11. * poutre,tuyau,linespring,tuyau fissure,barre,cerce,tuyo *
  12. * poutre de timoschenko,shb8,joi1,zone_cohesive
  13. * *
  14. *---------------------------------------------------------------------*
  15. * *
  16. * entrees : *
  17. * ________ *
  18. * *
  19. * ipmail pointeur sur un segment meleme *
  20. * lre nombre de ddl dans la matrice de rigidite *
  21. * nstrs nombre de composante de contraintes/deformations *
  22. * lw dimension du tableau de travail de l'element *
  23. * ivacar pointeur sur les chamelems de caracteristiques géo. *
  24. * ncarr nombre de caracteristiques geometriques *
  25. * ivamat pointeur sur les chamelems de caracteristiques mat. *
  26. * nmatt nombre de caracteristiques matériau *
  27. * ivect flag indiquant si on a entree les axes locaux *
  28. * mele numero de l'element fini *
  29. * ivastr pointeur sur un segment mptval contenant les *
  30. * les melvals de contraints *
  31. * isous numero de la sous-zone *
  32. * nbpgau nombre de points d'integration pour les contraintes *
  33. * nbptel nombre de points par element *
  34. * ipmint pointeur sur un segment minte *
  35. * nfor nombre de composantes de forces *
  36. * *
  37. * sorties : *
  38. * ________ *
  39. * *
  40. * ivafor pointeur sur un segment mptval contenant les *
  41. * les melvals de forces *
  42.  
  43. * *
  44. *---------------------------------------------------------------------*
  45. IMPLICIT INTEGER(I-N)
  46. IMPLICIT REAL*8(A-H,O-Z)
  47. *
  48. *
  49.  
  50. -INC PPARAM
  51. -INC CCOPTIO
  52. -INC CCHAMP
  53. -INC CCREEL
  54. -INC SMCHAML
  55. -INC SMCHPOI
  56. -INC SMELEME
  57. -INC SMCOORD
  58. -INC SMMODEL
  59. -INC SMINTE
  60. -INC SMLMOTS
  61. c
  62.  
  63. SEGMENT WRK1
  64. REAL*8 XFORC(LRE), XSTRS(NSTRS), XE(3,NBBB)
  65. ENDSEGMENT
  66. *
  67. SEGMENT WRK2
  68. REAL*8 SHPWRK(6,NBNN), BGENE(NSTRS,LRE)
  69. ENDSEGMENT
  70. *
  71. SEGMENT WRK3
  72. REAL*8 WORK(LW)
  73. ENDSEGMENT
  74. *
  75. SEGMENT WRK4
  76. REAL*8 BPSS(3,3), XEL(3,NBBB), XFOLO(LRE)
  77. ENDSEGMENT
  78. *
  79. SEGMENT WRK5
  80. REAL*8 XGENE(NSTN,LRN)
  81. ENDSEGMENT
  82. * segment pour shb8
  83. SEGMENT WRK7
  84. REAL*8 PROPEL(24),D(3)
  85. REAL*8 rel(24,24),work1(30)
  86. ENDSEGMENT
  87. *
  88. SEGMENT MPTVAL
  89. INTEGER IPOS(NS) ,NSOF(NS)
  90. INTEGER IVAL(NCOSOU)
  91. CHARACTER*16 TYVAL(NCOSOU)
  92. ENDSEGMENT
  93. POINTEUR MPTVA1.MPTVAL,MPTVA2.MPTVAL
  94. *
  95. CHARACTER*4 lesinc(7),lesdua(7)
  96. DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/
  97. DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/
  98. CHARACTER*8 CMATE
  99. logical dcmat2,dcmate
  100.  
  101. dcmat2 = .false.
  102. MELEME=IPMAIL
  103. SEGACT MELEME
  104. NBNN=NUM(/1)
  105. NBELEM=NUM(/2)
  106. *
  107. * introduction des coord du point autour duquel se fait le
  108. * mouvement de la section en defo plane generalisee
  109. * et initialisation des forces au noeud support de la defo
  110. * plane generalisee
  111. *
  112. ADPG=0.D0
  113. BDPG=0.D0
  114. CDPG=0.D0
  115. IF (IFOUR.EQ.-3)THEN
  116. IP=IIPDPG
  117. SEGACT MCOORD
  118. IREF=(IP-1)*(IDIM+1)
  119. XDPGE=XCOOR(IREF+1)
  120. YDPGE=XCOOR(IREF+2)
  121. ELSE
  122. XDPGE=0.D0
  123. YDPGE=0.D0
  124. ENDIF
  125. *
  126. NHRM=NIFOUR
  127. MINTE=IPMINT
  128. *
  129. c_______________________________________________________________________
  130. c_______________________________________________________________________
  131. c
  132. c numero des etiquettes :
  133. c etiquettes de 1 a 98 pour traitement specifique a l element
  134. c dans la zone specifique a chaque element commencant par :
  135. c 5 continue
  136. c element 5 etiquettes 1005 2005 3005 4005 ...
  137. c 44 continue
  138. c element 44 etiquettes 1044 2044 3044 4044 ...
  139. c_______________________________________________________________________
  140. c
  141. IF (MELE.LE.100)
  142. &GOTO (99,2,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  143. 1 99,99,99,99,99,99,99,99,29,30,99,99,99,99,99,99,99,99,99,99,
  144. 2 99,29,43,99,45,46,99,99,99,30,99,99,99,99,99,99,99,99,99,99,
  145. 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  146. 4 99,99,99,29,99,99,99,99,99,99,99,99,99,99,46,96,99,99,99,99
  147. 5 ),MELE
  148. IF (MELE.LE.200)
  149. &GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  150. 1 99,99,46,124,125,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  151. 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  152. 3 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  153. 4 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  154. 5 34),MELE-100
  155. IF (MELE.LE.300)
  156. &GOTO (34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  157. 1 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  158. 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  159. 3 260,34,34,34,34,265,266,266,266,99,99,271,272),MELE-200
  160. c
  161. 34 CONTINUE
  162. GOTO 99
  163. C____________________________________________________________________
  164. C
  165. C ELEMENT SEG2 (pour IMPEDANCE)
  166. C____________________________________________________________________
  167. C
  168. 2 CONTINUE
  169. IF (CMATE.EQ.'IMPELAST'.OR.CMATE.EQ.'IMPVOIGT'.OR.
  170. & CMATE.EQ.'IMPREUSS'.OR .cmate.eq.'IMPCOMPL') THEN
  171. * detection impedance "sur mesure"
  172. MPTVA1=IVASTR
  173. MPTVAL=IVAFOR
  174. if (ival(/1).eq.mptva1.ival(/1)*2) dcmat2 = .true.
  175. ENDIF
  176.  
  177. DO 310 IB=1,NBELEM
  178. C ON CHERCHE LES CONTRAINTES -
  179. C
  180. MPTVA1=IVASTR
  181. numstr = mptva1.ival(/1)
  182. C RANGEMENT DANS MELVAL
  183. C
  184. MPTVAL=IVAFOR
  185. DO 910 IGAU=1,NBNN
  186. DO 910 ICOMP=1,NFOR
  187. if (dcmat2) then
  188. if(icomp.le.numstr) then
  189. melva1 = mptva1.ival(icomp)
  190. else
  191. melva1 = mptva1.ival(icomp - numstr)
  192. endif
  193. if (igau.lt.2) then
  194. melval = ival(icomp)
  195. else
  196. melval = ival(icomp + nfor)
  197. endif
  198. else
  199. MELVA1=MPTVA1.IVAL(ICOMP)
  200. MELVAL=IVAL(ICOMP)
  201. endif
  202. IBMN=MIN(IB ,VELCHE(/2))
  203. IBM1=MIN(IB ,MELVA1.VELCHE(/2))
  204. IGM1=MIN(IGAU,MELVA1.VELCHE(/1))
  205. VELCHE(IGAU,IBMN)= MELVA1.VELCHE(IGM1,IBM1)
  206. 910 CONTINUE
  207. 310 CONTINUE
  208. GO TO 510
  209. c_______________________________________________________________________
  210. c_______________________________________________________________________
  211. c
  212. c elements poutre et poutre de timoschenko
  213. c_______________________________________________________________________
  214. c
  215. 29 CONTINUE
  216. if (dcmate) goto 2
  217. NBBB=NBNN
  218. SEGINI WRK1,WRK3
  219. c
  220. NCARR1=NCARR
  221. IF((IVECT.EQ.1).AND.(IFOUR.NE.-2)) NCARR1=NCARR-1
  222. c
  223. DO 3029 IB=1,NBELEM
  224. c
  225. c on cherche les coordonnees des noeuds de l elementib
  226. c
  227. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  228. c
  229. c il faudrait aussi modifier le vecteur local de la poutre
  230. c
  231. c rangement des caracteristiques dans work
  232. C
  233. MPTVAL=IVACAR
  234. C
  235. DO 6029 IC=1,NCARR1
  236. WORK(IC)=0.D0
  237. MELVAL=IVAL(IC)
  238. IF (MELVAL.NE.0) THEN
  239. IBMN=MIN(IB,VELCHE(/2))
  240. DO 4029 IGAU=1,NBNN
  241. IGMN=MIN(IGAU,VELCHE(/1))
  242. WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  243. 4029 CONTINUE
  244. WORK(IC)=WORK(IC)/NBNN
  245. ENDIF
  246. 6029 CONTINUE
  247. c
  248. c cas ou on a lu le mot vecteur
  249. C
  250. IF (IFOUR.NE.-2) THEN
  251. C
  252. IF (IVECT.EQ.1) THEN
  253. MELVAL=IVAL(NCARR)
  254. IF (MELVAL.NE.0) THEN
  255. IBMN=MIN(IB,IELCHE(/2))
  256. IP=IELCHE(1,IBMN)
  257. IREF=(IP-1)*(IDIM+1)
  258. DO 6129 IC=1,IDIM
  259. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  260. 6129 CONTINUE
  261. ELSE
  262. DO 6229 IC=1,IDIM
  263. WORK(NCARR+IC-1)=0.D0
  264. 6229 CONTINUE
  265. ENDIF
  266. ENDIF
  267. C
  268. ENDIF
  269. C
  270. c cas des tuyaux - on calcule les caracteristiques de la poutre
  271. c equivalente
  272. c
  273. IF(MELE.EQ.42) THEN
  274. CISA=WORK(4)
  275. VX =WORK(5)
  276. VY =WORK(6)
  277. VZ =WORK(7)
  278. CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,0)
  279. IF (KERRE.EQ.77) THEN
  280. CALL ERREUR(77)
  281. GOTO 510
  282. ENDIF
  283. ENDIF
  284. c
  285. c on cherche les contraintes -
  286. c
  287. MPTVAL=IVASTR
  288. IE=9
  289. DO 7029 IGAU=1,2
  290. DO 7029 ICOMP=1,NSTRS
  291. IE=IE+1
  292. MELVAL=IVAL(ICOMP)
  293. IBMN=MIN(IB ,VELCHE(/2))
  294. IGMN=MIN(IGAU,VELCHE(/1))
  295. WORK(IE)=VELCHE(IGMN,IBMN)
  296. 7029 CONTINUE
  297. c
  298. c on calcule les forces internes
  299. c
  300. IF(MELE.EQ.84) THEN
  301. IF(CMATE.NE.'SECTION') THEN
  302. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  303. CALL TIMBS2(XFORC,XE,WORK(10),WORK(22),KERRE)
  304. ELSE
  305. CALL TIMBSG(XFORC,WORK(7),XE,WORK(10),WORK(22),KERRE)
  306. ENDIF
  307. ELSE
  308. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  309. CALL TIMBS2(XFORC,XE,WORK(10),WORK(22),KERRE)
  310. ELSE
  311. CALL TIMBSG(XFORC,WORK(1),XE,WORK(10),WORK(22),KERRE)
  312. ENDIF
  313. ENDIF
  314. ELSE
  315. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  316. CALL POUBS2(XFORC,WORK,XE,WORK(10),WORK(22),KERRE)
  317. ELSE
  318. CALL POUBSG(XFORC,WORK,XE,WORK(10),WORK(22),KERRE)
  319. ENDIF
  320. ENDIF
  321. IF(KERRE.NE.0) THEN
  322. INTERR(1)=ISOUS
  323. INTERR(2)=IB
  324. SEGSUP WRK1,WRK3
  325. CALL ERREUR(128)
  326. GO TO 510
  327. ENDIF
  328. c
  329. c rangement dans melval
  330. c
  331. IE=0
  332. MPTVAL=IVAFOR
  333. DO 9029 IGAU=1,NBNN
  334. DO 9029 ICOMP=1,NFOR
  335. IE=IE+1
  336. MELVAL=IVAL(ICOMP)
  337. IBMN=MIN(IB ,VELCHE(/2))
  338. VELCHE(IGAU,IBMN)=XFORC(IE)
  339. 9029 CONTINUE
  340. 3029 CONTINUE
  341. SEGSUP WRK1,WRK3
  342. GO TO 510
  343. c_______________________________________________________________________
  344. c
  345. c elements lisp et lism
  346. c_______________________________________________________________________
  347. c
  348. 30 CONTINUE
  349. NBBB=NBNN
  350. NBNO=SHPTOT(/2)
  351. SEGINI WRK1,WRK3,WRK4
  352. c
  353. DO 3030 IB=1,NBELEM
  354. c
  355. c on cherche les coordonnees des noeuds de l element ib
  356. c
  357. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  358. c
  359. c
  360. c on cherche les contraintes
  361. c
  362. IE=0
  363. MPTVAL=IVASTR
  364. DO 7030 IGAU=1,NBPGAU
  365. DO 7030 ICOMP=1,NSTRS
  366. IE=IE+1
  367. MELVAL=IVAL(ICOMP)
  368. IGMN=MIN(IGAU,VELCHE(/1))
  369. IBMN=MIN(IB ,VELCHE(/2))
  370. WORK(IE)=VELCHE(IGMN,IBMN)
  371. 7030 CONTINUE
  372. c
  373. c on cherche les caracteristiques
  374. c
  375. MPTVAL=IVACAR
  376. DO 6030 IGAU=1,NBPGAU
  377. DO 6030 ICOMP=1,NCARR
  378. IE=IE+1
  379. MELVAL=IVAL(ICOMP)
  380. IF (MELVAL.NE.0) THEN
  381. IGMN=MIN(IGAU,VELCHE(/1))
  382. IBMN=MIN(IB ,VELCHE(/2))
  383. WORK(IE)=VELCHE(IGMN,IBMN)
  384. ELSE
  385. WORK(IE)=0.D0
  386. ENDIF
  387. 6030 CONTINUE
  388. c
  389. c on calcule b*sigma
  390. c
  391. ICNT=NBPGAU*NSTRS+1
  392. CALL LISPBS(WORK(1),WORK(ICNT),POIGAU,SHPTOT,
  393. 1 NBPGAU,NBNO,XE,XFOLO,BPSS,XFORC)
  394. c
  395. c rangement dans melval
  396. c
  397. IE=0
  398. MPTVAL=IVAFOR
  399. DO 9030 IGAU=1,NBNN
  400. DO 9030 ICOMP=1,6
  401. IE=IE+1
  402. MELVAL=IVAL(ICOMP)
  403. IBMN=MIN(IB ,VELCHE(/2))
  404. VELCHE(IGAU,IBMN)=XFORC(IE)
  405. 9030 CONTINUE
  406. 3030 CONTINUE
  407. SEGSUP WRK1,WRK3,WRK4
  408. GOTO 510
  409. c_______________________________________________________________________
  410. c
  411. c element tuyau fissure
  412. c_______________________________________________________________________
  413. c
  414. 43 CONTINUE
  415. NBBB=NBNN
  416. SEGINI WRK1,WRK3
  417. c
  418. DO 3043 IB=1,NBELEM
  419. c
  420. c on cherche les contraintes
  421. c
  422. IE=0
  423. MPTVAL=IVASTR
  424. DO 4043 IGAU=1,NBPTEL
  425. DO 4043 ICOMP=1,NSTRS
  426. IE=IE+1
  427. MELVAL=IVAL(ICOMP)
  428. IGMN=MIN(IGAU,VELCHE(/1))
  429. IBMN=MIN(IB ,VELCHE(/2))
  430. WORK(IE)=VELCHE(IGMN,IBMN)
  431. 4043 CONTINUE
  432. c
  433. c on cherche les caracteristiques
  434. c
  435. MPTVAL=IVACAR
  436. DO 5043 ICOMP=1,NCARR
  437. MELVAL=IVAL(ICOMP)
  438. IF (MELVAL.NE.0) THEN
  439. IBMN=MIN(IB ,VELCHE(/2))
  440. WORK(ICOMP+8)=VELCHE(1,IBMN)
  441. ELSE
  442. WORK(ICOMP+8)=0.D0
  443. ENDIF
  444. 5043 CONTINUE
  445. c
  446. c on calcule les forces internes
  447. c
  448. CALL TUFIBS(XFORC,WORK,WORK(9),WORK(18),KERRE)
  449. c
  450. c rangement dans melval
  451. c
  452. IE=0
  453. MPTVAL=IVAFOR
  454. DO 6043 IGAU=1,NBNN
  455. DO 6043 ICOMP=1,NFOR
  456. IE=IE+1
  457. MELVAL=IVAL(ICOMP)
  458. IBMN=MIN(IB ,VELCHE(/2))
  459. VELCHE(IGAU,IBMN)=XFORC(IE)
  460. 6043 CONTINUE
  461. 3043 CONTINUE
  462. SEGSUP WRK1,WRK3
  463. GO TO 510
  464. c_______________________________________________________________________
  465. c
  466. c element point (poi1) defos planes generalisees/materiau IMPEDANCE
  467. c_______________________________________________________________________
  468. c
  469. 45 CONTINUE
  470. NBBB=NBNN
  471. *
  472. *
  473. IF ((CMATE.EQ.'IMPELAST').OR.(CMATE.EQ.'IMPVOIGT').OR.
  474. & (CMATE.EQ.'IMPREUSS').OR .cmate.eq.'IMPCOMPL'.or.
  475. & cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') THEN
  476. mptva1 = ivastr
  477. mptval = ivafor
  478. segact mptva1,mptval
  479. do iv = 1,ival(/1)
  480. melva1 = mptva1.ival(iv)
  481. melval = ival(iv)
  482. segact melva1,melval*mod
  483. DO IB=1,NBELEM
  484.  
  485. DO 4145 IGAU=1,NBNN
  486. IGMN=MIN(IGAU,MELVA1.VELCHE(/1))
  487. IBMN=MIN(IB ,MELVA1.VELCHE(/2))
  488. valstr = MELVA1.VELCHE(IGMN,IBMN)
  489. VELCHE(IGMN,IBMN) = valstr
  490. 4145 CONTINUE
  491. ENDDO
  492.  
  493. enddo
  494.  
  495. GOTO 510
  496. ENDIF
  497. *
  498. IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN
  499. GO TO 99
  500. ENDIF
  501. *
  502. SEGINI WRK1,WRK3
  503. c
  504. DO 3045 IB=1,NBELEM
  505. c
  506. c on cherche les coordonnees des noeuds de l element ib
  507. c
  508. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  509. c
  510. c mise a zero des forces internes
  511. c
  512. CALL ZERO(XFORC,1,LRE)
  513. c
  514. c on cherche l'effort
  515. c
  516. MPTVAL=IVASTR
  517. MELVAL=IVAL(1)
  518. IBMN=MIN(IB ,VELCHE(/2))
  519. EFFORT=VELCHE(1,IBMN)
  520. c
  521. c on calcule les forces internes
  522. c
  523. CALL PO1BSG(XE,LRE,XDPGE,YDPGE,EFFORT,XFORC)
  524. ADPG=ADPG+XFORC(3)
  525. BDPG=BDPG+XFORC(4)
  526. CDPG=CDPG+XFORC(5)
  527. c
  528. c rangement dans melval
  529. c
  530. IE=0
  531. MPTVAL=IVAFOR
  532. DO 9045 IGAU=1,NBNN
  533. DO 9045 ICOMP=1,NFOR-3
  534. IE=IE+1
  535. MELVAL=IVAL(ICOMP)
  536. IBMN=MIN(IB ,VELCHE(/2))
  537. VELCHE(IGAU,IBMN)=XFORC(IE)
  538. 9045 CONTINUE
  539. 3045 CONTINUE
  540. c
  541. SEGSUP WRK1,WRK3
  542. GO TO 510
  543. c_______________________________________________________________________
  544. c
  545. c elements barre et cerce
  546. c_______________________________________________________________________
  547. c
  548. 46 CONTINUE
  549. NBBB=NBNN
  550. *
  551. IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  552. GO TO 99
  553. ENDIF
  554. *
  555. SEGINI WRK1,WRK3
  556. c
  557. DO 3046 IB=1,NBELEM
  558. c
  559. c on cherche les coordonnees des noeuds de l element ib
  560. c
  561. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  562. C
  563. IF(MELE.EQ.123) THEN
  564. c
  565. c on cherche l'effort
  566. c
  567. IE=0
  568. MPTVAL=IVASTR
  569. DO 4046 IGAU=1,NBPTEL
  570. DO 4046 ICOMP=1,NSTRS
  571. IE=IE+1
  572. MELVAL=IVAL(ICOMP)
  573. IGMN=MIN(IGAU,VELCHE(/1))
  574. IBMN=MIN(IB ,VELCHE(/2))
  575. WORK(IE)=VELCHE(IGMN,IBMN)
  576. 4046 CONTINUE
  577. c
  578. c on calcule les forces internes
  579. c
  580. CALL BARBS3(XFORC,XE,WORK,KERRE,QSIGAU,POIGAU,NBPGAU,IB)
  581. c
  582. ELSE
  583. c
  584. c on cherche l'effort
  585. c
  586. MPTVAL=IVASTR
  587. MELVAL=IVAL(1)
  588. NPPTEL=VELCHE(/1)
  589. IBMN=MIN(IB ,VELCHE(/2))
  590. IF(NPPTEL.EQ.1) THEN
  591. EFFORT=VELCHE(1,IBMN)
  592. ELSE IF(NPPTEL.EQ.2) THEN
  593. EFFOR1=VELCHE(1,IBMN)
  594. EFFOR2=VELCHE(2,IBMN)
  595. EFFORT=0.5D0*(EFFOR1+EFFOR2)
  596. ENDIF
  597. c
  598. c on calcule les forces internes
  599. c
  600. IF(MELE.EQ.46) CALL BARBSG(XFORC,XE,EFFORT,KERRE)
  601. IF(MELE.EQ.95) CALL CERBSG(XFORC,XE,EFFORT,KERRE)
  602. ENDIF
  603. C
  604. IF(KERRE.NE.0) THEN
  605. INTERR(1)=ISOUS
  606. INTERR(2)=IB
  607. SEGSUP WRK1,WRK3
  608. IF(MELE.EQ.46) CALL ERREUR(128)
  609. IF(MELE.EQ.95) CALL ERREUR(128)
  610. GO TO 510
  611. ENDIF
  612. c
  613. c rangement dans melval
  614. c
  615. NFOD=NFOR
  616. IF (IFOUR.EQ.-3.AND.MELE.EQ.46) NFOD=NFOR-3
  617. IE=0
  618. MPTVAL=IVAFOR
  619. DO 9046 IGAU=1,NBNN
  620. DO 9046 ICOMP=1,NFOD
  621. IE=IE+1
  622. MELVAL=IVAL(ICOMP)
  623. IBMN=MIN(IB ,VELCHE(/2))
  624. VELCHE(IGAU,IBMN)=XFORC(IE)
  625. 9046 CONTINUE
  626. 3046 CONTINUE
  627. SEGSUP WRK1,WRK3
  628. GO TO 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. SEGINI WRK1,WRK3,WRK5
  639. C
  640. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  641. C
  642. KERRE=0
  643. DO 3124 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. 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) THEN
  666. INTERR(1)=ISOUS
  667. INTERR(2)=IB
  668. IF(KERRE.EQ.1) CALL ERREUR(128)
  669. ENDIF
  670. C
  671. C MISE A ZERO DES FORCES INTERNES
  672. C
  673. CALL ZERO(XFORC,1,LRE)
  674. C
  675. C ON CHERCHE L'EFFORT
  676. C
  677. MPTVAL=IVASTR
  678. MELVAL=IVAL(1)
  679. IBMN=MIN(IB ,VELCHE(/2))
  680. NPPTEL=VELCHE(/1)
  681. IF(NPPTEL.EQ.1) THEN
  682. EFFORT=VELCHE(1,IBMN)
  683. ELSE IF(NPPTEL.EQ.2) THEN
  684. EFFOR1=VELCHE(1,IBMN)
  685. EFFOR2=VELCHE(2,IBMN)
  686. EFFORT=0.5D0*(EFFOR1+EFFOR2)
  687. ENDIF
  688. CC EFFORT=SECT*EFFORT
  689. C
  690. C ON CALCULE LES FORCES INTERNES
  691. C
  692. CALL BARINT(XFORC,XGENE,EFFORT,LRE)
  693. C
  694. C RANGEMENT DANS MELVAL
  695. C
  696. IE=0
  697. MPTVAL=IVAFOR
  698. DO 9199 IGAU=1,NBNN
  699. DO 9199 ICOMP=1,NFOR
  700. IE=IE+1
  701. MELVAL=IVAL(ICOMP)
  702. IBMN=MIN(IB ,VELCHE(/2))
  703. VELCHE(IGAU,IBMN)=XFORC(IE)
  704. 9199 CONTINUE
  705. 3124 CONTINUE
  706. SEGSUP WRK1,WRK3,WRK5
  707. GO TO 510
  708. c cccccccccccccccccccccccccccccccccccccccccccccccccccccc c
  709. c element coaxial COS2 (3D pour liaison acier-beton) c
  710. c cccccccccccccccccccccccccccccccccccccccccccccccccccccc c
  711. 271 continue
  712. NBBB=NBNN
  713. NSTN=NBNN
  714. LRN =LRE
  715. SEGINI WRK1,WRK3,WRK4,WRK5
  716. do 2713 ib=1,nbelem
  717. C
  718. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  719. vx1= xe(1,2) - xe(1,1)
  720. vy1= xe(2,2) - xe(2,1)
  721. vz1=0.d0
  722. if(idim.eq.3) vz1= xe(3,2)-xe(3,1)
  723. xl= sqrt( vx1*vx1 + vy1*vy1 + vz1*vz1)
  724. vx1= vx1 / xl
  725. vy1= vy1/ xl
  726. if(idim.eq.3) THEN
  727. vz1=vz1 / xl
  728. ENDIF
  729.  
  730. IE=0
  731. MPTVAL=IVASTR
  732. DO 2711 IGAU=1,2
  733. DO 2711 ICOMP=1,NSTRS
  734. IE=IE+1
  735. MELVAL=IVAL(ICOMP)
  736. IGMN=MIN(IGAU,VELCHE(/1))
  737. IBMN=MIN(IB ,VELCHE(/2))
  738. WORK(IE)=VELCHE(IGMN,IBMN)
  739. 2711 CONTINUE
  740. C
  741. MPTVAL=IVAcar
  742. DO 2712 ICOMP=1,NCARR
  743. MELVAL=IVAL(ICOMP)
  744. IGMN = VELCHE(/1)
  745. IBMN=MIN(IB,VELCHE(/2))
  746. SECA =VELCHE(IGMN,IBMN)
  747. 2712 CONTINUE
  748. diam = sqrt(4.d0*SECA/xpi)
  749. C
  750. C MISE A ZERO DES FORCES INTERNES
  751. C
  752. CALL ZERO(XFORC,1,LRE)
  753. C
  754. C
  755. C FORCES DANS LA DIRECTION TANGENTIELLE
  756. C
  757. ag = 1.d0-0.5773502691896257645d0
  758. agg = ag/(2.d0*(1-ag))
  759. t11 = work(1) + (work(1) -work(1 + idim))*agg
  760. t21 = work(1 + idim) + (work(1 + idim) -work(1))*agg
  761. FO11 = xpi*diam*xl*(t11/2.d0 + (t21 - t11)/8.d0)
  762. FO21 = xpi*diam*xl*(t21/2.d0 + (t11 - t21)/8.d0)
  763. C
  764. C FORCES DANS LA DIRECTION NORMALE
  765. C
  766. t12 = WORK(2) + (work(2) -work(2 + idim))*agg
  767. t22 = WORK(2 + IDIM)+ (work(2 + idim) -work(2))*agg
  768. FO12 = -1.d0*diam*xl*(t12/2.d0 + (t22 - t12)/8.d0)
  769. FO22 = -1.d0*diam*xl*(t22/2.d0 + (t12 - t22)/8.d0)
  770. c write(6,*) 'xstrs 1',ib,t11,t12,t12
  771. c write(6,*) 'xstrs 2',ib,t21,t22,t22
  772. IF (IDIM.EQ.2) THEN
  773. XFORC(1) = (FO11*VX1 + FO12*VY1) + XFORC(1)
  774. XFORC(3) = (FO21*VX1 + FO22*VY1) + XFORC(3)
  775. XFORC(2) = (FO11*VY1 + FO12*VX1) + XFORC(2)
  776. XFORC(4) = (FO21*VY1 + FO22*VX1) + XFORC(4)
  777. XFORC(5) = (-1.d0*(FO11*VX1 + FO12*VY1)) + XFORC(5)
  778. XFORC(7) = (-1.d0*(FO21*VX1 + FO22*VY1)) + XFORC(7)
  779. XFORC(6) = (-1.d0*(FO11*VY1 + FO12*VX1)) + XFORC(6)
  780. XFORC(8) = (-1.d0*(FO21*VY1 + FO22*VX1)) + XFORC(8)
  781. ELSE IF (IDIM.EQ.3) THEN
  782. IF (vy1.EQ.0.0D0.AND.vz1.EQ.0.0D0) THEN
  783. vx22 = 0.0D0
  784. vy22 = 1.0D0
  785. vz22 = 0.0D0
  786. ELSE IF ((vx1.EQ.0.0D0.AND.vy1.EQ.0.0D0).OR.
  787. . (vx1.EQ.0.0D0.AND.vz1.EQ.0.0D0)) THEN
  788. vx22 = 1.0D0
  789. vy22 = 0.0D0
  790. vz22 = 0.0D0
  791. ELSE IF (vy1.NE.0.0D0.AND.vz1.NE.0.0D0) THEN
  792. Vx22 = 0.0D0
  793. Vy22 = -vz1
  794. Vz22 = vy1
  795. LLL = 1
  796. ELSE IF (vx1.NE.0.0D0.AND.vz1.NE.0.0D0) THEN
  797. Vx22 = -vz1
  798. Vy22 = 0.0D0
  799. Vz22 = vx1
  800. LLL = 1
  801. ELSE IF (vy1.NE.0.0D0.AND.vx1.NE.0.0D0) THEN
  802. Vx22 = -vy1
  803. Vy22 = vx1
  804. Vz22 = 0.0D0
  805. LLL = 1
  806. END IF
  807. xl22 = sqrt((vx22*vx22) + (vy22*vy22)+ (vz22*vz22))
  808. vx22 = vx22/xl22
  809. vy22 = vy22/xl22
  810. vz22 = vz22/xl22
  811. vx3 = (vy1*Vz22) - (vz1*Vy22)
  812. vy3 = (vz1*Vx22) - (vx1*vz22)
  813. vz3 = (vx1*vy22) - (vy1*Vx22)
  814. xl3 = sqrt((vx3*vx3) + (vy3*vy3)+ (vz3*vz3))
  815. vx3 = vx3/xl3
  816. vy3 = vy3/xl3
  817. vz3 = vz3/xl3
  818. vx2 = (vy3*vz1) - (vz3*vy1)
  819. vy2 = (vz3*vx1) - (vx3*vz1)
  820. vz2 = (vx3*vy1) - (vy3*vx1)
  821. xl2 = sqrt((vx2*vx2) + (vy2*vy2)+ (vz2*vz2))
  822. vx2 = vx2/xl2
  823. vy2 = vy2/xl2
  824. vz2 = vz2/xl2
  825. F1 = FO11*vx1 + FO12*vx2 + FO12*vx3
  826. F2 = FO11*vy1 + FO12*vy2 + FO12*vy3
  827. F3 = FO11*vz1 + FO12*vz2 + FO12*vz3
  828. F4 = FO21*vx1 + FO22*vx2 + FO22*vx3
  829. F5 = FO21*vy1 + FO22*vy2 + FO22*vy3
  830. F6 = FO21*vz1 + FO22*vz2 + FO22*vz3
  831. XFORC(1) = F1 + XFORC(1)
  832. XFORC(2) = F2 + XFORC(2)
  833. XFORC(3) = F3 + XFORC(3)
  834. XFORC(4) = F4 + XFORC(4)
  835. XFORC(5) = F5 + XFORC(5)
  836. XFORC(6) = F6 + XFORC(6)
  837. XFORC(7) = -1.d0*F4 + XFORC(7)
  838. XFORC(8) = -1.d0*F5 + XFORC(8)
  839. XFORC(9) = -1.d0*F6 + XFORC(9)
  840. XFORC(10) = -1.d0*F1 + XFORC(10)
  841. XFORC(11) = -1.d0*F2 + XFORC(11)
  842. XFORC(12) = -1.d0*F3 + XFORC(12)
  843. ENDIF
  844. c write(6,*) 'xforc cos2', (xforc(io),io = 1,lre)
  845. C
  846. C RANGEMENT DANS MELVAL
  847. C
  848. IE=0
  849. MPTVAL=IVAFOR
  850. C
  851. C NODE=4= NOMBRE DE NOEUDS
  852. C ICOMP=NSTRS= NOMBRE DE COMPOSANTES DE CONTRAINTES PAR NOEUD
  853. C
  854. DO 2714 NODE=1,4
  855. DO 2714 ICOMP=1,NSTRS
  856. IE=IE+1
  857. MELVAL=IVAL(ICOMP)
  858. IBMN=MIN(IB ,VELCHE(/2))
  859. VELCHE(NODE,IBMN)=XFORC(IE)
  860. 2714 CONTINUE
  861.  
  862. 2713 continue
  863.  
  864. SEGSUP WRK1,WRK3,WRK4,WRK5
  865. GO TO 510
  866.  
  867. C_______________________________________________________________________
  868. C
  869. C ELEMENT COAXIAL (COA2)
  870. C_______________________________________________________________________
  871. C
  872. 272 continue
  873. NBNO=NBNN
  874. NBBB=NBNN
  875. SEGINI WRK1,WRK2,WRK3,WRK4
  876. LW = 24
  877. C
  878. DO 2721 IB=1,NBELEM
  879. C
  880. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  881. C
  882. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  883. C
  884. C MISE A ZERO DES FORCES INTERNES
  885. C
  886. CALL ZERO(XFORC,1,LRE)
  887. C
  888. C REPERE LOCAL
  889. C
  890. CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
  891. C
  892. C BOUCLE SUR LES POINTS DE GAUSS
  893. C
  894. DO 2722 IGAU=1,NBPGAU
  895. C
  896. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  897. C
  898. CALL BCO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  899. . BGENE,DJAC,IRRT,IDIM,NBNN,NSTRS,LRE)
  900. IF(IRRT.NE.0) THEN
  901. INTERR(1)=IB
  902. CALL ERREUR(764)
  903. GOTO 9985
  904. END IF
  905. C
  906. C ON CHERCHE LES CONTRAINTES -
  907. C
  908. MPTVAL=IVASTR
  909. DO 2723 ICOMP=1,NSTRS
  910. MELVAL=IVAL(ICOMP)
  911. IGMN=MIN(IGAU,VELCHE(/1))
  912. IBMN=MIN(IB ,VELCHE(/2))
  913. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  914. 2723 CONTINUE
  915. C
  916. C
  917. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  918. C
  919. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  920. vx1= xe(1,2) - xe(1,1)
  921. vy1= xe(2,2) - xe(2,1)
  922. vz1=0.d0
  923. if(idim.eq.3) vz1= xe(3,2)-xe(3,1)
  924. xl= sqrt( vx1*vx1 + vy1*vy1 + vz1*vz1)
  925. vx1= vx1 / xl
  926. vy1= vy1/ xl
  927. if(idim.eq.3) THEN
  928. vz1=vz1 / xl
  929. ENDIF
  930. C
  931. C recuperation de la section et calcul du diamètre
  932. C
  933. MPTVAL=IVACAR
  934. DO 2729 ICOMP=1,NCARR
  935. MELVAL=IVAL(ICOMP)
  936. IGMN = VELCHE(/1)
  937. IBMN=MIN(IB,VELCHE(/2))
  938. SECA =VELCHE(IGMN,IBMN)
  939. 2729 CONTINUE
  940. diam = sqrt(4.d0*SECA/xpi)
  941. C
  942. C ON CALCULE B*EFFORTS
  943. C
  944. DJAC=DJAC*POIGAU(IGAU)
  945. DO i=1,LRE
  946. cc = 0.D0
  947. DO j=1,NSTRS
  948. cc = cc + (BGENE(j,i) * XSTRS(j))
  949. ENDDO
  950. WORK(i) = xl * cc * DJAC * diam
  951. ENDDO
  952.  
  953. IF (IDIM.EQ.2) THEN
  954. WORK(1) = WORK(1) * xpi
  955. WORK(3) = WORK(3) * xpi
  956. WORK(5) = WORK(5) * xpi
  957. WORK(7) = WORK(7) * xpi
  958. WORK(1+4*idim) = WORK(1)*vx1 - WORK(2)*vy1
  959. WORK(2+4*idim) = WORK(1)*vy1 + WORK(2)*vx1
  960. WORK(3+4*idim) = WORK(3)*vx1 - WORK(4)*vy1
  961. WORK(4+4*idim) = WORK(3)*vy1 + WORK(4)*vx1
  962. WORK(5+4*idim) = WORK(5)*vx1 - WORK(6)*vy1
  963. WORK(6+4*idim) = WORK(5)*vy1 + WORK(6)*vx1
  964. WORK(7+4*idim) = WORK(7)*vx1 - WORK(8)*vy1
  965. WORK(8+4*idim) = WORK(7)*vy1 + WORK(8)*vx1
  966. ELSE IF (IDIM.EQ.3) THEN
  967. WORK(1) = WORK(1) * xpi
  968. WORK(4) = WORK(4) * xpi
  969. WORK(7) = WORK(7) * xpi
  970. WORK(10) = WORK(10) * xpi
  971. IF (vy1.EQ.0.0D0.AND.vz1.EQ.0.0D0) THEN
  972. vx22 = 0.0D0
  973. vy22 = 1.0D0
  974. vz22 = 0.0D0
  975. ELSE IF ((vx1.EQ.0.0D0.AND.vy1.EQ.0.0D0).OR.
  976. . (vx1.EQ.0.0D0.AND.vz1.EQ.0.0D0)) THEN
  977. vx22 = 1.0D0
  978. vy22 = 0.0D0
  979. vz22 = 0.0D0
  980. ELSE IF (vy1.NE.0.0D0.AND.vz1.NE.0.0D0) THEN
  981. Vx22 = 0.0D0
  982. Vy22 = -vz1
  983. Vz22 = vy1
  984. LLL = 1
  985. ELSE IF (vx1.NE.0.0D0.AND.vz1.NE.0.0D0) THEN
  986. Vx22 = -vz1
  987. Vy22 = 0.0D0
  988. Vz22 = vx1
  989. LLL = 1
  990. ELSE IF (vy1.NE.0.0D0.AND.vx1.NE.0.0D0) THEN
  991. Vx22 = -vy1
  992. Vy22 = vx1
  993. Vz22 = 0.0D0
  994. LLL = 1
  995. END IF
  996. xl22 = sqrt((vx22*vx22) + (vy22*vy22)+ (vz22*vz22))
  997. vx22 = vx22/xl22
  998. vy22 = vy22/xl22
  999. vz22 = vz22/xl22
  1000. vx3 = (vy1*Vz22) - (vz1*Vy22)
  1001. vy3 = (vz1*Vx22) - (vx1*vz22)
  1002. vz3 = (vx1*vy22) - (vy1*Vx22)
  1003. xl3 = sqrt((vx3*vx3) + (vy3*vy3)+ (vz3*vz3))
  1004. vx3 = vx3/xl3
  1005. vy3 = vy3/xl3
  1006. vz3 = vz3/xl3
  1007. vx2 = (vy3*vz1) - (vz3*vy1)
  1008. vy2 = (vz3*vx1) - (vx3*vz1)
  1009. vz2 = (vx3*vy1) - (vy3*vx1)
  1010. xl2 = sqrt((vx2*vx2) + (vy2*vy2)+ (vz2*vz2))
  1011. vx2 = vx2/xl2
  1012. vy2 = vy2/xl2
  1013. vz2 = vz2/xl2
  1014. WORK(1+4*idim) = WORK(1)*vx1 + WORK(2)*vx2 + WORK(3)*vx3
  1015. WORK(2+4*idim) = WORK(1)*vy1 + WORK(2)*vy2 + WORK(3)*vy3
  1016. WORK(3+4*idim) = WORK(1)*vz1 + WORK(2)*vz2 + WORK(3)*vz3
  1017. WORK(4+4*idim) = WORK(4)*vx1 + WORK(5)*vx2 + WORK(6)*vx3
  1018. WORK(5+4*idim) = WORK(4)*vy1 + WORK(5)*vy2 + WORK(6)*vy3
  1019. WORK(6+4*idim) = WORK(4)*vz1 + WORK(5)*vz2 + WORK(6)*vz3
  1020. WORK(7+4*idim) = WORK(7)*vx1 + WORK(8)*vx2 + WORK(9)*vx3
  1021. WORK(8+4*idim) = WORK(7)*vy1 + WORK(8)*vy2 + WORK(9)*vy3
  1022. WORK(9+4*idim) = WORK(7)*vz1 + WORK(8)*vz2 + WORK(9)*vz3
  1023. WORK(10+4*idim) = WORK(10)*vx1 + WORK(11)*vx2 + WORK(12)*vx3
  1024. WORK(11+4*idim) = WORK(10)*vy1 + WORK(11)*vy2 + WORK(12)*vy3
  1025. WORK(12+4*idim) = WORK(10)*vz1 + WORK(11)*vz2 + WORK(12)*vz3
  1026. DO i=1,LRE
  1027. XFORC(i) = WORK(i+4*idim) + XFORC(i)
  1028. ENDDO
  1029. END IF
  1030. 2722 CONTINUE
  1031. c write(6,*) 'xforc coa2', (xforc(io),io = 1,lre)
  1032. C
  1033. C RANGEMENT DANS MELVAL
  1034. C
  1035. IE=0
  1036. MPTVAL=IVAFOR
  1037. C
  1038. DO 2724 NODE=1,NBNN
  1039. ** AM 30/04/19
  1040. ** DO 2724 ICOMP=1,NSTRS
  1041. DO 2724 ICOMP=1,IDIM
  1042. IE=IE+1
  1043. MELVAL=IVAL(ICOMP)
  1044. IBMN=MIN(IB ,VELCHE(/2))
  1045. VELCHE(NODE,IBMN)=XFORC(IE)
  1046. 2724 CONTINUE
  1047. 2721 CONTINUE
  1048. 9985 CONTINUE
  1049. SEGSUP WRK1,WRK2,WRK3,WRK4
  1050. GO TO 510
  1051.  
  1052. *-----------------------------------------------
  1053. * element shb8
  1054. *------------------------------------------------
  1055. 260 CONTINUE
  1056. NBBB=NBNN
  1057. SEGINI WRK1,WRK7
  1058. DO 3260 IB=1,NBELEM
  1059. c
  1060. c on cherche les coordonnees des noeuds de l element ib
  1061. c
  1062. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1063. c
  1064. c on cherche les contraintes
  1065. c
  1066. IE=0
  1067. MPTVAL=IVASTR
  1068. DO 7260 IGAU=1,NBPGAU
  1069. DO 7260 ICOMP=1,NSTRS
  1070. IE=IE+1
  1071. MELVAL=IVAL(ICOMP)
  1072. IGMN=MIN(IGAU,VELCHE(/1))
  1073. IBMN=MIN(IB ,VELCHE(/2))
  1074. WORK1(IE)=VELCHE(IGMN,IBMN)
  1075. 7260 CONTINUE
  1076. c
  1077. c on cherche les materiaux
  1078. c
  1079. yyo=0.d0
  1080. ynu=0.d0
  1081. MPTVAL=IVAMAT
  1082. segact mptval
  1083. DO 6260 IGAU=1,NBPGAU
  1084. DO 6260 ICOMP=1,2
  1085. MELVAL=IVAL(ICOMP)
  1086. IF (MELVAL.NE.0) THEN
  1087. IGMN=MIN(IGAU,VELCHE(/1))
  1088. IBMN=MIN(IB ,VELCHE(/2))
  1089. if(icomp.eq.1) yyo=yyo+VELCHE(IGMN,IBMN)/nbpgau
  1090. if(icomp.eq.2)ynu=ynu+VELCHE(IGMN,IBMN)/nbpgau
  1091. ENDIF
  1092. 6260 CONTINUE
  1093. c
  1094. c on calcule b*sigma
  1095. c
  1096. d(1)=yyo
  1097. d(2)=ynu
  1098. d(3)=0
  1099. CALL shb8(8,XE,D,propel,work1,rel,xforc)
  1100. c
  1101. c rangement dans melval
  1102. c
  1103. IE=0
  1104. MPTVAL=IVAFOR
  1105. DO 9260 IGAU=1,Nbnn
  1106. DO 9260 ICOMP=1,3
  1107. IE=IE+1
  1108. MELVAL=IVAL(ICOMP)
  1109. IBMN=MIN(IB ,VELCHE(/2))
  1110. VELCHE(IGAU,IBMN)=XFORC(IE)
  1111. 9260 CONTINUE
  1112. 3260 CONTINUE
  1113. SEGSUP WRK1,WRk7
  1114. GO TO 510
  1115. C_______________________________________________________________________
  1116. C
  1117. C LIA2 : element de liaison a 2 noeuds (6 ddl par
  1118. C noeuds)
  1119. C_______________________________________________________________________
  1120. C
  1121. 125 CONTINUE
  1122. NBBB=NBNN
  1123. NSTN=3
  1124. LRN =3
  1125. SEGINI WRK1,WRK3,WRK5
  1126. C
  1127. KERRE=0
  1128. DO 3109 IB=1,NBELEM
  1129. C
  1130. C MISE A ZERO DES FORCES INTERNES
  1131. C
  1132. CALL ZERO(XFORC,1,LRE)
  1133. C
  1134. MPTVAL=IVACAR
  1135. DO IC=1,NCARR
  1136. IF(IVAL(IC).NE.0) THEN
  1137. MELVAL=IVAL(IC)
  1138. IBMN=MIN(IB,VELCHE(/2))
  1139. WORK(IC)=VELCHE(1,IBMN)
  1140. ELSE
  1141. WORK(IC)=0.D0
  1142. ENDIF
  1143. END DO
  1144. C
  1145. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1146. CALL MAPALI(XE,NBNN,WORK,XGENE,KERRE)
  1147. IF(KERRE.NE.0) THEN
  1148. INTERR(1)=ISOUS
  1149. INTERR(2)=IB
  1150. IF(KERRE.EQ.1) CALL ERREUR(128)
  1151. ENDIF
  1152. C
  1153. C ON CHERCHE LES CONTRAINTES -
  1154. C
  1155. MPTVAL=IVASTR
  1156. IE=0
  1157. DO 7109 IGAU=1,2
  1158. DO 7109 ICOMP=1,NSTRS
  1159. IE=IE+1
  1160. MELVAL=IVAL(ICOMP)
  1161. IBMN=MIN(IB ,VELCHE(/2))
  1162. IGMN=MIN(IGAU,VELCHE(/1))
  1163. XSTRS(IE)=VELCHE(IGMN,IBMN)
  1164. 7109 CONTINUE
  1165. C
  1166. C ON CALCULE LES FORCES INTERNES !!!! a ameliorer
  1167. C
  1168. CALL LIAINT(XSTRS,XGENE,XFORC,LRE,NSTRS)
  1169. C
  1170. C RANGEMENT DANS MELVAL
  1171. C
  1172. IE=0
  1173. MPTVAL=IVAFOR
  1174. DO 9109 IGAU=1,NBNN
  1175. DO 9109 ICOMP=1,NFOR
  1176. IE=IE+1
  1177. MELVAL=IVAL(ICOMP)
  1178. IBMN=MIN(IB ,VELCHE(/2))
  1179. VELCHE(IGAU,IBMN)=XFORC(IE)
  1180. 9109 CONTINUE
  1181. 3109 CONTINUE
  1182. SEGSUP WRK1,WRK3,WRK5
  1183. GO TO 510
  1184. C_______________________________________________________________________
  1185. C
  1186. C JOI1 : element de liaison a 2 noeuds (6 ddl par
  1187. C noeuds)
  1188. C_______________________________________________________________________
  1189. C
  1190. 265 CONTINUE
  1191. NBBB=NBNN
  1192. NSTN=3
  1193. LRN =3
  1194. SEGINI WRK1,WRK3,WRK4
  1195. C
  1196. KERRE=0
  1197. DO 3110 IB=1,NBELEM
  1198. C
  1199. C MISE A ZERO DES FORCES INTERNES
  1200. C
  1201. CALL ZERO(XFORC,1,LRE)
  1202. C
  1203. MPTVAL=IVAMAT
  1204. DO IC=1,NMATT
  1205. IF(IVAL(IC).NE.0) THEN
  1206. MELVAL=IVAL(IC)
  1207. IBMN=MIN(IB,VELCHE(/2))
  1208. WORK(IC)=VELCHE(1,IBMN)
  1209. ELSE
  1210. WORK(IC)=0.D0
  1211. ENDIF
  1212. END DO
  1213. C
  1214. CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  1215. C
  1216. C ON CHERCHE LES CONTRAINTES -
  1217. C
  1218. MPTVAL=IVASTR
  1219.  
  1220. IE=0
  1221. DO 7110 ICOMP=1,NSTRS
  1222. IE=IE+1
  1223. MELVAL=IVAL(ICOMP)
  1224. IBMN=MIN(IB ,VELCHE(/2))
  1225. XSTRS(IE)=VELCHE(1,IBMN)
  1226. 7110 CONTINUE
  1227. C
  1228. C ON CALCULE LES FORCES INTERNES
  1229. C
  1230. CALL INTJOI(XSTRS,XFORC,NSTRS)
  1231. C
  1232. C ON PASSE LES CONTRAINTES DANS LE REPERE GLOBAL
  1233. C
  1234. IAW1 = 101
  1235. IAW2=IAW1+LRE
  1236. CALL JOIGLV(XFORC,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM)
  1237. C
  1238. C RANGEMENT DANS MELVAL
  1239. C
  1240. IE=0
  1241. MPTVAL=IVAFOR
  1242. DO 9110 IGAU=1,NBNN
  1243. DO 9110 ICOMP=1,NFOR
  1244. IE=IE+1
  1245. MELVAL=IVAL(ICOMP)
  1246. IBMN=MIN(IB ,VELCHE(/2))
  1247. VELCHE(IGAU,IBMN)=XFORC(IE)
  1248. 9110 CONTINUE
  1249. 3110 CONTINUE
  1250. SEGSUP WRK1,WRK3,WRK4
  1251. GO TO 510
  1252. c_______________________________________________________________________
  1253. c
  1254. c element tuyo
  1255. c_______________________________________________________________________
  1256. c
  1257. 96 CONTINUE
  1258. NBBB=NBNN
  1259. SEGINI WRK1,WRK3
  1260. c
  1261. DO 3096 IB=1,NBELEM
  1262. c
  1263. c on cherche les coordonnees des noeuds de l elementib
  1264. c
  1265. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1266. c
  1267. c il faudrait aussi modifier le vecteur local de la poutre
  1268. c
  1269. c mise a zero des forces internes
  1270. c
  1271. CALL ZERO(XFORC,1,LRE)
  1272. c
  1273. c rangement des caracteristiques dans work
  1274. c
  1275. MPTVAL=IVACAR
  1276. DO 6096 IC=1,NCARR
  1277. IF (IVAL(IC).NE.0) THEN
  1278. MELVAL=IVAL(IC)
  1279. IBMN=MIN(IB,VELCHE(/2))
  1280. WORK(IC)=VELCHE(1,IBMN)
  1281. ELSE
  1282. WORK(IC)=0.D0
  1283. ENDIF
  1284. 6096 CONTINUE
  1285. c
  1286. c cas ou on a lu le mot vecteur
  1287. c
  1288. IF (IVECT.EQ.1) THEN
  1289. IF (IVAL(NCARR).NE.0) THEN
  1290. MELVAL=IVAL(NCARR)
  1291. IBMN=MIN(IB,IELCHE(/2))
  1292. IP=IELCHE(1,IBMN)
  1293. IREF=(IP-1)*(IDIM+1)
  1294. DO 6196 IC=1,IDIM
  1295. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  1296. 6196 CONTINUE
  1297. ELSE
  1298. DO 6296 IC=1,IDIM
  1299. WORK(NCARR+IC-1)=0.D0
  1300. 6296 CONTINUE
  1301. ENDIF
  1302. c
  1303. c cas du chamelem comverti
  1304. c
  1305. ELSE IF (IVECT.EQ.2) THEN
  1306. DO 6496 IC=1,IDIM
  1307. MELVAL=IVAL(NCARR+IC-3)
  1308. IF (MELVAL.NE.0) THEN
  1309. IBMN=MIN(IB,VELCHE(/2))
  1310. WORK(NCARR+IC-3)=VELCHE(1,IBMN)
  1311. ELSE
  1312. WORK(NCARR+IC-3)=0.D0
  1313. ENDIF
  1314. 6496 CONTINUE
  1315. ENDIF
  1316. c
  1317. c
  1318. c cas des tuyaux - on calcule les caracteristiques de la poutre
  1319. c equivalente
  1320. c
  1321. *Bizarre ici MELE = 96 ???
  1322. IF(MELE.EQ.42) THEN
  1323. CISA=WORK(4)
  1324. VX =WORK(5)
  1325. VY =WORK(6)
  1326. VZ =WORK(7)
  1327. CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,0)
  1328. IF (KERRE.EQ.77) THEN
  1329. CALL ERREUR(77)
  1330. GOTO 510
  1331. ENDIF
  1332. ENDIF
  1333. c
  1334. c on cherche les contraintes -
  1335. c
  1336. MPTVAL=IVASTR
  1337. IE=9
  1338. DO 7096 IGAU=1,2
  1339. DO 7096 ICOMP=1,NSTRS
  1340. IE=IE+1
  1341. MELVAL=IVAL(ICOMP)
  1342. IBMN=MIN(IB ,VELCHE(/2))
  1343. IGMN=MIN(IGAU,VELCHE(/1))
  1344. WORK(IE)=VELCHE(IGMN,IBMN)
  1345. 7096 CONTINUE
  1346. c
  1347. c on calcule les forces internes
  1348. c
  1349. CALL POUBSG(XFORC,WORK,XE,WORK(10),WORK(22),KERRE)
  1350. IF(KERRE.EQ.0) GO TO 5096
  1351. INTERR(1)=ISOUS
  1352. INTERR(2)=IB
  1353. SEGSUP WRK1,WRK3
  1354. CALL ERREUR(128)
  1355. GO TO 510
  1356. 5096 CONTINUE
  1357. c
  1358. c rangement dans melval
  1359. c
  1360. IE=0
  1361. MPTVAL=IVAFOR
  1362. DO 9096 IGAU=1,NBNN
  1363. DO 9096 ICOMP=1,NFOR
  1364. IE=IE+1
  1365. MELVAL=IVAL(ICOMP)
  1366. IBMN=MIN(IB ,VELCHE(/2))
  1367. VELCHE(IGAU,IBMN)=XFORC(IE)
  1368. 9096 CONTINUE
  1369. 3096 CONTINUE
  1370. SEGSUP WRK1,WRK3
  1371. GO TO 510
  1372.  
  1373. C_______________________________________________________________________
  1374. C
  1375. C ELEMENTS ZONE_COHESIVE ZOC2,ZOC3,ZOC4
  1376. C_______________________________________________________________________
  1377. C
  1378. 266 CONTINUE
  1379.  
  1380. NDIM = 2
  1381. IF(IFOUR.GT.0) NDIM = 3
  1382. NBBB=NBNN
  1383. SEGINI WRK1,WRK2,WRK4
  1384. C
  1385. DO 3266 IB=1,NBELEM
  1386. C
  1387. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1388. C
  1389. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1390. C
  1391. C MISE A ZERO DES FORCES INTERNES
  1392. C
  1393. CALL ZERO(XFORC,1,LRE)
  1394. C
  1395. C BOUCLE SUR LES POINTS DE GAUSS
  1396. C
  1397. DO 6266 IGAU=1,NBPGAU
  1398. C
  1399. CALL ZCOLOC(XE,SHPTOT,NBNN,MELE,IFOUR,IGAU,BPSS)
  1400. C
  1401. CALL BZCO(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,
  1402. . NSTRS,NBNN,LRE,MELE,SHPWRK,BGENE,DJAC,IERT)
  1403. IF (IERT.NE.0) THEN
  1404. INTERR(1)=IB
  1405. CALL ERREUR(612)
  1406. GOTO 99266
  1407. ENDIF
  1408. C
  1409. C ON CHERCHE LES CONTRAINTES -
  1410. C
  1411. MPTVAL=IVASTR
  1412. DO 7266 ICOMP=1,NSTRS
  1413. MELVAL=IVAL(ICOMP)
  1414. IGMN=MIN(IGAU,VELCHE(/1))
  1415. IBMN=MIN(IB ,VELCHE(/2))
  1416. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  1417. 7266 CONTINUE
  1418. C
  1419. C ON CALCULE B*EFFORTS
  1420. C
  1421. DJAC=DJAC*POIGAU(IGAU)
  1422. CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  1423. 6266 CONTINUE
  1424. C
  1425. C TRAITEMENT DE XFORC ET RANGEMENT DANS MELVAL
  1426. C
  1427. IE=0
  1428. MPTVAL=IVAFOR
  1429. C
  1430. DO 9266 NODE=1,NBNN
  1431. DO 9266 ICOMP=1,NDIM
  1432. IE=IE+1
  1433. MELVAL=IVAL(ICOMP)
  1434. IBMN=MIN(IB ,VELCHE(/2))
  1435. VELCHE(NODE,IBMN)=XFORC(IE)
  1436. 9266 CONTINUE
  1437. 3266 CONTINUE
  1438.  
  1439. 99266 CONTINUE
  1440. SEGSUP WRK1,WRK2,WRK4
  1441. GOTO 510
  1442. c_______________________________________________________________________
  1443. 99 CONTINUE
  1444. MOTERR(1:4)=NOMTP(MELE)
  1445. MOTERR(5:12)='BSIGMA'
  1446. CALL ERREUR(86)
  1447. *
  1448. 510 CONTINUE
  1449. RETURN
  1450. END
  1451.  
  1452.  
  1453.  
  1454.  
  1455.  
  1456.  
  1457.  
  1458.  

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