Télécharger rigi4.eso

Retour à la liste

Numérotation des lignes :

  1. C RIGI4 SOURCE BP208322 17/10/03 21:16:35 9580
  2. SUBROUTINE RIGI4(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,
  3. & IVAMAT,IVACAR,IVECT,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,
  4. & NMATT,NCARR,ISOUS,LW,IPORE,IPMATR,IIPDPG)
  5. *---------------------------------------------------------------------*
  6. * ________________________ *
  7. * | | *
  8. * | CALCUL DE LA RIGIDITE | *
  9. * |________________________| *
  10. * *
  11. * poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,joint 3D, *
  12. * cerce, tuyo,joints 2D, litu,zone cohesives *
  13. * *
  14. *---------------------------------------------------------------------*
  15. * *
  16. * *
  17. * ENTREES : *
  18. * ________ *
  19. * *
  20. * MATE Numero du materiau *
  21. * MELE Numero de l'element fini *
  22. * IPMAIL Pointeur sur un segment MELEME *
  23. * IPMINT Pointeur sur un segment MINTE *
  24. * NBPGAU Nombre de point d'integration pour la rigidite *
  25. * LRE Nombre de ddl dans la matrice de rigidite *
  26. * NSTRS Nombre de composante de contraintes/deformations *
  27. * IVAMAT Pointeur sur un segment MPTVAL pour le materiau ou *
  28. * pour une matrice de hooke *
  29. * IVACAR Pointeur sur un segment MPTVAL pour les caracteri- *
  30. * stiques *
  31. * IVECT FLAG INDIQUANT SI ON A ENTRE UN VECTEUR LOCAL *
  32. * CMATE Nom du materiau *
  33. * MFR Numero de la formulation element fini *
  34. * NBGMAT Taille maxi des melval du materiau (pt de gauss) *
  35. * NELMAT Taille maxi des melval du materiau (No d'element) *
  36. * IMAT (2 il y a une matrice de HOOKE,1 non ) *
  37. * NMATT Nombre de composantes de materiau (IMAT=1) *
  38. * NCARR Nombre de caracteristiques geometriques *
  39. * ISOUS NUMERO DE LA SOUS-ZONE *
  40. * LW Dimension du tableau de travail *
  41. * IPORE nombre de fonctions de forme
  42. * *
  43. * *
  44. * SORTIES : *
  45. * ________ *
  46. * *
  47. * IPMATR pointeur sur la rigidite de la sous-zone *
  48. * *
  49. * *
  50. *---------------------------------------------------------------------*
  51. IMPLICIT INTEGER(I-N)
  52. IMPLICIT REAL*8(A-H,O-Z)
  53. *
  54. -INC CCOPTIO
  55. -INC CCHAMP
  56. -INC CCREEL
  57. *-
  58. -INC SMCHAML
  59. -INC SMINTE
  60. -INC SMELEME
  61. -INC SMRIGID
  62. -INC SMMODEL
  63. -INC SMCOORD
  64. -INC SMLREEL
  65. -INC SMLMOTS
  66. *
  67. SEGMENT WRK1
  68. REAL*8 DDHOOK(NSTRS,NSTRS) ,DDHOMU(NSTRS,NSTRS)
  69. REAL*8 REL(LRE,LRE) , XE(3,NBBB)
  70. ENDSEGMENT
  71. *
  72. SEGMENT WRK2
  73. REAL*8 SHPWRK(6,NBNO) ,BGENE(NSTRS,LRE)
  74. ENDSEGMENT
  75. *
  76. SEGMENT WRK3
  77. REAL*8 WORK(LW)
  78. ENDSEGMENT
  79. *
  80. SEGMENT WRK4
  81. c cccccc
  82. REAL*8 BPSS(3,3),XEL(3,NBBB),rell(lre,lre),XPA(IDIM,IDIM)
  83. REAL*8 XPB(IDIM,IDIM)
  84. c cccccc
  85. ENDSEGMENT
  86. *
  87. SEGMENT WRK5
  88. REAL*8 XGENE(NSTN,LRN)
  89. ENDSEGMENT
  90. *
  91. SEGMENT WRK6
  92. REAL*8 PSS(3,3)
  93. ENDSEGMENT
  94. *
  95. SEGMENT WRK7
  96. REAL*8 PROPEL(14)
  97. REAL*8 OUT(5)
  98. REAL*8 WORK1(24*24)
  99. ENDSEGMENT
  100. *
  101. SEGMENT,MVELCH
  102. REAL*8 VALMAT(NV1)
  103. ENDSEGMENT
  104. *
  105. SEGMENT MPTVAL
  106. INTEGER IPOS(NS) ,NSOF(NS)
  107. INTEGER IVAL(NCOSOU)
  108. CHARACTER*16 TYVAL(NCOSOU)
  109. ENDSEGMENT
  110. *
  111. CHARACTER*4 lesinc(7),lesdua(7)
  112. DATA lesinc/'UX','UY','UZ','RX','RY','RZ','UR'/
  113. DATA lesdua/'FX','FY','FZ','MX','MY','MZ','FR'/
  114. DATA X577/.577350269189626D0/
  115. DIMENSION CRIGI(12),CMASS(12)
  116. CHARACTER*8 CMATE
  117. *
  118. MELEME=IPMAIL
  119. NBNN=NUM(/1)
  120. NBELEM=NUM(/2)
  121. *
  122. NV1=NMATT
  123. SEGINI,MVELCH
  124. *
  125. XMATRI=IPMATR
  126. * NLIGRP=LRE
  127. * NLIGRD=LRE
  128.  
  129. C Introduction du point autour duquel se fait le mouvement
  130. C de la section en defo plane generalisee
  131. C IIPDPG = numero du noeud/point support si defini pour le modele
  132. C IIPDPG > 0 si prise en compte du point support
  133. IF (IIPDPG.GT.0) THEN
  134. C <- Ici test equivalent a IF (IFOUR.EQ.-3)THEN
  135. c segact,mcoord
  136. IREF=(IIPDPG-1)*(IDIM+1)
  137. XDPGE=XCOOR(IREF+1)
  138. YDPGE=XCOOR(IREF+2)
  139. ELSE
  140. XDPGE=0.D0
  141. YDPGE=0.D0
  142. ENDIF
  143. *
  144. NHRM=NIFOUR
  145. *
  146. MINTE=IPMINT
  147. IRTD=1
  148. *
  149. *
  150. * cas cmate 'STATIQUE'
  151. IF (mfr.eq.28) THEN
  152. jgn = 4
  153. if (ifour.eq.2) then
  154. jgm = 6
  155. segini mlmots
  156. iinc = mlmots
  157. do igm = 1,jgm
  158. mots(igm) = lesinc(igm)
  159. enddo
  160. segini mlmots
  161. idua = mlmots
  162. do igm= 1,jgm
  163. mots(igm) = lesdua(igm)
  164. enddo
  165. else if (ifour.lt.0) then
  166. jgm = 4
  167. segini mlmots
  168. iinc = mlmots
  169. mots(1) = lesinc(1)
  170. mots(2) = lesinc(2)
  171. mots(3) = lesinc(4)
  172. mots(4) = lesinc(5)
  173. segini mlmots
  174. idua = mlmots
  175. mots(1) = lesdua(1)
  176. mots(2) = lesdua(2)
  177. mots(3) = lesdua(4)
  178. mots(4) = lesdua(5)
  179. else if (ifour.eq.0) then
  180. jgm = 3
  181. segini mlmots
  182. iinc = mlmots
  183. mots(1) = lesinc(7)
  184. mots(2) = lesinc(3)
  185. mots(3) = lesinc(6)
  186. segini mlmots
  187. idua = mlmots
  188. mots(1) = lesdua(7)
  189. mots(2) = lesdua(3)
  190. mots(3) = lesdua(6)
  191. else if (ifour.eq.1) then
  192. * a faire
  193. endif
  194. ENDIF
  195.  
  196.  
  197. C
  198. C_______________________________________________________________________
  199. C
  200. C NUMERO DES ETIQUETTES :
  201. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  202. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  203. C 5 CONTINUE
  204. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  205. C 44 CONTINUE
  206. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  207. C_______________________________________________________________________
  208. C
  209. IF (MELE.LE.100)
  210. * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  211. & GOTO ( 99, 2, 99, 99, 99, 99, 99, 99, 99, 99, 99
  212. * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  213. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  214. * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6
  215. & , 99, 99, 99, 99, 99, 99, 29, 30, 99, 99, 99
  216. * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  217. & , 99, 99, 99, 99, 99, 99, 99, 99, 29, 43, 99
  218. * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  219. & , 45, 46, 99, 99, 99, 30, 99, 99, 99, 99, 99
  220. * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  221. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  222. * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  223. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  224. * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  225. & , 99, 99, 99, 99, 99, 99, 29, 85, 86, 87, 88
  226. * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3
  227. & , 99, 99, 99, 92, 99, 99, 46, 96, 29, 29, 99
  228. * HYQ4
  229. & , 99),MELE
  230. IF (MELE.LE.200)
  231. * HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  232. & GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  233. * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  234. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  235. * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  236. & , 99, 46, 124, 125, 126, 127, 99, 99, 99, 99, 99
  237. * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  238. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  239. * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  240. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  241. * TE56 PY91 TRH6 ???? ???? ???? ???? ???? ???? ???? ????
  242. & , 99, 99, 92, 51, 51, 51, 51, 51, 51, 51, 51
  243. * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  244. & , 51, 168, 169, 170, 171, 172, 51, 51, 51, 51, 51
  245. * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  246. & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51
  247. * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  248. & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51
  249. * ???? ????
  250. & , 51, 51),MELE-100
  251. IF (MELE.LE.300)
  252. * ???? ???? ???? ???? ???? ???? ???? ???? ????
  253. & GOTO ( 51, 51, 51, 51, 51, 51, 51, 51, 51
  254. * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  255. & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51
  256. * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  257. & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51
  258. * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  259. & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51
  260. * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  261. & , 51, 51, 51, 51, 51, 51, 51, 51, 51, 51, 51
  262. * ???? ???? ???? ???? ???? ???? ???? ???? ???? ???? ????
  263. & , 51, 51, 51, 51, 258, 51, 260, 51, 51, 51, 51
  264. * JOI1 ZCO2 ZCO3 ZCO4
  265. c cccccc
  266. & , 129, 266, 266, 266, 51,51,271,272),MELE-200
  267. c cccccc
  268. 51 CONTINUE
  269. GOTO 99
  270.  
  271. 2 CONTINUE
  272. if (cmate.eq.'IMPELAST'.or.cmate.eq.'IMPVOIGT'.or.
  273. &cmate.eq.'IMPREUSS'.or.cmate.eq.'IMPCOMPL') then
  274. MPTVAL=IVAMAT
  275. MELVAL=IVAL(1)
  276. if (ival(/1).gt.1) then
  277. melva1 = ival(2)
  278. else
  279. melva1 = 0
  280. endif
  281. jddl = LRE/NBPGAU
  282. DO IB = 1,NBELEM
  283. * kich 1 pgau inutile
  284. IGAU = 1
  285. JDIAG = 0
  286. IBMN=MIN(IB,VELCHE(/2))
  287. IGMN=MIN(IGAU,VELCHE(/1))
  288. if (cmate.eq.'IMPCOMPL') then
  289. MLREEL=IELCHE(IGMN,IBMN)
  290. SEGACT MLREEL
  291. XRAID = prog(1)
  292. else
  293. XRAID = VELCHE(IGMN,IBMN)
  294. XTORS = XRAID
  295. if (melva1.gt.0) then
  296. XTORS = melva1.VELCHE(IGMN,IBMN)
  297. endif
  298. endif
  299. do j=1,jddl
  300. JDIAG = JDIAG + 1
  301. if (j.le.3) then
  302. RE(JDIAG,JDIAG,IB) = XRAID
  303. RE(JDIAG,JDIAG+jddl,IB) = XRAID*(-1.D0)
  304. else
  305. RE(JDIAG,JDIAG,IB) = XTORS
  306. RE(JDIAG,JDIAG+jddl,IB) = XTORS*(-1.D0)
  307. endif
  308. enddo
  309. do j=jddl+1,LRE
  310. JDIAG = JDIAG + 1
  311. if (j.le.jddl+3) then
  312. RE(JDIAG,JDIAG,IB) = XRAID
  313. RE(JDIAG,JDIAG-jddl,IB) = XRAID*(-1.D0)
  314. else
  315. RE(JDIAG,JDIAG,IB) = XTORS
  316. RE(JDIAG,JDIAG-jddl,IB) = XTORS*(-1.D0)
  317. endif
  318. enddo
  319. ENDDO
  320. SEGDES XMATRI
  321. goto 510
  322. endif
  323. if (mele.eq.2) goto 99
  324.  
  325. C_______________________________________________________________________
  326. C
  327. C ELEMENTS POUTRE TUYAU ET POUTRE TIMOSCHENKO
  328. C_______________________________________________________________________
  329. C
  330.  
  331. 29 CONTINUE
  332.  
  333. NBBB=NBNN
  334. SEGINI WRK1,WRK3
  335. C
  336. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  337. C
  338. KERRE=0
  339. DO 3029 IB=1,NBELEM
  340. C
  341. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  342. C
  343. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  344. C
  345. C CAS DE L'ELEMENT LITU OU LA MATRICE DE RIGIDITE EST NULLE
  346. C
  347. IF (MELE.EQ.98) THEN
  348. CALL ZERO(REL,LRE,LRE)
  349. GOTO 8029
  350. ENDIF
  351. C
  352. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  353. C SI LE VECTEUR EXISTE , IL EST EN DERNIERE POSITION
  354. C
  355. NCARR1=NCARR
  356. IF(IVECT.EQ.1) NCARR1=NCARR-1
  357. CALL ZERO(WORK,NCARR1,1)
  358. DO 4030 IGAU=1,NBNN
  359. MPTVAL=IVACAR
  360. DO 6029 IC=1,NCARR1
  361. IF (IVAL(IC).NE.0) THEN
  362. MELVAL=IVAL(IC)
  363. IBMN=MIN(IB,VELCHE(/2))
  364. IGMN=MIN(IGAU,VELCHE(/1))
  365. WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  366. ELSE
  367. WORK(IC)=0.D0
  368. ENDIF
  369. IF (IGAU.EQ.NBNN) WORK(IC)=WORK(IC)/NBNN
  370. 6029 CONTINUE
  371. 4030 CONTINUE
  372. C
  373. C CAS OU ON A LU LE MOT VECTEUR
  374. C
  375. IF (IVECT.EQ.1) THEN
  376. IF (IVAL(NCARR).NE.0) THEN
  377. MELVAL=IVAL(NCARR)
  378. IBMN=MIN(IB,IELCHE(/2))
  379. IP=IELCHE(1,IBMN)
  380. IREF=(IP-1)*(IDIM+1)
  381. DO 6129 IC=1,IDIM
  382. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  383. 6129 CONTINUE
  384. ELSE
  385. DO 6229 IC=1,IDIM
  386. WORK(NCARR+IC-1)=0.D0
  387. 6229 CONTINUE
  388. ENDIF
  389. ENDIF
  390. C
  391. MPTVAL=IVAMAT
  392. C
  393. C CAS DE L'ACOUSTIQUE PURE
  394. C
  395. IF (MELE.EQ.97) THEN
  396. DO 7029 IM=1,NMATT
  397. IF (IVAL(IM).NE.0) THEN
  398. MELVAL=IVAL(IM)
  399. IBMN=MIN(IB,VELCHE(/2))
  400. WORK(IM+9)=VELCHE(1,IBMN)
  401. ELSE
  402. WORK(IM+9)=0.D0
  403. ENDIF
  404. 7029 CONTINUE
  405. ELSE
  406. C
  407. C AUTRES CAS ......
  408. C
  409. MELVAL=IVAL(1)
  410. *
  411. IF(CMATE.NE.'SECTION') THEN
  412. IBMN=MIN(IB,VELCHE(/2))
  413. VALMAT(1)=VELCHE(1,IBMN)
  414. YOUNG=VALMAT(1)
  415. C
  416. C CAS DES TUYAUX - ON CALCULE LES CARACTERISTIQUES DE LA POUTRE
  417. C EQUIVALENTE
  418. IF(MELE.EQ.42) THEN
  419. PRES=WORK(4)
  420. CISA=WORK(5)
  421. WORK(4)=WORK(6)
  422. WORK(5)=WORK(7)
  423. WORK(6)=WORK(8)
  424. WORK(7)=PRES
  425. WORK(8)=CISA
  426. CALL TUYKAR(WORK,KERRE,2,YOUNG)
  427. ENDIF
  428. IF (KERRE.EQ.77) THEN
  429. CALL ERREUR(77)
  430. GOTO 510
  431. ENDIF
  432. C
  433. C ON CHERCHE LES COEFF DES MAT DE HOOKE
  434. C
  435. IF(IMAT.EQ.2) THEN
  436. MELVAL=IVAL(1)
  437. IBMN=MIN(IB,IELCHE(/2))
  438. MLREEL=IELCHE(1,IBMN)
  439. SEGACT MLREEL
  440. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  441. $ CALL DOHOOO(PROG,LHOOK,DDHOOK)
  442. SEGDES MLREEL
  443. C-------------
  444. C PROVISOIRE
  445. C-------------
  446. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  447. WORK(4)=DDHOOK(1,1)/WORK(1)
  448. WORK(5)=DDHOOK(2,2)/(MAX(WORK(3),WORK(1)))
  449. ELSE
  450. *
  451. *ZZZZ ATTENTION A LA DIVISION PAR 0.
  452. *
  453. WORK(10)=DDHOOK(1,1)/WORK(4)
  454. WORK(11)=DDHOOK(2,2)/WORK(5)
  455. ENDIF
  456. ELSE IF (IMAT.EQ.1) THEN
  457. *
  458. DO 9029 IM=1,NMATT
  459. IF (IVAL(IM).NE.0) THEN
  460. MELVAL=IVAL(IM)
  461. IBMN=MIN(IB,VELCHE(/2))
  462. VALMAT(IM)=VELCHE(1,IBMN)
  463. ELSE
  464. VALMAT(IM)=0.D0
  465. ENDIF
  466. 9029 CONTINUE
  467. IF(MELE.EQ.84) THEN
  468. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  469. CALL DOHTI2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  470. ELSE
  471. C
  472. CALL DOHTIM(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  473. ENDIF
  474. ELSE
  475. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  476. CALL DOHPT2(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  477. ELSE
  478. CALL DOHPTR(VALMAT,CMATE,IFOUR,WORK,LHOOK,DDHOOK,IRTD)
  479. ENDIF
  480. ENDIF
  481. C-------------
  482. C PROVISOIRE
  483. C-------------
  484. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  485. WORK(4)=VALMAT(1)
  486. AUX=VALMAT(2)
  487. WORK(5)=WORK(4)*0.5D0/(1.D0+AUX)
  488. ELSE
  489. C
  490. WORK(10)=VALMAT(1)
  491. AUX=VALMAT(2)
  492. WORK(11)=WORK(10)*0.5D0/(1.D0+AUX)
  493. ENDIF
  494. C-------------
  495. ENDIF
  496. *
  497. * CAS DE LA FORMULATION SECTION
  498. *
  499. ELSE
  500. IF(IMAT.EQ.2) THEN
  501. MELVAL=IVAL(1)
  502. IBMN=MIN(IB,IELCHE(/2))
  503. MLREEL=IELCHE(1,IBMN)
  504. SEGACT MLREEL
  505. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  506. $ CALL DOHOOO(PROG,LHOOK,DDHOOK)
  507. SEGDES MLREEL
  508. C
  509. ELSE IF (IMAT.EQ.1) THEN
  510. *
  511. * ON REGARDE SI ON A LA COMPOSANTE MAHO
  512. * SI OUI, ON LA PREND
  513. *
  514. IF(IVAL(3).NE.0) THEN
  515. MELVAL=IVAL(3)
  516. IBMN=MIN(IB,IELCHE(/2))
  517. MLREEL=IELCHE(1,IBMN)
  518. SEGACT MLREEL
  519. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  520. $ CALL DOHOOO(PROG,LHOOK,DDHOOK)
  521. SEGDES MLREEL
  522. *
  523. ELSE
  524. IBMN=MIN(IB,IELCHE(/2))
  525. IPMODL=IELCHE(1,IBMN)
  526. MELVAL=IVAL(2)
  527. IBMN=MIN(IB,IELCHE(/2))
  528. IPMAT=IELCHE(1,IBMN)
  529. CALL FRIGIE(IPMODL,IPMAT,CRIGI,CMASS)
  530. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  531. $ CALL DOHTIF(CRIGI,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  532. ENDIF
  533. ENDIF
  534. ENDIF
  535. ENDIF
  536. C
  537. C FIN TRAITEMENT DES DONNEES MATERIAUX
  538. C
  539. IF(MELE.EQ.97) THEN
  540. CALL ACORIG(REL,LRE,WORK,XE,KERRE)
  541. ELSE IF(MELE.EQ.84) THEN
  542. IF(CMATE.NE.'SECTION') THEN
  543.  
  544. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  545. CALL TIMRI2(REL,LRE,WORK,XE,WORK(12),KERRE)
  546. ELSE
  547. CALL TIMRIG(REL,LRE,WORK,XE,WORK(12),KERRE)
  548. ENDIF
  549. *
  550. ELSE
  551. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  552. CALL TIFRI2(REL,LRE,XE,WORK(12),LHOOK,
  553. $ DDHOOK,KERRE)
  554. ELSE
  555. CALL TIFRIG(REL,LRE,WORK,XE,WORK(12),LHOOK,
  556. $ DDHOOK,KERRE)
  557. ENDIF
  558. ENDIF
  559. ELSE
  560. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  561. CALL POURH2(REL,LRE,WORK,XE,WORK(12),IMAT,
  562. & LHOOK, DDHOOK, KERRE)
  563. ELSE
  564. CALL POURHG(REL,LRE,WORK,XE,WORK(12),IMAT,
  565. & LHOOK, DDHOOK, KERRE)
  566. ENDIF
  567. ENDIF
  568. C
  569. IF(KERRE.NE.0) INTERR(1)=ISOUS
  570. IF(KERRE.NE.0) INTERR(2)=IB
  571. C
  572. 4029 CONTINUE
  573. 8029 CONTINUE
  574. * SEGINI XMATRI
  575. * IMATTT(IB)=XMATRI
  576. C
  577. C REMPLISSAGE DE XMATRI
  578. C
  579. CALL REMPMT(REL,LRE,RE(1,1,IB))
  580. * SEGDES XMATRI
  581. 3029 CONTINUE
  582. IF(KERRE.EQ.1) CALL ERREUR(128)
  583. IF(KERRE.EQ.2) CALL ERREUR(138)
  584. IF(IRTD.EQ.0) THEN
  585. MOTERR(1:8)=CMATE
  586. MOTERR(9:16)=NOMFR(MFR/2+1)
  587. INTERR(1)=IFOUR
  588. CALL ERREUR(81)
  589. return
  590. ENDIF
  591. SEGDES XMATRI
  592. SEGSUP WRK1,WRK3,MVELCH
  593. GOTO 510
  594. C_______________________________________________________________________
  595. C
  596. C ELEMENTS LINESPRING LISP ET LISM
  597. C_______________________________________________________________________
  598. C
  599. 30 CONTINUE
  600. NBBB=NBNN
  601. NSTRS=2
  602. SEGINI WRK1,WRK3
  603. C
  604. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  605. C
  606. DO 3030 IB=1,NBELEM
  607. C
  608. C ON CHRCHE LES COORDONNEES DES NOEUDS
  609. C
  610. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  611. C
  612. C ON CHERCHE LES COEFFS DE LA MATRICE DE HOOKE
  613. C
  614. MPTVAL=IVAMAT
  615. IF(IMAT.EQ.2) THEN
  616. MELVAL=IVAL(1)
  617. IBMN=MIN(IB ,IELCHE(/2))
  618. MLREEL=IELCHE(1,IBMN)
  619. SEGACT MLREEL
  620. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  621. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  622. SEGDES MLREEL
  623. ELSE IF (IMAT.EQ.1) THEN
  624. *
  625. DO 9030 IM=1,NMATT
  626. IF (IVAL(IM).NE.0) THEN
  627. MELVAL=IVAL(IM)
  628. IBMN=MIN(IB ,VELCHE(/2))
  629. VALMAT(IM)=VELCHE(1,IBMN)
  630. ELSE
  631. VALMAT(IM)=0.D0
  632. ENDIF
  633. 9030 CONTINUE
  634. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  635. 1 CALL DOHLIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  636. ENDIF
  637. C
  638. C ON CHERCHE LES CARACTERISTIQUES ON OUBLIE LE 2 IEME POINT DEGAUS
  639. C
  640. IE=0
  641. MPTVAL=IVACAR
  642. DO 7030 IC=1,3,2
  643. DO 7030 ID=1,NCARR
  644. IE=IE+1
  645. MELVAL=IVAL(ID)
  646. IGMN=MIN(IC,VELCHE(/1))
  647. IBMN=MIN(IB,VELCHE(/2))
  648. WORK(IE)=VELCHE(IGMN,IBMN)
  649. 7030 CONTINUE
  650. C
  651. C CALCUL DE LA RIGIDITE
  652. C
  653. CALL LISPRI(XE,WORK,DDHOOK,WORK(11),MELE,REL,I70,I343,I157,I158)
  654. C IF(I70.EQ.1) INTERR(1)=IB
  655. IF(I158.EQ.1) INTERR(1)=IB
  656. IF(I343.EQ.1) INTERR(1)=IB
  657. * SEGINI XMATRI
  658. * IMATTT(IB)=XMATRI
  659. C
  660. C REMPLISSAGE DE XMATRI
  661. C
  662. CALL REMPMT(REL,LRE,RE(1,1,IB))
  663. * SEGDES XMATRI
  664. 3030 CONTINUE
  665. C IF(I70.EQ.1) CALL ERREUR(70)
  666. IF(I158.EQ.1) CALL ERREUR(158)
  667. IF(I343.EQ.1) CALL ERREUR(343)
  668. IF(IRTD.EQ.0) THEN
  669. MOTERR(1:8)=CMATE
  670. MOTERR(9:16)=NOMFR(MFR/2+1)
  671. INTERR(1)=IFOUR
  672. CALL ERREUR(81)
  673. ENDIF
  674. SEGDES XMATRI
  675. SEGSUP WRK1,WRK3,MVELCH
  676. GOTO 510
  677. C_______________________________________________________________________
  678. C
  679. C ELEMENT TUYAU FISSURE
  680. C_______________________________________________________________________
  681. C
  682. 43 CONTINUE
  683. NBBB=NBNN
  684. NSTRS=2
  685. SEGINI WRK1,WRK3
  686. C
  687. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  688. C
  689. DO 3043 IB=1,NBELEM
  690. C
  691. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  692. C
  693. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  694. C
  695. C
  696. C ON CHERCHE LES COEFF DES MAT DE HOOKE
  697. C
  698. MPTVAL=IVAMAT
  699. IF(IMAT.EQ.2) THEN
  700. MELVAL=IVAL(1)
  701. IBMN=MIN(IB ,IELCHE(/2))
  702. MLREEL=IELCHE(1,IBMN)
  703. SEGACT MLREEL
  704. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  705. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  706. SEGDES MLREEL
  707. ELSE IF (IMAT.EQ.1) THEN
  708. *
  709. DO 9043 IM=1,NMATT
  710. IF (IVAL(IM).NE.0) THEN
  711. MELVAL=IVAL(IM)
  712. IBMN=MIN(IB ,VELCHE(/2))
  713. VALMAT(IM)=VELCHE(1,IBMN)
  714. ELSE
  715. VALMAT(IM)=0.D0
  716. ENDIF
  717. 9043 CONTINUE
  718. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  719. 1 CALL DOHFIS(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  720. ENDIF
  721. C
  722. C CHERCHER LES CARACTERISTIQUES
  723. C
  724. MPTVAL=IVACAR
  725. DO 4043 IC=1,NCARR
  726. MELVAL=IVAL(IC)
  727. IBMN=MIN(IB,VELCHE(/2))
  728. WORK(IC)=VELCHE(1,IBMN)
  729. 4043 CONTINUE
  730. C
  731. C ON CALCULE SA RAIDEUR
  732. C
  733. CALL TUFIRI(REL,WORK(1),DDHOOK,I137)
  734. IF(I137.NE.0) INTERR(1)=ISOUS
  735. IF(I137.NE.0) INTERR(2)=IB
  736. C
  737. * SEGINI XMATRI
  738. * IMATTT(IB)=XMATRI
  739. C
  740. C REMPLISSAGE DE XMATRI
  741. C
  742. CALL REMPMT(REL,LRE,RE(1,1,IB))
  743. * SEGDES XMATRI
  744. 3043 CONTINUE
  745. IF(I137.EQ.1) CALL ERREUR(137)
  746. IF(I137.EQ.2) CALL ERREUR(123)
  747. IF(I137.EQ.3) CALL ERREUR(266)
  748. IF(IRTD.EQ.0) THEN
  749. MOTERR(1:8)=CMATE
  750. MOTERR(9:16)=NOMFR(MFR/2+1)
  751. INTERR(1)=IFOUR
  752. CALL ERREUR(81)
  753. ENDIF
  754. SEGDES XMATRI
  755. SEGSUP WRK1,WRK3,MVELCH
  756. GOTO 510
  757. C_______________________________________________________________________
  758. C
  759. C ELEMENT POI1
  760. C_______________________________________________________________________
  761. C
  762. 45 CONTINUE
  763. if (cmate.eq.'IMPELAST'.or.cmate.eq.'IMPVOIGT'.or.
  764. &cmate.eq.'IMPREUSS'.or.cmate.eq.'IMPCOMPL') then
  765.  
  766. MPTVAL=IVAMAT
  767. MELVAL=IVAL(1)
  768. if (ival(/1).gt.1) then
  769. melva1 = ival(2)
  770. else
  771. melva1 = 0
  772. endif
  773. DO IB = 1,NBELEM
  774. JDIAG = 0
  775. * SEGINI XMATRI
  776. * IMATTT(IB)=XMATRI
  777. IBMN=MIN(IB,VELCHE(/2))
  778. do igau = 1,NBPGAU
  779. IGMN=MIN(IGAU,VELCHE(/1))
  780. XRAID = VELCHE(IGMN,IBMN)
  781. XTORS = XRAID
  782. if (melva1.gt.0) then
  783. XTORS = melva1.VELCHE(IGMN,IBMN)
  784. endif
  785. do j =1,LRE
  786. JDIAG = JDIAG + 1
  787. if (j.le.3) then
  788. RE(JDIAG,JDIAG,IB) = XRAID
  789. else
  790. RE(JDIAG,JDIAG,IB) = XTORS
  791. endif
  792. enddo
  793. enddo
  794. * SEGDES XMATRI
  795. ENDDO
  796. SEGDES XMATRI
  797. goto 510
  798. endif
  799.  
  800. IF (CMATE.EQ.'MODAL') THEN
  801. * MODAL
  802. DO IB = 1,NBELEM
  803. MPTVAL=IVAMAT
  804. MELVAL=IVAL(1)
  805. IBMN=MIN(IB,VELCHE(/2))
  806. XFREQ=VELCHE(1,IBMN)
  807. MELVAL=IVAL(2)
  808. IBMN=MIN(IB,VELCHE(/2))
  809. XMASS=VELCHE(1,IBMN)
  810. OMEG = 2. * XPI * XFREQ
  811. RE(1,1,IB) = XMASS * OMEG * OMEG
  812. cbp-2017-10-02 if (xfreq.lt.0) RE(1,1,IB) = RE(1,1,IB) * (-1.)
  813. if (XFREQ.LT.0.D0) RE(1,1,IB) = 0.D0
  814. ENDDO
  815. SEGDES XMATRI
  816. GOTO 510
  817. *
  818.  
  819. ELSE IF (CMATE.EQ.'STATIQUE') THEN
  820. * STATIQUE
  821. DO IB = 1,NBELEM
  822. MPTVAL=IVAMAT
  823. MELVAL=IVAL(1)
  824. IBMN=MIN(IB,IELCHE(/2))
  825. idepl=IELCHE(1,IBMN)
  826. MELVAL=IVAL(2)
  827. IBMN=MIN(IB,IELCHE(/2))
  828. itreac=IELCHE(1,IBMN)
  829. CALL XTY1(idepl,itreac,iinc,idua,X1)
  830. if (ierr.ne.0) return
  831. re(1,1,IB) = x1
  832. ENDDO
  833. SEGDES XMATRI
  834. GOTO 510
  835. ENDIF
  836. *
  837. IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN
  838. GOTO 99
  839. ENDIF
  840. NBBB=NBNN
  841. SEGINI WRK1,WRK3
  842. C
  843. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  844. C
  845. KERRE=0
  846. DO 3045 IB=1,NBELEM
  847. C
  848. C ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  849. C
  850. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  851. C
  852. C
  853. C ON RECUPERE LA SECTION DE L'ELEMENT
  854. C
  855. MPTVAL=IVACAR
  856. MELVAL=IVAL(1)
  857. IBMN=MIN(IB,VELCHE(/2))
  858. SECT=VELCHE(1,IBMN)
  859. C
  860. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  861. C
  862. MPTVAL=IVAMAT
  863. IF(IMAT.EQ.2) THEN
  864. MELVAL=IVAL(1)
  865. IBMN=MIN(IB ,IELCHE(/2))
  866. MLREEL=IELCHE(1,IBMN)
  867. SEGACT MLREEL
  868. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  869. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  870. SEGDES MLREEL
  871. ELSE IF (IMAT.EQ.1) THEN
  872. *
  873. DO 9045 IM=1,NMATT
  874. IF (IVAL(IM).NE.0) THEN
  875. MELVAL=IVAL(IM)
  876. IBMN=MIN(IB ,VELCHE(/2))
  877. VALMAT(IM)=VELCHE(1,IBMN)
  878. ELSE
  879. VALMAT(IM)=0.D0
  880. ENDIF
  881. 9045 CONTINUE
  882. CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  883. ENDIF
  884. CALL PO1RIG(REL,LRE,DDHOOK(1,1),XE,KERRE,XDPGE,YDPGE)
  885. C
  886. * SEGINI XMATRI
  887. * IMATTT(IB)=XMATRI
  888. C
  889. C REMPLISSAGE DE XMATRI
  890. C
  891. CALL REMPMT(REL,LRE,RE(1,1,IB))
  892. * SEGDES XMATRI
  893. 3045 CONTINUE
  894. IF(IRTD.EQ.0) THEN
  895. MOTERR(1:8)=CMATE
  896. MOTERR(9:16)=NOMFR(MFR/2+1)
  897. INTERR(1)=IFOUR
  898. CALL ERREUR(81)
  899. ENDIF
  900. SEGDES XMATRI
  901. SEGSUP WRK1,WRK3,MVELCH
  902. GOTO 510
  903. C_______________________________________________________________________
  904. C
  905. C ELEMENTS BARRE ET CERCE
  906. C_______________________________________________________________________
  907. C
  908. 46 CONTINUE
  909. *
  910. IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  911. GO TO 99
  912. ENDIF
  913. NBBB=NBNN
  914. SEGINI WRK1,WRK3
  915. IF(MELE.EQ.123) THEN
  916. NSTN=NBNN
  917. LRN =LRE
  918. SEGINI WRK5
  919. ENDIF
  920. C
  921. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  922. C
  923. KERRE=0
  924. DO 3046 IB=1,NBELEM
  925. C
  926. C ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  927. C
  928. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  929. C
  930. C
  931. C ON RECUPERE LA SECTION DE L'ELEMENT
  932. C
  933. MPTVAL=IVACAR
  934. MELVAL=IVAL(1)
  935. IBMN=MIN(IB,VELCHE(/2))
  936. SECT=VELCHE(1,IBMN)
  937. C
  938. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  939. C
  940. MPTVAL=IVAMAT
  941. IF(IMAT.EQ.2) THEN
  942. MELVAL=IVAL(1)
  943. IBMN=MIN(IB ,IELCHE(/2))
  944. MLREEL=IELCHE(1,IBMN)
  945. SEGACT MLREEL
  946. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  947. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  948. SEGDES MLREEL
  949. ELSE IF (IMAT.EQ.1) THEN
  950. *
  951. DO 9046 IM=1,NMATT
  952. IF (IVAL(IM).NE.0) THEN
  953. MELVAL=IVAL(IM)
  954. IBMN=MIN(IB ,VELCHE(/2))
  955. VALMAT(IM)=VELCHE(1,IBMN)
  956. ELSE
  957. VALMAT(IM)=0.D0
  958. ENDIF
  959. 9046 CONTINUE
  960. CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  961. ENDIF
  962. IF(MELE.EQ.46) CALL BARRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
  963. IF(MELE.EQ.95) CALL CERRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
  964. IF(MELE.EQ.123)CALL BARIG3(REL,LRE,DDHOOK(1,1),XE,XGENE,KERRE,IB)
  965. IF(KERRE.NE.0) INTERR(1)=ISOUS
  966. IF(KERRE.NE.0) INTERR(2)=IB
  967. C
  968. * SEGINI XMATRI
  969. * IMATTT(IB)=XMATRI
  970. C
  971. C REMPLISSAGE DE XMATRI
  972. C
  973. CALL REMPMT(REL,LRE,RE(1,1,IB))
  974. * SEGDES XMATRI
  975. 3046 CONTINUE
  976. IF(MELE.EQ.46.AND.KERRE.EQ.1) CALL ERREUR(128)
  977. IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601)
  978. IF(MELE.EQ.123.AND.KERRE.EQ.1) CALL ERREUR(128)
  979. IF(IRTD.EQ.0) THEN
  980. MOTERR(1:8)=CMATE
  981. MOTERR(9:16)=NOMFR(MFR/2+1)
  982. INTERR(1)=IFOUR
  983. CALL ERREUR(81)
  984. ENDIF
  985. SEGDES XMATRI
  986. SEGSUP WRK1,WRK3,MVELCH
  987. IF(MELE.EQ.123) SEGSUP WRK5
  988. GOTO 510
  989. C
  990. C_______________________________________________________________________
  991. C
  992. C ELEMENT BARRE 3D EXCENTRE (BAEX)
  993. C_______________________________________________________________________
  994. C
  995. 124 CONTINUE
  996. NBBB=NBNN
  997. NBNO=NBNN
  998. NSTRS1=NSTRS
  999. NSTRS=NBNN
  1000. SEGINI WRK1,WRK2,WRK3
  1001. C
  1002. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1003. C
  1004. KERRE=0
  1005. DO 3108 IB=1,NBELEM
  1006. C
  1007. C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON
  1008. C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK
  1009. C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ
  1010. C
  1011. MPTVAL=IVACAR
  1012. DO IC=1,NCARR
  1013. IF(IVAL(IC).NE.0) THEN
  1014. MELVAL=IVAL(IC)
  1015. IBMN=MIN(IB,VELCHE(/2))
  1016. WORK(IC)=VELCHE(1,IBMN)
  1017. ELSE
  1018. WORK(IC)=0.D0
  1019. ENDIF
  1020. END DO
  1021. SECT=WORK(1)
  1022. C
  1023. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  1024. C
  1025. MPTVAL=IVAMAT
  1026. IF(IMAT.EQ.2) THEN
  1027. MELVAL=IVAL(1)
  1028. IBMN=MIN(IB ,IELCHE(/2))
  1029. MLREEL=IELCHE(1,IBMN)
  1030. SEGACT MLREEL
  1031. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  1032. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1033. SEGDES MLREEL
  1034. ELSE IF (IMAT.EQ.1) THEN
  1035. DO 9108 IM=1,NMATT
  1036. IF (IVAL(IM).NE.0) THEN
  1037. MELVAL=IVAL(IM)
  1038. IBMN=MIN(IB ,VELCHE(/2))
  1039. VALMAT(IM)=VELCHE(1,IBMN)
  1040. ELSE
  1041. VALMAT(IM)=0.D0
  1042. ENDIF
  1043. 9108 CONTINUE
  1044. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  1045. 1 CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  1046. ENDIF
  1047. C
  1048. C BGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE
  1049. C
  1050. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1051. CALL MAPAEX(XE,NBNN,WORK,AL,BGENE,LRE,KERRE)
  1052. IF(KERRE.NE.0) INTERR(1)=ISOUS
  1053. IF(KERRE.NE.0) INTERR(2)=IB
  1054. IF(KERRE.EQ.1) CALL ERREUR(128)
  1055. CALL RIGBEX(REL,LRE,DDHOOK(1,1),AL,BGENE)
  1056. C
  1057. * SEGINI XMATRI
  1058. * IMATTT(IB)=XMATRI
  1059. C
  1060. C REMPLISSAGE DE XMATRI
  1061. C
  1062. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1063. * SEGDES XMATRI
  1064. 3108 CONTINUE
  1065. NSTRS=NSTRS1
  1066. SEGDES XMATRI
  1067. SEGSUP WRK1,WRK2,WRK3,MVELCH
  1068. GOTO 510
  1069. C_______________________________________________________________________
  1070. C
  1071. C LIA2 : element de liaison a 2 noeuds (6 ddl par noeuds)
  1072. C_______________________________________________________________________
  1073. C
  1074. 125 CONTINUE
  1075. NBBB=NBNN
  1076. NBNO=NBNN
  1077. SEGINI WRK1,WRK2,WRK3,WRK4
  1078. C
  1079. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1080. C
  1081. KERRE=0
  1082. DO 3109 IB=1,NBELEM
  1083. C
  1084. MPTVAL=IVACAR
  1085. DO IC=1,NCARR
  1086. IF(IVAL(IC).NE.0) THEN
  1087. MELVAL=IVAL(IC)
  1088. IBMN=MIN(IB,VELCHE(/2))
  1089. WORK(IC)=VELCHE(1,IBMN)
  1090. ELSE
  1091. WORK(IC)=0.D0
  1092. ENDIF
  1093. END DO
  1094. C
  1095. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1096. CALL MAPALI(XE,NBNN,WORK,BPSS,KERRE)
  1097. IF(KERRE.NE.0) INTERR(1)=ISOUS
  1098. IF(KERRE.NE.0) INTERR(2)=IB
  1099. IF(KERRE.EQ.1) CALL ERREUR(128)
  1100. CALL RIGLI2(REL,LRE,BPSS,WORK)
  1101. C
  1102. * SEGINI XMATRI
  1103. * IMATTT(IB)=XMATRI
  1104. C
  1105. C REMPLISSAGE DE XMATRI
  1106. C
  1107. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1108. * SEGDES XMATRI
  1109. 3109 CONTINUE
  1110. SEGDES XMATRI
  1111. SEGSUP WRK1,WRK2,WRK3,MVELCH
  1112. GOTO 510
  1113. *-------------------------------------------------------------
  1114. C_______________________________________________________________________
  1115. C
  1116. C JOI1 : element de liaison a 2 noeuds (6 ddl par noeuds)
  1117. C_______________________________________________________________________
  1118. C
  1119. 129 CONTINUE
  1120. NBBB=NBNN
  1121. NBNO=NBNN
  1122. SEGINI WRK1,WRK2,WRK3,WRK4
  1123. C
  1124. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1125. C
  1126. KERRE=0
  1127. DO 3110 IB=1,NBELEM
  1128. C
  1129. MPTVAL=IVAMAT
  1130. DO IC=1,NMATT
  1131. IF(IVAL(IC).NE.0) THEN
  1132. MELVAL=IVAL(IC)
  1133. IBMN=MIN(IB,VELCHE(/2))
  1134. WORK(IC)=VELCHE(1,IBMN)
  1135. ELSE
  1136. WORK(IC)=0.D0
  1137. ENDIF
  1138. END DO
  1139. C
  1140. CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  1141. c
  1142. c on calcule la matrice de rigidité localement
  1143. c
  1144. CALL RIGJOI(NMATT,REL,LRE,WORK,IDIM,CMATE)
  1145. c
  1146. c on passe en repère global
  1147. c
  1148. IAW1=101
  1149. IAW2=IAW1+LRE*LRE
  1150. IAW3=IAW2+LRE*LRE
  1151. IAW4=IAW3+LRE*LRE
  1152. CALL JOIGLO(REL,BPSS,WORK(IAW1),WORK(IAW2),
  1153. & WORK(IAW3),WORK(IAW4),LRE,IDIM)
  1154. *
  1155. C
  1156. * SEGINI XMATRI
  1157. * IMATTT(IB)=XMATRI
  1158. C
  1159. C REMPLISSAGE DE XMATRI
  1160. C
  1161. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1162. *
  1163. * SEGDES XMATRI
  1164. 3110 CONTINUE
  1165. SEGDES XMATRI
  1166. SEGSUP WRK1,WRK2,WRK3,MVELCH
  1167. GOTO 510
  1168. *-------------------------------------------------------------
  1169. c
  1170. c element coaxial COS2 (3D pour liaison acier-beton)
  1171. c
  1172. 271 continue
  1173. NBBB=NBNN
  1174. lw=5
  1175. SEGINI WRK1,WRK4,wrk3
  1176. do 3271 ib= 1,nbelem
  1177. C
  1178. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1179. C
  1180.  
  1181. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1182. CALL ZERO (REL,LRE,LRE)
  1183. CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
  1184. MPTVAL=IVAmat
  1185. if(imat.eq.1) then
  1186. DO IC=1,2
  1187. IF(IVAL(IC).NE.0) THEN
  1188. MELVAL=IVAL(IC)
  1189. IBMN=MIN(IB,VELCHE(/2))
  1190. WORK(ic)=VELCHE(1,IBMN)
  1191. ELSE
  1192. WORK(IC)=0.D0
  1193. ENDIF
  1194. END DO
  1195. ELSE
  1196. MELVAL=IVAL(1)
  1197. IBMN=MIN(IB,IELCHE(/2))
  1198. MLREEL=IELCHE(1,IBMN)
  1199. SEGACT MLREEL
  1200. if(idim.eq.3) then
  1201. work(1)= prog(1)
  1202. work(2) = prog(9)
  1203. else if (idim.eq.1.or.idim.eq.2) then
  1204. CALL ERREUR(81)
  1205. endif
  1206. segdes mlreel
  1207. endif
  1208. C
  1209. C
  1210. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1211. C
  1212. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1213. xv1= xe(1,2)-xe(1,1)
  1214. yv1= xe(2,2)-xe(2,1)
  1215. zv1=0.d0
  1216. if( idim.eq.3) zv1 = xe(3,2)-xe(3,1)
  1217. xl= sqrt(xv1*xv1 + yv1*yv1 + zv1*zv1)
  1218. C
  1219. C recuperation de la section et calcul du diamètre
  1220. C
  1221. MPTVAL=IVACAR
  1222. DO 2712 ICOMP=1,NCARR
  1223. MELVAL=IVAL(ICOMP)
  1224. IGMN = VELCHE(/1)
  1225. IBMN=MIN(IB,VELCHE(/2))
  1226. SECA =VELCHE(IGMN,IBMN)
  1227. 2712 CONTINUE
  1228. diam = sqrt(4.d0*SECA/xpi)
  1229. C
  1230. xls1 = (3.d0*xpi*diam*xl)/8.d0
  1231. xls2 = (1.d0*xpi*diam*xl)/8.d0
  1232. xks1 = xls1*work(1)
  1233. xks2 = xls2*work(1)
  1234. xln1 = (3.d0*diam*xl)/8.d0
  1235. xln2 = (1.d0*diam*xl)/8.d0
  1236. xkn1 = xln1*work(2)
  1237. xkn2 = xln2*work(2)
  1238. xks = work(1)
  1239. xkn = work(2)
  1240. if (idim.eq.2) then
  1241. C cas de matrice elastique
  1242. rel(1,1)= xks1
  1243. rel(1,3)= xks2
  1244. rel(1,5)= -xks2
  1245. rel(1,7)=-xks1
  1246. rel(7,7)= xks1
  1247. rel(7,1)=-xks1
  1248. rel(7,3)= -xks2
  1249. rel(7,5)= xks2
  1250. rel(3,3)=xks1
  1251. rel(3,5)=-xks1
  1252. rel(3,1)= xks2
  1253. rel(3,7)= -xks2
  1254. rel(5,5)=xks1
  1255. rel(5,3)=-xks1
  1256. rel(5,1)= -xks2
  1257. rel(5,7)= xks2
  1258. c ---------------------------
  1259. rel(2,2)= xkn1
  1260. rel(2,4)= xkn2
  1261. rel(2,6)= -xkn2
  1262. rel(2,8)=-xkn1
  1263. rel(8,8)= xkn1
  1264. rel(8,2)=-xkn1
  1265. rel(8,4)= -xkn2
  1266. rel(8,6)= xkn2
  1267. rel(4,4)=xkn1
  1268. rel(4,6)=-xkn1
  1269. rel(4,2)= xkn2
  1270. rel(4,8)= -xkn2
  1271. rel(6,6)=xkn1
  1272. rel(6,4)=-xkn1
  1273. rel(6,2)= -xkn2
  1274. rel(6,8)= xkn2
  1275. else if (idim.eq.3) then
  1276. C cas de matrice elastique
  1277. rel(1,1)= xks1
  1278. rel(1,4)= xks2
  1279. rel(1,7)= -xks2
  1280. rel(1,10)=-xks1
  1281. rel(10,10)= xks1
  1282. rel(10,1)=-xks1
  1283. rel(10,4)= -xks2
  1284. rel(10,7)= xks2
  1285. rel(4,4)=xks1
  1286. rel(4,7)=-xks1
  1287. rel(4,1)= xks2
  1288. rel(4,10)= -xks2
  1289. rel(7,7)=xks1
  1290. rel(7,4)=-xks1
  1291. rel(7,1)= -xks2
  1292. rel(7,10)= xks2
  1293. C ------- remplissage de KN ------------
  1294. rel(2,2)= xkn1
  1295. rel(2,5)= xkn2
  1296. rel(2,8)= -xkn2
  1297. rel(2,11)=-xkn1
  1298. rel(11,11)= xkn1
  1299. rel(11,2)=-xkn1
  1300. rel(11,5)= -xkn2
  1301. rel(11,8)= xkn2
  1302. rel(5,5)=xkn1
  1303. rel(5,8)=-xkn1
  1304. rel(5,2)= xkn2
  1305. rel(5,11)= -xkn2
  1306. rel(8,8)=xkn1
  1307. rel(8,5)=-xkn1
  1308. rel(8,2)= -xkn2
  1309. rel(8,11)= xkn2
  1310. c------------
  1311. rel(3,3)= xkn1
  1312. rel(3,6)= xkn2
  1313. rel(3,9)= -xkn2
  1314. rel(3,12)=-xkn1
  1315. rel(12,12)= xkn1
  1316. rel(12,3)=-xkn1
  1317. rel(12,6)= -xkn2
  1318. rel(12,9)= xkn2
  1319. rel(6,6)=xkn1
  1320. rel(6,9)=-xkn1
  1321. rel(6,3)= xkn2
  1322. rel(6,12)= -xkn2
  1323. rel(9,9)=xkn1
  1324. rel(9,6)=-xkn1
  1325. rel(9,3)= -xkn2
  1326. rel(9,12)= xkn2
  1327. endif
  1328. do 3272 ia = 1, 4
  1329. do 3272 ic = 1,4
  1330. do 3273 io=1,idim
  1331. do 3273 iu=1,idim
  1332. xpa(io,iu)= rel( ia*idim-idim+io,ic*idim -idim +iu)
  1333. 3273 continue
  1334. call prodt(xpb,xpa,bpss,idim,idim)
  1335. do 3274 io=1,idim
  1336. do 3274 iu=1,idim
  1337. rell( ia*idim-idim+io,ic*idim -idim +iu) = xpb(io,iu)
  1338. 3274 continue
  1339. 3272 continue
  1340. C
  1341. C REMPLISSAGE DE XMATRI
  1342. C
  1343. CALL REMPMT(RELL,LRE,RE(1,1,IB))
  1344. 3271 continue
  1345. SEGDES XMATRI
  1346. SEGSUP WRK1,WRK3,WRK4
  1347. GOTO 510
  1348. c cccccc
  1349. C_______________________________________________________________________
  1350. C
  1351. C SECTEUR DE CALCUL POUR LE COA2
  1352. C
  1353. C_______________________________________________________________________
  1354. C
  1355. 272 continue
  1356. NBNO=NBNN
  1357. NBBB=NBNN
  1358. SEGINI WRK1,WRK2,WRK4
  1359. C
  1360. C BOUCLE POUR TOUS LES ELEMENTS
  1361. C
  1362. DO 2721 IB=1,NBELEM
  1363. C
  1364. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1365. C
  1366. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1367. C
  1368. CALL ZERO (REL,LRE,LRE)
  1369. C
  1370. C CALCUL DES AXES LOCAUX
  1371. C
  1372. CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
  1373. DO 2722 IGAU=1,NBPGAU
  1374. C
  1375. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1376. C
  1377. CALL BCO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1378. . BGENE,DJAC,IRRT,IDIM)
  1379. IF(IRRT.NE.0) THEN
  1380. INTERR(1)=IB
  1381. CALL ERREUR(764)
  1382. GOTO 9985
  1383. ENDIF
  1384. C
  1385. C
  1386. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1387. C
  1388. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1389. xv1= xe(1,2)-xe(1,1)
  1390. yv1= xe(2,2)-xe(2,1)
  1391. zv1=0.d0
  1392. if( idim.eq.3) zv1 = xe(3,2)-xe(3,1)
  1393. xl= sqrt(xv1*xv1 + yv1*yv1 + zv1*zv1)
  1394. C
  1395. C recuperation de la section et calcul du diamètre
  1396. C
  1397. MPTVAL=IVACAR
  1398. DO 2729 ICOMP=1,NCARR
  1399. MELVAL=IVAL(ICOMP)
  1400. IGMN = VELCHE(/1)
  1401. IBMN=MIN(IB,VELCHE(/2))
  1402. SECA =VELCHE(IGMN,IBMN)
  1403. 2729 CONTINUE
  1404. diam = sqrt(4.d0*SECA/xpi)
  1405. C
  1406. DJAC=DJAC*POIGAU(IGAU)
  1407. C
  1408. C CALCUL DE LA MATRICE DE HOOK
  1409. C
  1410. MPTVAL=IVAMAT
  1411. IF(IMAT.EQ.2) THEN
  1412. MELVAL=IVAL(1)
  1413. IBMN=MIN(IB ,IELCHE(/2))
  1414. IGMN=MIN(IGAU,IELCHE(/1))
  1415. MLREEL=IELCHE(IGMN,IBMN)
  1416. SEGACT MLREEL
  1417. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1418. 1 CALL DOHOCO(PROG,LHOOK,DDHOOK,XL,DIAM)
  1419. SEGDES MLREEL
  1420. ELSE IF (IMAT.EQ.1) THEN
  1421. DO 2723 IM=1,NMATT
  1422. IF (IVAL(IM).NE.0) THEN
  1423. MELVAL=IVAL(IM)
  1424. IBMN=MIN(IB ,VELCHE(/2))
  1425. IGMN=MIN(IGAU,VELCHE(/1))
  1426. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1427. ELSE
  1428. VALMAT(IM)=0.D0
  1429. ENDIF
  1430. 2723 CONTINUE
  1431. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1432. 1 CALL DOUCO2(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD,XL,DIAM)
  1433. END IF
  1434. C
  1435. C CALCUL ET INTEGRATION DE BDB
  1436. C
  1437. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1438. 2722 CONTINUE
  1439. C
  1440. do 2726 ia = 1,4
  1441. do 2726 ic = 1,4
  1442. do 2727 io=1,idim
  1443. do 2727 iu=1,idim
  1444. xpa(io,iu)= rel( ia*idim-idim+io,ic*idim -idim +iu)
  1445. 2727 continue
  1446. call prodt(xpb,xpa,bpss,idim,idim)
  1447. do 2728 io=1,idim
  1448. do 2728 iu=1,idim
  1449. rell( ia*idim-idim+io,ic*idim -idim +iu) = xpb(io,iu)
  1450. 2728 continue
  1451. 2726 continue
  1452. C
  1453. C REMPLISSAGE DE XMATRI
  1454. C
  1455. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1456. 2721 CONTINUE
  1457. C
  1458. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1459. C
  1460. IF (IRTD.EQ.0) THEN
  1461. MOTERR(1:8) = CMATE
  1462. MOTERR(9:16) = NOMFR(MFR/2+1)
  1463. INTERR(1) = IFOUR
  1464. CALL ERREUR(81)
  1465. ENDIF
  1466. C
  1467. c SEGDES XMATRI
  1468. 9985 CONTINUE
  1469. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1470. GOTO 510
  1471. *-----------------------------------------------------------------------
  1472. C_______________________________________________________________________
  1473. C
  1474. C SECTEUR DE CALCUL POUR LE JOI2
  1475. C
  1476. C_______________________________________________________________________
  1477. C
  1478. 85 CONTINUE
  1479. NBNO=NBNN
  1480. NBBB=NBNN
  1481. SEGINI WRK1,WRK2,WRK4
  1482. C
  1483. C BOUCLE POUR TOUS LES ELEMENTS
  1484. C
  1485. DO 3085 IB=1,NBELEM
  1486. C
  1487. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1488. C
  1489. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1490. C
  1491. CALL ZERO (REL,LRE,LRE)
  1492. C
  1493. C CALCUL DES AXES LOCAUX
  1494. C
  1495. CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1496. C
  1497. CCC IF (NOQUAL.EQ.1) THEN
  1498. CCCC NOEUDS TROP VOISINS
  1499. CCC INTERR(1)=IB
  1500. CCCC *******MESSAGE D'ERREUR 323 A ADAPTER AUX JOINTS
  1501. CCC CALL ERREUR(323)
  1502. CCC ELSE IF ( NOQUAL.EQ.2 ) THEN
  1503. CCCC JOINT NON PLAN
  1504. CCC INTERR(1)=IB
  1505. CCCC *******MESSAGE D'ERREUR 323 A ADAPTER AUX JOINTS
  1506. CCC CALL ERREUR(323)
  1507. CCC RETURN
  1508. CCC ENDIF
  1509. C
  1510. C BOUCLE SUR LES POINTS DE GAUSS
  1511. C
  1512. DO 4085 IGAU=1,NBPGAU
  1513. C
  1514. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1515. C
  1516. CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1517. + BGENE,DJAC,IRRT)
  1518. DJAC=DJAC*POIGAU(IGAU)
  1519.  
  1520. *
  1521. IF (IFOUR.EQ.0) THEN
  1522. C
  1523. C EN AXISYMETRIE, ON MULTIPLIE PAR R
  1524. C (R=RAYON DE COURBURE DU POINT DE GAUSS)
  1525. C
  1526. RAYON=0.0D0
  1527. NUMSUP=NBNO/2
  1528. *
  1529. DO 5085 IRAY=1,NUMSUP
  1530. RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  1531. 5085 CONTINUE
  1532. * modif TC
  1533. * dr = XE(1,2)-xe(1,1)
  1534. * ra= XE(1,1)
  1535. * rb= XE(1,2)
  1536. * rayona = rb*rb*rb/6.d0 - 0.5d0*ra*ra*rb +ra*ra*ra /3.d0
  1537. * rayona=rayona *2.d0 /dr / dr
  1538. * rayonb= rb*rb*rb/3.d0 - 0.5d0*ra*rb*rb +ra*ra*ra /6.d0
  1539. * rayonb=rayonb *2.d0 / dr / dr
  1540.  
  1541. * rayon= rayona
  1542. * if(igau.eq.2) rayon=rayonb
  1543. DJAC=DJAC*RAYON
  1544. ENDIF
  1545. C
  1546. C IRRT=1 JACOBIEN <= 0
  1547. IF(IRRT.NE.0) THEN
  1548. INTERR(1)=IB
  1549. CALL ERREUR(612)
  1550. ENDIF
  1551. C
  1552. C CALCUL DE LA MATRICE DE HOOK
  1553. C
  1554. MPTVAL=IVAMAT
  1555. IF(IMAT.EQ.2) THEN
  1556. MELVAL=IVAL(1)
  1557. IBMN=MIN(IB ,IELCHE(/2))
  1558. IGMN=MIN(IGAU,IELCHE(/1))
  1559. MLREEL=IELCHE(IGMN,IBMN)
  1560. SEGACT MLREEL
  1561. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1562. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1563. SEGDES MLREEL
  1564. ELSE IF (IMAT.EQ.1) THEN
  1565. DO 9085 IM=1,NMATT
  1566. IF (IVAL(IM).NE.0) THEN
  1567. MELVAL=IVAL(IM)
  1568. IBMN=MIN(IB ,VELCHE(/2))
  1569. IGMN=MIN(IGAU,VELCHE(/1))
  1570. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1571. ELSE
  1572. VALMAT(IM)=0.D0
  1573. ENDIF
  1574. 9085 CONTINUE
  1575. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1576. 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1577. ENDIF
  1578. C
  1579. C CALCUL ET INTEGRATION DE BDB
  1580. C
  1581. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1582. 4085 CONTINUE
  1583. C
  1584. * SEGINI XMATRI
  1585. * IMATTT(IB)=XMATRI
  1586. C
  1587. C REMPLISSAGE DE XMATRI
  1588. C
  1589. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1590. * SEGDES XMATRI
  1591. 3085 CONTINUE
  1592. C
  1593. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1594. C
  1595. IF (IRTD.EQ.0) THEN
  1596. MOTERR(1:8) = CMATE
  1597. MOTERR(9:16) = NOMFR(MFR/2+1)
  1598. INTERR(1) = IFOUR
  1599. CALL ERREUR(81)
  1600. ENDIF
  1601. C
  1602. SEGDES XMATRI
  1603. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1604. GOTO 510
  1605. C_______________________________________________________________________
  1606. C
  1607. C SECTEUR DE CALCUL POUR LE JGI2
  1608. C
  1609. C_______________________________________________________________________
  1610. C
  1611. 170 CONTINUE
  1612. NBNO=NBNN
  1613. NBBB=NBNN
  1614. SEGINI WRK1,WRK2,WRK4
  1615. C
  1616. C BOUCLE POUR TOUS LES ELEMENTS
  1617. C
  1618. DO IB=1,NBELEM
  1619. C
  1620. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1621. C
  1622. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1623. C
  1624. CALL ZERO (REL,LRE,LRE)
  1625. C
  1626. C CALCUL DES AXES LOCAUX
  1627. C
  1628. CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1629. C
  1630. C BOUCLE SUR LES POINTS DE GAUSS
  1631. C
  1632. DO IGAU=1,NBPGAU
  1633. C
  1634. C ON CHERCHE L EPAISSEUR DU JOINT
  1635. C
  1636. EPAIST=0.D0
  1637. MPTVAL=IVACAR
  1638. MELVAL=IVAL(1)
  1639. IF (MELVAL.NE.0) THEN
  1640. IGMN=MIN(IGAU,VELCHE(/1))
  1641. IBMN=MIN(IB,VELCHE(/2))
  1642. EPAIST=VELCHE(IGMN,IBMN)
  1643. ENDIF
  1644. C
  1645. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1646. C
  1647. CcPPj CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1648. CcPPj. EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT)
  1649. CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
  1650. . EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT)
  1651. DJAC=DJAC*POIGAU(IGAU)
  1652. C
  1653. IF (IFOUR.EQ.0) THEN
  1654. C
  1655. C EN AXISYMETRIE, ON MULTIPLIE PAR R
  1656. C (R=RAYON DE COURBURE DU POINT DE GAUSS)
  1657. C
  1658. RAYON=0.0D0
  1659. NUMSUP=NBNO/2
  1660. DO IRAY=1,NUMSUP
  1661. RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  1662. ENDDO
  1663. DJAC=DJAC*RAYON
  1664. ENDIF
  1665. C
  1666. C IRRT=1 JACOBIEN <= 0
  1667. IF(IRRT.NE.0) THEN
  1668. INTERR(1)=IB
  1669. CALL ERREUR(612)
  1670. ENDIF
  1671. C
  1672. C CALCUL DE LA MATRICE DE HOOK
  1673. C
  1674. MPTVAL=IVAMAT
  1675. IF(IMAT.EQ.2) THEN
  1676. MELVAL=IVAL(1)
  1677. IBMN=MIN(IB ,IELCHE(/2))
  1678. IGMN=MIN(IGAU,IELCHE(/1))
  1679. MLREEL=IELCHE(IGMN,IBMN)
  1680. SEGACT MLREEL
  1681. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1682. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1683. SEGDES MLREEL
  1684. ELSE IF (IMAT.EQ.1) THEN
  1685. DO IM=1,NMATT
  1686. IF (IVAL(IM).NE.0) THEN
  1687. MELVAL=IVAL(IM)
  1688. IBMN=MIN(IB ,VELCHE(/2))
  1689. IGMN=MIN(IGAU,VELCHE(/1))
  1690. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1691. ELSE
  1692. VALMAT(IM)=0.D0
  1693. ENDIF
  1694. ENDDO
  1695. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1696. 1 CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD)
  1697. ENDIF
  1698. C
  1699. C CALCUL ET INTEGRATION DE BDB
  1700. C
  1701. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1702. ENDDO
  1703. C
  1704. * SEGINI XMATRI
  1705. * IMATTT(IB)=XMATRI
  1706. C
  1707. C REMPLISSAGE DE XMATRI
  1708. C
  1709. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1710. * SEGDES XMATRI
  1711. ENDDO
  1712. C
  1713. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1714. C
  1715. IF (IRTD.EQ.0) THEN
  1716. MOTERR(1:8) = CMATE
  1717. MOTERR(9:16) = NOMFR(MFR/2+1)
  1718. INTERR(1) = IFOUR
  1719. CALL ERREUR(81)
  1720. ENDIF
  1721. C
  1722. SEGDES XMATRI
  1723. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1724. GOTO 510
  1725. C_______________________________________________________________________
  1726. C
  1727. C SECTEUR DE CALCUL POUR LE JCT3 en 2D cisaillement
  1728. C
  1729. C_______________________________________________________________________
  1730. C
  1731. 168 CONTINUE
  1732. NBNO=NBNN
  1733. NBBB=NBNN
  1734. SEGINI WRK1,WRK2,WRK4
  1735. C
  1736. C BOUCLE POUR TOUS LES ELEMENTS
  1737. C
  1738. DO IB=1,NBELEM
  1739. C
  1740. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1741. C
  1742. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1743. C
  1744. CALL ZERO (REL,LRE,LRE)
  1745. C
  1746. C CALCUL DES AXES LOCAUX
  1747. C
  1748. CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1749. C
  1750. IF (NOQUAL.EQ.1) THEN
  1751. INTERR(1)=IB
  1752. MOTERR(1:4) = 'JGT3'
  1753. CALL ERREUR(765)
  1754. RETURN
  1755. ELSE IF ( NOQUAL.EQ.2) THEN
  1756. INTERR(1)=IB
  1757. MOTERR(1:4) = 'JGT3'
  1758. CALL ERREUR(766)
  1759. RETURN
  1760. ENDIF
  1761. C
  1762. C BOUCLE SUR LES POINTS DE GAUSS
  1763. C
  1764. DO IGAU=1,NBPGAU
  1765. C 4
  1766. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1767. C
  1768. CALL BJT3C(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1769. + BGENE,DJAC,IRRT)
  1770. DJAC=DJAC*POIGAU(IGAU)
  1771. C IRRT=1 JACOBIEN <= 0
  1772. IF(IRRT.NE.0) THEN
  1773. CALL ERREUR(764)
  1774. ENDIF
  1775. C
  1776. C CALCUL DE LA MATRICE DE HOOK
  1777. C
  1778. MPTVAL=IVAMAT
  1779. IF(IMAT.EQ.2) THEN
  1780. MELVAL=IVAL(1)
  1781. IBMN=MIN(IB ,IELCHE(/2))
  1782. IGMN=MIN(IGAU,IELCHE(/1))
  1783. MLREEL=IELCHE(IGMN,IBMN)
  1784. SEGACT MLREEL
  1785. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1786. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1787. SEGDES MLREEL
  1788. ELSE IF (IMAT.EQ.1) THEN
  1789. DO IM=1,NMATT
  1790. IF (IVAL(IM).NE.0) THEN
  1791. MELVAL=IVAL(IM)
  1792. IBMN=MIN(IB ,VELCHE(/2))
  1793. IGMN=MIN(IGAU,VELCHE(/1))
  1794. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1795. ELSE
  1796. VALMAT(IM)=0.D0
  1797. ENDIF
  1798. ENDDO
  1799. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1800. 1 CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1801. ENDIF
  1802. C
  1803. C CALCUL ET INTEGRATION DE BDB
  1804. C
  1805. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1806. ENDDO
  1807. C
  1808. * SEGINI XMATRI
  1809. * IMATTT(IB)=XMATRI
  1810. C
  1811. C REMPLISSAGE DE XMATRI
  1812. C
  1813. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1814. * SEGDES XMATRI
  1815. ENDDO
  1816. C
  1817. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1818. C
  1819. IF (IRTD.EQ.0) THEN
  1820. MOTERR(1:8) = CMATE
  1821. MOTERR(9:16) = NOMFR(MFR/2+1)
  1822. INTERR(1) = IFOUR
  1823. CALL ERREUR(81)
  1824. ENDIF
  1825. C
  1826. SEGDES XMATRI
  1827. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1828. GOTO 510
  1829. C_______________________________________________________________________
  1830. C
  1831. C SECTEUR DE CALCUL POUR LE JGT3 GENERALISE
  1832. C
  1833. C_______________________________________________________________________
  1834. C
  1835. 171 CONTINUE
  1836. NBNO=NBNN
  1837. NBBB=NBNN
  1838. SEGINI WRK1,WRK2,WRK4
  1839. C
  1840. C BOUCLE POUR TOUS LES ELEMENTS
  1841. C
  1842. DO IB=1,NBELEM
  1843. C
  1844. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1845. C
  1846. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1847. C
  1848. CALL ZERO (REL,LRE,LRE)
  1849. C
  1850. C CALCUL DES AXES LOCAUX
  1851. C
  1852. CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1853. C
  1854. IF (NOQUAL.EQ.1) THEN
  1855. INTERR(1)=IB
  1856. MOTERR(1:4) = 'JGT3'
  1857. CALL ERREUR(765)
  1858. RETURN
  1859. ELSE IF ( NOQUAL.EQ.2) THEN
  1860. INTERR(1)=IB
  1861. MOTERR(1:4) = 'JGT3'
  1862. CALL ERREUR(766)
  1863. RETURN
  1864. ENDIF
  1865. C
  1866. C BOUCLE SUR LES POINTS DE GAUSS
  1867. C
  1868. DO IGAU=1,NBPGAU
  1869. C
  1870. C ON CHERCHE L'EPAISSEUR DU JOINT
  1871. C
  1872. EPAIST=0.D0
  1873. MPTVAL=IVACAR
  1874. MELVAL=IVAL(1)
  1875. IF (MELVAL.NE.0) THEN
  1876. IGMN=MIN(IGAU,VELCHE(/1))
  1877. IBMN=MIN(IB,VELCHE(/2))
  1878. EPAIST=VELCHE(IGMN,IBMN)
  1879. ENDIF
  1880. C 4
  1881. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1882. C
  1883. CcPPj CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1884. CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
  1885. + EPAIST,BGENE,DJAC,IRRT)
  1886. DJAC=DJAC*POIGAU(IGAU)
  1887. C IRRT=1 JACOBIEN <= 0
  1888. IF(IRRT.NE.0) THEN
  1889. CALL ERREUR(764)
  1890. ENDIF
  1891. C
  1892. C CALCUL DE LA MATRICE DE HOOK
  1893. C
  1894. MPTVAL=IVAMAT
  1895. IF(IMAT.EQ.2) THEN
  1896. MELVAL=IVAL(1)
  1897. IBMN=MIN(IB ,IELCHE(/2))
  1898. IGMN=MIN(IGAU,IELCHE(/1))
  1899. MLREEL=IELCHE(IGMN,IBMN)
  1900. SEGACT MLREEL
  1901. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1902. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1903. SEGDES MLREEL
  1904. ELSE IF (IMAT.EQ.1) THEN
  1905. DO IM=1,NMATT
  1906. IF (IVAL(IM).NE.0) THEN
  1907. MELVAL=IVAL(IM)
  1908. IBMN=MIN(IB ,VELCHE(/2))
  1909. IGMN=MIN(IGAU,VELCHE(/1))
  1910. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1911. ELSE
  1912. VALMAT(IM)=0.D0
  1913. ENDIF
  1914. ENDDO
  1915. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1916. 1 CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD)
  1917. ENDIF
  1918. C
  1919. C CALCUL ET INTEGRATION DE BDB
  1920. C
  1921. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1922. ENDDO
  1923. C
  1924. * SEGINI XMATRI
  1925. * IMATTT(IB)=XMATRI
  1926. C
  1927. C REMPLISSAGE DE XMATRI
  1928. C
  1929. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1930. * SEGDES XMATRI
  1931. ENDDO
  1932. C
  1933. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1934. C
  1935. IF (IRTD.EQ.0) THEN
  1936. MOTERR(1:8) = CMATE
  1937. MOTERR(9:16) = NOMFR(MFR/2+1)
  1938. INTERR(1) = IFOUR
  1939. CALL ERREUR(81)
  1940. ENDIF
  1941. C
  1942. SEGDES XMATRI
  1943. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1944. GOTO 510
  1945. C_______________________________________________________________________
  1946. C
  1947. C SECTEUR DE CALCUL POUR LE JCI4 en 2D cisaillement
  1948. C
  1949. C_______________________________________________________________________
  1950. C
  1951. 169 CONTINUE
  1952. NBNO=NBNN
  1953. NBBB=NBNN
  1954. SEGINI WRK1,WRK2,WRK4
  1955. C
  1956. C BOUCLE POUR TOUS LES ELEMENTS
  1957. C
  1958. DO IB=1,NBELEM
  1959. C
  1960. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1961. C
  1962. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1963. C
  1964. CALL ZERO (REL,LRE,LRE)
  1965. C
  1966. C CALCUL DES AXES LOCAUX
  1967. C
  1968. CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1969.  
  1970. IF (NOQUAL.EQ.1) THEN
  1971. INTERR(1)=IB
  1972. MOTERR(1:4) = 'JCI4'
  1973. CALL ERREUR(765)
  1974. RETURN
  1975. ELSE IF ( NOQUAL.EQ.2 ) THEN
  1976. INTERR(1)=IB
  1977. MOTERR(1:4) = 'JCI4'
  1978. CALL ERREUR(766)
  1979. RETURN
  1980. ENDIF
  1981. C
  1982. C BOUCLE SUR LES POINTS DE GAUSS
  1983. C
  1984. DO IGAU=1,NBPGAU
  1985. C
  1986. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1987. C
  1988. CALL BJO4C(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT)
  1989. DJAC=DJAC*POIGAU(IGAU)
  1990. C IRRT=1 JACOBIEN <= 0
  1991. IF(IRRT.NE.0) THEN
  1992. INTERR(1)=IB
  1993. CALL ERREUR(611)
  1994. ENDIF
  1995. C
  1996. C CALCUL DE LA MATRICE DE HOOK
  1997. C
  1998. MPTVAL=IVAMAT
  1999. IF(IMAT.EQ.2) THEN
  2000. MELVAL=IVAL(1)
  2001. IBMN=MIN(IB ,IELCHE(/2))
  2002. IGMN=MIN(IGAU,IELCHE(/1))
  2003. MLREEL=IELCHE(IGMN,IBMN)
  2004. SEGACT MLREEL
  2005. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2006. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2007. SEGDES MLREEL
  2008. ELSE IF (IMAT.EQ.1) THEN
  2009. DO IM=1,NMATT
  2010. IF (IVAL(IM).NE.0) THEN
  2011. MELVAL=IVAL(IM)
  2012. IBMN=MIN(IB ,VELCHE(/2))
  2013. IGMN=MIN(IGAU,VELCHE(/1))
  2014. VALMAT(IM)=VELCHE(IGMN,IBMN)
  2015. ELSE
  2016. VALMAT(IM)=0.D0
  2017. ENDIF
  2018. ENDDO
  2019. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2020. 1 CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2021. ENDIF
  2022. C
  2023. C CALCUL ET INTEGRATION DE BDB
  2024. C
  2025. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2026. ENDDO
  2027. C
  2028. * SEGINI XMATRI
  2029. * IMATTT(IB)=XMATRI
  2030. C
  2031. C REMPLISSAGE DE XMATRI
  2032. C
  2033. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2034. * SEGDES XMATRI
  2035. ENDDO
  2036. C
  2037. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2038. C
  2039. IF (IRTD.EQ.0) THEN
  2040. MOTERR(1:8) = CMATE
  2041. MOTERR(9:16) = NOMFR(MFR/2+1)
  2042. INTERR(1) = IFOUR
  2043. CALL ERREUR(81)
  2044. ENDIF
  2045. C
  2046. SEGDES XMATRI
  2047. SEGSUP WRK1,WRK2,WRK4,MVELCH
  2048. GOTO 510
  2049. C_______________________________________________________________________
  2050. C
  2051. C SECTEUR DE CALCUL POUR LE JGI4 GENERALISE
  2052. C
  2053. C_______________________________________________________________________
  2054. C
  2055. 172 CONTINUE
  2056. NBNO=NBNN
  2057. NBBB=NBNN
  2058. SEGINI WRK1,WRK2,WRK4
  2059. C
  2060. C BOUCLE POUR TOUS LES ELEMENTS
  2061. C
  2062. DO IB=1,NBELEM
  2063. C
  2064. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2065. C
  2066. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2067. C
  2068. CALL ZERO (REL,LRE,LRE)
  2069. C
  2070. C CALCUL DES AXES LOCAUX
  2071. C
  2072. CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  2073.  
  2074. IF (NOQUAL.EQ.1) THEN
  2075. INTERR(1)=IB
  2076. MOTERR(1:4) = 'JGI4'
  2077. CALL ERREUR(765)
  2078. RETURN
  2079. ELSE IF ( NOQUAL.EQ.2 ) THEN
  2080. CbPPj INTERR(1)=IB
  2081. CbPPj MOTERR(1:4) = 'JGI4'
  2082. CbPPj CALL ERREUR(766)
  2083. CbPPj RETURN
  2084. WRITE(IOIMP,*)'RIGI4(WARNING): JGI4 element number',IB,
  2085. . ' not planar'
  2086. ENDIF
  2087. C
  2088. C BOUCLE SUR LES POINTS DE GAUSS
  2089. C
  2090. DO IGAU=1,NBPGAU
  2091. C
  2092. C ON CHERCHE L'EPAISSEUR DU JOINT
  2093. C
  2094. EPAIST=0.D0
  2095. MPTVAL=IVACAR
  2096. MELVAL=IVAL(1)
  2097. IF (MELVAL.NE.0) THEN
  2098. IGMN=MIN(IGAU,VELCHE(/1))
  2099. IBMN=MIN(IB,VELCHE(/2))
  2100. EPAIST=VELCHE(IGMN,IBMN)
  2101. ENDIF
  2102. C
  2103. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2104. C
  2105. CcPPj CALL BJO4G(IGAU,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,IRRT)
  2106. CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,
  2107. . IRRT)
  2108. DJAC=DJAC*POIGAU(IGAU)
  2109. C IRRT=1 JACOBIEN <= 0
  2110. IF(IRRT.NE.0) THEN
  2111. INTERR(1)=IB
  2112. CALL ERREUR(611)
  2113. ENDIF
  2114. C
  2115. C CALCUL DE LA MATRICE DE HOOK
  2116. C
  2117. MPTVAL=IVAMAT
  2118. IF(IMAT.EQ.2) THEN
  2119. MELVAL=IVAL(1)
  2120. IBMN=MIN(IB ,IELCHE(/2))
  2121. IGMN=MIN(IGAU,IELCHE(/1))
  2122. MLREEL=IELCHE(IGMN,IBMN)
  2123. SEGACT MLREEL
  2124. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2125. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2126. SEGDES MLREEL
  2127. ELSE IF (IMAT.EQ.1) THEN
  2128. DO IM=1,NMATT
  2129. IF (IVAL(IM).NE.0) THEN
  2130. MELVAL=IVAL(IM)
  2131. IBMN=MIN(IB ,VELCHE(/2))
  2132. IGMN=MIN(IGAU,VELCHE(/1))
  2133. VALMAT(IM)=VELCHE(IGMN,IBMN)
  2134. ELSE
  2135. VALMAT(IM)=0.D0
  2136. ENDIF
  2137. ENDDO
  2138. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2139. 1 CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD)
  2140. ENDIF
  2141. C
  2142. C CALCUL ET INTEGRATION DE BDB
  2143. C
  2144. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2145. ENDDO
  2146. C
  2147. * SEGINI XMATRI
  2148. * IMATTT(IB)=XMATRI
  2149. C
  2150. C REMPLISSAGE DE XMATRI
  2151. C
  2152. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2153. * SEGDES XMATRI
  2154. ENDDO
  2155. C
  2156. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2157. C
  2158. IF (IRTD.EQ.0) THEN
  2159. MOTERR(1:8) = CMATE
  2160. MOTERR(9:16) = NOMFR(MFR/2+1)
  2161. INTERR(1) = IFOUR
  2162. CALL ERREUR(81)
  2163. ENDIF
  2164. C
  2165. SEGDES XMATRI
  2166. SEGSUP WRK1,WRK2,WRK4,MVELCH
  2167. GOTO 510
  2168. C
  2169. C_______________________________________________________________________
  2170. C
  2171. C SECTEUR DE CALCUL POUR LE JOI3 SANS TEST DE PLANEITE
  2172. C ET SANS REPERE LOCAL
  2173. C
  2174. C_______________________________________________________________________
  2175. C
  2176. 86 CONTINUE
  2177. NBNO=NBNN
  2178. NBBB=NBNN
  2179. SEGINI WRK1,WRK2,WRK4
  2180. C
  2181. C BOUCLE POUR TOUS LES ELEMENTS
  2182. C
  2183. DO 3086 IB=1,NBELEM
  2184. C
  2185. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2186. C
  2187. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2188. C
  2189. CALL ZERO (REL,LRE,LRE)
  2190. C
  2191. C BOUCLE SUR LES POINTS DE GAUSS
  2192. C
  2193. DO 4086 IGAU=1,NBPGAU
  2194. C
  2195. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2196. C
  2197.  
  2198. CALL JO3LOC(XE,SHPTOT,IGAU,NBNO,BPSS)
  2199. CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK,
  2200. + BGENE,DJAC,IRRT)
  2201. DJAC=DJAC*POIGAU(IGAU)
  2202. *
  2203. IF (IFOUR.EQ.0) THEN
  2204. C
  2205. C EN AXISYMETRIE, ON MULTIPLIE PAR R
  2206. C (R=RAYON DE COURBURE DU POINT DE GAUSS)
  2207. C
  2208. RAYON=0.0D0
  2209. NUMSUP=NBNO/2
  2210. DO 5086 IRAY=1,NUMSUP
  2211. RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  2212. 5086 CONTINUE
  2213. DJAC=DJAC*RAYON
  2214. ENDIF
  2215. C
  2216. C IRRT=1 JACOBIEN <= 0
  2217. IF(IRRT.NE.0) THEN
  2218. INTERR(1)=IB
  2219. CALL ERREUR(612)
  2220. ENDIF
  2221. C
  2222. C CALCUL DE LA MATRICE DE HOOK
  2223. C
  2224. MPTVAL=IVAMAT
  2225. IF(IMAT.EQ.2) THEN
  2226. MELVAL=IVAL(1)
  2227. IBMN=MIN(IB ,IELCHE(/2))
  2228. IGMN=MIN(IGAU,IELCHE(/1))
  2229. MLREEL=IELCHE(IGMN,IBMN)
  2230. SEGACT MLREEL
  2231. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2232. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2233. SEGDES MLREEL
  2234. ELSE IF (IMAT.EQ.1) THEN
  2235. DO 9086 IM=1,NMATT
  2236. IF (IVAL(IM).NE.0) THEN
  2237. MELVAL=IVAL(IM)
  2238. IBMN=MIN(IB ,VELCHE(/2))
  2239. IGMN=MIN(IGAU,VELCHE(/1))
  2240. VALMAT(IM)=VELCHE(IGMN,IBMN)
  2241. ELSE
  2242. VALMAT(IM)=0.D0
  2243. ENDIF
  2244. 9086 CONTINUE
  2245. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2246. 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2247. ENDIF
  2248. C
  2249. C CALCUL ET INTEGRATION DE BDB
  2250. C
  2251. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2252. 4086 CONTINUE
  2253. C
  2254. * SEGINI XMATRI
  2255. * IMATTT(IB)=XMATRI
  2256. C
  2257. C REMPLISSAGE DE XMATRI
  2258. C
  2259. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2260. * SEGDES XMATRI
  2261. 3086 CONTINUE
  2262. C
  2263. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2264. C
  2265. IF (IRTD.EQ.0) THEN
  2266. MOTERR(1:8) = CMATE
  2267. MOTERR(9:16) = NOMFR(MFR/2+1)
  2268. INTERR(1) = IFOUR
  2269. CALL ERREUR(81)
  2270. ENDIF
  2271. C
  2272. SEGDES XMATRI
  2273. SEGSUP WRK1,WRK2,WRK4,MVELCH
  2274. GOTO 510
  2275. C_______________________________________________________________________
  2276. C
  2277. C SECTEUR DE CALCUL POUR LE JOT3
  2278. C
  2279. C_______________________________________________________________________
  2280. C
  2281. 87 CONTINUE
  2282. NBNO=NBNN
  2283. NBBB=NBNN
  2284. SEGINI WRK1,WRK2,WRK4
  2285. C
  2286. C BOUCLE POUR TOUS LES ELEMENTS
  2287. C
  2288. DO 3087 IB=1,NBELEM
  2289. C
  2290. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2291. C
  2292. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2293. C
  2294. CALL ZERO (REL,LRE,LRE)
  2295. C
  2296. C CALCUL DES AXES LOCAUX
  2297. C
  2298. CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  2299. C
  2300. IF (NOQUAL.EQ.1) THEN
  2301. INTERR(1)=IB
  2302. MOTERR(1:4) = 'JOT3'
  2303. CALL ERREUR(765)
  2304. RETURN
  2305. ELSE IF ( NOQUAL.EQ.2) THEN
  2306. INTERR(1)=IB
  2307. MOTERR(1:4) = 'JOT3'
  2308. CALL ERREUR(766)
  2309. RETURN
  2310. ENDIF
  2311. C
  2312. C BOUCLE SUR LES POINTS DE GAUSS
  2313. C
  2314. DO 4087 IGAU=1,NBPGAU
  2315. C 4
  2316. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2317. C
  2318. CALL BJT3(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  2319. + BGENE,DJAC,IRRT)
  2320. DJAC=DJAC*POIGAU(IGAU)
  2321. C IRRT=1 JACOBIEN <= 0
  2322. IF(IRRT.NE.0) THEN
  2323. CALL ERREUR(764)
  2324. ENDIF
  2325. C
  2326. C CALCUL DE LA MATRICE DE HOOK
  2327. C
  2328. MPTVAL=IVAMAT
  2329. IF(IMAT.EQ.2) THEN
  2330. MELVAL=IVAL(1)
  2331. IBMN=MIN(IB ,IELCHE(/2))
  2332. IGMN=MIN(IGAU,IELCHE(/1))
  2333. MLREEL=IELCHE(IGMN,IBMN)
  2334. SEGACT MLREEL
  2335. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2336. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2337. SEGDES MLREEL
  2338. ELSE IF (IMAT.EQ.1) THEN
  2339. DO 9087 IM=1,NMATT
  2340. IF (IVAL(IM).NE.0) THEN
  2341. MELVAL=IVAL(IM)
  2342. IBMN=MIN(IB ,VELCHE(/2))
  2343. IGMN=MIN(IGAU,VELCHE(/1))
  2344. VALMAT(IM)=VELCHE(IGMN,IBMN)
  2345. ELSE
  2346. VALMAT(IM)=0.D0
  2347. ENDIF
  2348. 9087 CONTINUE
  2349. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2350. 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2351. ENDIF
  2352. C
  2353. C CALCUL ET INTEGRATION DE BDB
  2354. C
  2355. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2356. 4087 CONTINUE
  2357. C
  2358. * SEGINI XMATRI
  2359. * IMATTT(IB)=XMATRI
  2360. C
  2361. C REMPLISSAGE DE XMATRI
  2362. C
  2363. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2364. * SEGDES XMATRI
  2365. 3087 CONTINUE
  2366. C
  2367. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2368. C
  2369. IF (IRTD.EQ.0) THEN
  2370. MOTERR(1:8) = CMATE
  2371. MOTERR(9:16) = NOMFR(MFR/2+1)
  2372. INTERR(1) = IFOUR
  2373. CALL ERREUR(81)
  2374. ENDIF
  2375. C
  2376. SEGDES XMATRI
  2377. SEGSUP WRK1,WRK2,WRK4,MVELCH
  2378. GOTO 510
  2379. C_______________________________________________________________________
  2380. C
  2381. C SECTEUR DE CALCUL POUR LE JOI4
  2382. C
  2383. C_______________________________________________________________________
  2384. C
  2385. 88 CONTINUE
  2386. NBNO=NBNN
  2387. NBBB=NBNN
  2388. SEGINI WRK1,WRK2,WRK4
  2389. C
  2390. C BOUCLE POUR TOUS LES ELEMENTS
  2391. C
  2392. DO 3088 IB=1,NBELEM
  2393. C
  2394. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2395. C
  2396. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2397. C
  2398. CALL ZERO (REL,LRE,LRE)
  2399. C
  2400. C CALCUL DES AXES LOCAUX
  2401. C
  2402. CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  2403.  
  2404. IF (NOQUAL.EQ.1) THEN
  2405. INTERR(1)=IB
  2406. MOTERR(1:4) = 'JOI4'
  2407. CALL ERREUR(765)
  2408. RETURN
  2409. ELSE IF ( NOQUAL.EQ.2 ) THEN
  2410. INTERR(1)=IB
  2411. MOTERR(1:4) = 'JOI4'
  2412. CALL ERREUR(766)
  2413. RETURN
  2414. ENDIF
  2415. C
  2416. C BOUCLE SUR LES POINTS DE GAUSS
  2417. C
  2418. DO 4088 IGAU=1,NBPGAU
  2419. C
  2420. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2421. C
  2422. CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT)
  2423. DJAC=DJAC*POIGAU(IGAU)
  2424. C IRRT=1 JACOBIEN <= 0
  2425. IF(IRRT.NE.0) THEN
  2426. INTERR(1)=IB
  2427. CALL ERREUR(611)
  2428. ENDIF
  2429. C
  2430. C CALCUL DE LA MATRICE DE HOOK
  2431. C
  2432. MPTVAL=IVAMAT
  2433. IF(IMAT.EQ.2) THEN
  2434. MELVAL=IVAL(1)
  2435. IBMN=MIN(IB ,IELCHE(/2))
  2436. IGMN=MIN(IGAU,IELCHE(/1))
  2437. MLREEL=IELCHE(IGMN,IBMN)
  2438. SEGACT MLREEL
  2439. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2440. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2441. SEGDES MLREEL
  2442. ELSE IF (IMAT.EQ.1) THEN
  2443. DO 9088 IM=1,NMATT
  2444. IF (IVAL(IM).NE.0) THEN
  2445. MELVAL=IVAL(IM)
  2446. IBMN=MIN(IB ,VELCHE(/2))
  2447. IGMN=MIN(IGAU,VELCHE(/1))
  2448. VALMAT(IM)=VELCHE(IGMN,IBMN)
  2449. ELSE
  2450. VALMAT(IM)=0.D0
  2451. ENDIF
  2452. 9088 CONTINUE
  2453. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2454. 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2455. ENDIF
  2456. C
  2457. C CALCUL ET INTEGRATION DE BDB
  2458. C
  2459. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2460. 4088 CONTINUE
  2461. C
  2462. * SEGINI XMATRI
  2463. * IMATTT(IB)=XMATRI
  2464. C
  2465. C REMPLISSAGE DE XMATRI
  2466. C
  2467. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2468. * SEGDES XMATRI
  2469. 3088 CONTINUE
  2470. C
  2471. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2472. C
  2473. IF (IRTD.EQ.0) THEN
  2474. MOTERR(1:8) = CMATE
  2475. MOTERR(9:16) = NOMFR(MFR/2+1)
  2476. INTERR(1) = IFOUR
  2477. CALL ERREUR(81)
  2478. ENDIF
  2479. C
  2480. SEGDES XMATRI
  2481. SEGSUP WRK1,WRK2,WRK4,MVELCH
  2482. GOTO 510
  2483. C_______________________________________________________________________
  2484. C
  2485. C SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISE TRIH
  2486. C_______________________________________________________________________
  2487. C
  2488. 92 CONTINUE
  2489. NBNO=NBNN
  2490. NBBB=NBNN
  2491. LRN =NBNN
  2492. NSTN=3
  2493. SEGINI WRK1,WRK2 ,WRK5
  2494. I195=0
  2495. DO 3092 IB=1,NBELEM
  2496. C
  2497. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2498. C
  2499. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2500. CALL ZERO (REL,LRE,LRE)
  2501. *
  2502. MPTVAL=IVAMAT
  2503. DO 9092 IM=1,10
  2504. IF (IVAL(IM).NE.0) THEN
  2505. MELVAL=IVAL(IM)
  2506. IBMN=MIN(IB ,VELCHE(/2))
  2507. VALMAT(IM)=VELCHE(1,IBMN)
  2508. ELSE
  2509. VALMAT(IM)=0.D0
  2510.  
  2511. ENDIF
  2512. 9092 CONTINUE
  2513. C
  2514. C ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB
  2515. C
  2516. RHOF =VALMAT(4)
  2517. E =VALMAT(6)
  2518. C =VALMAT(7)
  2519. RHOREF=VALMAT(8)
  2520. CREF =VALMAT(9)
  2521. RLCAR =VALMAT(10)
  2522. C
  2523. C ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB
  2524. C
  2525. MPTVAL=IVACAR
  2526. IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
  2527. MELVAL=IVAL(1)
  2528. IBMN=MIN(IB,VELCHE(/2))
  2529. SCEL =VELCHE(1,IBMN)
  2530. MELVAL=IVAL(2)
  2531. IBMN=MIN(IB,VELCHE(/2))
  2532. SFLU =VELCHE(1,IBMN)
  2533. MELVAL=IVAL(3)
  2534. IBMN=MIN(IB,VELCHE(/2))
  2535. EPS =VELCHE(1,IBMN)
  2536. MELVAL=IVAL(4)
  2537. IBMN=MIN(IB,VELCHE(/2))
  2538. XINERT=VELCHE(1,IBMN)
  2539. EI = E*XINERT/(EPS*EPS)
  2540. ELSE
  2541. MELVAL=IVAL(1)
  2542. IBMN=MIN(IB,VELCHE(/2))
  2543. SCEL =VELCHE(1,IBMN)
  2544. MELVAL=IVAL(2)
  2545. IBMN=MIN(IB,VELCHE(/2))
  2546. SFLU =VELCHE(1,IBMN)
  2547. MELVAL=IVAL(3)
  2548. IBMN=MIN(IB,VELCHE(/2))
  2549. EPS =VELCHE(1,IBMN)
  2550. C E REPRESENTE LA RIGIDITE MODALE DE LA POUTRE
  2551. EI = E /(EPS*EPS)
  2552. ENDIF
  2553. C
  2554. C CALCUL DES COEFFICIENTS DE NORMALISATION
  2555. C
  2556. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  2557. VKL1 =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL)
  2558. VKL2 = EI/SCEL
  2559. C
  2560. C BOUCLE SUR LES POINTS DE GAUSS
  2561. C
  2562. ISDJC=0
  2563. DO 4092 IGAU=1,NBPGAU
  2564. CALL TRIHR1(IGAU,MELE,MFR,NBNO,IFOUR,NIFOUR,XE,SHPTOT,
  2565. # SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT)
  2566. IF(IRRT.NE.1) GOTO 5092
  2567. DJAC=DJAC*POIGAU(IGAU)
  2568. CALL TRIHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL)
  2569. 4092 CONTINUE
  2570. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  2571. * SEGINI XMATRI
  2572. * IMATTT(IB)=XMATRI
  2573. C
  2574. C REMPLISSAGE DE XMATRI
  2575. C
  2576. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2577. * SEGDES XMATRI
  2578. 3092 CONTINUE
  2579. C
  2580. C IMPRESSION D UN EVENTUEL MESSAGE D ERREUR
  2581. C
  2582. 5092 CONTINUE
  2583. IF(IRRT.EQ.0) THEN
  2584. MOTERR(1:4)=NOMTP(MELE)
  2585. CALL ERREUR(420)
  2586. ELSE
  2587. IF(IRRT.EQ.2) THEN
  2588. INTERR(1)=IB
  2589. CALL ERREUR(405)
  2590. ENDIF
  2591. ENDIF
  2592. IF(I195.NE.0) INTERR(1)=I195
  2593. IF(I195.NE.0) CALL ERREUR(195)
  2594. SEGDES XMATRI
  2595. SEGSUP WRK1,WRK2,WRK5,MVELCH
  2596. GOTO 510
  2597. *_______________________________________________________________________
  2598. *
  2599. * ELEMENT TUYO
  2600. *_______________________________________________________________________
  2601. *
  2602. 96 CONTINUE
  2603. NBNO=IPORE
  2604. NBBB=NBNN
  2605. SEGINI WRK1,WRK2,WRK3,WRK6
  2606. C
  2607. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  2608. C
  2609. DO 3096 IB=1,NBELEM
  2610. KERRE=0
  2611. C
  2612. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2613. C
  2614. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2615. CALL ZERO (REL,LRE,LRE)
  2616. *
  2617. XL=(XE(1,2)-XE(1,1))**2+(XE(2,2)-XE(2,1))**2+
  2618. . (XE(3,2)-XE(3,1))**2
  2619. XL=SQRT(XL)
  2620. IF(XL.EQ.0.D0) THEN
  2621. KERRE=1
  2622. GO TO 3096
  2623. ENDIF
  2624. C
  2625. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  2626. C ON SUPPOSE QU'ELLES SONT CONSTANTES POUR L'ELEMENT
  2627. C
  2628. MPTVAL=IVACAR
  2629. DO 6096 IC=1,NCARR
  2630. IF (IVAL(IC).NE.0) THEN
  2631. MELVAL=IVAL(IC)
  2632. IBMN=MIN(IB,VELCHE(/2))
  2633. WORK(IC)=VELCHE(1,IBMN)
  2634. ELSE
  2635. WORK(IC)=0.D0
  2636. ENDIF
  2637. 6096 CONTINUE
  2638. C
  2639. C TRAITEMENT DU VECTEUR
  2640. C
  2641. IF (IVAL(NCARR).NE.0) THEN
  2642. MELVAL=IVAL(NCARR)
  2643. IBMN=MIN(IB,IELCHE(/2))
  2644. IP=IELCHE(1,IBMN)
  2645. IREF=(IP-1)*(IDIM+1)
  2646. DO 6196 IC=1,IDIM
  2647. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  2648. 6196 CONTINUE
  2649. ELSE
  2650. DO 6296 IC=1,IDIM
  2651. WORK(NCARR+IC-1)=0.D0
  2652. 6296 CONTINUE
  2653. ENDIF
  2654. C
  2655. C CALCUL DU REPERE LOCAL
  2656. C
  2657. CALL TUYPAS(XE,XL,WORK,PSS,KERRE)
  2658. IF(KERRE.NE.0) THEN
  2659. INTERR(1)=IB
  2660. CALL ERREUR(5 )
  2661. RETURN
  2662. ENDIF
  2663. C
  2664. C BOUCLE SUR LES POINTS DE GAUSS
  2665. C
  2666. DO 4096 IGAU=1,NBPGAU
  2667. C
  2668. C TRAITEMENT DU MATERIAU
  2669. C IL PEUT VARIER D'UN POINT DE GAUSS A L'AUTRE
  2670. C
  2671. MPTVAL=IVAMAT
  2672. IF(IMAT.EQ.2) THEN
  2673. MELVAL=IVAL(1)
  2674. IGMN=MIN(IGAU,VELCHE(/1))
  2675. IBMN=MIN(IB ,IELCHE(/2))
  2676. MLREEL=IELCHE(IGMN,IBMN)
  2677. SEGACT MLREEL
  2678. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2679. . CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2680. SEGDES MLREEL
  2681. *
  2682. ELSE IF (IMAT.EQ.1) THEN
  2683. *
  2684. DO 9096 IM=1,NMATT
  2685. IF (IVAL(IM).NE.0) THEN
  2686. MELVAL=IVAL(IM)
  2687. IGMN=MIN(IGAU,VELCHE(/1))
  2688. IBMN=MIN(IB ,VELCHE(/2))
  2689. VALMAT(IM)=VELCHE(IGMN,IBMN)
  2690. ELSE
  2691. VALMAT(IM)=0.D0
  2692. ENDIF
  2693. 9096 CONTINUE
  2694. CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2695. EPAIST=WORK(1)
  2696. CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU)
  2697. ENDIF
  2698. *
  2699. * CALCUL DE LA MATRICE B ET DU JACOBIEN
  2700. *
  2701. CALL BTUYO(IGAU,MINTE,WRK1,WRK2,WRK3,XL,DJAC,KERRE)
  2702. DJAC=DJAC*POIGAU(IGAU)
  2703. *
  2704. IF(KERRE.NE.0) THEN
  2705. INTERR(1)=IB
  2706. CALL ERREUR(5)
  2707. ENDIF
  2708. *
  2709. * CALCUL ET INTEGRATION DE BTDB
  2710. *
  2711. CALL BDBST(BGENE,DJAC,DDHOMU,LRE,NSTRS,REL)
  2712. 4096 CONTINUE
  2713. *
  2714. * CHANGEMENT DE BASE
  2715. *
  2716. CALL TUYROT(REL,LRE,PSS,1)
  2717. *
  2718. * SEGINI XMATRI
  2719. * IMATTT(IB)=XMATRI
  2720. C
  2721. C REMPLISSAGE DE XMATRI
  2722. C
  2723. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2724. * SEGDES XMATRI
  2725. 3096 CONTINUE
  2726. IF(KERRE.EQ.1) CALL ERREUR(128)
  2727. IF(KERRE.EQ.2) CALL ERREUR(138)
  2728. IF(IRTD.EQ.0) THEN
  2729. MOTERR(1:8)=CMATE
  2730. MOTERR(9:16)=NOMFR(MFR/2+1)
  2731. INTERR(1)=IFOUR
  2732. CALL ERREUR(81)
  2733. return
  2734. ENDIF
  2735. SEGDES XMATRI
  2736. SEGSUP WRK1,WRK2,WRK3,WRK6,MVELCH
  2737. GOTO 510
  2738. C_______________________________________________________________________
  2739. C
  2740. C SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISES QUAH
  2741. C_______________________________________________________________________
  2742. C
  2743. 126 CONTINUE
  2744. C
  2745. NBNO=NBNN
  2746. NBBB=NBNN
  2747. LRN =NBNN+NBNN
  2748. NSTN=2
  2749. SEGINI WRK1,WRK2 ,WRK5
  2750. I195=0
  2751. DO 3126 IB=1,NBELEM
  2752. C
  2753. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2754. C
  2755. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2756. CALL ZERO (REL,LRE,LRE)
  2757. *
  2758. MPTVAL=IVAMAT
  2759. DO 9126 IM=1,10
  2760. IF (IVAL(IM).NE.0) THEN
  2761. MELVAL=IVAL(IM)
  2762. IBMN=MIN(IB ,VELCHE(/2))
  2763. VALMAT(IM)=VELCHE(1,IBMN)
  2764. ELSE
  2765. VALMAT(IM)=0.D0
  2766.  
  2767. ENDIF
  2768. 9126 CONTINUE
  2769. C
  2770. C ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB
  2771. C
  2772. RHOF =VALMAT(4)
  2773.  
  2774. E =VALMAT(6)
  2775.  
  2776. C =VALMAT(7)
  2777.  
  2778. RHOREF=VALMAT(8)
  2779.  
  2780. CREF =VALMAT(9)
  2781.  
  2782. RLCAR =VALMAT(10)
  2783.  
  2784. C
  2785. C ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB
  2786. C
  2787. MPTVAL=IVACAR
  2788. MELVAL=IVAL(1)
  2789. IBMN=MIN(IB,VELCHE(/2))
  2790. SCEL =VELCHE(1,IBMN)
  2791.  
  2792. MELVAL=IVAL(2)
  2793. IBMN=MIN(IB,VELCHE(/2))
  2794. SFLU =VELCHE(1,IBMN)
  2795.  
  2796. MELVAL=IVAL(3)
  2797. IBMN=MIN(IB,VELCHE(/2))
  2798. EPS =VELCHE(1,IBMN)
  2799.  
  2800. MELVAL=IVAL(5)
  2801. IBMN=MIN(IB,VELCHE(/2))
  2802. XINERT=VELCHE(1,IBMN)
  2803. EI = E*XINERT/(EPS*EPS)
  2804. C
  2805. C CALCUL DES COEFFICIENTS DE NORMALISATION
  2806. C
  2807. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  2808. VKL1 =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL)
  2809. VKL2 = EI/SCEL
  2810. C
  2811. C
  2812. C BOUCLE SUR LES POINTS DE GAUSS
  2813. C
  2814. ISDJC=0
  2815. DO 4126 IGAU=1,NBPGAU
  2816. CALL QUAHR1(IGAU,MELE,MFR,NBNO,IFOUR,NIFOUR,XE,SHPTOT,
  2817. # SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT)
  2818. IF(IRRT.NE.1) GOTO 5126
  2819. DJAC=DJAC*POIGAU(IGAU)
  2820. CALL QUAHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL)
  2821. 4126 CONTINUE
  2822. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  2823. * SEGINI XMATRI
  2824. * IMATTT(IB)=XMATRI
  2825. C
  2826. C REMPLISSAGE DE XMATRI
  2827. C
  2828. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2829. * SEGDES XMATRI
  2830. 3126 CONTINUE
  2831. C
  2832. C IMPRESSION D UN EVENTUEL MESSAGE D ERREUR
  2833. C
  2834. 5126 CONTINUE
  2835. IF(IRRT.EQ.0) THEN
  2836. MOTERR(1:4)=NOMTP(MELE)
  2837. CALL ERREUR(420)
  2838. ELSE
  2839. IF(IRRT.EQ.2) THEN
  2840. INTERR(1)=IB
  2841. CALL ERREUR(405)
  2842. ENDIF
  2843. ENDIF
  2844. IF(I195.NE.0) INTERR(1)=I195
  2845. IF(I195.NE.0) CALL ERREUR(195)
  2846. SEGDES XMATRI
  2847. SEGSUP WRK1,WRK2,WRK5,MVELCH
  2848. GOTO 510
  2849. C_______________________________________________________________________
  2850. C
  2851. C SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISES CUBH
  2852. C_______________________________________________________________________
  2853. C
  2854. 127 CONTINUE
  2855. NBNO=NBNN
  2856. NBBB=NBNN
  2857. LRN =NBNN*2
  2858. NSTN=2
  2859. C
  2860. SEGINI WRK1,WRK2 ,WRK5
  2861. I195=0
  2862. DO 3127 IB=1,NBELEM
  2863. C
  2864. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2865. C
  2866. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2867. CALL ZERO (REL,LRE,LRE)
  2868. *
  2869. MPTVAL=IVAMAT
  2870. DO 9127 IM=1,10
  2871. IF (IVAL(IM).NE.0) THEN
  2872. MELVAL=IVAL(IM)
  2873. IBMN=MIN(IB ,VELCHE(/2))
  2874. VALMAT(IM)=VELCHE(1,IBMN)
  2875. ELSE
  2876. VALMAT(IM)=0.D0
  2877.  
  2878. ENDIF
  2879. 9127 CONTINUE
  2880. C
  2881. C ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB
  2882. C
  2883. RHOF =VALMAT(4)
  2884.  
  2885. E =VALMAT(6)
  2886.  
  2887. C =VALMAT(7)
  2888.  
  2889. RHOREF=VALMAT(8)
  2890.  
  2891. CREF =VALMAT(9)
  2892.  
  2893. RLCAR =VALMAT(10)
  2894. C
  2895. C ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB
  2896. C
  2897. MPTVAL=IVACAR
  2898. MELVAL=IVAL(1)
  2899. IBMN=MIN(IB,VELCHE(/2))
  2900. SCEL =VELCHE(1,IBMN)
  2901.  
  2902. MELVAL=IVAL(2)
  2903. IBMN=MIN(IB,VELCHE(/2))
  2904. SFLU =VELCHE(1,IBMN)
  2905.  
  2906. MELVAL=IVAL(3)
  2907. IBMN=MIN(IB,VELCHE(/2))
  2908. EPS =VELCHE(1,IBMN)
  2909.  
  2910. MELVAL=IVAL(5)
  2911. IBMN=MIN(IB,VELCHE(/2))
  2912. XINERT=VELCHE(1,IBMN)
  2913. EI = E*XINERT/(EPS*EPS)
  2914. C
  2915. C CALCUL DES COEFFICIENTS DE NORMALISATION
  2916. C
  2917. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  2918. VKL1 =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL)
  2919. VKL2 = EI/SCEL
  2920. C
  2921. C BOUCLE SUR LES POINTS DE GAUSS
  2922. C
  2923. ISDJC=0
  2924. DO 4127 IGAU=1,NBPGAU
  2925. CALL CUBHR1(IGAU,MELE,MFR,NBNO,NIFOUR,XE,SHPTOT,
  2926. # SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT)
  2927. IF(IRRT.NE.1) GOTO 5127
  2928. DJAC=DJAC*POIGAU(IGAU)
  2929. C
  2930. C
  2931. CALL CUBHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL)
  2932. 4127 CONTINUE
  2933. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  2934. * SEGINI XMATRI
  2935. * IMATTT(IB)=XMATRI
  2936. C
  2937. C REMPLISSAGE DE XMATRI
  2938. C
  2939. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2940. * SEGDES XMATRI
  2941. 3127 CONTINUE
  2942. C
  2943. C IMPRESSION D UN EVENTUEL MESSAGE D ERREUR
  2944. C
  2945. 5127 CONTINUE
  2946. IF(IRRT.EQ.0) THEN
  2947. MOTERR(1:4)=NOMTP(MELE)
  2948. CALL ERREUR(420)
  2949. ELSE
  2950. IF(IRRT.EQ.2) THEN
  2951. INTERR(1)=IB
  2952. CALL ERREUR(405)
  2953. ENDIF
  2954. ENDIF
  2955. IF(I195.NE.0) INTERR(1)=I195
  2956. IF(I195.NE.0) CALL ERREUR(195)
  2957. SEGDES XMATRI
  2958. SEGSUP WRK1,WRK2,WRK5,MVELCH
  2959. GOTO 510
  2960.  
  2961. C_______________________________________________________________________
  2962. C
  2963. C ELEMENTS CIFL MACRO ELEMENT CISAILLEMENT FLEXION
  2964. C
  2965. C_______________________________________________________________________
  2966. C
  2967. 258 CONTINUE
  2968. NBNO=NBNN
  2969. NBBB=NBNN
  2970. SEGINI WRK1,WRK2,WRK3,WRK4
  2971. C
  2972. C BOUCLE POUR TOUS LES ELEMENTS
  2973. C
  2974. DO IB=1,NBELEM
  2975. C
  2976. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2977. C
  2978. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2979. C
  2980. CALL ZERO (REL,LRE,LRE)
  2981. C
  2982. C PASSAGE DES AXES GLOBAUX AUX AXES LOCAUX
  2983. C
  2984. CALL MURLOC(XE,NBNN,LHOOK,LRE,BPSS,XH,BGENE)
  2985. C
  2986. C CALCUL DE LA MATRICE DE HOOK
  2987. C
  2988. MPTVAL=IVAMAT
  2989. IF(IMAT.EQ.2) THEN
  2990. MELVAL=IVAL(1)
  2991. IGMN=MIN(1,IELCHE(/1))
  2992. MLREEL=IELCHE(IGMN,IBMN)
  2993. SEGACT MLREEL