Télécharger rigi4.eso

Retour à la liste

Numérotation des lignes :

  1. C RIGI4 SOURCE BP208322 17/02/23 21:15:11 9320
  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. if (xfreq.lt.0) RE(1,1,IB) = RE(1,1,IB) * (-1.)
  813. ENDDO
  814. SEGDES XMATRI
  815. GOTO 510
  816. *
  817.  
  818. ELSE IF (CMATE.EQ.'STATIQUE') THEN
  819. * STATIQUE
  820. DO IB = 1,NBELEM
  821. MPTVAL=IVAMAT
  822. MELVAL=IVAL(1)
  823. IBMN=MIN(IB,IELCHE(/2))
  824. idepl=IELCHE(1,IBMN)
  825. MELVAL=IVAL(2)
  826. IBMN=MIN(IB,IELCHE(/2))
  827. itreac=IELCHE(1,IBMN)
  828. CALL XTY1(idepl,itreac,iinc,idua,X1)
  829. if (ierr.ne.0) return
  830. re(1,1,IB) = x1
  831. ENDDO
  832. SEGDES XMATRI
  833. GOTO 510
  834. ENDIF
  835. *
  836. IF(MELE.EQ.45.AND.IFOUR.NE.-3) THEN
  837. GOTO 99
  838. ENDIF
  839. NBBB=NBNN
  840. SEGINI WRK1,WRK3
  841. C
  842. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  843. C
  844. KERRE=0
  845. DO 3045 IB=1,NBELEM
  846. C
  847. C ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  848. C
  849. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  850. C
  851. C
  852. C ON RECUPERE LA SECTION DE L'ELEMENT
  853. C
  854. MPTVAL=IVACAR
  855. MELVAL=IVAL(1)
  856. IBMN=MIN(IB,VELCHE(/2))
  857. SECT=VELCHE(1,IBMN)
  858. C
  859. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  860. C
  861. MPTVAL=IVAMAT
  862. IF(IMAT.EQ.2) THEN
  863. MELVAL=IVAL(1)
  864. IBMN=MIN(IB ,IELCHE(/2))
  865. MLREEL=IELCHE(1,IBMN)
  866. SEGACT MLREEL
  867. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  868. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  869. SEGDES MLREEL
  870. ELSE IF (IMAT.EQ.1) THEN
  871. *
  872. DO 9045 IM=1,NMATT
  873. IF (IVAL(IM).NE.0) THEN
  874. MELVAL=IVAL(IM)
  875. IBMN=MIN(IB ,VELCHE(/2))
  876. VALMAT(IM)=VELCHE(1,IBMN)
  877. ELSE
  878. VALMAT(IM)=0.D0
  879. ENDIF
  880. 9045 CONTINUE
  881. CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  882. ENDIF
  883. CALL PO1RIG(REL,LRE,DDHOOK(1,1),XE,KERRE,XDPGE,YDPGE)
  884. C
  885. * SEGINI XMATRI
  886. * IMATTT(IB)=XMATRI
  887. C
  888. C REMPLISSAGE DE XMATRI
  889. C
  890. CALL REMPMT(REL,LRE,RE(1,1,IB))
  891. * SEGDES XMATRI
  892. 3045 CONTINUE
  893. IF(IRTD.EQ.0) THEN
  894. MOTERR(1:8)=CMATE
  895. MOTERR(9:16)=NOMFR(MFR/2+1)
  896. INTERR(1)=IFOUR
  897. CALL ERREUR(81)
  898. ENDIF
  899. SEGDES XMATRI
  900. SEGSUP WRK1,WRK3,MVELCH
  901. GOTO 510
  902. C_______________________________________________________________________
  903. C
  904. C ELEMENTS BARRE ET CERCE
  905. C_______________________________________________________________________
  906. C
  907. 46 CONTINUE
  908. *
  909. IF(MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) THEN
  910. GO TO 99
  911. ENDIF
  912. NBBB=NBNN
  913. SEGINI WRK1,WRK3
  914. IF(MELE.EQ.123) THEN
  915. NSTN=NBNN
  916. LRN =LRE
  917. SEGINI WRK5
  918. ENDIF
  919. C
  920. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  921. C
  922. KERRE=0
  923. DO 3046 IB=1,NBELEM
  924. C
  925. C ON CHERCHE LES COORDONNEES DE L ELEMENT IB
  926. C
  927. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  928. C
  929. C
  930. C ON RECUPERE LA SECTION DE L'ELEMENT
  931. C
  932. MPTVAL=IVACAR
  933. MELVAL=IVAL(1)
  934. IBMN=MIN(IB,VELCHE(/2))
  935. SECT=VELCHE(1,IBMN)
  936. C
  937. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  938. C
  939. MPTVAL=IVAMAT
  940. IF(IMAT.EQ.2) THEN
  941. MELVAL=IVAL(1)
  942. IBMN=MIN(IB ,IELCHE(/2))
  943. MLREEL=IELCHE(1,IBMN)
  944. SEGACT MLREEL
  945. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  946. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  947. SEGDES MLREEL
  948. ELSE IF (IMAT.EQ.1) THEN
  949. *
  950. DO 9046 IM=1,NMATT
  951. IF (IVAL(IM).NE.0) THEN
  952. MELVAL=IVAL(IM)
  953. IBMN=MIN(IB ,VELCHE(/2))
  954. VALMAT(IM)=VELCHE(1,IBMN)
  955. ELSE
  956. VALMAT(IM)=0.D0
  957. ENDIF
  958. 9046 CONTINUE
  959. CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  960. ENDIF
  961. IF(MELE.EQ.46) CALL BARRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
  962. IF(MELE.EQ.95) CALL CERRIG(REL,LRE,DDHOOK(1,1),XE,KERRE)
  963. IF(MELE.EQ.123)CALL BARIG3(REL,LRE,DDHOOK(1,1),XE,XGENE,KERRE,IB)
  964. IF(KERRE.NE.0) INTERR(1)=ISOUS
  965. IF(KERRE.NE.0) INTERR(2)=IB
  966. C
  967. * SEGINI XMATRI
  968. * IMATTT(IB)=XMATRI
  969. C
  970. C REMPLISSAGE DE XMATRI
  971. C
  972. CALL REMPMT(REL,LRE,RE(1,1,IB))
  973. * SEGDES XMATRI
  974. 3046 CONTINUE
  975. IF(MELE.EQ.46.AND.KERRE.EQ.1) CALL ERREUR(128)
  976. IF(MELE.EQ.95.AND.KERRE.EQ.1) CALL ERREUR(601)
  977. IF(MELE.EQ.123.AND.KERRE.EQ.1) CALL ERREUR(128)
  978. IF(IRTD.EQ.0) THEN
  979. MOTERR(1:8)=CMATE
  980. MOTERR(9:16)=NOMFR(MFR/2+1)
  981. INTERR(1)=IFOUR
  982. CALL ERREUR(81)
  983. ENDIF
  984. SEGDES XMATRI
  985. SEGSUP WRK1,WRK3,MVELCH
  986. IF(MELE.EQ.123) SEGSUP WRK5
  987. GOTO 510
  988. C
  989. C_______________________________________________________________________
  990. C
  991. C ELEMENT BARRE 3D EXCENTRE (BAEX)
  992. C_______________________________________________________________________
  993. C
  994. 124 CONTINUE
  995. NBBB=NBNN
  996. NBNO=NBNN
  997. NSTRS1=NSTRS
  998. NSTRS=NBNN
  999. SEGINI WRK1,WRK2,WRK3
  1000. C
  1001. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1002. C
  1003. KERRE=0
  1004. DO 3108 IB=1,NBELEM
  1005. C
  1006. C ON RECUPERE LA SECTION DE L'ELEMENT, SES EXCENTREMENTS ET SON
  1007. C ORIENTATION. LES CARACTERISTIQUES SONT RANGEES DANS WORK
  1008. C SELON L'ORDRE SUIVANT: SECT EXCZ EXCY VX VY VZ
  1009. C
  1010. MPTVAL=IVACAR
  1011. DO IC=1,NCARR
  1012. IF(IVAL(IC).NE.0) THEN
  1013. MELVAL=IVAL(IC)
  1014. IBMN=MIN(IB,VELCHE(/2))
  1015. WORK(IC)=VELCHE(1,IBMN)
  1016. ELSE
  1017. WORK(IC)=0.D0
  1018. ENDIF
  1019. END DO
  1020. SECT=WORK(1)
  1021. C
  1022. C ON CHERCHE LE COEFF DE LA MAT DE HOOKE
  1023. C
  1024. MPTVAL=IVAMAT
  1025. IF(IMAT.EQ.2) THEN
  1026. MELVAL=IVAL(1)
  1027. IBMN=MIN(IB ,IELCHE(/2))
  1028. MLREEL=IELCHE(1,IBMN)
  1029. SEGACT MLREEL
  1030. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  1031. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1032. SEGDES MLREEL
  1033. ELSE IF (IMAT.EQ.1) THEN
  1034. DO 9108 IM=1,NMATT
  1035. IF (IVAL(IM).NE.0) THEN
  1036. MELVAL=IVAL(IM)
  1037. IBMN=MIN(IB ,VELCHE(/2))
  1038. VALMAT(IM)=VELCHE(1,IBMN)
  1039. ELSE
  1040. VALMAT(IM)=0.D0
  1041. ENDIF
  1042. 9108 CONTINUE
  1043. IF (IB.LE.NELMAT.OR.NBGMAT.GT.1)
  1044. 1 CALL DOHBRR(VALMAT,SECT,DDHOOK(1,1),IRTD)
  1045. ENDIF
  1046. C
  1047. C BGENE STOCKE LA MATRICE DE PASSAGE DE L'ELEMENT EXCENTRE
  1048. C
  1049. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1050. CALL MAPAEX(XE,NBNN,WORK,AL,BGENE,LRE,KERRE)
  1051. IF(KERRE.NE.0) INTERR(1)=ISOUS
  1052. IF(KERRE.NE.0) INTERR(2)=IB
  1053. IF(KERRE.EQ.1) CALL ERREUR(128)
  1054. CALL RIGBEX(REL,LRE,DDHOOK(1,1),AL,BGENE)
  1055. C
  1056. * SEGINI XMATRI
  1057. * IMATTT(IB)=XMATRI
  1058. C
  1059. C REMPLISSAGE DE XMATRI
  1060. C
  1061. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1062. * SEGDES XMATRI
  1063. 3108 CONTINUE
  1064. NSTRS=NSTRS1
  1065. SEGDES XMATRI
  1066. SEGSUP WRK1,WRK2,WRK3,MVELCH
  1067. GOTO 510
  1068. C_______________________________________________________________________
  1069. C
  1070. C LIA2 : element de liaison a 2 noeuds (6 ddl par noeuds)
  1071. C_______________________________________________________________________
  1072. C
  1073. 125 CONTINUE
  1074. NBBB=NBNN
  1075. NBNO=NBNN
  1076. SEGINI WRK1,WRK2,WRK3,WRK4
  1077. C
  1078. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1079. C
  1080. KERRE=0
  1081. DO 3109 IB=1,NBELEM
  1082. C
  1083. MPTVAL=IVACAR
  1084. DO IC=1,NCARR
  1085. IF(IVAL(IC).NE.0) THEN
  1086. MELVAL=IVAL(IC)
  1087. IBMN=MIN(IB,VELCHE(/2))
  1088. WORK(IC)=VELCHE(1,IBMN)
  1089. ELSE
  1090. WORK(IC)=0.D0
  1091. ENDIF
  1092. END DO
  1093. C
  1094. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1095. CALL MAPALI(XE,NBNN,WORK,BPSS,KERRE)
  1096. IF(KERRE.NE.0) INTERR(1)=ISOUS
  1097. IF(KERRE.NE.0) INTERR(2)=IB
  1098. IF(KERRE.EQ.1) CALL ERREUR(128)
  1099. CALL RIGLI2(REL,LRE,BPSS,WORK)
  1100. C
  1101. * SEGINI XMATRI
  1102. * IMATTT(IB)=XMATRI
  1103. C
  1104. C REMPLISSAGE DE XMATRI
  1105. C
  1106. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1107. * SEGDES XMATRI
  1108. 3109 CONTINUE
  1109. SEGDES XMATRI
  1110. SEGSUP WRK1,WRK2,WRK3,MVELCH
  1111. GOTO 510
  1112. *-------------------------------------------------------------
  1113. C_______________________________________________________________________
  1114. C
  1115. C JOI1 : element de liaison a 2 noeuds (6 ddl par noeuds)
  1116. C_______________________________________________________________________
  1117. C
  1118. 129 CONTINUE
  1119. NBBB=NBNN
  1120. NBNO=NBNN
  1121. SEGINI WRK1,WRK2,WRK3,WRK4
  1122. C
  1123. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  1124. C
  1125. KERRE=0
  1126. DO 3110 IB=1,NBELEM
  1127. C
  1128. MPTVAL=IVAMAT
  1129. DO IC=1,NMATT
  1130. IF(IVAL(IC).NE.0) THEN
  1131. MELVAL=IVAL(IC)
  1132. IBMN=MIN(IB,VELCHE(/2))
  1133. WORK(IC)=VELCHE(1,IBMN)
  1134. ELSE
  1135. WORK(IC)=0.D0
  1136. ENDIF
  1137. END DO
  1138. C
  1139. CALL MAPALU(NMATT,WORK,BPSS,IDIM)
  1140. c
  1141. c on calcule la matrice de rigidité localement
  1142. c
  1143. CALL RIGJOI(NMATT,REL,LRE,WORK,IDIM,CMATE)
  1144. c
  1145. c on passe en repère global
  1146. c
  1147. IAW1=101
  1148. IAW2=IAW1+LRE*LRE
  1149. IAW3=IAW2+LRE*LRE
  1150. IAW4=IAW3+LRE*LRE
  1151. CALL JOIGLO(REL,BPSS,WORK(IAW1),WORK(IAW2),
  1152. & WORK(IAW3),WORK(IAW4),LRE,IDIM)
  1153. *
  1154. C
  1155. * SEGINI XMATRI
  1156. * IMATTT(IB)=XMATRI
  1157. C
  1158. C REMPLISSAGE DE XMATRI
  1159. C
  1160. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1161. *
  1162. * SEGDES XMATRI
  1163. 3110 CONTINUE
  1164. SEGDES XMATRI
  1165. SEGSUP WRK1,WRK2,WRK3,MVELCH
  1166. GOTO 510
  1167. *-------------------------------------------------------------
  1168. c
  1169. c element coaxial COS2 (3D pour liaison acier-beton)
  1170. c
  1171. 271 continue
  1172. NBBB=NBNN
  1173. lw=5
  1174. SEGINI WRK1,WRK4,wrk3
  1175. do 3271 ib= 1,nbelem
  1176. C
  1177. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1178. C
  1179.  
  1180. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1181. CALL ZERO (REL,LRE,LRE)
  1182. CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
  1183. MPTVAL=IVAmat
  1184. if(imat.eq.1) then
  1185. DO IC=1,2
  1186. IF(IVAL(IC).NE.0) THEN
  1187. MELVAL=IVAL(IC)
  1188. IBMN=MIN(IB,VELCHE(/2))
  1189. WORK(ic)=VELCHE(1,IBMN)
  1190. ELSE
  1191. WORK(IC)=0.D0
  1192. ENDIF
  1193. END DO
  1194. ELSE
  1195. MELVAL=IVAL(1)
  1196. IBMN=MIN(IB,IELCHE(/2))
  1197. MLREEL=IELCHE(1,IBMN)
  1198. SEGACT MLREEL
  1199. if(idim.eq.3) then
  1200. work(1)= prog(1)
  1201. work(2) = prog(9)
  1202. else if (idim.eq.1.or.idim.eq.2) then
  1203. CALL ERREUR(81)
  1204. endif
  1205. segdes mlreel
  1206. endif
  1207. C
  1208. C
  1209. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1210. C
  1211. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1212. xv1= xe(1,2)-xe(1,1)
  1213. yv1= xe(2,2)-xe(2,1)
  1214. zv1=0.d0
  1215. if( idim.eq.3) zv1 = xe(3,2)-xe(3,1)
  1216. xl= sqrt(xv1*xv1 + yv1*yv1 + zv1*zv1)
  1217. C
  1218. C recuperation de la section et calcul du diamètre
  1219. C
  1220. MPTVAL=IVACAR
  1221. DO 2712 ICOMP=1,NCARR
  1222. MELVAL=IVAL(ICOMP)
  1223. IGMN = VELCHE(/1)
  1224. IBMN=MIN(IB,VELCHE(/2))
  1225. SECA =VELCHE(IGMN,IBMN)
  1226. 2712 CONTINUE
  1227. diam = sqrt(4.d0*SECA/xpi)
  1228. C
  1229. xls1 = (3.d0*xpi*diam*xl)/8.d0
  1230. xls2 = (1.d0*xpi*diam*xl)/8.d0
  1231. xks1 = xls1*work(1)
  1232. xks2 = xls2*work(1)
  1233. xln1 = (3.d0*diam*xl)/8.d0
  1234. xln2 = (1.d0*diam*xl)/8.d0
  1235. xkn1 = xln1*work(2)
  1236. xkn2 = xln2*work(2)
  1237. xks = work(1)
  1238. xkn = work(2)
  1239. if (idim.eq.2) then
  1240. C cas de matrice elastique
  1241. rel(1,1)= xks1
  1242. rel(1,3)= xks2
  1243. rel(1,5)= -xks2
  1244. rel(1,7)=-xks1
  1245. rel(7,7)= xks1
  1246. rel(7,1)=-xks1
  1247. rel(7,3)= -xks2
  1248. rel(7,5)= xks2
  1249. rel(3,3)=xks1
  1250. rel(3,5)=-xks1
  1251. rel(3,1)= xks2
  1252. rel(3,7)= -xks2
  1253. rel(5,5)=xks1
  1254. rel(5,3)=-xks1
  1255. rel(5,1)= -xks2
  1256. rel(5,7)= xks2
  1257. c ---------------------------
  1258. rel(2,2)= xkn1
  1259. rel(2,4)= xkn2
  1260. rel(2,6)= -xkn2
  1261. rel(2,8)=-xkn1
  1262. rel(8,8)= xkn1
  1263. rel(8,2)=-xkn1
  1264. rel(8,4)= -xkn2
  1265. rel(8,6)= xkn2
  1266. rel(4,4)=xkn1
  1267. rel(4,6)=-xkn1
  1268. rel(4,2)= xkn2
  1269. rel(4,8)= -xkn2
  1270. rel(6,6)=xkn1
  1271. rel(6,4)=-xkn1
  1272. rel(6,2)= -xkn2
  1273. rel(6,8)= xkn2
  1274. else if (idim.eq.3) then
  1275. C cas de matrice elastique
  1276. rel(1,1)= xks1
  1277. rel(1,4)= xks2
  1278. rel(1,7)= -xks2
  1279. rel(1,10)=-xks1
  1280. rel(10,10)= xks1
  1281. rel(10,1)=-xks1
  1282. rel(10,4)= -xks2
  1283. rel(10,7)= xks2
  1284. rel(4,4)=xks1
  1285. rel(4,7)=-xks1
  1286. rel(4,1)= xks2
  1287. rel(4,10)= -xks2
  1288. rel(7,7)=xks1
  1289. rel(7,4)=-xks1
  1290. rel(7,1)= -xks2
  1291. rel(7,10)= xks2
  1292. C ------- remplissage de KN ------------
  1293. rel(2,2)= xkn1
  1294. rel(2,5)= xkn2
  1295. rel(2,8)= -xkn2
  1296. rel(2,11)=-xkn1
  1297. rel(11,11)= xkn1
  1298. rel(11,2)=-xkn1
  1299. rel(11,5)= -xkn2
  1300. rel(11,8)= xkn2
  1301. rel(5,5)=xkn1
  1302. rel(5,8)=-xkn1
  1303. rel(5,2)= xkn2
  1304. rel(5,11)= -xkn2
  1305. rel(8,8)=xkn1
  1306. rel(8,5)=-xkn1
  1307. rel(8,2)= -xkn2
  1308. rel(8,11)= xkn2
  1309. c------------
  1310. rel(3,3)= xkn1
  1311. rel(3,6)= xkn2
  1312. rel(3,9)= -xkn2
  1313. rel(3,12)=-xkn1
  1314. rel(12,12)= xkn1
  1315. rel(12,3)=-xkn1
  1316. rel(12,6)= -xkn2
  1317. rel(12,9)= xkn2
  1318. rel(6,6)=xkn1
  1319. rel(6,9)=-xkn1
  1320. rel(6,3)= xkn2
  1321. rel(6,12)= -xkn2
  1322. rel(9,9)=xkn1
  1323. rel(9,6)=-xkn1
  1324. rel(9,3)= -xkn2
  1325. rel(9,12)= xkn2
  1326. endif
  1327. do 3272 ia = 1, 4
  1328. do 3272 ic = 1,4
  1329. do 3273 io=1,idim
  1330. do 3273 iu=1,idim
  1331. xpa(io,iu)= rel( ia*idim-idim+io,ic*idim -idim +iu)
  1332. 3273 continue
  1333. call prodt(xpb,xpa,bpss,idim,idim)
  1334. do 3274 io=1,idim
  1335. do 3274 iu=1,idim
  1336. rell( ia*idim-idim+io,ic*idim -idim +iu) = xpb(io,iu)
  1337. 3274 continue
  1338. 3272 continue
  1339. C
  1340. C REMPLISSAGE DE XMATRI
  1341. C
  1342. CALL REMPMT(RELL,LRE,RE(1,1,IB))
  1343. 3271 continue
  1344. SEGDES XMATRI
  1345. SEGSUP WRK1,WRK3,WRK4
  1346. GOTO 510
  1347. c cccccc
  1348. C_______________________________________________________________________
  1349. C
  1350. C SECTEUR DE CALCUL POUR LE COA2
  1351. C
  1352. C_______________________________________________________________________
  1353. C
  1354. 272 continue
  1355. NBNO=NBNN
  1356. NBBB=NBNN
  1357. SEGINI WRK1,WRK2,WRK4
  1358. C
  1359. C BOUCLE POUR TOUS LES ELEMENTS
  1360. C
  1361. DO 2721 IB=1,NBELEM
  1362. C
  1363. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1364. C
  1365. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1366. C
  1367. CALL ZERO (REL,LRE,LRE)
  1368. C
  1369. C CALCUL DES AXES LOCAUX
  1370. C
  1371. CALL CO2LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL,IDIM)
  1372. DO 2722 IGAU=1,NBPGAU
  1373. C
  1374. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1375. C
  1376. CALL BCO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1377. . BGENE,DJAC,IRRT,IDIM)
  1378. IF(IRRT.NE.0) THEN
  1379. INTERR(1)=IB
  1380. CALL ERREUR(764)
  1381. GOTO 9985
  1382. ENDIF
  1383. C
  1384. C
  1385. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1386. C
  1387. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1388. xv1= xe(1,2)-xe(1,1)
  1389. yv1= xe(2,2)-xe(2,1)
  1390. zv1=0.d0
  1391. if( idim.eq.3) zv1 = xe(3,2)-xe(3,1)
  1392. xl= sqrt(xv1*xv1 + yv1*yv1 + zv1*zv1)
  1393. C
  1394. C recuperation de la section et calcul du diamètre
  1395. C
  1396. MPTVAL=IVACAR
  1397. DO 2729 ICOMP=1,NCARR
  1398. MELVAL=IVAL(ICOMP)
  1399. IGMN = VELCHE(/1)
  1400. IBMN=MIN(IB,VELCHE(/2))
  1401. SECA =VELCHE(IGMN,IBMN)
  1402. 2729 CONTINUE
  1403. diam = sqrt(4.d0*SECA/xpi)
  1404. C
  1405. DJAC=DJAC*POIGAU(IGAU)
  1406. C
  1407. C CALCUL DE LA MATRICE DE HOOK
  1408. C
  1409. MPTVAL=IVAMAT
  1410. IF(IMAT.EQ.2) THEN
  1411. MELVAL=IVAL(1)
  1412. IBMN=MIN(IB ,IELCHE(/2))
  1413. IGMN=MIN(IGAU,IELCHE(/1))
  1414. MLREEL=IELCHE(IGMN,IBMN)
  1415. SEGACT MLREEL
  1416. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1417. 1 CALL DOHOCO(PROG,LHOOK,DDHOOK,XL,DIAM)
  1418. SEGDES MLREEL
  1419. ELSE IF (IMAT.EQ.1) THEN
  1420. DO 2723 IM=1,NMATT
  1421. IF (IVAL(IM).NE.0) THEN
  1422. MELVAL=IVAL(IM)
  1423. IBMN=MIN(IB ,VELCHE(/2))
  1424. IGMN=MIN(IGAU,VELCHE(/1))
  1425. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1426. ELSE
  1427. VALMAT(IM)=0.D0
  1428. ENDIF
  1429. 2723 CONTINUE
  1430. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1431. 1 CALL DOUCO2(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD,XL,DIAM)
  1432. END IF
  1433. C
  1434. C CALCUL ET INTEGRATION DE BDB
  1435. C
  1436. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1437. 2722 CONTINUE
  1438. C
  1439. do 2726 ia = 1,4
  1440. do 2726 ic = 1,4
  1441. do 2727 io=1,idim
  1442. do 2727 iu=1,idim
  1443. xpa(io,iu)= rel( ia*idim-idim+io,ic*idim -idim +iu)
  1444. 2727 continue
  1445. call prodt(xpb,xpa,bpss,idim,idim)
  1446. do 2728 io=1,idim
  1447. do 2728 iu=1,idim
  1448. rell( ia*idim-idim+io,ic*idim -idim +iu) = xpb(io,iu)
  1449. 2728 continue
  1450. 2726 continue
  1451. C
  1452. C REMPLISSAGE DE XMATRI
  1453. C
  1454. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1455. 2721 CONTINUE
  1456. C
  1457. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1458. C
  1459. IF (IRTD.EQ.0) THEN
  1460. MOTERR(1:8) = CMATE
  1461. MOTERR(9:16) = NOMFR(MFR/2+1)
  1462. INTERR(1) = IFOUR
  1463. CALL ERREUR(81)
  1464. ENDIF
  1465. C
  1466. c SEGDES XMATRI
  1467. 9985 CONTINUE
  1468. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1469. GOTO 510
  1470. *-----------------------------------------------------------------------
  1471. C_______________________________________________________________________
  1472. C
  1473. C SECTEUR DE CALCUL POUR LE JOI2
  1474. C
  1475. C_______________________________________________________________________
  1476. C
  1477. 85 CONTINUE
  1478. NBNO=NBNN
  1479. NBBB=NBNN
  1480. SEGINI WRK1,WRK2,WRK4
  1481. C
  1482. C BOUCLE POUR TOUS LES ELEMENTS
  1483. C
  1484. DO 3085 IB=1,NBELEM
  1485. C
  1486. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1487. C
  1488. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1489. C
  1490. CALL ZERO (REL,LRE,LRE)
  1491. C
  1492. C CALCUL DES AXES LOCAUX
  1493. C
  1494. CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1495. C
  1496. CCC IF (NOQUAL.EQ.1) THEN
  1497. CCCC NOEUDS TROP VOISINS
  1498. CCC INTERR(1)=IB
  1499. CCCC *******MESSAGE D'ERREUR 323 A ADAPTER AUX JOINTS
  1500. CCC CALL ERREUR(323)
  1501. CCC ELSE IF ( NOQUAL.EQ.2 ) THEN
  1502. CCCC JOINT NON PLAN
  1503. CCC INTERR(1)=IB
  1504. CCCC *******MESSAGE D'ERREUR 323 A ADAPTER AUX JOINTS
  1505. CCC CALL ERREUR(323)
  1506. CCC RETURN
  1507. CCC ENDIF
  1508. C
  1509. C BOUCLE SUR LES POINTS DE GAUSS
  1510. C
  1511. DO 4085 IGAU=1,NBPGAU
  1512. C
  1513. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1514. C
  1515. CALL BJO2(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1516. + BGENE,DJAC,IRRT)
  1517. DJAC=DJAC*POIGAU(IGAU)
  1518.  
  1519. *
  1520. IF (IFOUR.EQ.0) THEN
  1521. C
  1522. C EN AXISYMETRIE, ON MULTIPLIE PAR R
  1523. C (R=RAYON DE COURBURE DU POINT DE GAUSS)
  1524. C
  1525. RAYON=0.0D0
  1526. NUMSUP=NBNO/2
  1527. *
  1528. DO 5085 IRAY=1,NUMSUP
  1529. RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  1530. 5085 CONTINUE
  1531. * modif TC
  1532. * dr = XE(1,2)-xe(1,1)
  1533. * ra= XE(1,1)
  1534. * rb= XE(1,2)
  1535. * rayona = rb*rb*rb/6.d0 - 0.5d0*ra*ra*rb +ra*ra*ra /3.d0
  1536. * rayona=rayona *2.d0 /dr / dr
  1537. * rayonb= rb*rb*rb/3.d0 - 0.5d0*ra*rb*rb +ra*ra*ra /6.d0
  1538. * rayonb=rayonb *2.d0 / dr / dr
  1539.  
  1540. * rayon= rayona
  1541. * if(igau.eq.2) rayon=rayonb
  1542. DJAC=DJAC*RAYON
  1543. ENDIF
  1544. C
  1545. C IRRT=1 JACOBIEN <= 0
  1546. IF(IRRT.NE.0) THEN
  1547. INTERR(1)=IB
  1548. CALL ERREUR(612)
  1549. ENDIF
  1550. C
  1551. C CALCUL DE LA MATRICE DE HOOK
  1552. C
  1553. MPTVAL=IVAMAT
  1554. IF(IMAT.EQ.2) THEN
  1555. MELVAL=IVAL(1)
  1556. IBMN=MIN(IB ,IELCHE(/2))
  1557. IGMN=MIN(IGAU,IELCHE(/1))
  1558. MLREEL=IELCHE(IGMN,IBMN)
  1559. SEGACT MLREEL
  1560. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1561. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1562. SEGDES MLREEL
  1563. ELSE IF (IMAT.EQ.1) THEN
  1564. DO 9085 IM=1,NMATT
  1565. IF (IVAL(IM).NE.0) THEN
  1566. MELVAL=IVAL(IM)
  1567. IBMN=MIN(IB ,VELCHE(/2))
  1568. IGMN=MIN(IGAU,VELCHE(/1))
  1569. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1570. ELSE
  1571. VALMAT(IM)=0.D0
  1572. ENDIF
  1573. 9085 CONTINUE
  1574. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1575. 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1576. ENDIF
  1577. C
  1578. C CALCUL ET INTEGRATION DE BDB
  1579. C
  1580. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1581. 4085 CONTINUE
  1582. C
  1583. * SEGINI XMATRI
  1584. * IMATTT(IB)=XMATRI
  1585. C
  1586. C REMPLISSAGE DE XMATRI
  1587. C
  1588. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1589. * SEGDES XMATRI
  1590. 3085 CONTINUE
  1591. C
  1592. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1593. C
  1594. IF (IRTD.EQ.0) THEN
  1595. MOTERR(1:8) = CMATE
  1596. MOTERR(9:16) = NOMFR(MFR/2+1)
  1597. INTERR(1) = IFOUR
  1598. CALL ERREUR(81)
  1599. ENDIF
  1600. C
  1601. SEGDES XMATRI
  1602. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1603. GOTO 510
  1604. C_______________________________________________________________________
  1605. C
  1606. C SECTEUR DE CALCUL POUR LE JGI2
  1607. C
  1608. C_______________________________________________________________________
  1609. C
  1610. 170 CONTINUE
  1611. NBNO=NBNN
  1612. NBBB=NBNN
  1613. SEGINI WRK1,WRK2,WRK4
  1614. C
  1615. C BOUCLE POUR TOUS LES ELEMENTS
  1616. C
  1617. DO IB=1,NBELEM
  1618. C
  1619. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1620. C
  1621. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1622. C
  1623. CALL ZERO (REL,LRE,LRE)
  1624. C
  1625. C CALCUL DES AXES LOCAUX
  1626. C
  1627. CALL JO2LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1628. C
  1629. C BOUCLE SUR LES POINTS DE GAUSS
  1630. C
  1631. DO IGAU=1,NBPGAU
  1632. C
  1633. C ON CHERCHE L EPAISSEUR DU JOINT
  1634. C
  1635. EPAIST=0.D0
  1636. MPTVAL=IVACAR
  1637. MELVAL=IVAL(1)
  1638. IF (MELVAL.NE.0) THEN
  1639. IGMN=MIN(IGAU,VELCHE(/1))
  1640. IBMN=MIN(IB,VELCHE(/2))
  1641. EPAIST=VELCHE(IGMN,IBMN)
  1642. ENDIF
  1643. C
  1644. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1645. C
  1646. CcPPj CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1647. CcPPj. EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT)
  1648. CALL BJO2GN(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
  1649. . EPAIST,BGENE,DJAC,XDPGE,YDPGE,IRRT)
  1650. DJAC=DJAC*POIGAU(IGAU)
  1651. C
  1652. IF (IFOUR.EQ.0) THEN
  1653. C
  1654. C EN AXISYMETRIE, ON MULTIPLIE PAR R
  1655. C (R=RAYON DE COURBURE DU POINT DE GAUSS)
  1656. C
  1657. RAYON=0.0D0
  1658. NUMSUP=NBNO/2
  1659. DO IRAY=1,NUMSUP
  1660. RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  1661. ENDDO
  1662. DJAC=DJAC*RAYON
  1663. ENDIF
  1664. C
  1665. C IRRT=1 JACOBIEN <= 0
  1666. IF(IRRT.NE.0) THEN
  1667. INTERR(1)=IB
  1668. CALL ERREUR(612)
  1669. ENDIF
  1670. C
  1671. C CALCUL DE LA MATRICE DE HOOK
  1672. C
  1673. MPTVAL=IVAMAT
  1674. IF(IMAT.EQ.2) THEN
  1675. MELVAL=IVAL(1)
  1676. IBMN=MIN(IB ,IELCHE(/2))
  1677. IGMN=MIN(IGAU,IELCHE(/1))
  1678. MLREEL=IELCHE(IGMN,IBMN)
  1679. SEGACT MLREEL
  1680. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1681. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1682. SEGDES MLREEL
  1683. ELSE IF (IMAT.EQ.1) THEN
  1684. DO IM=1,NMATT
  1685. IF (IVAL(IM).NE.0) THEN
  1686. MELVAL=IVAL(IM)
  1687. IBMN=MIN(IB ,VELCHE(/2))
  1688. IGMN=MIN(IGAU,VELCHE(/1))
  1689. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1690. ELSE
  1691. VALMAT(IM)=0.D0
  1692. ENDIF
  1693. ENDDO
  1694. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1695. 1 CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD)
  1696. ENDIF
  1697. C
  1698. C CALCUL ET INTEGRATION DE BDB
  1699. C
  1700. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1701. ENDDO
  1702. C
  1703. * SEGINI XMATRI
  1704. * IMATTT(IB)=XMATRI
  1705. C
  1706. C REMPLISSAGE DE XMATRI
  1707. C
  1708. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1709. * SEGDES XMATRI
  1710. ENDDO
  1711. C
  1712. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1713. C
  1714. IF (IRTD.EQ.0) THEN
  1715. MOTERR(1:8) = CMATE
  1716. MOTERR(9:16) = NOMFR(MFR/2+1)
  1717. INTERR(1) = IFOUR
  1718. CALL ERREUR(81)
  1719. ENDIF
  1720. C
  1721. SEGDES XMATRI
  1722. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1723. GOTO 510
  1724. C_______________________________________________________________________
  1725. C
  1726. C SECTEUR DE CALCUL POUR LE JCT3 en 2D cisaillement
  1727. C
  1728. C_______________________________________________________________________
  1729. C
  1730. 168 CONTINUE
  1731. NBNO=NBNN
  1732. NBBB=NBNN
  1733. SEGINI WRK1,WRK2,WRK4
  1734. C
  1735. C BOUCLE POUR TOUS LES ELEMENTS
  1736. C
  1737. DO IB=1,NBELEM
  1738. C
  1739. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1740. C
  1741. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1742. C
  1743. CALL ZERO (REL,LRE,LRE)
  1744. C
  1745. C CALCUL DES AXES LOCAUX
  1746. C
  1747. CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1748. C
  1749. IF (NOQUAL.EQ.1) THEN
  1750. INTERR(1)=IB
  1751. MOTERR(1:4) = 'JGT3'
  1752. CALL ERREUR(765)
  1753. RETURN
  1754. ELSE IF ( NOQUAL.EQ.2) THEN
  1755. INTERR(1)=IB
  1756. MOTERR(1:4) = 'JGT3'
  1757. CALL ERREUR(766)
  1758. RETURN
  1759. ENDIF
  1760. C
  1761. C BOUCLE SUR LES POINTS DE GAUSS
  1762. C
  1763. DO IGAU=1,NBPGAU
  1764. C 4
  1765. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1766. C
  1767. CALL BJT3C(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1768. + BGENE,DJAC,IRRT)
  1769. DJAC=DJAC*POIGAU(IGAU)
  1770. C IRRT=1 JACOBIEN <= 0
  1771. IF(IRRT.NE.0) THEN
  1772. CALL ERREUR(764)
  1773. ENDIF
  1774. C
  1775. C CALCUL DE LA MATRICE DE HOOK
  1776. C
  1777. MPTVAL=IVAMAT
  1778. IF(IMAT.EQ.2) THEN
  1779. MELVAL=IVAL(1)
  1780. IBMN=MIN(IB ,IELCHE(/2))
  1781. IGMN=MIN(IGAU,IELCHE(/1))
  1782. MLREEL=IELCHE(IGMN,IBMN)
  1783. SEGACT MLREEL
  1784. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1785. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1786. SEGDES MLREEL
  1787. ELSE IF (IMAT.EQ.1) THEN
  1788. DO IM=1,NMATT
  1789. IF (IVAL(IM).NE.0) THEN
  1790. MELVAL=IVAL(IM)
  1791. IBMN=MIN(IB ,VELCHE(/2))
  1792. IGMN=MIN(IGAU,VELCHE(/1))
  1793. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1794. ELSE
  1795. VALMAT(IM)=0.D0
  1796. ENDIF
  1797. ENDDO
  1798. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1799. 1 CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1800. ENDIF
  1801. C
  1802. C CALCUL ET INTEGRATION DE BDB
  1803. C
  1804. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1805. ENDDO
  1806. C
  1807. * SEGINI XMATRI
  1808. * IMATTT(IB)=XMATRI
  1809. C
  1810. C REMPLISSAGE DE XMATRI
  1811. C
  1812. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1813. * SEGDES XMATRI
  1814. ENDDO
  1815. C
  1816. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1817. C
  1818. IF (IRTD.EQ.0) THEN
  1819. MOTERR(1:8) = CMATE
  1820. MOTERR(9:16) = NOMFR(MFR/2+1)
  1821. INTERR(1) = IFOUR
  1822. CALL ERREUR(81)
  1823. ENDIF
  1824. C
  1825. SEGDES XMATRI
  1826. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1827. GOTO 510
  1828. C_______________________________________________________________________
  1829. C
  1830. C SECTEUR DE CALCUL POUR LE JGT3 GENERALISE
  1831. C
  1832. C_______________________________________________________________________
  1833. C
  1834. 171 CONTINUE
  1835. NBNO=NBNN
  1836. NBBB=NBNN
  1837. SEGINI WRK1,WRK2,WRK4
  1838. C
  1839. C BOUCLE POUR TOUS LES ELEMENTS
  1840. C
  1841. DO IB=1,NBELEM
  1842. C
  1843. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1844. C
  1845. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1846. C
  1847. CALL ZERO (REL,LRE,LRE)
  1848. C
  1849. C CALCUL DES AXES LOCAUX
  1850. C
  1851. CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1852. C
  1853. IF (NOQUAL.EQ.1) THEN
  1854. INTERR(1)=IB
  1855. MOTERR(1:4) = 'JGT3'
  1856. CALL ERREUR(765)
  1857. RETURN
  1858. ELSE IF ( NOQUAL.EQ.2) THEN
  1859. INTERR(1)=IB
  1860. MOTERR(1:4) = 'JGT3'
  1861. CALL ERREUR(766)
  1862. RETURN
  1863. ENDIF
  1864. C
  1865. C BOUCLE SUR LES POINTS DE GAUSS
  1866. C
  1867. DO IGAU=1,NBPGAU
  1868. C
  1869. C ON CHERCHE L'EPAISSEUR DU JOINT
  1870. C
  1871. EPAIST=0.D0
  1872. MPTVAL=IVACAR
  1873. MELVAL=IVAL(1)
  1874. IF (MELVAL.NE.0) THEN
  1875. IGMN=MIN(IGAU,VELCHE(/1))
  1876. IBMN=MIN(IB,VELCHE(/2))
  1877. EPAIST=VELCHE(IGMN,IBMN)
  1878. ENDIF
  1879. C 4
  1880. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1881. C
  1882. CcPPj CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  1883. CALL BJT3G(IGAU,MFR,IFOUR,NIFOUR,XE,XEL,BPSS,SHPTOT,SHPWRK,
  1884. + EPAIST,BGENE,DJAC,IRRT)
  1885. DJAC=DJAC*POIGAU(IGAU)
  1886. C IRRT=1 JACOBIEN <= 0
  1887. IF(IRRT.NE.0) THEN
  1888. CALL ERREUR(764)
  1889. ENDIF
  1890. C
  1891. C CALCUL DE LA MATRICE DE HOOK
  1892. C
  1893. MPTVAL=IVAMAT
  1894. IF(IMAT.EQ.2) THEN
  1895. MELVAL=IVAL(1)
  1896. IBMN=MIN(IB ,IELCHE(/2))
  1897. IGMN=MIN(IGAU,IELCHE(/1))
  1898. MLREEL=IELCHE(IGMN,IBMN)
  1899. SEGACT MLREEL
  1900. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1901. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  1902. SEGDES MLREEL
  1903. ELSE IF (IMAT.EQ.1) THEN
  1904. DO IM=1,NMATT
  1905. IF (IVAL(IM).NE.0) THEN
  1906. MELVAL=IVAL(IM)
  1907. IBMN=MIN(IB ,VELCHE(/2))
  1908. IGMN=MIN(IGAU,VELCHE(/1))
  1909. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1910. ELSE
  1911. VALMAT(IM)=0.D0
  1912. ENDIF
  1913. ENDDO
  1914. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1915. 1 CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD)
  1916. ENDIF
  1917. C
  1918. C CALCUL ET INTEGRATION DE BDB
  1919. C
  1920. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  1921. ENDDO
  1922. C
  1923. * SEGINI XMATRI
  1924. * IMATTT(IB)=XMATRI
  1925. C
  1926. C REMPLISSAGE DE XMATRI
  1927. C
  1928. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1929. * SEGDES XMATRI
  1930. ENDDO
  1931. C
  1932. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  1933. C
  1934. IF (IRTD.EQ.0) THEN
  1935. MOTERR(1:8) = CMATE
  1936. MOTERR(9:16) = NOMFR(MFR/2+1)
  1937. INTERR(1) = IFOUR
  1938. CALL ERREUR(81)
  1939. ENDIF
  1940. C
  1941. SEGDES XMATRI
  1942. SEGSUP WRK1,WRK2,WRK4,MVELCH
  1943. GOTO 510
  1944. C_______________________________________________________________________
  1945. C
  1946. C SECTEUR DE CALCUL POUR LE JCI4 en 2D cisaillement
  1947. C
  1948. C_______________________________________________________________________
  1949. C
  1950. 169 CONTINUE
  1951. NBNO=NBNN
  1952. NBBB=NBNN
  1953. SEGINI WRK1,WRK2,WRK4
  1954. C
  1955. C BOUCLE POUR TOUS LES ELEMENTS
  1956. C
  1957. DO IB=1,NBELEM
  1958. C
  1959. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1960. C
  1961. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1962. C
  1963. CALL ZERO (REL,LRE,LRE)
  1964. C
  1965. C CALCUL DES AXES LOCAUX
  1966. C
  1967. CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  1968.  
  1969. IF (NOQUAL.EQ.1) THEN
  1970. INTERR(1)=IB
  1971. MOTERR(1:4) = 'JCI4'
  1972. CALL ERREUR(765)
  1973. RETURN
  1974. ELSE IF ( NOQUAL.EQ.2 ) THEN
  1975. INTERR(1)=IB
  1976. MOTERR(1:4) = 'JCI4'
  1977. CALL ERREUR(766)
  1978. RETURN
  1979. ENDIF
  1980. C
  1981. C BOUCLE SUR LES POINTS DE GAUSS
  1982. C
  1983. DO IGAU=1,NBPGAU
  1984. C
  1985. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  1986. C
  1987. CALL BJO4C(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT)
  1988. DJAC=DJAC*POIGAU(IGAU)
  1989. C IRRT=1 JACOBIEN <= 0
  1990. IF(IRRT.NE.0) THEN
  1991. INTERR(1)=IB
  1992. CALL ERREUR(611)
  1993. ENDIF
  1994. C
  1995. C CALCUL DE LA MATRICE DE HOOK
  1996. C
  1997. MPTVAL=IVAMAT
  1998. IF(IMAT.EQ.2) THEN
  1999. MELVAL=IVAL(1)
  2000. IBMN=MIN(IB ,IELCHE(/2))
  2001. IGMN=MIN(IGAU,IELCHE(/1))
  2002. MLREEL=IELCHE(IGMN,IBMN)
  2003. SEGACT MLREEL
  2004. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2005. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2006. SEGDES MLREEL
  2007. ELSE IF (IMAT.EQ.1) THEN
  2008. DO IM=1,NMATT
  2009. IF (IVAL(IM).NE.0) THEN
  2010. MELVAL=IVAL(IM)
  2011. IBMN=MIN(IB ,VELCHE(/2))
  2012. IGMN=MIN(IGAU,VELCHE(/1))
  2013. VALMAT(IM)=VELCHE(IGMN,IBMN)
  2014. ELSE
  2015. VALMAT(IM)=0.D0
  2016. ENDIF
  2017. ENDDO
  2018. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2019. 1 CALL DOCO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2020. ENDIF
  2021. C
  2022. C CALCUL ET INTEGRATION DE BDB
  2023. C
  2024. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2025. ENDDO
  2026. C
  2027. * SEGINI XMATRI
  2028. * IMATTT(IB)=XMATRI
  2029. C
  2030. C REMPLISSAGE DE XMATRI
  2031. C
  2032. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2033. * SEGDES XMATRI
  2034. ENDDO
  2035. C
  2036. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2037. C
  2038. IF (IRTD.EQ.0) THEN
  2039. MOTERR(1:8) = CMATE
  2040. MOTERR(9:16) = NOMFR(MFR/2+1)
  2041. INTERR(1) = IFOUR
  2042. CALL ERREUR(81)
  2043. ENDIF
  2044. C
  2045. SEGDES XMATRI
  2046. SEGSUP WRK1,WRK2,WRK4,MVELCH
  2047. GOTO 510
  2048. C_______________________________________________________________________
  2049. C
  2050. C SECTEUR DE CALCUL POUR LE JGI4 GENERALISE
  2051. C
  2052. C_______________________________________________________________________
  2053. C
  2054. 172 CONTINUE
  2055. NBNO=NBNN
  2056. NBBB=NBNN
  2057. SEGINI WRK1,WRK2,WRK4
  2058. C
  2059. C BOUCLE POUR TOUS LES ELEMENTS
  2060. C
  2061. DO IB=1,NBELEM
  2062. C
  2063. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2064. C
  2065. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2066. C
  2067. CALL ZERO (REL,LRE,LRE)
  2068. C
  2069. C CALCUL DES AXES LOCAUX
  2070. C
  2071. CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  2072.  
  2073. IF (NOQUAL.EQ.1) THEN
  2074. INTERR(1)=IB
  2075. MOTERR(1:4) = 'JGI4'
  2076. CALL ERREUR(765)
  2077. RETURN
  2078. ELSE IF ( NOQUAL.EQ.2 ) THEN
  2079. CbPPj INTERR(1)=IB
  2080. CbPPj MOTERR(1:4) = 'JGI4'
  2081. CbPPj CALL ERREUR(766)
  2082. CbPPj RETURN
  2083. WRITE(IOIMP,*)'RIGI4(WARNING): JGI4 element number',IB,
  2084. . ' not planar'
  2085. ENDIF
  2086. C
  2087. C BOUCLE SUR LES POINTS DE GAUSS
  2088. C
  2089. DO IGAU=1,NBPGAU
  2090. C
  2091. C ON CHERCHE L'EPAISSEUR DU JOINT
  2092. C
  2093. EPAIST=0.D0
  2094. MPTVAL=IVACAR
  2095. MELVAL=IVAL(1)
  2096. IF (MELVAL.NE.0) THEN
  2097. IGMN=MIN(IGAU,VELCHE(/1))
  2098. IBMN=MIN(IB,VELCHE(/2))
  2099. EPAIST=VELCHE(IGMN,IBMN)
  2100. ENDIF
  2101. C
  2102. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2103. C
  2104. CcPPj CALL BJO4G(IGAU,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,IRRT)
  2105. CALL BJO4G(IGAU,XE,XEL,BPSS,SHPTOT,SHPWRK,EPAIST,BGENE,DJAC,
  2106. . IRRT)
  2107. DJAC=DJAC*POIGAU(IGAU)
  2108. C IRRT=1 JACOBIEN <= 0
  2109. IF(IRRT.NE.0) THEN
  2110. INTERR(1)=IB
  2111. CALL ERREUR(611)
  2112. ENDIF
  2113. C
  2114. C CALCUL DE LA MATRICE DE HOOK
  2115. C
  2116. MPTVAL=IVAMAT
  2117. IF(IMAT.EQ.2) THEN
  2118. MELVAL=IVAL(1)
  2119. IBMN=MIN(IB ,IELCHE(/2))
  2120. IGMN=MIN(IGAU,IELCHE(/1))
  2121. MLREEL=IELCHE(IGMN,IBMN)
  2122. SEGACT MLREEL
  2123. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2124. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2125. SEGDES MLREEL
  2126. ELSE IF (IMAT.EQ.1) THEN
  2127. DO IM=1,NMATT
  2128. IF (IVAL(IM).NE.0) THEN
  2129. MELVAL=IVAL(IM)
  2130. IBMN=MIN(IB ,VELCHE(/2))
  2131. IGMN=MIN(IGAU,VELCHE(/1))
  2132. VALMAT(IM)=VELCHE(IGMN,IBMN)
  2133. ELSE
  2134. VALMAT(IM)=0.D0
  2135. ENDIF
  2136. ENDDO
  2137. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2138. 1 CALL DOGO88(VALMAT,CMATE,EPAIST,IFOUR,LHOOK,DDHOOK,IRTD)
  2139. ENDIF
  2140. C
  2141. C CALCUL ET INTEGRATION DE BDB
  2142. C
  2143. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2144. ENDDO
  2145. C
  2146. * SEGINI XMATRI
  2147. * IMATTT(IB)=XMATRI
  2148. C
  2149. C REMPLISSAGE DE XMATRI
  2150. C
  2151. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2152. * SEGDES XMATRI
  2153. ENDDO
  2154. C
  2155. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2156. C
  2157. IF (IRTD.EQ.0) THEN
  2158. MOTERR(1:8) = CMATE
  2159. MOTERR(9:16) = NOMFR(MFR/2+1)
  2160. INTERR(1) = IFOUR
  2161. CALL ERREUR(81)
  2162. ENDIF
  2163. C
  2164. SEGDES XMATRI
  2165. SEGSUP WRK1,WRK2,WRK4,MVELCH
  2166. GOTO 510
  2167. C
  2168. C_______________________________________________________________________
  2169. C
  2170. C SECTEUR DE CALCUL POUR LE JOI3 SANS TEST DE PLANEITE
  2171. C ET SANS REPERE LOCAL
  2172. C
  2173. C_______________________________________________________________________
  2174. C
  2175. 86 CONTINUE
  2176. NBNO=NBNN
  2177. NBBB=NBNN
  2178. SEGINI WRK1,WRK2,WRK4
  2179. C
  2180. C BOUCLE POUR TOUS LES ELEMENTS
  2181. C
  2182. DO 3086 IB=1,NBELEM
  2183. C
  2184. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2185. C
  2186. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2187. C
  2188. CALL ZERO (REL,LRE,LRE)
  2189. C
  2190. C BOUCLE SUR LES POINTS DE GAUSS
  2191. C
  2192. DO 4086 IGAU=1,NBPGAU
  2193. C
  2194. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2195. C
  2196.  
  2197. CALL JO3LOC(XE,SHPTOT,IGAU,NBNO,BPSS)
  2198. CALL BJO3(IGAU,MFR,IFOUR,NIFOUR,XE,BPSS,SHPTOT,SHPWRK,
  2199. + BGENE,DJAC,IRRT)
  2200. DJAC=DJAC*POIGAU(IGAU)
  2201. *
  2202. IF (IFOUR.EQ.0) THEN
  2203. C
  2204. C EN AXISYMETRIE, ON MULTIPLIE PAR R
  2205. C (R=RAYON DE COURBURE DU POINT DE GAUSS)
  2206. C
  2207. RAYON=0.0D0
  2208. NUMSUP=NBNO/2
  2209. DO 5086 IRAY=1,NUMSUP
  2210. RAYON=RAYON +( SHPTOT(1,IRAY,IGAU)*XE(1,IRAY) )
  2211. 5086 CONTINUE
  2212. DJAC=DJAC*RAYON
  2213. ENDIF
  2214. C
  2215. C IRRT=1 JACOBIEN <= 0
  2216. IF(IRRT.NE.0) THEN
  2217. INTERR(1)=IB
  2218. CALL ERREUR(612)
  2219. ENDIF
  2220. C
  2221. C CALCUL DE LA MATRICE DE HOOK
  2222. C
  2223. MPTVAL=IVAMAT
  2224. IF(IMAT.EQ.2) THEN
  2225. MELVAL=IVAL(1)
  2226. IBMN=MIN(IB ,IELCHE(/2))
  2227. IGMN=MIN(IGAU,IELCHE(/1))
  2228. MLREEL=IELCHE(IGMN,IBMN)
  2229. SEGACT MLREEL
  2230. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2231. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2232. SEGDES MLREEL
  2233. ELSE IF (IMAT.EQ.1) THEN
  2234. DO 9086 IM=1,NMATT
  2235. IF (IVAL(IM).NE.0) THEN
  2236. MELVAL=IVAL(IM)
  2237. IBMN=MIN(IB ,VELCHE(/2))
  2238. IGMN=MIN(IGAU,VELCHE(/1))
  2239. VALMAT(IM)=VELCHE(IGMN,IBMN)
  2240. ELSE
  2241. VALMAT(IM)=0.D0
  2242. ENDIF
  2243. 9086 CONTINUE
  2244. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2245. 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2246. ENDIF
  2247. C
  2248. C CALCUL ET INTEGRATION DE BDB
  2249. C
  2250. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2251. 4086 CONTINUE
  2252. C
  2253. * SEGINI XMATRI
  2254. * IMATTT(IB)=XMATRI
  2255. C
  2256. C REMPLISSAGE DE XMATRI
  2257. C
  2258. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2259. * SEGDES XMATRI
  2260. 3086 CONTINUE
  2261. C
  2262. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2263. C
  2264. IF (IRTD.EQ.0) THEN
  2265. MOTERR(1:8) = CMATE
  2266. MOTERR(9:16) = NOMFR(MFR/2+1)
  2267. INTERR(1) = IFOUR
  2268. CALL ERREUR(81)
  2269. ENDIF
  2270. C
  2271. SEGDES XMATRI
  2272. SEGSUP WRK1,WRK2,WRK4,MVELCH
  2273. GOTO 510
  2274. C_______________________________________________________________________
  2275. C
  2276. C SECTEUR DE CALCUL POUR LE JOT3
  2277. C
  2278. C_______________________________________________________________________
  2279. C
  2280. 87 CONTINUE
  2281. NBNO=NBNN
  2282. NBBB=NBNN
  2283. SEGINI WRK1,WRK2,WRK4
  2284. C
  2285. C BOUCLE POUR TOUS LES ELEMENTS
  2286. C
  2287. DO 3087 IB=1,NBELEM
  2288. C
  2289. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2290. C
  2291. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2292. C
  2293. CALL ZERO (REL,LRE,LRE)
  2294. C
  2295. C CALCUL DES AXES LOCAUX
  2296. C
  2297. CALL JT3LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  2298. C
  2299. IF (NOQUAL.EQ.1) THEN
  2300. INTERR(1)=IB
  2301. MOTERR(1:4) = 'JOT3'
  2302. CALL ERREUR(765)
  2303. RETURN
  2304. ELSE IF ( NOQUAL.EQ.2) THEN
  2305. INTERR(1)=IB
  2306. MOTERR(1:4) = 'JOT3'
  2307. CALL ERREUR(766)
  2308. RETURN
  2309. ENDIF
  2310. C
  2311. C BOUCLE SUR LES POINTS DE GAUSS
  2312. C
  2313. DO 4087 IGAU=1,NBPGAU
  2314. C 4
  2315. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2316. C
  2317. CALL BJT3(IGAU,MFR,IFOUR,NIFOUR,XEL,BPSS,SHPTOT,SHPWRK,
  2318. + BGENE,DJAC,IRRT)
  2319. DJAC=DJAC*POIGAU(IGAU)
  2320. C IRRT=1 JACOBIEN <= 0
  2321. IF(IRRT.NE.0) THEN
  2322. CALL ERREUR(764)
  2323. ENDIF
  2324. C
  2325. C CALCUL DE LA MATRICE DE HOOK
  2326. C
  2327. MPTVAL=IVAMAT
  2328. IF(IMAT.EQ.2) THEN
  2329. MELVAL=IVAL(1)
  2330. IBMN=MIN(IB ,IELCHE(/2))
  2331. IGMN=MIN(IGAU,IELCHE(/1))
  2332. MLREEL=IELCHE(IGMN,IBMN)
  2333. SEGACT MLREEL
  2334. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2335. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2336. SEGDES MLREEL
  2337. ELSE IF (IMAT.EQ.1) THEN
  2338. DO 9087 IM=1,NMATT
  2339. IF (IVAL(IM).NE.0) THEN
  2340. MELVAL=IVAL(IM)
  2341. IBMN=MIN(IB ,VELCHE(/2))
  2342. IGMN=MIN(IGAU,VELCHE(/1))
  2343. VALMAT(IM)=VELCHE(IGMN,IBMN)
  2344. ELSE
  2345. VALMAT(IM)=0.D0
  2346. ENDIF
  2347. 9087 CONTINUE
  2348. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2349. 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2350. ENDIF
  2351. C
  2352. C CALCUL ET INTEGRATION DE BDB
  2353. C
  2354. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2355. 4087 CONTINUE
  2356. C
  2357. * SEGINI XMATRI
  2358. * IMATTT(IB)=XMATRI
  2359. C
  2360. C REMPLISSAGE DE XMATRI
  2361. C
  2362. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2363. * SEGDES XMATRI
  2364. 3087 CONTINUE
  2365. C
  2366. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2367. C
  2368. IF (IRTD.EQ.0) THEN
  2369. MOTERR(1:8) = CMATE
  2370. MOTERR(9:16) = NOMFR(MFR/2+1)
  2371. INTERR(1) = IFOUR
  2372. CALL ERREUR(81)
  2373. ENDIF
  2374. C
  2375. SEGDES XMATRI
  2376. SEGSUP WRK1,WRK2,WRK4,MVELCH
  2377. GOTO 510
  2378. C_______________________________________________________________________
  2379. C
  2380. C SECTEUR DE CALCUL POUR LE JOI4
  2381. C
  2382. C_______________________________________________________________________
  2383. C
  2384. 88 CONTINUE
  2385. NBNO=NBNN
  2386. NBBB=NBNN
  2387. SEGINI WRK1,WRK2,WRK4
  2388. C
  2389. C BOUCLE POUR TOUS LES ELEMENTS
  2390. C
  2391. DO 3088 IB=1,NBELEM
  2392. C
  2393. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2394. C
  2395. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2396. C
  2397. CALL ZERO (REL,LRE,LRE)
  2398. C
  2399. C CALCUL DES AXES LOCAUX
  2400. C
  2401. CALL JO4LOC(XE,SHPTOT,NBNO,XEL,BPSS,NOQUAL)
  2402.  
  2403. IF (NOQUAL.EQ.1) THEN
  2404. INTERR(1)=IB
  2405. MOTERR(1:4) = 'JOI4'
  2406. CALL ERREUR(765)
  2407. RETURN
  2408. ELSE IF ( NOQUAL.EQ.2 ) THEN
  2409. INTERR(1)=IB
  2410. MOTERR(1:4) = 'JOI4'
  2411. CALL ERREUR(766)
  2412. RETURN
  2413. ENDIF
  2414. C
  2415. C BOUCLE SUR LES POINTS DE GAUSS
  2416. C
  2417. DO 4088 IGAU=1,NBPGAU
  2418. C
  2419. C CALCUL DE LA MATRICE B ET DU JACOBIEN EN IGAU
  2420. C
  2421. CALL BJO4(IGAU,XEL,BPSS,SHPTOT,SHPWRK,BGENE,DJAC,IRRT)
  2422. DJAC=DJAC*POIGAU(IGAU)
  2423. C IRRT=1 JACOBIEN <= 0
  2424. IF(IRRT.NE.0) THEN
  2425. INTERR(1)=IB
  2426. CALL ERREUR(611)
  2427. ENDIF
  2428. C
  2429. C CALCUL DE LA MATRICE DE HOOK
  2430. C
  2431. MPTVAL=IVAMAT
  2432. IF(IMAT.EQ.2) THEN
  2433. MELVAL=IVAL(1)
  2434. IBMN=MIN(IB ,IELCHE(/2))
  2435. IGMN=MIN(IGAU,IELCHE(/1))
  2436. MLREEL=IELCHE(IGMN,IBMN)
  2437. SEGACT MLREEL
  2438. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2439. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2440. SEGDES MLREEL
  2441. ELSE IF (IMAT.EQ.1) THEN
  2442. DO 9088 IM=1,NMATT
  2443. IF (IVAL(IM).NE.0) THEN
  2444. MELVAL=IVAL(IM)
  2445. IBMN=MIN(IB ,VELCHE(/2))
  2446. IGMN=MIN(IGAU,VELCHE(/1))
  2447. VALMAT(IM)=VELCHE(IGMN,IBMN)
  2448. ELSE
  2449. VALMAT(IM)=0.D0
  2450. ENDIF
  2451. 9088 CONTINUE
  2452. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2453. 1 CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2454. ENDIF
  2455. C
  2456. C CALCUL ET INTEGRATION DE BDB
  2457. C
  2458. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  2459. 4088 CONTINUE
  2460. C
  2461. * SEGINI XMATRI
  2462. * IMATTT(IB)=XMATRI
  2463. C
  2464. C REMPLISSAGE DE XMATRI
  2465. C
  2466. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2467. * SEGDES XMATRI
  2468. 3088 CONTINUE
  2469. C
  2470. C IMPRESSION EVENTUELLE D'UN MESSAGE D'ERREUR
  2471. C
  2472. IF (IRTD.EQ.0) THEN
  2473. MOTERR(1:8) = CMATE
  2474. MOTERR(9:16) = NOMFR(MFR/2+1)
  2475. INTERR(1) = IFOUR
  2476. CALL ERREUR(81)
  2477. ENDIF
  2478. C
  2479. SEGDES XMATRI
  2480. SEGSUP WRK1,WRK2,WRK4,MVELCH
  2481. GOTO 510
  2482. C_______________________________________________________________________
  2483. C
  2484. C SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISE TRIH
  2485. C_______________________________________________________________________
  2486. C
  2487. 92 CONTINUE
  2488. NBNO=NBNN
  2489. NBBB=NBNN
  2490. LRN =NBNN
  2491. NSTN=3
  2492. SEGINI WRK1,WRK2 ,WRK5
  2493. I195=0
  2494. DO 3092 IB=1,NBELEM
  2495. C
  2496. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2497. C
  2498. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2499. CALL ZERO (REL,LRE,LRE)
  2500. *
  2501. MPTVAL=IVAMAT
  2502. DO 9092 IM=1,10
  2503. IF (IVAL(IM).NE.0) THEN
  2504. MELVAL=IVAL(IM)
  2505. IBMN=MIN(IB ,VELCHE(/2))
  2506. VALMAT(IM)=VELCHE(1,IBMN)
  2507. ELSE
  2508. VALMAT(IM)=0.D0
  2509.  
  2510. ENDIF
  2511. 9092 CONTINUE
  2512. C
  2513. C ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB
  2514. C
  2515. RHOF =VALMAT(4)
  2516. E =VALMAT(6)
  2517. C =VALMAT(7)
  2518. RHOREF=VALMAT(8)
  2519. CREF =VALMAT(9)
  2520. RLCAR =VALMAT(10)
  2521. C
  2522. C ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB
  2523. C
  2524. MPTVAL=IVACAR
  2525. IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
  2526. MELVAL=IVAL(1)
  2527. IBMN=MIN(IB,VELCHE(/2))
  2528. SCEL =VELCHE(1,IBMN)
  2529. MELVAL=IVAL(2)
  2530. IBMN=MIN(IB,VELCHE(/2))
  2531. SFLU =VELCHE(1,IBMN)
  2532. MELVAL=IVAL(3)
  2533. IBMN=MIN(IB,VELCHE(/2))
  2534. EPS =VELCHE(1,IBMN)
  2535. MELVAL=IVAL(4)
  2536. IBMN=MIN(IB,VELCHE(/2))
  2537. XINERT=VELCHE(1,IBMN)
  2538. EI = E*XINERT/(EPS*EPS)
  2539. ELSE
  2540. MELVAL=IVAL(1)
  2541. IBMN=MIN(IB,VELCHE(/2))
  2542. SCEL =VELCHE(1,IBMN)
  2543. MELVAL=IVAL(2)
  2544. IBMN=MIN(IB,VELCHE(/2))
  2545. SFLU =VELCHE(1,IBMN)
  2546. MELVAL=IVAL(3)
  2547. IBMN=MIN(IB,VELCHE(/2))
  2548. EPS =VELCHE(1,IBMN)
  2549. C E REPRESENTE LA RIGIDITE MODALE DE LA POUTRE
  2550. EI = E /(EPS*EPS)
  2551. ENDIF
  2552. C
  2553. C CALCUL DES COEFFICIENTS DE NORMALISATION
  2554. C
  2555. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  2556. VKL1 =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL)
  2557. VKL2 = EI/SCEL
  2558. C
  2559. C BOUCLE SUR LES POINTS DE GAUSS
  2560. C
  2561. ISDJC=0
  2562. DO 4092 IGAU=1,NBPGAU
  2563. CALL TRIHR1(IGAU,MELE,MFR,NBNO,IFOUR,NIFOUR,XE,SHPTOT,
  2564. # SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT)
  2565. IF(IRRT.NE.1) GOTO 5092
  2566. DJAC=DJAC*POIGAU(IGAU)
  2567. CALL TRIHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL)
  2568. 4092 CONTINUE
  2569. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  2570. * SEGINI XMATRI
  2571. * IMATTT(IB)=XMATRI
  2572. C
  2573. C REMPLISSAGE DE XMATRI
  2574. C
  2575. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2576. * SEGDES XMATRI
  2577. 3092 CONTINUE
  2578. C
  2579. C IMPRESSION D UN EVENTUEL MESSAGE D ERREUR
  2580. C
  2581. 5092 CONTINUE
  2582. IF(IRRT.EQ.0) THEN
  2583. MOTERR(1:4)=NOMTP(MELE)
  2584. CALL ERREUR(420)
  2585. ELSE
  2586. IF(IRRT.EQ.2) THEN
  2587. INTERR(1)=IB
  2588. CALL ERREUR(405)
  2589. ENDIF
  2590. ENDIF
  2591. IF(I195.NE.0) INTERR(1)=I195
  2592. IF(I195.NE.0) CALL ERREUR(195)
  2593. SEGDES XMATRI
  2594. SEGSUP WRK1,WRK2,WRK5,MVELCH
  2595. GOTO 510
  2596. *_______________________________________________________________________
  2597. *
  2598. * ELEMENT TUYO
  2599. *_______________________________________________________________________
  2600. *
  2601. 96 CONTINUE
  2602. NBNO=IPORE
  2603. NBBB=NBNN
  2604. SEGINI WRK1,WRK2,WRK3,WRK6
  2605. C
  2606. C BOUCLE DE CALCUL POUR LES DIFFERENTS ELEMENTS
  2607. C
  2608. DO 3096 IB=1,NBELEM
  2609. KERRE=0
  2610. C
  2611. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2612. C
  2613. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2614. CALL ZERO (REL,LRE,LRE)
  2615. *
  2616. XL=(XE(1,2)-XE(1,1))**2+(XE(2,2)-XE(2,1))**2+
  2617. . (XE(3,2)-XE(3,1))**2
  2618. XL=SQRT(XL)
  2619. IF(XL.EQ.0.D0) THEN
  2620. KERRE=1
  2621. GO TO 3096
  2622. ENDIF
  2623. C
  2624. C RANGEMENT DES CARACTERISTIQUES DANS WORK
  2625. C ON SUPPOSE QU'ELLES SONT CONSTANTES POUR L'ELEMENT
  2626. C
  2627. MPTVAL=IVACAR
  2628. DO 6096 IC=1,NCARR
  2629. IF (IVAL(IC).NE.0) THEN
  2630. MELVAL=IVAL(IC)
  2631. IBMN=MIN(IB,VELCHE(/2))
  2632. WORK(IC)=VELCHE(1,IBMN)
  2633. ELSE
  2634. WORK(IC)=0.D0
  2635. ENDIF
  2636. 6096 CONTINUE
  2637. C
  2638. C TRAITEMENT DU VECTEUR
  2639. C
  2640. IF (IVAL(NCARR).NE.0) THEN
  2641. MELVAL=IVAL(NCARR)
  2642. IBMN=MIN(IB,IELCHE(/2))
  2643. IP=IELCHE(1,IBMN)
  2644. IREF=(IP-1)*(IDIM+1)
  2645. DO 6196 IC=1,IDIM
  2646. WORK(NCARR+IC-1)=XCOOR(IREF+IC)
  2647. 6196 CONTINUE
  2648. ELSE
  2649. DO 6296 IC=1,IDIM
  2650. WORK(NCARR+IC-1)=0.D0
  2651. 6296 CONTINUE
  2652. ENDIF
  2653. C
  2654. C CALCUL DU REPERE LOCAL
  2655. C
  2656. CALL TUYPAS(XE,XL,WORK,PSS,KERRE)
  2657. IF(KERRE.NE.0) THEN
  2658. INTERR(1)=IB
  2659. CALL ERREUR(5 )
  2660. RETURN
  2661. ENDIF
  2662. C
  2663. C BOUCLE SUR LES POINTS DE GAUSS
  2664. C
  2665. DO 4096 IGAU=1,NBPGAU
  2666. C
  2667. C TRAITEMENT DU MATERIAU
  2668. C IL PEUT VARIER D'UN POINT DE GAUSS A L'AUTRE
  2669. C
  2670. MPTVAL=IVAMAT
  2671. IF(IMAT.EQ.2) THEN
  2672. MELVAL=IVAL(1)
  2673. IGMN=MIN(IGAU,VELCHE(/1))
  2674. IBMN=MIN(IB ,IELCHE(/2))
  2675. MLREEL=IELCHE(IGMN,IBMN)
  2676. SEGACT MLREEL
  2677. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2678. . CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2679. SEGDES MLREEL
  2680. *
  2681. ELSE IF (IMAT.EQ.1) THEN
  2682. *
  2683. DO 9096 IM=1,NMATT
  2684. IF (IVAL(IM).NE.0) THEN
  2685. MELVAL=IVAL(IM)
  2686. IGMN=MIN(IGAU,VELCHE(/1))
  2687. IBMN=MIN(IB ,VELCHE(/2))
  2688. VALMAT(IM)=VELCHE(IGMN,IBMN)
  2689. ELSE
  2690. VALMAT(IM)=0.D0
  2691. ENDIF
  2692. 9096 CONTINUE
  2693. CALL DOHCOM(VALMAT,NMATT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  2694. EPAIST=WORK(1)
  2695. CALL HOOKMU(EPAIST,0.D0,LHOOK,DDHOOK,DDHOMU)
  2696. ENDIF
  2697. *
  2698. * CALCUL DE LA MATRICE B ET DU JACOBIEN
  2699. *
  2700. CALL BTUYO(IGAU,MINTE,WRK1,WRK2,WRK3,XL,DJAC,KERRE)
  2701. DJAC=DJAC*POIGAU(IGAU)
  2702. *
  2703. IF(KERRE.NE.0) THEN
  2704. INTERR(1)=IB
  2705. CALL ERREUR(5)
  2706. ENDIF
  2707. *
  2708. * CALCUL ET INTEGRATION DE BTDB
  2709. *
  2710. CALL BDBST(BGENE,DJAC,DDHOMU,LRE,NSTRS,REL)
  2711. 4096 CONTINUE
  2712. *
  2713. * CHANGEMENT DE BASE
  2714. *
  2715. CALL TUYROT(REL,LRE,PSS,1)
  2716. *
  2717. * SEGINI XMATRI
  2718. * IMATTT(IB)=XMATRI
  2719. C
  2720. C REMPLISSAGE DE XMATRI
  2721. C
  2722. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2723. * SEGDES XMATRI
  2724. 3096 CONTINUE
  2725. IF(KERRE.EQ.1) CALL ERREUR(128)
  2726. IF(KERRE.EQ.2) CALL ERREUR(138)
  2727. IF(IRTD.EQ.0) THEN
  2728. MOTERR(1:8)=CMATE
  2729. MOTERR(9:16)=NOMFR(MFR/2+1)
  2730. INTERR(1)=IFOUR
  2731. CALL ERREUR(81)
  2732. return
  2733. ENDIF
  2734. SEGDES XMATRI
  2735. SEGSUP WRK1,WRK2,WRK3,WRK6,MVELCH
  2736. GOTO 510
  2737. C_______________________________________________________________________
  2738. C
  2739. C SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISES QUAH
  2740. C_______________________________________________________________________
  2741. C
  2742. 126 CONTINUE
  2743. C
  2744. NBNO=NBNN
  2745. NBBB=NBNN
  2746. LRN =NBNN+NBNN
  2747. NSTN=2
  2748. SEGINI WRK1,WRK2 ,WRK5
  2749. I195=0
  2750. DO 3126 IB=1,NBELEM
  2751. C
  2752. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2753. C
  2754. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2755. CALL ZERO (REL,LRE,LRE)
  2756. *
  2757. MPTVAL=IVAMAT
  2758. DO 9126 IM=1,10
  2759. IF (IVAL(IM).NE.0) THEN
  2760. MELVAL=IVAL(IM)
  2761. IBMN=MIN(IB ,VELCHE(/2))
  2762. VALMAT(IM)=VELCHE(1,IBMN)
  2763. ELSE
  2764. VALMAT(IM)=0.D0
  2765.  
  2766. ENDIF
  2767. 9126 CONTINUE
  2768. C
  2769. C ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB
  2770. C
  2771. RHOF =VALMAT(4)
  2772.  
  2773. E =VALMAT(6)
  2774.  
  2775. C =VALMAT(7)
  2776.  
  2777. RHOREF=VALMAT(8)
  2778.  
  2779. CREF =VALMAT(9)
  2780.  
  2781. RLCAR =VALMAT(10)
  2782.  
  2783. C
  2784. C ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB
  2785. C
  2786. MPTVAL=IVACAR
  2787. MELVAL=IVAL(1)
  2788. IBMN=MIN(IB,VELCHE(/2))
  2789. SCEL =VELCHE(1,IBMN)
  2790.  
  2791. MELVAL=IVAL(2)
  2792. IBMN=MIN(IB,VELCHE(/2))
  2793. SFLU =VELCHE(1,IBMN)
  2794.  
  2795. MELVAL=IVAL(3)
  2796. IBMN=MIN(IB,VELCHE(/2))
  2797. EPS =VELCHE(1,IBMN)
  2798.  
  2799. MELVAL=IVAL(5)
  2800. IBMN=MIN(IB,VELCHE(/2))
  2801. XINERT=VELCHE(1,IBMN)
  2802. EI = E*XINERT/(EPS*EPS)
  2803. C
  2804. C CALCUL DES COEFFICIENTS DE NORMALISATION
  2805. C
  2806. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  2807. VKL1 =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL)
  2808. VKL2 = EI/SCEL
  2809. C
  2810. C
  2811. C BOUCLE SUR LES POINTS DE GAUSS
  2812. C
  2813. ISDJC=0
  2814. DO 4126 IGAU=1,NBPGAU
  2815. CALL QUAHR1(IGAU,MELE,MFR,NBNO,IFOUR,NIFOUR,XE,SHPTOT,
  2816. # SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT)
  2817. IF(IRRT.NE.1) GOTO 5126
  2818. DJAC=DJAC*POIGAU(IGAU)
  2819. CALL QUAHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL)
  2820. 4126 CONTINUE
  2821. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  2822. * SEGINI XMATRI
  2823. * IMATTT(IB)=XMATRI
  2824. C
  2825. C REMPLISSAGE DE XMATRI
  2826. C
  2827. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2828. * SEGDES XMATRI
  2829. 3126 CONTINUE
  2830. C
  2831. C IMPRESSION D UN EVENTUEL MESSAGE D ERREUR
  2832. C
  2833. 5126 CONTINUE
  2834. IF(IRRT.EQ.0) THEN
  2835. MOTERR(1:4)=NOMTP(MELE)
  2836. CALL ERREUR(420)
  2837. ELSE
  2838. IF(IRRT.EQ.2) THEN
  2839. INTERR(1)=IB
  2840. CALL ERREUR(405)
  2841. ENDIF
  2842. ENDIF
  2843. IF(I195.NE.0) INTERR(1)=I195
  2844. IF(I195.NE.0) CALL ERREUR(195)
  2845. SEGDES XMATRI
  2846. SEGSUP WRK1,WRK2,WRK5,MVELCH
  2847. GOTO 510
  2848. C_______________________________________________________________________
  2849. C
  2850. C SECTEUR DE CALCUL POUR LES ELEMENTS HOMOGENEISES CUBH
  2851. C_______________________________________________________________________
  2852. C
  2853. 127 CONTINUE
  2854. NBNO=NBNN
  2855. NBBB=NBNN
  2856. LRN =NBNN*2
  2857. NSTN=2
  2858. C
  2859. SEGINI WRK1,WRK2 ,WRK5
  2860. I195=0
  2861. DO 3127 IB=1,NBELEM
  2862. C
  2863. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2864. C
  2865. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2866. CALL ZERO (REL,LRE,LRE)
  2867. *
  2868. MPTVAL=IVAMAT
  2869. DO 9127 IM=1,10
  2870. IF (IVAL(IM).NE.0) THEN
  2871. MELVAL=IVAL(IM)
  2872. IBMN=MIN(IB ,VELCHE(/2))
  2873. VALMAT(IM)=VELCHE(1,IBMN)
  2874. ELSE
  2875. VALMAT(IM)=0.D0
  2876.  
  2877. ENDIF
  2878. 9127 CONTINUE
  2879. C
  2880. C ON CHERCHE LES CARACTERISTIQUES DU MATERIAU POUR L ELEMENT IB
  2881. C
  2882. RHOF =VALMAT(4)
  2883.  
  2884. E =VALMAT(6)
  2885.  
  2886. C =VALMAT(7)
  2887.  
  2888. RHOREF=VALMAT(8)
  2889.  
  2890. CREF =VALMAT(9)
  2891.  
  2892. RLCAR =VALMAT(10)
  2893. C
  2894. C ON CHERCHE LES CARACTERISTIQUES GEOMETRIQUES POUR L ELEMENT IB
  2895. C
  2896. MPTVAL=IVACAR
  2897. MELVAL=IVAL(1)
  2898. IBMN=MIN(IB,VELCHE(/2))
  2899. SCEL =VELCHE(1,IBMN)
  2900.  
  2901. MELVAL=IVAL(2)
  2902. IBMN=MIN(IB,VELCHE(/2))
  2903. SFLU =VELCHE(1,IBMN)
  2904.  
  2905. MELVAL=IVAL(3)
  2906. IBMN=MIN(IB,VELCHE(/2))
  2907. EPS =VELCHE(1,IBMN)
  2908.  
  2909. MELVAL=IVAL(5)
  2910. IBMN=MIN(IB,VELCHE(/2))
  2911. XINERT=VELCHE(1,IBMN)
  2912. EI = E*XINERT/(EPS*EPS)
  2913. C
  2914. C CALCUL DES COEFFICIENTS DE NORMALISATION
  2915. C
  2916. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  2917. VKL1 =(COEFPR*COEFPR*SFLU)/(RHOF*C*C*SCEL)
  2918. VKL2 = EI/SCEL
  2919. C
  2920. C BOUCLE SUR LES POINTS DE GAUSS
  2921. C
  2922. ISDJC=0
  2923. DO 4127 IGAU=1,NBPGAU
  2924. CALL CUBHR1(IGAU,MELE,MFR,NBNO,NIFOUR,XE,SHPTOT,
  2925. # SHPWRK,NST,ISDJC,XGENE,DJAC,IRRT)
  2926. IF(IRRT.NE.1) GOTO 5127
  2927. DJAC=DJAC*POIGAU(IGAU)
  2928. C
  2929. C
  2930. CALL CUBHR2(XGENE,DJAC,VKL1,VKL2,LRE,NST,NBNO,IFOUR,REL)
  2931. 4127 CONTINUE
  2932. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) I195=IB
  2933. * SEGINI XMATRI
  2934. * IMATTT(IB)=XMATRI
  2935. C
  2936. C REMPLISSAGE DE XMATRI
  2937. C
  2938. CALL REMPMT(REL,LRE,RE(1,1,IB))
  2939. * SEGDES XMATRI
  2940. 3127 CONTINUE
  2941. C
  2942. C IMPRESSION D UN EVENTUEL MESSAGE D ERREUR
  2943. C
  2944. 5127 CONTINUE
  2945. IF(IRRT.EQ.0) THEN
  2946. MOTERR(1:4)=NOMTP(MELE)
  2947. CALL ERREUR(420)
  2948. ELSE
  2949. IF(IRRT.EQ.2) THEN
  2950. INTERR(1)=IB
  2951. CALL ERREUR(405)
  2952. ENDIF
  2953. ENDIF
  2954. IF(I195.NE.0) INTERR(1)=I195
  2955. IF(I195.NE.0) CALL ERREUR(195)
  2956. SEGDES XMATRI
  2957. SEGSUP WRK1,WRK2,WRK5,MVELCH
  2958. GOTO 510
  2959.  
  2960. C_______________________________________________________________________
  2961. C
  2962. C ELEMENTS CIFL MACRO ELEMENT CISAILLEMENT FLEXION
  2963. C
  2964. C_______________________________________________________________________
  2965. C
  2966. 258 CONTINUE
  2967. NBNO=NBNN
  2968. NBBB=NBNN
  2969. SEGINI WRK1,WRK2,WRK3,WRK4
  2970. C
  2971. C BOUCLE POUR TOUS LES ELEMENTS
  2972. C
  2973. DO IB=1,NBELEM
  2974. C
  2975. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  2976. C
  2977. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  2978. C
  2979. CALL ZERO (REL,LRE,LRE)
  2980. C
  2981. C PASSAGE DES AXES GLOBAUX AUX AXES LOCAUX
  2982. C
  2983. CALL MURLOC(XE,NBNN,LHOOK,LRE,BPSS,XH,BGENE)
  2984. C
  2985. C CALCUL DE LA MATRICE DE HOOK
  2986. C
  2987. MPTVAL=IVAMAT
  2988. IF(IMAT.EQ.2) THEN
  2989. MELVAL=IVAL(1)
  2990. IGMN=MIN(1,IELCHE(/1))
  2991. MLREEL=IELCHE(IGMN,IBMN)
  2992. SEGACT MLREEL
  2993. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  2994. 1 CALL DOHOOO(PROG,LHOOK,DDHOOK)
  2995. SEGDES MLREEL
  2996. ELSE IF