Télécharger sigma3.eso

Retour à la liste

Numérotation des lignes :

  1. C SIGMA3 SOURCE PV 19/01/25 21:15:19 10085
  2. SUBROUTINE SIGMA3(IPMAIL,IVADEP,NDEP,IVACAR,NCARR,IPMINT,
  3. & IVECT,IVAMAT,MELE,IMAT,NELMAT,NBGMAT,LHOOK,CMATE,IREPS2,
  4. & NBPTEL,NSTRS,MFR,NMATT,NBPGAU,ISOUS,LRE,LW,IVASTR,UZDPG,
  5. & RYDPG,RXDPG,IIPDPG,inoer)
  6. *---------------------------------------------------------------------*
  7. * __________________________ *
  8. * | | *
  9. * | CALCUL DES CONTRAINTES| *
  10. * |________________________| *
  11. * *
  12. * poutre,tuyau,linespring,tuyau fissure,barre,cerce,tuyo,shb8 *
  13. * *
  14. * *
  15. *---------------------------------------------------------------------*
  16. * *
  17. * ENTREES : *
  18. * ________ *
  19. * *
  20. * IPMAIL Pointeur sur un segment MELEME *
  21. * IVADEP Pointeur sur le chamelem de deplacements *
  22. * NDEP Nombre de composantes de deplacements *
  23. * IVACAR Pointeur sur les chamelems de caracteristiques *
  24. * NCARR Nombre de caracteristiques geometriques *
  25. * IVECT Flag indiquant si on a entree les axes locaux *
  26. * IVAMAT Pointeur sur un segment MPTVAL pour le materiau ou *
  27. * MELE Numero de l'element fini *
  28. * IMAT (2 il y a une matrice de HOOKE,1 non ) *
  29. * NELMAT Taille maxi des melval du materiau (No d'element) *
  30. * NBGMAT Taille maxi des melval du materiau (pt de gauss) *
  31. * LHOOK Dimension de la matrice de Hooke *
  32. * CMATE Nom du materiau *
  33. * IRESP2 Flag pour indiquer si on veut les contraintes *
  34. * de Piola-Kirchhoff *
  35. * NBPTEL Nombre de points par element *
  36. * NSTRS Nombre de composante de contraintes/deformations *
  37. * MFR Numero de formulation de l'element fini *
  38. * NMATT Nombre de composante de materiau (IMAT=1) *
  39. * pour une matrice de hooke *
  40. * NBPGAU Nombre de point d'integration pour la rigidite *
  41. * ISOUS NUMERO DE LA SOUS-ZONE *
  42. * LRE Nombre de ddl dans la matrice de rigidite *
  43. * LW Dimension du tableau de travail de l'element *
  44. * *
  45. * SORTIES : *
  46. * ________ *
  47. * *
  48. * IVASTR pointeur sur un segment MPTVAL contenant les *
  49. * les melvals de contraints *
  50. * *
  51. *---------------------------------------------------------------------*
  52. IMPLICIT INTEGER(I-N)
  53. IMPLICIT REAL*8(A-H,O-Z)
  54. INTEGER KERRE
  55. *
  56. -INC CCOPTIO
  57. -INC CCHAMP
  58. -INC CCREEL
  59. -INC SMCHAML
  60. -INC SMINTE
  61. -INC SMELEME
  62. -INC SMCOORD
  63. -INC SMLREEL
  64. *
  65. SEGMENT WRK1
  66. REAL*8 DDHOOK(LHOOK,LHOOK) ,XDDL(LRE) ,XSTRS(NSTRS)
  67. REAL*8 XE(3,NBBB) ,DDHOMU(NSTRS,NSTRS)
  68. ENDSEGMENT
  69. *
  70. SEGMENT WRK2
  71. REAL*8 BPSS(3,3) ,BGENE(LHOOK,LRE)
  72. ENDSEGMENT
  73. *
  74. SEGMENT WRK3
  75. REAL*8 WORK(LW)
  76. ENDSEGMENT
  77. *
  78. SEGMENT WRK5
  79. REAL*8 XGENE(NSTN,LRN)
  80. ENDSEGMENT
  81. *
  82. SEGMENT WRK7
  83. REAL*8 PROPEL(45)
  84. REAL*8 OUT(30),rel(1,1),work1(24)
  85. ENDSEGMENT
  86. *
  87. SEGMENT,MVELCH
  88. REAL*8 VALMAT(NV1)
  89. ENDSEGMENT
  90. *
  91. SEGMENT MPTVAL
  92. INTEGER IPOS(NS) ,NSOF(NS)
  93. INTEGER IVAL(NCOSOU)
  94. CHARACTER*16 TYVAL(NCOSOU)
  95. ENDSEGMENT
  96. *
  97. DIMENSION CRIGI(12),CMASS(12)
  98. CHARACTER*4 CMOT
  99. CHARACTER*8 CMATE
  100.  
  101. KERRE=0
  102. *
  103. * INITIALISATION DU POINT AUTOUR DUQUEL SE FAIT LE MOUVEMENT
  104. * EN DEFORMATION PLANE GENERALISEE
  105. *
  106. IF (IFOUR.EQ.-3) THEN
  107. IP=IIPDPG
  108. SEGACT MCOORD
  109. IREF=(IP-1)*(IDIM+1)
  110. XDPGE=XCOOR(IREF+1)
  111. YDPGE=XCOOR(IREF+2)
  112. ELSE
  113. XDPGE=0.D0
  114. YDPGE=0.D0
  115. ENDIF
  116. *
  117. MELEME=IPMAIL
  118. NBNN=NUM(/1)
  119. NBELEM=NUM(/2)
  120. *
  121. NV1=NMATT
  122. SEGINI,MVELCH
  123. *
  124. NHRM=NIFOUR
  125. MINTE=IPMINT
  126. *
  127. IRTD=1
  128. NBBB=NBNN
  129. SEGINI WRK1
  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,99,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,258,34,
  159. 3 260,34,34,34,34,265),MELE-200
  160. C
  161. 34 CONTINUE
  162. C
  163. GOTO 99
  164. C_______________________________________________________________________
  165. CC
  166. C____________________________________________________________________
  167. C
  168. C ELEMENTS POUTRES TUYAUX
  169. C____________________________________________________________________
  170. C
  171. 29 CONTINUE
  172. SEGINI WRK3
  173. C
  174. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  175. C
  176. DO 3029 IB=1,NBELEM
  177. C
  178. C ON CHERCHE LES DEPLACEMENTS
  179. C
  180. IE=1
  181. NCARR1=NCARR
  182. IF(IVECT.EQ.1) NCARR1=NCARR-1
  183. CALL ZERO(WORK,NCARR1,1)
  184. DO 4029 IGAU=1,NBNN
  185. MPTVAL=IVADEP
  186. DO 4039 ICOMP=1,NDEP
  187. MELVAL=IVAL(ICOMP)
  188. IGMN=MIN(IGAU,VELCHE(/1))
  189. IBMN=MIN(IB ,VELCHE(/2))
  190. XDDL(IE)=VELCHE(IGMN,IBMN)
  191. IE=IE+1
  192. 4039 CONTINUE
  193. C
  194. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  195. C
  196. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  197. C
  198. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  199. C SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION
  200. C
  201. MPTVAL=IVACAR
  202. DO 6029 IC=1,NCARR1
  203. IF (IVAL(IC).NE.0) THEN
  204. MELVAL=IVAL(IC)
  205. IBMN=MIN(IB,VELCHE(/2))
  206. IGMN=MIN(IGAU,VELCHE(/1))
  207. WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  208. ELSE
  209. WORK(IC)=0.D0
  210. ENDIF
  211. C
  212. IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  213. 6029 CONTINUE
  214. 4029 CONTINUE
  215. C
  216. C CAS OU ON A LU LE MOT VECTEUR
  217. C
  218. C
  219. IF ((IVECT.EQ.1).AND.(IFOUR.EQ.2)) THEN
  220. C
  221. IF (IVAL(NCARR).NE.0) THEN
  222. MELVAL=IVAL(NCARR)
  223. IBMN=MIN(IB,IELCHE(/2))
  224. IP=IELCHE(1,IBMN)
  225. IREF=(IP-1)*(IDIM+1)
  226. DO 6129 IC=1,IDIM
  227. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  228. 6129 CONTINUE
  229. ELSE
  230. DO 6229 IC=1,IDIM
  231. WORK(NCARR+IC-1)=0.D0
  232. 6229 CONTINUE
  233. ENDIF
  234. ENDIF
  235. C
  236. C TRAITEMENT DU MATERIAU
  237. C
  238. MPTVAL=IVAMAT
  239. MELVAL=IVAL(1)
  240. *
  241. IF(CMATE.NE.'SECTION') THEN
  242. IBMN=MIN(IB,VELCHE(/2))
  243. YOUNG=VELCHE(1,IBMN)
  244. C
  245. C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE EQUIVA
  246. C
  247. IF(MELE.EQ.42) THEN
  248. PRES=WORK(4)
  249. CISA=WORK(5)
  250. WORK(4)=WORK(6)
  251. WORK(5)=WORK(7)
  252. WORK(6)=WORK(8)
  253. WORK(7)=PRES
  254. WORK(8)=CISA
  255. CALL TUYKAR(WORK,KERRE,2,YOUNG)
  256. ENDIF
  257. IF (KERRE.EQ.77) THEN
  258. CALL ERREUR(77)
  259. GOTO 510
  260. ENDIF
  261. C
  262. C ON CHERCHE LES COEFF DES MAT DE HOOKE
  263. C
  264. MPTVAL=IVAMAT
  265. IF(IMAT.EQ.2) THEN
  266. MELVAL=IVAL(1)
  267. IBMN=MIN(IB ,IELCHE(/2))
  268. MLREEL=IELCHE(1,IBMN)
  269. SEGACT MLREEL
  270. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  271. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  272. SEGDES MLREEL
  273. C-------------
  274. C PROVISOIRE
  275. C-------------
  276. *
  277. C
  278. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  279. C
  280. WORK(4)=DDHOOK(1,1)/WORK(1)
  281. WORK(5)=DDHOOK(2,2)/(MAX(WORK(3),WORK(1)))
  282. ELSE
  283. WORK(10)=DDHOOK(1,1)/WORK(4)
  284. WORK(11)=DDHOOK(4,4)/WORK(1)
  285. ENDIF
  286. ELSE IF (IMAT.EQ.1) THEN
  287. *
  288. DO 9029 IM=1,NMATT
  289. IF (IVAL(IM).NE.0) THEN
  290. MELVAL=IVAL(IM)
  291. IBMN=MIN(IB ,VELCHE(/2))
  292. VALMAT(IM)=VELCHE(1,IBMN)
  293. ELSE
  294. VALMAT(IM)=0.D0
  295. ENDIF
  296. 9029 CONTINUE
  297. IF(MELE.EQ.84) THEN
  298. C
  299. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  300. CALL DOHTI2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  301. ELSE
  302. C
  303. CALL DOHTIM(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  304. ENDIF
  305. ELSE
  306. C
  307. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  308. CALL DOHPT2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  309. ELSE
  310. C
  311. CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  312. ENDIF
  313. ENDIF
  314. C-------------
  315. C PROVISOIRE
  316. C-------------
  317. C
  318. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  319. WORK(4)=VALMAT(1)
  320. AUX=VALMAT(2)
  321. WORK(5)=WORK(4)*0.5D0/(1.D0+AUX)
  322. ELSE
  323. C
  324. WORK(10)=VALMAT(1)
  325. AUX=VALMAT(2)
  326. WORK(11)=WORK(10)*0.5D0/(1.D0+AUX)
  327. ENDIF
  328. C-------------
  329. ENDIF
  330. *
  331. * CAS DE LA FORMULATION SECTION
  332. *
  333. ELSE
  334. IF(IMAT.EQ.2) THEN
  335. MELVAL=IVAL(1)
  336. IBMN=MIN(IB ,IELCHE(/2))
  337. MLREEL=IELCHE(1,IBMN)
  338. SEGACT MLREEL
  339. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  340. $ CALL DOHOOO(PROG,LHOOK,DDHOOK)
  341. SEGDES MLREEL
  342. ELSE IF (IMAT.EQ.1) THEN
  343. *
  344. * ON REGARDE SI ON A LA COMPOSANTE MAHO
  345. * SI OUI, ON LA PREND
  346. *
  347. IF(IVAL(3).NE.0) THEN
  348. MELVAL=IVAL(3)
  349. IBMN=MIN(IB ,IELCHE(/2))
  350. MLREEL=IELCHE(1,IBMN)
  351. SEGACT MLREEL
  352. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  353. $ CALL DOHOOO(PROG,LHOOK,DDHOOK)
  354. SEGDES MLREEL
  355. ELSE
  356. IBMN=MIN(IB,IELCHE(/2))
  357. IPMODL=IELCHE(1,IBMN)
  358. MELVAL=IVAL(2)
  359. IBMN=MIN(IB,IELCHE(/2))
  360. IPMAT=IELCHE(1,IBMN)
  361. CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS)
  362. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  363. $ CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  364. ENDIF
  365. ENDIF
  366. ENDIF
  367. C
  368. C ON CALCULE LES CONTRAINTES ( STOCKEES DANS WORK ET NON PAS DANS XSTRS
  369. C
  370. IF(MELE.EQ.84) THEN
  371. IF(CMATE.NE.'SECTION') THEN
  372. C
  373. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  374. CALL TIMST2(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2)
  375. ELSE
  376. C
  377. CALL TIMSTR(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2)
  378. ENDIF
  379. ELSE
  380. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  381. CALL TIFST2(XE,XDDL,LHOOK,DDHOOK,
  382. $ WORK(12),WORK(25),IREPS2)
  383. ELSE
  384. CALL TIFSTR(XE,XDDL,LHOOK,DDHOOK,WORK,
  385. $ WORK(12),WORK(25),IREPS2)
  386. ENDIF
  387. ENDIF
  388. ELSE
  389. C
  390. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  391. CALL POUST2(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2)
  392. ELSE
  393. C
  394. CALL POUSTR(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2)
  395. ENDIF
  396. ENDIF
  397. C
  398. C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES
  399. C
  400. ID=12
  401. DO 7029 IGAU=1,NBPTEL
  402. MPTVAL=IVASTR
  403. DO 7029 ICOMP=1,NSTRS
  404. MELVAL=IVAL(ICOMP)
  405. IBMN=MIN(IB ,VELCHE(/2))
  406. VELCHE(IGAU,IBMN)=WORK(ID)
  407. ID=ID+1
  408. 7029 CONTINUE
  409. C
  410. 3029 CONTINUE
  411. IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN
  412. MOTERR(1:8)=CMATE
  413. MOTERR(9:12)=NOMFR(MFR/2+1)
  414. INTERR(1)=IFOUR
  415. CALL ERREUR(81)
  416. ENDIF
  417. SEGSUP MVELCH,WRK1,WRK3
  418. GOTO 510
  419. C____________________________________________________________________
  420. C
  421. C ELEMENT LINESPRING LISP ET LISM
  422. C____________________________________________________________________
  423. C
  424. 30 CONTINUE
  425. NSTR=NSTRS
  426. NSTRS=2
  427. C ATTENTION ON NE SERT PAS DE XSTRS(NSTRS) DS WRK1
  428. C
  429. SEGINI WRK3
  430. C
  431. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELELEMTS
  432. C
  433. DO 3030 IB=1,NBELEM
  434. C
  435. C ON CHERCHE LES DEPLACEMENTS
  436. C
  437. IE=1
  438. DO 4030 IGAU=1,NBNN
  439. MPTVAL=IVADEP
  440. DO 4030 ICOMP=1,NDEP
  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. 4030 CONTINUE
  447. C
  448. C ON CHERCHE LES COORDONNEES DES NOEUDS ET ON REACTUALISE
  449. C
  450. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  451. C
  452. C ON CHERCHE LA MATRICE DE HOOKE
  453. C
  454. MPTVAL=IVAMAT
  455. IF(IMAT.EQ.2) THEN
  456. MELVAL=IVAL(1)
  457. IBMN=MIN(IB ,IELCHE(/2))
  458. MLREEL=IELCHE(1,IBMN)
  459. SEGACT MLREEL
  460. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  461. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  462. SEGDES MLREEL
  463. ELSE IF (IMAT.EQ.1) THEN
  464. DO 9030 IM=1,NMATT
  465. IF (IVAL(IM).NE.0) THEN
  466. MELVAL=IVAL(IM)
  467. IBMN=MIN(IB ,VELCHE(/2))
  468. VALMAT(IM)=VELCHE(1,IBMN)
  469. ELSE
  470. VALMAT(IM)=0.D0
  471. ENDIF
  472. 9030 CONTINUE
  473. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  474. 1 CALL DOHLIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  475. ENDIF
  476. C
  477. C ON CHERCHE LES CARACTERISTIQUES ON OUBLIE LE 2 IEME PT DE GAUSS
  478. C
  479. IE=1
  480. DO 7030 IC=1,3,2
  481. MPTVAL=IVACAR
  482. DO 7030 ICOMP=1,NCARR
  483. MELVAL=IVAL(ICOMP)
  484. IF (MELVAL.NE.0) THEN
  485. IGMN=MIN(IC,VELCHE(/1))
  486. IBMN=MIN(IB,VELCHE(/2))
  487. WORK(IE)=VELCHE(IGMN,IBMN)
  488. ELSE
  489. WORK(IE)=0.D0
  490. ENDIF
  491. IE=IE+1
  492. 7030 CONTINUE
  493. C
  494. C CALCUL DES CONTRAINTES
  495. C
  496. CALL LISPST(XE,WORK,DDHOOK,XDDL,WORK(11),NBPGAU,MELE,WORK(53),
  497. 1 I69,I70,I195,I157)
  498. C
  499. IF(I69.NE.0) THEN
  500. CALL ERREUR( 69)
  501. * RETURN
  502. ENDIF
  503. IF(I70.NE.0) THEN
  504. CALL ERREUR( 70)
  505. * RETURN
  506. ENDIF
  507. IF(I195.NE.0) THEN
  508. if (inoer.eq.0) then
  509. CALL ERREUR( 195)
  510. * RETURN
  511. else
  512. call soucis(195)
  513. endif
  514. ENDIF
  515. IF(I157.NE.0) THEN
  516. CALL ERREUR( 157)
  517. * RETURN
  518. ENDIF
  519. IE=1
  520. DO 8030 IGAU=1,NBPTEL
  521. MPTVAL=IVASTR
  522. DO 8030 ICOMP=1,NSTR
  523. MELVAL=IVAL(ICOMP)
  524. IBMN=MIN(IB ,VELCHE(/2))
  525. VELCHE(IGAU,IBMN)=WORK(52+IE)
  526. IE=IE+1
  527. 8030 CONTINUE
  528. 3030 CONTINUE
  529. IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN
  530. MOTERR(1:8)=CMATE
  531. MOTERR(9:12)=NOMFR(MFR/2+1)
  532. INTERR(1)=IFOUR
  533. CALL ERREUR(81)
  534. ENDIF
  535. SEGSUP MVELCH,WRK1,WRK3
  536. GOTO 510
  537. C____________________________________________________________________
  538. C____________________________________________________________________
  539. C
  540. C ELEMENT TUYAU FISSURE
  541. C____________________________________________________________________
  542. C
  543. 43 CONTINUE
  544. C ATTENTION ON NE SERT PAS DE XSTRS(NSTRS) DS WRK1
  545. C
  546. SEGINI WRK3
  547. C
  548. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  549. C
  550. DO 3043 IB=1,NBELEM
  551. C
  552. C ON CHERCHE LES DEPLACEMENTS
  553. C
  554. IE=1
  555. DO 4043 IGAU=1,NBNN
  556. MPTVAL=IVADEP
  557. DO 4043 ICOMP=1,NDEP
  558. MELVAL=IVAL(ICOMP)
  559. IGMN=MIN(IGAU,VELCHE(/1))
  560. IBMN=MIN(IB ,VELCHE(/2))
  561. XDDL(IE)=VELCHE(IGMN,IBMN)
  562. IE=IE+1
  563. 4043 CONTINUE
  564. C
  565. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  566. C
  567. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  568. C
  569. C ON CHERCHE LES CARACTERISTIQUES
  570. C
  571. MPTVAL=IVACAR
  572. DO 7043 IC=1,9
  573. MELVAL=IVAL(IC)
  574. IF (MELVAL.NE.0) THEN
  575. IBMN=MIN(IB,VELCHE(/2))
  576. WORK(IC)=VELCHE(1,IBMN)
  577. ELSE
  578. WORK(IC)=0.D0
  579. ENDIF
  580. 7043 CONTINUE
  581. C
  582. C ON CHERCHE LES COEFF DES MAT DE HOOKE
  583. C
  584. MPTVAL=IVAMAT
  585. IF(IMAT.EQ.2) THEN
  586. MELVAL=IVAL(1)
  587. IBMN=MIN(IB ,IELCHE(/2))
  588. MLREEL=IELCHE(1,IBMN)
  589. SEGACT MLREEL
  590. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  591. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  592. SEGDES MLREEL
  593. ELSE IF (IMAT.EQ.1) THEN
  594. DO 9043 IM=1,NMATT
  595. IF (IVAL(IM).NE.0) THEN
  596. MELVAL=IVAL(IM)
  597. IBMN=MIN(IB ,VELCHE(/2))
  598. VALMAT(IM)=VELCHE(1,IBMN)
  599. ELSE
  600. VALMAT(IM)=0.D0
  601. ENDIF
  602. 9043 CONTINUE
  603. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  604. 1 CALL DOHFIS1(VALMAT,WORK(1),CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  605. ENDIF
  606. C
  607. C ON CALCULE LES CONTRAINTES
  608. C
  609. CALL TUFIST(VALMAT,XDDL,WORK(1),DDHOOK,WORK(10),
  610. 1 WORK(20),WORK(31),I137)
  611. IF(I137.NE.0) INTERR(1)=ISOUS
  612. IF(I137.NE.0) INTERR(2)=IB
  613. C
  614. MPTVAL=IVASTR
  615. DO 6043 ICOMP=1,8
  616. MELVAL=IVAL(ICOMP)
  617. IBMN=MIN(IB,VELCHE(/2))
  618. VELCHE(1,IBMN)=WORK(30+ICOMP)
  619. 6043 CONTINUE
  620. C
  621. 3043 CONTINUE
  622. IF(I137.EQ.1) CALL ERREUR(137)
  623. IF(I137.EQ.2) CALL ERREUR(123)
  624. IF(I137.EQ.3) CALL ERREUR(266)
  625. IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN
  626. MOTERR(1:8)=CMATE
  627. MOTERR(9:12)=NOMFR(MFR/2+1)
  628. INTERR(1)=IFOUR
  629. CALL ERREUR(81)
  630. ENDIF
  631. SEGSUP MVELCH,WRK1,WRK3
  632. GOTO 510
  633. C____________________________________________________________________
  634. C
  635. C ELEMENT POINT (POI1)
  636. C____________________________________________________________________
  637. C
  638. 45 CONTINUE
  639. *
  640. IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN
  641. GO TO 99
  642. ENDIF
  643. *
  644. SEGINI WRK3
  645. C
  646. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  647. C
  648. DO 3045 IB=1,NBELEM
  649. C
  650. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  651. C
  652. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  653. C
  654. C ON CALCULE LES DEFORMATIONS
  655. C
  656. CALL PO1EPS(XE,UZDPG,RYDPG,RXDPG,XDPGE,YDPGE,WORK)
  657. C
  658. MPTVAL=IVACAR
  659. MELVAL=IVAL(1)
  660. IF (MELVAL.NE.0) THEN
  661. IBMN=MIN(IB,VELCHE(/2))
  662. SECT=VELCHE(1,IBMN)
  663. ELSE
  664. CALL ERREUR(5)
  665. GO TO 3045
  666. ENDIF
  667. C
  668. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  669. C
  670. MPTVAL=IVADEP
  671. MPTVAL=IVAMAT
  672. IF(IMAT.EQ.2) THEN
  673. MELVAL=IVAL(1)
  674. IBMN=MIN(IB ,IELCHE(/2))
  675. MLREEL=IELCHE(1,IBMN)
  676. SEGACT MLREEL
  677. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  678. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  679. SEGDES MLREEL
  680. ELSE IF (IMAT.EQ.1) THEN
  681. DO 9045 IM=1,NMATT
  682. IF (IVAL(IM).NE.0) THEN
  683. MELVAL=IVAL(IM)
  684. IBMN=MIN(IB ,VELCHE(/2))
  685. VALMAT(IM)=VELCHE(1,IBMN)
  686. ELSE
  687. VALMAT(IM)=0.D0
  688. ENDIF
  689. 9045 CONTINUE
  690. CALL DOHBRR(VALMAT,SECT,DDHOOK,IRTD)
  691. ENDIF
  692. MPTVAL=IVADEP
  693. C
  694. C REMPLISSAGE DU SEGMENT CONTENANT LES DEFORMATIONS
  695. C
  696. ID=1
  697. DO 7045 IGAU=1,NBPTEL
  698. MPTVAL=IVASTR
  699. DO 7045 ICOMP=1,NSTRS
  700. MELVAL=IVAL(ICOMP)
  701. IBMN=MIN(IB ,VELCHE(/2))
  702. VELCHE(IGAU,IBMN)=WORK(ID)*DDHOOK(1,1)
  703. ID=ID+1
  704. 7045 CONTINUE
  705. MPTVAL=IVADEP
  706. C
  707. 3045 CONTINUE
  708. IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN
  709. MOTERR(1:8)=CMATE
  710. MOTERR(9:12)=NOMFR(MFR/2+1)
  711. INTERR(1)=IFOUR
  712. CALL ERREUR(81)
  713. ENDIF
  714. SEGSUP MVELCH,WRK1,WRK3
  715. GOTO 510
  716. C____________________________________________________________________
  717. C
  718. C BARRE ET CERCE
  719. C____________________________________________________________________
  720. C
  721. 46 CONTINUE
  722. *
  723. IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  724. GO TO 99
  725. ENDIF
  726. *
  727. SEGINI WRK3
  728. C
  729. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  730. C
  731. DO 3046 IB=1,NBELEM
  732. KERRE=0
  733. C
  734. C ON CHERCHE LES DEPLACEMENTS
  735. C
  736. NDDD=NDEP
  737. IF (IFOUR.EQ.-3.AND.MELE.EQ.46) NDDD=NDEP-3
  738. IE=1
  739. DO 4046 IGAU=1,NBNN
  740. MPTVAL=IVADEP
  741. DO 4046 ICOMP=1,NDDD
  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. 4046 CONTINUE
  748. C
  749. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  750. C
  751. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  752. C
  753. C ON CALCULE LES DEFORMATIONS
  754. C
  755. IF(MELE.EQ.46) CALL BAREPS(XE,XDDL,WORK,IREPS2)
  756. IF(MELE.EQ.95) CALL CEREPS(XE,XDDL,WORK,IREPS2,KERRE)
  757. IF(MELE.EQ.123)CALL BAREP3(XE,XDDL,WORK,QSIGAU,POIGAU,NBPGAU,IB)
  758. IF(KERRE.NE.0) THEN
  759. CALL ERREUR(601)
  760. GO TO 3046
  761. ENDIF
  762. MPTVAL=IVACAR
  763. MELVAL=IVAL(1)
  764. IF (MELVAL.NE.0) THEN
  765. IBMN=MIN(IB,VELCHE(/2))
  766. SECT=VELCHE(1,IBMN)
  767. ELSE
  768. CALL ERREUR(5)
  769. GO TO 3046
  770. ENDIF
  771. C
  772. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  773. C
  774. MPTVAL=IVADEP
  775. MPTVAL=IVAMAT
  776. IF(IMAT.EQ.2) THEN
  777. MELVAL=IVAL(1)
  778. IBMN=MIN(IB ,IELCHE(/2))
  779. MLREEL=IELCHE(1,IBMN)
  780. SEGACT MLREEL
  781. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  782. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  783. SEGDES MLREEL
  784. ELSE IF (IMAT.EQ.1) THEN
  785. DO 9046 IM=1,NMATT
  786. IF (IVAL(IM).NE.0) THEN
  787. MELVAL=IVAL(IM)
  788. IBMN=MIN(IB ,VELCHE(/2))
  789. VALMAT(IM)=VELCHE(1,IBMN)
  790. ELSE
  791. VALMAT(IM)=0.D0
  792. ENDIF
  793. 9046 CONTINUE
  794. CALL DOHBRR(VALMAT,SECT,DDHOOK,IRTD)
  795. ENDIF
  796. MPTVAL=IVADEP
  797. C
  798. C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES
  799. C
  800. ID=1
  801. DO 7046 IGAU=1,NBPTEL
  802. MPTVAL=IVASTR
  803. DO 7046 ICOMP=1,NSTRS
  804. MELVAL=IVAL(ICOMP)
  805. IBMN=MIN(IB ,VELCHE(/2))
  806. VELCHE(IGAU,IBMN)=WORK(ID)*DDHOOK(1,1)
  807. ID=ID+1
  808. 7046 CONTINUE
  809. MPTVAL=IVADEP
  810. C
  811. 3046 CONTINUE
  812. IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN
  813. MOTERR(1:8)=CMATE
  814. MOTERR(9:12)=NOMFR(MFR/2+1)
  815. INTERR(1)=IFOUR
  816. CALL ERREUR(81)
  817. ENDIF
  818. IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601)
  819. SEGSUP MVELCH,WRK1,WRK3
  820. GOTO 510
  821. C
  822. C____________________________________________________________________
  823. C
  824. C ELEMENT BARRE 3D EXCENTRE (BAEX)
  825. C____________________________________________________________________
  826. C
  827. 124 CONTINUE
  828. NBBB=NBNN
  829. NSTN=NBNN
  830. LRN =LRE
  831. SEGINI WRK1,WRK3,WRK5
  832. C
  833. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  834. C
  835. DO 3108 IB=1,NBELEM
  836. C
  837. C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON
  838. C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK
  839. C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ
  840. C
  841. MPTVAL=IVACAR
  842. DO IC=1,NCARR
  843. IF(IVAL(IC).NE.0) THEN
  844. MELVAL=IVAL(IC)
  845. IBMN=MIN(IB,VELCHE(/2))
  846. WORK(IC)=VELCHE(1,IBMN)
  847. ELSE
  848. WORK(IC)=0.D0
  849. ENDIF
  850. END DO
  851. SECT=WORK(1)
  852. C
  853. C XGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE
  854. C
  855. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  856. CALL MAPAEX(XE,NBNN,WORK,AL,XGENE,LRE,KERRE)
  857. IF(KERRE.NE.0) INTERR(1)=ISOUS
  858. IF(KERRE.NE.0) INTERR(2)=IB
  859. IF(KERRE.EQ.1) CALL ERREUR(128)
  860. C
  861. C ON CHERCHE LES DEPLACEMENTS
  862. C
  863. IE=1
  864. DO 4108 IGAU=1,NBNN
  865. MPTVAL=IVADEP
  866. DO 4108 ICOMP=1,NDEP
  867. MELVAL=IVAL(ICOMP)
  868. IGMN=MIN(IGAU,VELCHE(/1))
  869. IBMN=MIN(IB ,VELCHE(/2))
  870. XDDL(IE)=VELCHE(IGMN,IBMN)
  871. IE=IE+1
  872. 4108 CONTINUE
  873. C
  874. C ON CALCULE LES DEFORMATIONS
  875. C
  876. CALL BAEPEX(XDDL,XGENE,AL,XSTRS,LRE)
  877. C
  878. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  879. C
  880. MPTVAL=IVAMAT
  881. IF(IMAT.EQ.2) THEN
  882. MELVAL=IVAL(1)
  883. IBMN=MIN(IB ,IELCHE(/2))
  884. MLREEL=IELCHE(1,IBMN)
  885. SEGACT MLREEL
  886. IF(IB.LE.NELMAT.OR.NBGMAT.GT.1) CALL DOHOOO(PROG,LHOOK,DDHOOK)
  887. SEGDES MLREEL
  888. ELSE IF (IMAT.EQ.1) THEN
  889. DO 9124 IM=1,NMATT
  890. IF (IVAL(IM).NE.0) THEN
  891. MELVAL=IVAL(IM)
  892. IBMN=MIN(IB ,VELCHE(/2))
  893. VALMAT(IM)=VELCHE(1,IBMN)
  894. ELSE
  895. VALMAT(IM)=0.D0
  896. ENDIF
  897. 9124 CONTINUE
  898. CALL DOHBRR(VALMAT,SECT,DDHOOK,IRTD)
  899. ENDIF
  900. C
  901. C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES
  902. C
  903. ID=1
  904. DO 7108 IGAU=1,NBPTEL
  905. MPTVAL=IVASTR
  906. DO 7108 ICOMP=1,NSTRS
  907. MELVAL=IVAL(ICOMP)
  908. IBMN=MIN(IB ,VELCHE(/2))
  909. VELCHE(IGAU,IBMN)=XSTRS(ID)*DDHOOK(1,1)
  910. ID=ID+1
  911. 7108 CONTINUE
  912. C
  913. 3108 CONTINUE
  914. SEGSUP WRK1,WRK3,WRK5,MVELCH
  915. GOTO 510
  916. C_______________________________________________________________________
  917. C
  918. C LIA2 : element de liaison a 2 noeuds (6 ddl par
  919. C noeuds)
  920. C_______________________________________________________________________
  921. C
  922. 125 CONTINUE
  923. NBBB=NBNN
  924. NSTN=3
  925. LRN =3
  926. SEGINI WRK1,WRK3,WRK5
  927. C
  928. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  929. C
  930. DO 3109 IB=1,NBELEM
  931. C
  932. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  933. C
  934. MPTVAL=IVACAR
  935. DO IC=1,NCARR
  936. IF(IVAL(IC).NE.0) THEN
  937. MELVAL=IVAL(IC)
  938. IBMN=MIN(IB,VELCHE(/2))
  939. WORK(IC)=VELCHE(1,IBMN)
  940. ELSE
  941. WORK(IC)=0.D0
  942. ENDIF
  943. END DO
  944. C
  945. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  946. CALL MAPALI(XE,NBNN,WORK,XGENE,KERRE)
  947. IF(KERRE.NE.0) INTERR(1)=ISOUS
  948. IF(KERRE.NE.0) INTERR(2)=IB
  949. IF(KERRE.EQ.1) CALL ERREUR(128)
  950. C
  951. C ON CHERCHE LES DEPLACEMENTS
  952. C
  953. IE=1
  954. DO 4109 IGAU=1,NBNN
  955. MPTVAL=IVADEP
  956. DO 4109 ICOMP=1,NDEP
  957. MELVAL=IVAL(ICOMP)
  958. IGMN=MIN(IGAU,VELCHE(/1))
  959. IBMN=MIN(IB ,VELCHE(/2))
  960. XDDL(IE)=VELCHE(IGMN,IBMN)
  961. IE=IE+1
  962. 4109 CONTINUE
  963. C
  964. C ON CALCULE LES CONTRAINTES (EFFORTS : F = K * U)
  965. C
  966. CALL SIGLIA(XGENE,XDDL,WORK,LRE,NBNN,XSTRS)
  967. C
  968. C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES
  969. C
  970. ID=1
  971. DO 7109 IGAU=1,NBPTEL
  972. MPTVAL=IVASTR
  973. DO 7109 ICOMP=1,NSTRS
  974. MELVAL=IVAL(ICOMP)
  975. IBMN=MIN(IB ,VELCHE(/2))
  976. VELCHE(IGAU,IBMN)=XSTRS(ID)
  977. ID=ID+1
  978. 7109 CONTINUE
  979. C
  980. 3109 CONTINUE
  981. SEGSUP MVELCH,WRK1,WRK3,WRK5
  982. GOTO 510
  983. C_______________________________________________________________________
  984. C
  985. C JOI1 : element de liaison a 2 noeuds (6 ddl par
  986. C noeuds)
  987. C_______________________________________________________________________
  988. C
  989. 265 CONTINUE
  990. NBBB=NBNN
  991. NSTN=3
  992. LRN =3
  993. SEGINI WRK1,WRK3,WRK2
  994. C
  995. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  996. C
  997. DO 3110 IB=1,NBELEM
  998. C
  999. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  1000. C
  1001. MPTVAL=IVAMAT
  1002. DO IC=1,NMATT
  1003. IF(IVAL(IC).NE.0) THEN
  1004. MELVAL=IVAL(IC)
  1005. IBMN=MIN(IB,VELCHE(/2))
  1006. WORK(IC)=VELCHE(1,IBMN)
  1007. ELSE
  1008. WORK(IC)=0.D0
  1009. ENDIF
  1010. END DO
  1011. C
  1012. CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  1013. C
  1014. C ON CHERCHE LES DEPLACEMENTS
  1015. C
  1016. IE=1
  1017. DO 4110 IGAU=1,NBNN
  1018. MPTVAL=IVADEP
  1019. DO 4110 ICOMP=1,NDEP
  1020. MELVAL=IVAL(ICOMP)
  1021. IGMN=MIN(IGAU,VELCHE(/1))
  1022. IBMN=MIN(IB ,VELCHE(/2))
  1023. XDDL(IE)=VELCHE(IGMN,IBMN)
  1024. IE=IE+1
  1025. 4110 CONTINUE
  1026. C
  1027. C CALCUL DES DEPLACEMENTS LOCAUX
  1028. C
  1029. IAW1 = 101
  1030. IAW2 = IAW1 + LRE
  1031. CALL JOILOC(XDDL,BPSS,WORK(IAW1),WORK(IAW2),LRE,IDIM)
  1032. C
  1033. C ON CALCULE LES CONTRAINTES (EFFORTS : F = K * U)
  1034. C
  1035. CALL ZERO(XSTRS,NSTRS,1)
  1036. *
  1037. CALL SIGJOI(NMATT,XDDL,WORK,LRE,XSTRS,IDIM,NSTRS,CMATE)
  1038. C
  1039. C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES
  1040. C
  1041. ID=1
  1042. DO 7110 IGAU=1,NBPTEL
  1043. MPTVAL=IVASTR
  1044. DO 7110 ICOMP=1,NSTRS
  1045. MELVAL=IVAL(ICOMP)
  1046. IBMN=MIN(IB ,VELCHE(/2))
  1047. VELCHE(IGAU,IBMN)=XSTRS(ID)
  1048. ID=ID+1
  1049. 7110 CONTINUE
  1050. C
  1051. 3110 CONTINUE
  1052. SEGSUP MVELCH,WRK1,WRK3,WRK2
  1053. GOTO 510
  1054. C____________________________________________________________________
  1055. C
  1056. C ELEMENT TUYO
  1057. C____________________________________________________________________
  1058. C
  1059. 96 CONTINUE
  1060. SEGINI WRK3
  1061. C
  1062. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1063. C
  1064. DO 3096 IB=1,NBELEM
  1065. C
  1066. C ON CHERCHE LES DEPLACEMENTS
  1067. C
  1068. IE=1
  1069. DO 4096 IGAU=1,NBNN
  1070. MPTVAL=IVADEP
  1071. DO 4096 ICOMP=1,NDEP
  1072. MELVAL=IVAL(ICOMP)
  1073. IGMN=MIN(IGAU,VELCHE(/1))
  1074. IBMN=MIN(IB ,VELCHE(/2))
  1075. XDDL(IE)=VELCHE(IGMN,IBMN)
  1076. IE=IE+1
  1077. 4096 CONTINUE
  1078. C
  1079. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1080. C
  1081. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1082. C
  1083. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  1084. C
  1085. MPTVAL=IVACAR
  1086. DO 6096 IC=1,NCARR
  1087. IF (IVAL(IC).NE.0) THEN
  1088. MELVAL=IVAL(IC)
  1089. IBMN=MIN(IB,VELCHE(/2))
  1090. WORK(IC)=VELCHE(1,IBMN)
  1091. ELSE
  1092. WORK(IC)=0.D0
  1093. ENDIF
  1094. 6096 CONTINUE
  1095. C
  1096. C CAS OU ON A LU LE MOT VECTEUR
  1097. C
  1098. C
  1099. IF (IVECT.EQ.1) THEN
  1100. IF (IVAL(NCARR).NE.0) THEN
  1101. MELVAL=IVAL(NCARR)
  1102. IBMN=MIN(IB,IELCHE(/2))
  1103. IP=IELCHE(1,IBMN)
  1104. IREF=(IP-1)*(IDIM+1)
  1105. DO 6196 IC=1,IDIM
  1106. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  1107. 6196 CONTINUE
  1108. ELSE
  1109. DO 6296 IC=1,IDIM
  1110. WORK(NCARR+IC-1)=0.D0
  1111. 6296 CONTINUE
  1112. ENDIF
  1113. C
  1114. C CAS DU CHAMELEM COMVERTI
  1115. C
  1116. ELSE IF (IVECT.EQ.2) THEN
  1117. DO 6496 IC=1,IDIM
  1118. MELVAL=IVAL(NCARR+IC-3)
  1119. IF (MELVAL.NE.0) THEN
  1120. IBMN=MIN(IB,VELCHE(/2))
  1121. WORK(NCARR+IC-3)=VELCHE(1,IBMN)
  1122. ELSE
  1123. WORK(NCARR+IC-3)=0.D0
  1124. ENDIF
  1125. 6496 CONTINUE
  1126. ENDIF
  1127. C
  1128. MPTVAL=IVAMAT
  1129. MELVAL=IVAL(1)
  1130. IBMN=MIN(IB,VELCHE(/2))
  1131. YOUNG=VELCHE(1,IBMN)
  1132. C
  1133. C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE EQUIVA
  1134. C
  1135. IF(MELE.EQ.42) THEN
  1136. PRES=WORK(4)
  1137. WORK(4)=WORK(5)
  1138. WORK(5)=WORK(6)
  1139. WORK(6)=WORK(7)
  1140. WORK(7)=PRES
  1141. CALL TUYKAR(WORK,KERRE,2,YOUNG)
  1142. ENDIF
  1143. IF (KERRE.EQ.77) THEN
  1144. CALL ERREUR(77)
  1145. GOTO 510
  1146. ENDIF
  1147. C
  1148. C ON CHERCHE LES COEFF DES MAT DE HOOKE
  1149. C
  1150. MPTVAL=IVAMAT
  1151. IF(IMAT.EQ.2) THEN
  1152. MELVAL=IVAL(1)
  1153. IBMN=MIN(IB ,IELCHE(/2))
  1154. MLREEL=IELCHE(1,IBMN)
  1155. SEGACT MLREEL
  1156. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  1157. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1158. SEGDES MLREEL
  1159. C-------------
  1160. C PROVISOIRE
  1161. C-------------
  1162. WORK(10)=DDHOOK(1,1)/WORK(4)
  1163. WORK(11)=DDHOOK(2,2)/WORK(5)
  1164. ELSE IF (IMAT.EQ.1) THEN
  1165. *
  1166. DO 9096 IM=1,NMATT
  1167. IF (IVAL(IM).NE.0) THEN
  1168. MELVAL=IVAL(IM)
  1169. IBMN=MIN(IB ,VELCHE(/2))
  1170. VALMAT(IM)=VELCHE(1,IBMN)
  1171. ELSE
  1172. VALMAT(IM)=0.D0
  1173. ENDIF
  1174. 9096 CONTINUE
  1175. CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  1176. C-------------
  1177. C PROVISOIRE
  1178. C-------------
  1179. WORK(10)=VALMAT(1)
  1180. AUX=VALMAT(2)
  1181. WORK(11)=WORK(10)*0.5D0/(1.D0+AUX)
  1182. C-------------
  1183. ENDIF
  1184. C
  1185. C ON CALCULE LES CONTRAINTES ( STOCKEES DANS WORK ET NON PAS DANS XSTRS
  1186. C
  1187. CALL POUSTR(XE,XDDL,WORK,WORK(12),WORK(25),IREPS2)
  1188. C
  1189. C REMPLISSAGE DU SEGMENT CONTENANT LES CONTRAINTES
  1190. C
  1191. ID=12
  1192. DO 7096 IGAU=1,NBPTEL
  1193. MPTVAL=IVASTR
  1194. DO 7096 ICOMP=1,NSTRS
  1195. MELVAL=IVAL(ICOMP)
  1196. IBMN=MIN(IB ,VELCHE(/2))
  1197. VELCHE(IGAU,IBMN)=WORK(ID)
  1198. ID=ID+1
  1199. 7096 CONTINUE
  1200. C
  1201. 3096 CONTINUE
  1202. IF(IRTD.EQ.0.AND.IMAT.EQ.1) THEN
  1203. MOTERR(1:8)=CMATE
  1204. MOTERR(9:12)=NOMFR(MFR/2+1)
  1205. INTERR(1)=IFOUR
  1206. CALL ERREUR(81)
  1207. ENDIF
  1208. SEGSUP MVELCH,WRK1,WRK3
  1209. GOTO 510
  1210.  
  1211. c_______________________________________________________________________
  1212. c
  1213. c ELEMENTS CIFL MACRO ELEMENT CISAILLEMENT FLEXION
  1214. c____________________________________________________________________
  1215. c
  1216. 258 CONTINUE
  1217. NBNO=NBNN
  1218. SEGINI WRK2,WRK3
  1219. c
  1220. DO IB=1,NBELEM
  1221. C
  1222. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L'ELEMENT IB
  1223. C
  1224. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1225. C
  1226. C ON CHERCHE LES DEPLACEMENTS (UX1,UY1,RZ1,UX2,UY2,RZ2,UM,RM)
  1227. C
  1228. MPTVAL=IVADEP
  1229. MELVAL=IVAL(1)
  1230. XDDL(1)=VELCHE(MIN(1,VELCHE(/1)),MIN(IB ,VELCHE(/2)))
  1231. XDDL(4)=VELCHE(MIN(3,VELCHE(/1)),MIN(IB ,VELCHE(/2)))
  1232. MELVAL=IVAL(2)
  1233. XDDL(2)=VELCHE(MIN(1,VELCHE(/1)),MIN(IB ,VELCHE(/2)))
  1234. XDDL(5)=VELCHE(MIN(3,VELCHE(/1)),MIN(IB ,VELCHE(/2)))
  1235. MELVAL=IVAL(3)
  1236. XDDL(3)=VELCHE(MIN(1,VELCHE(/1)),MIN(IB ,VELCHE(/2)))
  1237. XDDL(6)=VELCHE(MIN(3,VELCHE(/1)),MIN(IB ,VELCHE(/2)))
  1238. MELVAL=IVAL(4)
  1239. XDDL(7)=VELCHE(MIN(2,VELCHE(/1)),MIN(IB ,VELCHE(/2)))
  1240. MELVAL=IVAL(5)
  1241. XDDL(8)=VELCHE(MIN(2,VELCHE(/1)),MIN(IB ,VELCHE(/2)))
  1242. C
  1243. C PASSAGE DES AXES GLOBAUX AUX AXES LOCAUX
  1244. C
  1245. CALL MURLOC(XE,NBNN,LHOOK,LRE,BPSS,XH,BGENE)
  1246. c
  1247. c matrice de hooke
  1248. c
  1249. MPTVAL=IVAMAT
  1250. IF(IMAT.EQ.2) THEN
  1251. MELVAL=IVAL(1)
  1252. IBMN=MIN(IB ,IELCHE(/2))
  1253. MLREEL=IELCHE(1,IBMN)
  1254. SEGACT MLREEL
  1255. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1256. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1257. SEGDES MLREEL
  1258. ELSE IF (IMAT.EQ.1) THEN
  1259. C
  1260. DO IM=1,NMATT
  1261. IF (IVAL(IM).NE.0) THEN
  1262. MELVAL=IVAL(IM)
  1263. IBMN=MIN(IB ,VELCHE(/2))
  1264. VALMAT(IM)=VELCHE(1,IBMN)
  1265. ELSE
  1266. VALMAT(IM)=0.D0
  1267. ENDIF
  1268. ENDDO
  1269. C
  1270. MPTVAL=IVACAR
  1271. DO IC=1,NCARR
  1272. IF (IVAL(IC).NE.0) THEN
  1273. MELVAL=IVAL(IC)
  1274. IBMN=MIN(IB,VELCHE(/2))
  1275. WORK(IC)=VELCHE(1,IBMN)
  1276. ELSE
  1277. WORK(IC)=0.D0
  1278. ENDIF
  1279. ENDDO
  1280. C
  1281. CALL DOHMUR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  1282. ENDIF
  1283. c
  1284. DDHOOK(1,1)=DDHOOK(1,1)/(XH/2)
  1285. DDHOOK(2,2)=DDHOOK(2,2)/(XH/2)
  1286. DDHOOK(3,3)=DDHOOK(3,3)/ XH
  1287. DDHOOK(4,4)=DDHOOK(4,4)/(XH/2)
  1288. DDHOOK(5,5)=DDHOOK(5,5)/(XH/2)
  1289. CALL DBST(BGENE,DDHOOK,XDDL,LRE,NSTRS,XSTRS)
  1290. c
  1291. c
  1292. c remplissage du segment contenant les contraintes
  1293. c
  1294. MPTVAL=IVASTR
  1295. DO ICOMP=1,NSTRS
  1296. MELVAL=IVAL(ICOMP)
  1297. IBMN=MIN(IB ,VELCHE(/2))
  1298. VELCHE(1,IBMN)=XSTRS(ICOMP)
  1299. ENDDO
  1300. ENDDO
  1301. C
  1302. IF(IRTD.EQ.0) THEN
  1303. MOTERR(1:8)=CMATE
  1304. MOTERR(9:12)=NOMFR(MFR/2+1)
  1305. INTERR(1)=IFOUR
  1306. CALL ERREUR(81)
  1307. ENDIF
  1308. SEGSUP MVELCH,WRK1,WRK2,WRK3
  1309. GOTO 510
  1310. C_______________________________________________________________________
  1311. C
  1312. C ELEMENT DE COQUE VOLUMIQUE SHB8
  1313. C_______________________________________________________________________
  1314. C
  1315. 260 CONTINUE
  1316. NBNO=NBNN
  1317. NBBB=NBNN
  1318. SEGINI WRK1,WRK7,MVELCH
  1319. C
  1320. C BOUCLE POUR TOUS LES ELEMENTS
  1321. C
  1322. DO IB=1,NBELEM
  1323. C
  1324. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1325. C
  1326. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1327. C
  1328. C on cherche les deplacements
  1329. C
  1330. MPTVAL=IVADEP
  1331. IE=1
  1332. DO IGAU=1,NBNN
  1333. MPTVAL=IVADEP
  1334. DO ICOMP=1,3
  1335. MELVAL=IVAL(ICOMP)
  1336. IGMN=MIN(IGAU,VELCHE(/1))
  1337. IBMN=MIN(IB ,VELCHE(/2))
  1338. WORK1(IE)=VELCHE(IGMN,IBMN)
  1339. IE=IE+1
  1340. enddo
  1341. enddo
  1342. MPTVAL=IVAMAT
  1343. DO 9070 IM=1,NMATT
  1344. IF (IVAL(IM).NE.0) THEN
  1345. MELVAL=IVAL(IM)
  1346. IBMN=MIN(IB ,VELCHE(/2))
  1347. VALMAT(IM)=VELCHE(1,IBMN)
  1348.  
  1349. ELSE
  1350. VALMAT(IM)=0.D0
  1351.  
  1352. ENDIF
  1353. 9070 CONTINUE
  1354.  
  1355. PROPEL(1)=VALMAT(1)
  1356. PROPEL(2)=VALMAT(2)
  1357. DO IM=3,12
  1358. PROPEL(IM)=VALMAT(1)
  1359. ENDDO
  1360. PROPEL(3)=ireps2
  1361. PROPEL(14)=VALMAT(1)
  1362.  
  1363. C
  1364. C CALCUL DES CONTRAINTES
  1365. C
  1366. call SHB8 (7,XE,DDHOOK,PROPEL,WORK1,REL,OUT)
  1367. MPTVAL=IVASTR
  1368. IE=1
  1369. DO ICOMP=1,NSTRS
  1370. MELVAL=IVAL(ICOMP)
  1371. DO IBG=1,5
  1372. MELVAL=IVAL(ICOMP)
  1373. IBMN=MIN(IB ,VELCHE(/2))
  1374. VELCHE(IBG,IBMN)=out(ICOMP+ (IBG-1)*NSTRS)
  1375. ENDDO
  1376. ENDDO
  1377. ENDDO
  1378. SEGSUP WRK1,WRK7,MVELCH
  1379. GO TO 510
  1380. *____________________________________________________________________
  1381. 99 CONTINUE
  1382. SEGSUP MVELCH,WRK1
  1383. MOTERR(1:4)=NOMTP(MELE)
  1384. MOTERR(9:12)='SIGM'
  1385. CALL ERREUR(86)
  1386. *
  1387. 510 CONTINUE
  1388. RETURN
  1389. END
  1390.  
  1391.  
  1392.  
  1393.  
  1394.  
  1395.  
  1396.  
  1397.  
  1398.  
  1399.  
  1400.  
  1401.  
  1402.  
  1403.  
  1404.  
  1405.  
  1406.  
  1407.  
  1408.  
  1409.  
  1410.  

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