Télécharger rigi2.eso

Retour à la liste

Numérotation des lignes :

rigi2
  1. C RIGI2 SOURCE SP204843 25/07/03 21:15:07 12308
  2. SUBROUTINE RIGI2(MATE,MELE,IPMAIL,IPMINT,NBPGAU,LRE,NSTRS,
  3. & IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,IMAT,LHOOK,NMATT,
  4. & IPORE,NDDL,IPMATR,IIPDPG,NCAR1,MELPHA,NOER)
  5. *---------------------------------------------------------------------*
  6. * __________________________ *
  7. * | | *
  8. * | CALCUL DE LA RIGIDITE | *
  9. * |________________________| *
  10. * *
  11. * massif, liquide, 'surface libre', poreux et joints poreux, *
  12. * incompressible *
  13. * *
  14. *---------------------------------------------------------------------*
  15. * *
  16. * ENTREES : *
  17. * ________ *
  18. * *
  19. * MATE Numero du materiau *
  20. * MELE Numero de l'element fini *
  21. * IPMAIL Pointeur sur un segment MELEME *
  22. * IPMINT Pointeur sur un segment MINTE *
  23. * NBPGAU Nombre de point d'integration pour la rigidite *
  24. * LRE Nombre de ddl dans la matrice de rigidite *
  25. * NSTRS Nombre de composante de contraintes/deformations *
  26. * IVAMAT Pointeur sur un segment MPTVAL pour le materiau ou *
  27. * pour une matrice de hooke *
  28. * IVACAR Pointeur sur un segment MPTVAL de caractéristiques *
  29. * CMATE Nom du materiau *
  30. * MFR Numero de la formulation element fini *
  31. * NBGMAT Taille maxi des melval du materiau (pt de gauss) *
  32. * NELMAT Taille maxi des melval du materiau (No d'element) *
  33. * IMAT (2 il y a une matrice de HOOKE,1 non ) *
  34. * NMATT Nombre de composante de materiau (IMAT=1) *
  35. * LHOOK Dimension de la matrice de Hooke *
  36. * IPORE Nombre de fonctions de forme *
  37. * NDDL Nombre de degre de liberte *
  38. * *
  39. * SORTIES : *
  40. * ________ *
  41. * *
  42. * IPMATR pointeur sur la rigidite de la sous-zone *
  43. * *
  44. *---------------------------------------------------------------------*
  45. IMPLICIT INTEGER(I-N)
  46. IMPLICIT REAL*8(A-H,O-Z)
  47.  
  48. -INC PPARAM
  49. -INC CCOPTIO
  50. -INC CCHAMP
  51. -INC CCREEL
  52.  
  53. -INC SMCHAML
  54. -INC SMINTE
  55. -INC SMELEME
  56. -INC SMRIGID
  57. -INC SMCOORD
  58. -INC SMLREEL
  59.  
  60. -INC TMPTVAL
  61.  
  62. SEGMENT WRK1
  63. REAL*8 DDHOOK(LHOOK,LHOOK) ,DDHOMU(LHOOK,LHOOK)
  64. REAL*8 REL(LRE,LRE) ,RINT(LRE,LRE) , XE(3,NBBB)
  65. ENDSEGMENT
  66. *
  67. SEGMENT WRK2
  68. REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE)
  69. ENDSEGMENT
  70. *
  71. SEGMENT WRK3
  72. REAL*8 BPSS(3,3),XEL(3,NBBB)
  73. REAL*8 XNTH(LPP,LPP),XNTB(LPP,LPP),XNTT(LPP)
  74. ENDSEGMENT
  75. *
  76. SEGMENT WRK5
  77. REAL*8 XGENE(NSTN,LRN)
  78. ENDSEGMENT
  79. *
  80. SEGMENT WRK55
  81. REAL*8 YGENE(NCOT,NBNN),COBMA(LHOOK)
  82. ENDSEGMENT
  83. *
  84. SEGMENT WRK555
  85. REAL*8 XREL(LRN,LRN),COBB(NSTN),CPBB(NSTN),KKBB(NSTN,NSTN)
  86. ENDSEGMENT
  87. *
  88. SEGMENT WRK8
  89. REAL*8 XLOC(3,3),XGLOB(3,3),TXR(IDIM,IDIM)
  90. REAL*8 D1HO(LHOOK,LHOOK),ROTH(LHOOK,LHOOK)
  91. ENDSEGMENT
  92. *
  93. SEGMENT,MVELCH
  94. REAL*8 VALMAT(NV1)
  95. ENDSEGMENT
  96. *
  97. segment mwrk67
  98. real*8 valcar(nca1), xatef1(3,3)
  99. endsegment
  100.  
  101. DIMENSION A(4,60),BB(3,60),PP(4,4)
  102. CHARACTER*8 CMATE,celem
  103. logical drend,BDPGE
  104. *
  105. * WRITE (*,*) 'Entrée dans RIGI2.'
  106. MELEME=IPMAIL
  107. NBNN=NUM(/1)
  108. NBELEM=NUM(/2)
  109. *
  110. NV1=NMATT
  111. SEGINI,MVELCH
  112. *
  113. XMATRI=IPMATR
  114. c* NLIGRD=LRE
  115. c* NLIGRP=LRE
  116.  
  117. C Introduction du point autour duquel se fait le mouvement
  118. C de la section en defo plane generalisee
  119. C IIPDPG = numero du noeud/point support si defini pour le modele
  120. IF (IIPDPG.GT.0) THEN
  121. IF (IFOUR.EQ.-3) THEN
  122. BDPGE=.TRUE.
  123. IREF=(IIPDPG-1)*(IDIM+1)
  124. XDPGE=XCOOR(IREF+1)
  125. YDPGE=XCOOR(IREF+2)
  126. ELSE IF (IFOUR.EQ. 7 .OR. IFOUR.EQ. 8 .OR. IFOUR.EQ. 9 .OR.
  127. & IFOUR.EQ.10 .OR. IFOUR.EQ.11 .OR. IFOUR.EQ.14) THEN
  128. BDPGE=.TRUE.
  129. XDPGE=XZero
  130. YDPGE=XZero
  131. else
  132. write(ioimp,*) 'RIGI2 : ERREUR DPGE'
  133. call erreur(5)
  134. return
  135. ENDIF
  136. ELSE
  137. BDPGE=.FALSE.
  138. XDPGE=XZero
  139. YDPGE=XZero
  140. ENDIF
  141. *
  142. NHRM=NIFOUR
  143. *
  144. MINTE=IPMINT
  145. IRTD=1
  146. IDECAP=0
  147. C_______________________________________________________________________
  148. C
  149. C NUMERO DES ETIQUETTES :
  150. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  151. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  152. C 5 CONTINUE
  153. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  154. C 44 CONTINUE
  155. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  156. C_______________________________________________________________________
  157. C
  158. IF(MELE.GE.1.AND.MELE.LE.100) THEN
  159. C CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8
  160. GOTO ( 99, 99, 99, 4, 99, 4, 99, 4, 99, 4
  161. C QUA9 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6
  162. 1 , 99, 99, 99, 4, 4, 4, 4, 99, 99, 99
  163. C LIA8 MULT TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP
  164. 2 , 99, 99, 4, 4, 4, 4, 99, 99, 99, 99
  165. C FAC3 FAC4 FAC6 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5
  166. 3 , 99, 99, 99, 99, 35, 35, 35, 35, 35, 35
  167. C COQ8 TUYA TUFI COQ2 POI1 BARR RACO LSU2 COQ4 LISM
  168. 4 , 99, 99, 99, 99, 99, 99, 99, 48, 99, 99
  169. C COF3 RES2 LSU3 LSU4 LICO COQ6 CVS2 CVS3 CVT3 CVT6
  170. 5 , 99, 99, 48, 48, 99, 99, 99, 99, 99, 99
  171. C CVQ4 CVQ8 THP5 TH13 THP6 TH15 THC8 TH20 ICT3 ICQ4
  172. 6 , 99, 99, 99, 99, 99, 99, 99, 99, 4, 4
  173. C ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 IC15 TRIP QUAP
  174. 7 , 4, 4, 4, 4, 4, 4, 4, 4, 79, 79
  175. C CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 JOI6 JOI8
  176. 8 , 79, 79, 79, 99, 99, 99, 99, 99, 99, 99
  177. C LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 HYQ4
  178. 9 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99)
  179. c cccccc
  180. . ,MELE
  181. ELSEIF(MELE.GE.101.AND.MELE.LE.200) THEN
  182. C HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  183. GOTO ( 99, 99, 99, 99, 99, 99, 99, 80, 80, 80
  184. C POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12
  185. 1 , 4, 4, 4, 4, 4, 4, 4, 4, 4, 4
  186. C PO13 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3
  187. 2 , 4, 4, 99, 99, 99, 99, 99, 99, 99, 99
  188. C QUF4 CUF8 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18
  189. 3 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  190. C MT10 MP14 SEF3 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6
  191. 4 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  192. C TR21 QU36 C216 P126 TE56 PY91 TRH6 BSE2 BTR4 BQU5
  193. 5 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  194. C BCU9 BPR7 BTE5 BPY6 FRO4 SEGS POJS JCT3 JCI4 JGI2
  195. 6 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  196. C JGT3 JGI4 TRIQ QUAQ CUBQ TETQ PRIQ TRIR QUAR CUBR
  197. 7 , 99, 99, 173, 173, 173, 173, 173, 173, 173, 173
  198. C TETR PRIR Q4RI Q8RI JOQ3 JOQ6 JOQ8 JOR3 JOR6 JOR8
  199. 8 , 173, 173, 4, 4, 185, 185, 185, 185, 185, 185
  200. C T1D2 T1D3 M1D2 M1D3 LC03 LC07 LC09 LC27 LC21 LC15
  201. 9 , 99, 99, 4, 4, 99, 99, 99, 99, 99, 99)
  202. c cccccc
  203. . ,MELE-100
  204. ELSEIF(MELE.GE.201.AND.MELE.LE.300) THEN
  205. C LC19 LS03 LS07 LS09 LS27 LS21 LS15 LS19 BS03 BS07
  206. GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  207. C BS09 BS27 BS21 BS15 BS19 MC03 MC07 MC09 MC27 MC21
  208. 1 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  209. C MC15 MC19 M103 M107 M109 M127 M121 M115 M119 MS03
  210. 2 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  211. C MS07 MS09 MS27 MS21 MS15 MS19 QC03 QC07 QC09 QC27
  212. 3 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  213. C QC21 QC15 QC19 Q103 Q107 Q109 Q127 Q121 Q115 Q119
  214. 4 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  215. C QS03 QS07 QS09 QS27 QS21 QS15 QS19 CIFL SURE SHB8
  216. 5 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  217. C CAF2 CAF3 XQ4R XC8R JOI1 ZCO2 ZCO3 ZCO4 TUY2 TUY3
  218. 6 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  219. C COS2 COA2 ICY5 IC13 CU27 PR21 TE15 PY19 C20R P15R
  220. 7 , 99, 99, 4, 4, 4, 4, 4, 4, 4, 4)
  221. c cccccc
  222. . ,MELE-200
  223. ENDIF
  224. GOTO 99
  225. C_______________________________________________________________________
  226. C
  227. C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET INCOMPRESSIBLES
  228. C_______________________________________________________________________
  229. C
  230. 4 CONTINUE
  231. DIM3=1.D0
  232. *
  233. * CAS ORTHOTROPE ( 2) ANISOTROPE ( 3) UNIDIRICTIONNEL (4)
  234. *
  235. * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE DE
  236. * L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
  237. IPMIN2 = 0
  238. IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
  239. NLG=NUMGEO(MELE)
  240. CALL RESHPT(1,NBNN,NLG,MELE,0,IPMIN2,IRT1)
  241. MINTE2=IPMIN2
  242. SEGACT MINTE2
  243. SEGINI WRK8
  244. ENDIF
  245.  
  246. NBNO=NBNN
  247. NBBB=NBNN
  248. SEGINI WRK1,WRK2
  249.  
  250. if (melpha.gt.0) melva1 = melpha
  251.  
  252. * Initialisation en cas de matrice d'efficacite
  253. MWRK67 = 0
  254. celem = ' '
  255. IF (IVACAR.GT.0) THEN
  256. MPTVAL=IVACAR
  257. * SEGACT,MPTVAL
  258. IF (IVAL(NCAR1).GT.0 .OR. IVAL(NCAR1+1).GT.0) THEN
  259. nca1 = IVAL(/1)
  260. SEGINI,MWRK67
  261. celem = 'MASSIF '
  262. nstep = 2
  263. if (ifour.eq.2) nstep = 3
  264. drend = .false.
  265. irend = 0
  266. if (ival(ncar1).gt.0.and.tyval(ncar1).eq.'REAL*8') then
  267. drend = .true.
  268. irend = 1
  269. endif
  270. if (ival(ncar1).eq.0.and.tyval(ncar1+1).eq.'REAL*8') then
  271. drend = .false.
  272. irend = 2
  273. endif
  274. ENDIF
  275. ENDIF
  276.  
  277. DO 3004 IB=1,NBELEM
  278. C
  279. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  280. C
  281. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  282. C
  283. C CALCUL DES AXES LOCAUX DANS LE CAS DES MATERIAUX ORTHOTROPE ,
  284. C ANISOTROPE ET UNIDIRECTIONNEL
  285. C
  286. C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1)THEN
  287. IF (IPMIN2.NE.0) THEN
  288. NBSH=MINTE2.SHPTOT(/2)
  289. CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  290. if (nbsh.eq.-1) then
  291. call erreur(525)
  292. goto 9904
  293. endif
  294. ENDIF
  295. C
  296. CALL ZERO (RINT,LRE,LRE)
  297. C
  298. C= EF InCompressibles : CALCUL DES COEFF UTILES A LA MATRICE B-BARRE
  299. IF (MFR.EQ.31) THEN
  300. CALL BBCALC(MELE,NBNN,MFR,IDIM,XE,
  301. & NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  302. & NSTRS,LRE,IFOUR,NHRM,A,BB,SHPTOT,SHPWRK,
  303. & BGENE,XDPGE,YDPGE,PP,NOER)
  304. IF (NOER.NE.0) THEN
  305. CALL ERREUR(noer)
  306. RETURN
  307. ENDIF
  308. ENDIF
  309. C segact,wrk1*mod
  310. C
  311. C BOUCLE SUR LES POINTS DE GAUSS
  312. C
  313. ISDJC=0
  314. DO 4004 IGAU=1,NBPGAU
  315. C
  316. C RECUPERATION DE L'EPAISSEUR
  317. C
  318. IF (IFOUR.EQ.-2)THEN
  319. MPTVAL=IVACAR
  320. IF (IVACAR.NE.0) THEN
  321. MELVAL=IVAL(1)
  322. IF (MELVAL.NE.0) THEN
  323. IGMN=MIN(IGAU,VELCHE(/1))
  324. IBMN=MIN(IB,VELCHE(/2))
  325. DIM3=VELCHE(IGMN,IBMN)
  326. ELSE
  327. DIM3=1.D0
  328. ENDIF
  329. ENDIF
  330. ENDIF
  331.  
  332. *
  333. CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  334. 1 MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,XE,
  335. 2 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  336.  
  337. IF (DJAC.EQ.0.D0) THEN
  338. INTERR(1)=IB
  339. CALL ERREUR(259)
  340. GOTO 9904
  341. ENDIF
  342. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  343. DJAC=ABS(DJAC)*POIGAU(IGAU)
  344.  
  345. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  346. IF (MFR.EQ.31) THEN
  347. CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  348. & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  349. ENDIF
  350. C
  351. MPTVAL=IVAMAT
  352. IF(IMAT.EQ.2) THEN
  353. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN
  354. MELVAL=IVAL(1)
  355. IBMN=MIN(IB ,IELCHE(/2))
  356. IGMN=MIN(IGAU,IELCHE(/1))
  357. MLREEL=IELCHE(IGMN,IBMN)
  358. SEGACT,MLREEL
  359. CALL DOHOOO(PROG,LHOOK,DDHOOK)
  360. C SEGDES MLREEL
  361. ENDIF
  362. ELSE IF (IMAT.EQ.1) THEN
  363. DO 9004 IM=1,NMATT
  364. IF (IVAL(IM).NE.0) THEN
  365. MELVAL=IVAL(IM)
  366. IBMN=MIN(IB ,VELCHE(/2))
  367. IGMN=MIN(IGAU,VELCHE(/1))
  368. if (ibmn.gt.0.and.igmn.gt.0) then
  369. VALMAT(IM)=VELCHE(IGMN,IBMN)
  370. else
  371. VALMAT(IM)=0.D0
  372. endif
  373. ELSE
  374. VALMAT(IM)=0.D0
  375. ENDIF
  376. 9004 CONTINUE
  377. IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)THEN
  378. IF(IGAU.LE.NBGMAT)
  379. 1 CALL DOHMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
  380. 2 ROTH,DDHOOK,LHOOK,1,IRTD)
  381. ELSE
  382. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  383. 1 CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  384. ENDIF
  385. ENDIF
  386. C
  387. C CHOIX POUR BDB/DEFO PLANE GENE --- PRODUIT MATRICIEL NORMAL
  388. C /MASSIF ------------ PRODUIT PAR BLOC
  389. C
  390. * initialise
  391. CALL ZERO (REL,LRE,LRE)
  392. * calcul rigidite elementaire
  393. IF (BDPGE) THEN
  394. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  395. ELSE
  396. CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL,MFR,IFOUR,MATE,
  397. 1 IGAU,IMAT,0.D0)
  398. ENDIF
  399.  
  400. * matrice d'efficacite
  401. IF (MWRK67.GT.0) THEN
  402. MPTVAL=IVACAR
  403. DO 9008 IM= 1,IVAL(/1)
  404. IF (IVAL(IM).GT.0) THEN
  405. MELVAL=IVAL(IM)
  406. IF (TYVAL(IM).EQ.'REAL*8') THEN
  407. IBMN=MIN(IB ,VELCHE(/2))
  408. IGMN=MIN(IGAU,VELCHE(/1))
  409. VALCAR(IM)=VELCHE(IGMN,IBMN)
  410. ELSE
  411. IBMN=MIN(IB ,IELCHE(/2))
  412. IGMN=MIN(IGAU,IELCHE(/1))
  413. VALCAR(IM)=IELCHE(IGMN,IBMN)
  414. ENDIF
  415. ELSE
  416. VALCAR(IM)=0.D0
  417. ENDIF
  418. 9008 CONTINUE
  419. do i = 1,nstep
  420. do j = 1, nstep
  421. xatef1(i,j) = 0.d0
  422. enddo
  423. enddo
  424. if (irend.eq.1) then
  425. xatef1(1,1) = valcar(ncar1)
  426. xatef1(2,2) = valcar(ncar1)
  427. if (nstep.eq.3) xatef1(3,3) = valcar(ncar1)
  428. else if (irend.eq.2) then
  429. xatef1(1,1) = valcar(ncar1+7)
  430. xatef1(2,2) = valcar(ncar1+8)
  431. if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9)
  432. endif
  433. call effi2(valcar,tyval,nca1,ncar1,rel,lre,ib,igau,xatef1,
  434. & nstep,drend,celem)
  435. ENDIF
  436.  
  437. * ponderation par la phase
  438. IF (MELPHA.GT.0) THEN
  439. IBMN=MIN(IB ,melva1.VELCHE(/2))
  440. IGMN=MIN(IGAU,melva1.VELCHE(/1))
  441. coe1 = melva1.velche(igmn,ibmn)
  442. ELSE
  443. coe1 = 1.D0
  444. ENDIF
  445. * stocke
  446. do jj = 1,LRE
  447. do ii = 1,LRE
  448. rint(ii,jj) = rint(ii,jj) + rel(ii,jj)*coe1
  449. enddo
  450. enddo
  451. *
  452. 4004 CONTINUE
  453. *
  454. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  455. INTERR(1)=IB
  456. if (noer.eq.0) CALL ERREUR(195)
  457. noer=195
  458. GOTO 9904
  459. ENDIF
  460. C
  461. C REMPLISSAGE DE XMATRI
  462. C
  463. c CALL REMPMT(RINT,LRE,RE)
  464. DO IBK=1,LRE
  465. DO IAK=1,LRE
  466. RE(IAK,IBK,IB)=RINT(IAK,IBK)
  467. ENDDO
  468. ENDDO
  469. * do i = 1,8
  470. * write(6,*) re(13,3*i-2),re(13,3*i-1),re(13,3*i)
  471. * enddo
  472. *
  473. 3004 CONTINUE
  474. c
  475. IF(IRTD.EQ.0) THEN
  476. MOTERR(1:8)=CMATE
  477. MOTERR(9:16)=NOMFR(MFR/2+1)
  478. INTERR(1)=IFOUR
  479. CALL ERREUR(81)
  480. ENDIF
  481. 9904 CONTINUE
  482. C* IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND.IMAT.EQ.1) THEN
  483. IF (IPMIN2.NE.0) THEN
  484. SEGDES MINTE2
  485. SEGSUP WRK8
  486. ENDIF
  487. SEGSUP WRK1,WRK2
  488. IF (MWRK67.NE.0) SEGSUP,MWRK67
  489. GOTO 510
  490. C_______________________________________________________________________
  491. C
  492. C SECTEUR DE CALCUL POUR LES ELEMENTS LIQUIDES
  493. C_______________________________________________________________________
  494. C
  495. 35 CONTINUE
  496. NBNO=NBNN
  497. NBBB=NBNN
  498. NSTRS=NDDL
  499. SEGINI WRK1,WRK2
  500. c
  501. DO 3035 IB=1,NBELEM
  502. C
  503. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  504. C
  505. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  506. CALL ZERO (REL,LRE,LRE)
  507. C
  508. C BOUCLE SUR LES POINTS DE GAUSS
  509. C
  510. ISDJC=0
  511. DO 4035 IGAU=1,NBPGAU
  512.  
  513. MPTVAL=IVAMAT
  514. DO IM=1,5
  515. IF (IVAL(IM).NE.0) THEN
  516. MELVAL=IVAL(IM)
  517. IGMN=MIN(IGAU,VELCHE(/1))
  518. IBMN=MIN(IB,VELCHE(/2))
  519. VALMAT(IM)=VELCHE(IGMN,IBMN)
  520. ELSE
  521. VALMAT(IM)=0.D0
  522. ENDIF
  523. ENDDO
  524. C
  525. C CALCUL DES COEFFICIENTS DE NORMALISATION
  526. C
  527. RHO =VALMAT(1)
  528. C =VALMAT(2)
  529. RHOREF=VALMAT(3)
  530. CREF =VALMAT(4)
  531. RLCAR =VALMAT(5)
  532. C
  533. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  534. VKL =(COEFPR*COEFPR)/(RHO*C*C)
  535.  
  536. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE,
  537. 1 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  538. IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  539.  
  540. DJAC=ABS(DJAC)*POIGAU(IGAU)
  541. CALL NKLNST(BGENE,DJAC,VKL,LRE,NSTRS,REL)
  542. 4035 CONTINUE
  543. *
  544. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  545. INTERR(1)=IB
  546. CALL ERREUR(195)
  547. noer=195
  548. GOTO 9935
  549. ENDIF
  550. C
  551. C REMPLISSAGE DE XMATRI
  552. C
  553. CALL REMPMT(REL,LRE,RE(1,1,IB))
  554. 3035 CONTINUE
  555. *
  556. 9935 CONTINUE
  557. SEGSUP WRK1,WRK2
  558. GOTO 510
  559. C_______________________________________________________________________
  560. C
  561. C SECTEUR DE CALCUL POUR LES ELEMENTS DE SURFACE LIBRE
  562. C_______________________________________________________________________
  563. C
  564. 48 CONTINUE
  565. NBNO=NBNN
  566. NBBB=NBNN
  567. NSTRS=NDDL
  568. SEGINI WRK1,WRK2
  569. c
  570. DO 3048 IB=1,NBELEM
  571. C
  572. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  573. C
  574. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  575. CALL ZERO (REL,LRE,LRE)
  576. C
  577. MPTVAL=IVAMAT
  578. DO 9048 IM=1,6
  579. IF (IVAL(IM).NE.0) THEN
  580. MELVAL=IVAL(IM)
  581. IBMN=MIN(IB ,VELCHE(/2))
  582. VALMAT(IM)=VELCHE(1,IBMN)
  583. ELSE
  584. VALMAT(IM)=0.D0
  585. ENDIF
  586. 9048 CONTINUE
  587. C
  588. RHO =VALMAT(1)
  589. G =VALMAT(6)
  590. VKS =RHO*G
  591. C
  592. C BOUCLE SUR LES POINTS DE GAUSS
  593. C
  594. ISDJC=0
  595. DO 4048 IGAU=1,NBPGAU
  596. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE,
  597. 1 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  598. IF(DJAC.LT.0.0) ISDJC=ISDJC+1
  599.  
  600. DJAC=ABS(DJAC)*POIGAU(IGAU)
  601. CALL NKSNST(BGENE,DJAC,VKS,LRE,NSTRS,REL)
  602. 4048 CONTINUE
  603. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  604. INTERR(1)=IB
  605. CALL ERREUR(195)
  606. noer=195
  607. GOTO 9948
  608. ENDIF
  609. C
  610. C REMPLISSAGE DE XMATRI
  611. C
  612. CALL REMPMT(REL,LRE,RE(1,1,ib))
  613. 3048 CONTINUE
  614. C
  615. 9948 CONTINUE
  616. SEGSUP WRK1,WRK2
  617. GOTO 510
  618. C_______________________________________________________________________
  619. C
  620. C MILIEUX POREUX
  621. C_______________________________________________________________________
  622. C
  623. 79 CONTINUE
  624. C
  625. C* Cas non pevus actuellement
  626. IF (IMAT.EQ.1) THEN
  627. IF (MATE.LT.1.OR.MATE.GT.4) GOTO 99
  628. ELSE
  629. GOTO 99
  630. ENDIF
  631. C
  632. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  633. C NBNO = NOMBRE DE FONCTIONS DE FORME
  634. C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  635. C
  636. DIM3=1.D0
  637. NCOT=0
  638. NBNO=IPORE
  639. NBBB=NBNN
  640. NSTN=1
  641. **************** AM 08/01/01
  642. ***** NSTMU=2
  643. ***** IF(IFOUR.GE.0) NSTMU=3
  644. NSTMU=3
  645. LRN = NBNO-NBBB
  646. LRB=LRE-NBNN
  647.  
  648. IELE=NUMGEO(MELE)
  649. IF(IELE.EQ.6 ) NCOT=3
  650. IF(IELE.EQ.10) NCOT=4
  651. IF(IELE.EQ.15) NCOT=12
  652. IF(IELE.EQ.17) NCOT=9
  653. IF(IELE.EQ.24) NCOT=6
  654. IF(NCOT.EQ.0) THEN
  655. CALL ERREUR(5)
  656. GOTO 510
  657. ENDIF
  658. *
  659. * CAS NON ISOTROPES
  660. * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES
  661. * AU CENTRE DE L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
  662. *
  663. IPMIN2 = 0
  664. IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1 ) THEN
  665. CALL RESHPT(1,NBNO,IELE,MELE,0,IPMIN2,IRT1)
  666. MINTE2=IPMIN2
  667. SEGACT MINTE2
  668. SEGINI WRK8
  669. NSTMU=LHOOK
  670. ENDIF
  671. *
  672. SEGINI WRK1,WRK2,WRK5,WRK55
  673. *
  674. DO 3079 IB=1,NBELEM
  675. *
  676. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  677. *
  678. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  679. *
  680. * CALCUL DES AXES LOCAUX DANS LES CAS NON ISOTROPES
  681. *
  682. C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)
  683. C* . .AND.IMAT.EQ.1)THEN
  684. IF (IPMIN2.NE.0) THEN
  685. NBSH=MINTE2.SHPTOT(/2)
  686. CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  687. if (nbsh.eq.-1) then
  688. call erreur(525)
  689. goto 9979
  690. endif
  691. ENDIF
  692. *
  693. CALL ZERO (REL,LRE,LRE)
  694. *
  695. * TRAITEMENT POUR NOEUDS MILIEUX PRESSION
  696. *
  697. FREF = 1.D6
  698. CALL BNPOR2(YGENE,NCOT,IELE)
  699. IF(IERR.NE.0) GOTO 9979
  700. *
  701. * DO 27895 IOI=1,NCOT
  702. * WRITE(6,28927) IOI
  703. *28927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3)
  704. * WRITE(6,28928) (YGENE(IOI,J),J=1,NBNN)
  705. *28928 FORMAT(8(1X,1PE10.3))
  706. *27895 CONTINUE
  707. C
  708. C BOUCLE SUR LES POINTS DE GAUSS
  709. C
  710. ISDJC=0
  711. DO 4079 IGAU=1,NBPGAU
  712. C
  713. C RECUPERATION DE L'EPAISSEUR
  714. C
  715. IF (IFOUR.EQ.-2)THEN
  716. MPTVAL=IVACAR
  717. IF (IVACAR.NE.0) THEN
  718. MELVAL=IVAL(1)
  719. IF (MELVAL.NE.0) THEN
  720. IGMN=MIN(IGAU,VELCHE(/1))
  721. IBMN=MIN(IB,VELCHE(/2))
  722. DIM3=VELCHE(IGMN,IBMN)
  723. ELSE
  724. DIM3=1.D0
  725. ENDIF
  726. ENDIF
  727. ENDIF
  728. C
  729.  
  730. c write(6,*) 'rigi2 WRK1,lhook,nstrs=',WRK1,lhook,nstrs
  731. CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
  732. . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
  733. IF (DJAC.EQ.0.D0) THEN
  734. INTERR(1)=IB
  735. CALL ERREUR(259)
  736. GOTO 9979
  737. ENDIF
  738. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  739. DJAC=ABS(DJAC)*POIGAU(IGAU)
  740. C
  741. * IF(IGAU.EQ.1) THEN
  742. * DO 27892 IOI=1,LHOOK
  743. * WRITE(6,28920) IOI
  744. *28920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3)
  745. * WRITE(6,28921) (BGENE(IOI,J),J=1,LRE)
  746. *28921 FORMAT(8(1X,1PE10.3))
  747. *27892 CONTINUE
  748. * DO 27893 IOI=1,NSTN
  749. * WRITE(6,28922) IOI
  750. *28922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3)
  751. * WRITE(6,28923) (XGENE(IOI,J),J=1,LRN)
  752. *28923 FORMAT(8(1X,1PE10.3))
  753. *27893 CONTINUE
  754. * ENDIF
  755.  
  756. MPTVAL=IVAMAT
  757. C*D IF(IMAT.EQ.2) THEN
  758. C*D GO TO 99
  759. C*D ELSE IF (IMAT.EQ.1) THEN
  760. *
  761. DO 9079 IM=1,NMATT
  762. IF (IVAL(IM).NE.0) THEN
  763. MELVAL=IVAL(IM)
  764. IBMN=MIN(IB ,VELCHE(/2))
  765. IGMN=MIN(IGAU,VELCHE(/1))
  766. VALMAT(IM)=VELCHE(IGMN,IBMN)
  767. ELSE
  768. VALMAT(IM)=0.D0
  769. ENDIF
  770. 9079 CONTINUE
  771. *
  772. IF(MATE.EQ.1) THEN
  773. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  774. . CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  775. DO 4879 I=1,NSTMU
  776. COBMA(I) =VALMAT(3)
  777. 4879 CONTINUE
  778. XMOB =VALMAT(4)
  779. *
  780. ELSE IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  781. IF(IGAU.LE.NBGMAT)
  782. . CALL PORMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
  783. . ROTH,DDHOOK,LHOOK,COBMA,XMOB,1,IRTD)
  784. C*D ELSE
  785. C*D GO TO 99
  786. ENDIF
  787. *
  788. C*D ENDIF
  789. *
  790. CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE,
  791. . IGAU,IMAT,0.D0)
  792. EREF =1.D0
  793. DJACER=DJAC*EREF
  794. DO I=1,LRB
  795. DO J=1,LRN
  796. JJ=J+LRB
  797. r_z = 0.D0
  798. DO K=1,NSTMU
  799. r_z = r_z + COBMA(K)*BGENE(K,I)
  800. ENDDO
  801. r_z = r_z * DJACER * XGENE(1,J)
  802. REL(JJ,I)=REL(JJ,I) - r_z
  803. ENDDO
  804. ENDDO
  805. *
  806. IF(XMOB.EQ.0.D0) THEN
  807. UNSURM=0.D0
  808. ELSE
  809. UNSURM=1.D0 / XMOB
  810. ENDIF
  811. COMJAC=UNSURM*DJAC*EREF*EREF
  812. DO I=1,LRN
  813. II=I+LRB
  814. r_z = COMJAC*XGENE(1,I)
  815. DO J=1,I
  816. JJ=J+LRB
  817. REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J)
  818. ENDDO
  819. ENDDO
  820. C
  821. COMJAC=UNSURM*DJAC*FREF
  822. DO I=1,NBNN
  823. II=I+LRB
  824. DO J=1,I
  825. JJ=J+LRB
  826. r_z = 0.D0
  827. DO K=1,NCOT
  828. r_z = r_z + YGENE(K,I)*YGENE(K,J)
  829. ENDDO
  830. REL(II,JJ)=REL(II,JJ) + (COMJAC*r_z)
  831. ENDDO
  832. ENDDO
  833. *
  834. 4079 CONTINUE
  835. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  836. INTERR(1)=IB
  837. CALL ERREUR(195)
  838. noer=195
  839. GOTO 9979
  840. ENDIF
  841. C
  842. C REMPLISSAGE DE XMATRI
  843. C
  844. CALL REMPMT(REL,LRE,RE(1,1,ib))
  845. *
  846. 3079 CONTINUE
  847. c
  848. IF(IRTD.EQ.0) THEN
  849. MOTERR(1:8)=CMATE
  850. MOTERR(9:16)=NOMFR(MFR/2+1)
  851. INTERR(1)=IFOUR
  852. CALL ERREUR(81)
  853. ENDIF
  854. 9979 CONTINUE
  855. SEGSUP WRK1,WRK2,WRK5,WRK55
  856. C* IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1) THEN
  857. IF (IPMIN2.NE.0) THEN
  858. SEGDES MINTE2
  859. SEGSUP WRK8
  860. ENDIF
  861. GOTO 510
  862. C_______________________________________________________________________
  863. C
  864. C MILIEUX POREUX - SUITE
  865. C_______________________________________________________________________
  866. C
  867. 173 CONTINUE
  868. C
  869. C CAS NON ISOTROPES NON PREVUS ACTUELLEMENT
  870. IF (IMAT.EQ.1) THEN
  871. IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  872. CALL ERREUR(251)
  873. GO TO 510
  874. ENDIF
  875. ELSE
  876. C* ELSE IF (IMAT.EQ.2) THEN
  877. GO TO 99
  878. ENDIF
  879. C
  880. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  881. C NBNO = NOMBRE DE FONCTIONS DE FORME
  882. C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  883. C
  884. IF(MFR.EQ.57) IDECAP=2
  885. IF(MFR.EQ.59) IDECAP=3
  886. *
  887. DIM3=1.D0
  888. NCOT=0
  889. NBNO=IPORE
  890. NBBB=NBNN
  891. NSTN=IDECAP
  892. *
  893. **************** AM 08/01/01
  894. ***** NSTMU=2
  895. ***** IF(IFOUR.GE.0) NSTMU=3
  896. *
  897. NSTMU=3
  898. LPP=NBNO-NBBB
  899. LRN = IDECAP*LPP
  900. **** LRB=LRE-LRN
  901. LRB=LRE-(IDECAP*NBBB)
  902. IELE=NUMGEO(MELE)
  903. *
  904. IF(IELE.EQ.6 ) NCOT=3
  905. IF(IELE.EQ.10) NCOT=4
  906. IF(IELE.EQ.15) NCOT=12
  907. IF(IELE.EQ.17) NCOT=9
  908. IF(IELE.EQ.24) NCOT=6
  909. IF(NCOT.EQ.0) THEN
  910. CALL ERREUR(5)
  911. GO TO 510
  912. ENDIF
  913. *
  914. SEGINI WRK1,WRK2,WRK5,WRK55,WRK555
  915.  
  916. DO 3173 IB=1,NBELEM
  917. *
  918. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  919. *
  920. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  921. *
  922. CALL ZERO (REL,LRE,LRE)
  923. *
  924. * TRAITEMENT POUR NOEUDS MILIEUX PRESSION
  925. *
  926. FREF = 1.D6
  927. CALL BNPOR2(YGENE,NCOT,IELE)
  928. IF(IERR.NE.0) GO TO 9973
  929.  
  930. * DO 17895 IOI=1,NCOT
  931. * WRITE(6,78927) IOI
  932. *78927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3)
  933. * WRITE(6,78928) (YGENE(IOI,J),J=1,NBNN)
  934. *78928 FORMAT(8(1X,1PE10.3))
  935. *17895 CONTINUE
  936. C
  937. C BOUCLE SUR LES POINTS DE GAUSS
  938. C
  939. ISDJC=0
  940. DO 4173 IGAU=1,NBPGAU
  941. C
  942. C RECUPERATION DE L'EPAISSEUR
  943. C
  944. IF (IFOUR.EQ.-2)THEN
  945. MPTVAL=IVACAR
  946. IF (IVACAR.NE.0) THEN
  947. MELVAL=IVAL(1)
  948. IF (MELVAL.NE.0) THEN
  949. IGMN=MIN(IGAU,VELCHE(/1))
  950. IBMN=MIN(IB,VELCHE(/2))
  951. DIM3=VELCHE(IGMN,IBMN)
  952. ELSE
  953. DIM3=1.D0
  954. ENDIF
  955. ENDIF
  956. ENDIF
  957. C
  958. NSTB=LHOOK
  959. CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  960. . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1)
  961. IF(DJAC.EQ.0.D0) THEN
  962. INTERR(1)=IB
  963. CALL ERREUR(259)
  964. GOTO 9973
  965. ENDIF
  966. IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  967. DJAC=ABS(DJAC)*POIGAU(IGAU)
  968. C
  969. * IF(IGAU.EQ.1) THEN
  970. * DO 17892 IOI=1,LHOOK
  971. * WRITE(6,78920) IOI
  972. *78920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3)
  973. * WRITE(6,78921) (BGENE(IOI,J),J=1,LRE)
  974. *78921 FORMAT(8(1X,1PE10.3))
  975. *17892 CONTINUE
  976. * DO 17893 IOI=1,NSTN
  977. * WRITE(6,78922) IOI
  978. *78922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3)
  979. * WRITE(6,78923) (XGENE(IOI,J),J=1,LRN)
  980. *78923 FORMAT(8(1X,1PE10.3))
  981. *17893 CONTINUE
  982. * ENDIF
  983.  
  984. MPTVAL=IVAMAT
  985. C*D IF(IMAT.EQ.2) THEN
  986. C*D GO TO 99
  987. C*D ELSE IF (IMAT.EQ.1) THEN
  988. *
  989. DO 9173 IM=1,NMATT
  990. IF (IVAL(IM).NE.0) THEN
  991. MELVAL=IVAL(IM)
  992. IBMN=MIN(IB ,VELCHE(/2))
  993. IGMN=MIN(IGAU,VELCHE(/1))
  994. VALMAT(IM)=VELCHE(IGMN,IBMN)
  995. ELSE
  996. VALMAT(IM)=0.D0
  997. ENDIF
  998. 9173 CONTINUE
  999. *
  1000. C*D IF(MATE.EQ.1) THEN
  1001. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1002. . CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  1003. *
  1004. C*D ELSE
  1005. C*D GO TO 99
  1006. C*D ENDIF
  1007. C*D ENDIF
  1008. *
  1009. CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL)
  1010. EREF =1.D0
  1011. *
  1012. IF(MFR.EQ.57) THEN
  1013. COBB(1) = VALMAT(3)
  1014. COBB(2) = VALMAT(4)
  1015. CPBB(1) = VALMAT(5)
  1016. CPBB(2) = VALMAT(6)
  1017. KKBB(1,1)= VALMAT(7)
  1018. KKBB(1,2)= VALMAT(8)
  1019. KKBB(2,1)= VALMAT(9)
  1020. KKBB(2,2)= VALMAT(10)
  1021. *
  1022. ELSE IF(MFR.EQ.59) THEN
  1023. COBB(1) = VALMAT(3)
  1024. COBB(2) = VALMAT(4)
  1025. COBB(3) = VALMAT(5)
  1026. CPBB(1) = VALMAT(6)
  1027. CPBB(2) = VALMAT(7)
  1028. CPBB(3) = VALMAT(8)
  1029. KKBB(1,1)= VALMAT(9)
  1030. KKBB(1,2)= VALMAT(10)
  1031. KKBB(1,3)= VALMAT(11)
  1032. KKBB(2,1)= VALMAT(12)
  1033. KKBB(2,2)= VALMAT(13)
  1034. KKBB(2,3)= VALMAT(14)
  1035. KKBB(3,1)= VALMAT(15)
  1036. KKBB(3,2)= VALMAT(16)
  1037. KKBB(3,3)= VALMAT(17)
  1038. ENDIF
  1039. *
  1040. DJACER=DJAC*EREF
  1041.  
  1042. DO IPR=1,IDECAP
  1043. LRBDEC=LRB + (IPR-1)*NBBB
  1044. LPPDEC= (IPR-1)*LPP
  1045. COMJAC=COBB(IPR)*DJACER
  1046. DO I=1,LRB
  1047. r_z = 0.D0
  1048. DO K=1,NSTMU
  1049. r_z = r_z + BGENE(K,I)
  1050. ENDDO
  1051. r_z = r_z * COMJAC
  1052. DO J=1,LPP
  1053. JJ=J+LRBDEC
  1054. JX=J+LPPDEC
  1055. REL(I,JJ)=REL(I,JJ)-r_z*XGENE(IPR,JX)
  1056. ENDDO
  1057. ENDDO
  1058. ENDDO
  1059. *
  1060. DO IPR=1,IDECAP
  1061. LRBDEC=LRB + (IPR-1)*NBBB
  1062. LPPDEC= (IPR-1)*LPP
  1063. COMJAC=CPBB(IPR)*DJACER
  1064. DO I=1,LRB
  1065. r_z = 0.D0
  1066. DO K=1,NSTMU
  1067. r_z = r_z + BGENE(K,I)
  1068. ENDDO
  1069. r_z = COMJAC*r_z
  1070. DO J=1,LPP
  1071. JJ=J+LRBDEC
  1072. JX=J+LPPDEC
  1073. * ici - pour bsig
  1074. REL(JJ,I)=REL(JJ,I)-r_z*XGENE(IPR,JX)
  1075. ENDDO
  1076. ENDDO
  1077. ENDDO
  1078. *
  1079. COMJAC=DJAC*EREF*EREF
  1080. CALL ZERO(XREL,LRN,LRN)
  1081. CALL BDBSTS(XGENE,COMJAC,KKBB,LRN,NSTN,XREL)
  1082.  
  1083. DO IPR=1,IDECAP
  1084. IRBDEC=LRB + (IPR-1)*NBBB
  1085. IPPDEC= (IPR-1)*LPP
  1086. DO JPR=1,IDECAP
  1087. JRBDEC=LRB + (JPR-1)*NBBB
  1088. JPPDEC= (JPR-1)*LPP
  1089. DO I=1,LPP
  1090. II=I+IRBDEC
  1091. IX=I+IPPDEC
  1092. DO J=1,LPP
  1093. JJ=J+JRBDEC
  1094. JX=J+JPPDEC
  1095.  
  1096. * IF(IGAU.EQ.1) THEN
  1097. * PRINT *,'I =',I,' IX=',IX,' II=',II
  1098. * PRINT *,'J =',J,' JX=',JX,' JJ=',JJ, ' XREL=',XREL(IX,JX)
  1099. * ENDIF
  1100.  
  1101. REL(II,JJ)=REL(II,JJ)-XREL(IX,JX)
  1102. ENDDO
  1103. ENDDO
  1104. ENDDO
  1105. ENDDO
  1106. C
  1107. DO IPR=1,IDECAP
  1108. COMJAC=KKBB(IPR,IPR)*DJAC*FREF
  1109. LRBDEC=LRB + (IPR-1)*NBBB
  1110. DO I=1,NBNN
  1111. II=I+LRBDEC
  1112. DO J=1,NBNN
  1113. JJ=J+LRBDEC
  1114. r_z = 0.D0
  1115. DO K=1,NCOT
  1116. r_z = r_z + YGENE(K,I)*YGENE(K,J)
  1117. ENDDO
  1118. REL(II,JJ)=REL(II,JJ) + (COMJAC * r_z)
  1119. ENDDO
  1120. ENDDO
  1121. ENDDO
  1122. *
  1123. 4173 CONTINUE
  1124. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1125. INTERR(1)=IB
  1126. CALL ERREUR(195)
  1127. noer=195
  1128. GOTO 9973
  1129. ENDIF
  1130. C
  1131. C REMPLISSAGE DE XMATRI
  1132. C
  1133. CALL REMPMS(REL,LRE,RE(1,1,ib))
  1134. 3173 CONTINUE
  1135. c
  1136. IF(IRTD.EQ.0) THEN
  1137. MOTERR(1:8)=CMATE
  1138. MOTERR(9:16)=NOMFR(MFR/2+1)
  1139. INTERR(1)=IFOUR
  1140. CALL ERREUR(81)
  1141. ENDIF
  1142. 9973 CONTINUE
  1143. SEGSUP WRK1,WRK2,WRK5,WRK55,WRK555
  1144. GOTO 510
  1145. C_______________________________________________________________________
  1146. C
  1147. C JOINTS EN FORMULATION MILIEUX POREUX
  1148. C_______________________________________________________________________
  1149. C
  1150. 80 CONTINUE
  1151. C
  1152. * CAS NON PREVUS
  1153. IF (IMAT.EQ.1) THEN
  1154. IF (MATE.NE.1) GOTO 99
  1155. ELSE IF (IMAT.EQ.2) THEN
  1156. GOTO 99
  1157. ENDIF
  1158. C
  1159. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  1160. C NBNO = NOMBRE DE FONCTIONS DE FORME
  1161. C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  1162. C
  1163. NCOT=0
  1164. NBNO=IPORE
  1165. NBBB=NBNN
  1166. NSTN=1
  1167. NSTMU=2
  1168. IF(IFOUR.EQ.2) NSTMU=3
  1169. LRN=(NBNO-NBBB)*3/2
  1170. LPP=LRN
  1171. LRB=LRE-NBNN
  1172. IELE=NUMGEO(MELE)
  1173. IF(IELE.EQ.29) NCOT=2
  1174. IF(IELE.EQ.30) NCOT=6
  1175. IF(IELE.EQ.31) NCOT=8
  1176. IF(NCOT.EQ.0) THEN
  1177. CALL ERREUR(5)
  1178. GO TO 510
  1179. ENDIF
  1180. *
  1181. SEGINI WRK1,WRK2,WRK3,WRK5,WRK55
  1182. *
  1183. DO 3080 IB=1,NBELEM
  1184. *
  1185. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1186. *
  1187. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1188. *
  1189. * CALCUL DES AXES LOCAUX ET DES COORDONNES LOCALES
  1190. *
  1191. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1192. *
  1193. CALL ZERO (REL,LRE,LRE)
  1194. *
  1195. CALL INTDEL(XNTH,XNTB,XNTT,LRN,MELE)
  1196. *
  1197. * TRAITEMENT POUR NOEUDS MILIEUX PRESSION
  1198. *
  1199. FREF = 1.D6
  1200. CALL BNPOR2(YGENE,NCOT,IELE)
  1201. IF (IERR.NE.0) GOTO 9980
  1202. *
  1203. * BOUCLE SUR LES POINTS DE GAUSS
  1204. *
  1205. ISDJC=0
  1206. DO 4080 IGAU=1,NBPGAU
  1207. *
  1208. CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  1209. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
  1210. IF (DJAC.EQ.0.D0) THEN
  1211. INTERR(1)=IB
  1212. CALL ERREUR(259)
  1213. GOTO 9980
  1214. ENDIF
  1215. IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  1216. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1217. *
  1218. MPTVAL=IVAMAT
  1219. C*D IF(IMAT.EQ.2) THEN
  1220. C*D GO TO 99
  1221. C*D ELSE IF (IMAT.EQ.1) THEN
  1222. *
  1223. DO 9080 IM=1,NMATT
  1224. IF (IVAL(IM).NE.0) THEN
  1225. MELVAL=IVAL(IM)
  1226. IBMN=MIN(IB ,VELCHE(/2))
  1227. IGMN=MIN(IGAU,VELCHE(/1))
  1228. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1229. ELSE
  1230. VALMAT(IM)=0.D0
  1231. ENDIF
  1232. 9080 CONTINUE
  1233. *
  1234. C*D IF(MATE.EQ.1) THEN
  1235. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1236. . CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1237.  
  1238. C*D ELSE
  1239. C*D GO TO 99
  1240. C*D ENDIF
  1241. C*D ENDIF
  1242. *
  1243. CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE,
  1244. . IGAU,IMAT,0.D0)
  1245. EREF =1.D0
  1246. *
  1247. COBMA(NSTMU)=VALMAT(3)
  1248. XMOB=VALMAT(4)
  1249. *
  1250. IF(XMOB.EQ.0.D0) THEN
  1251. UNSURM=0.D0
  1252. ELSE
  1253. UNSURM=1.D0 / XMOB
  1254. ENDIF
  1255. *
  1256. DJACER=DJAC*EREF*COBMA(NSTMU)
  1257. DO I=1,LRB
  1258. r_z = DJACER*BGENE(NSTMU,I)
  1259. DO J=1,LRN
  1260. JJ=J+LRB
  1261. REL(JJ,I)=REL(JJ,I)-r_z*XGENE(1,J)*XNTT(J)
  1262. ENDDO
  1263. ENDDO
  1264. *
  1265. COMJAC=UNSURM*DJAC*EREF*EREF
  1266. DO I=1,LRN
  1267. II=I+LRB
  1268. r_z = COMJAC*XGENE(1,I)*XNTT(I)
  1269. DO J=1,I
  1270. JJ=J+LRB
  1271. REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J)*XNTT(J)
  1272. ENDDO
  1273. ENDDO
  1274. *
  1275. COMJAC=UNSURM*DJAC*FREF
  1276. DO I=1,NBNN
  1277. II=I+LRB
  1278. DO J=1,I
  1279. JJ=J+LRB
  1280. r_z = 0.D0
  1281. DO K=1,NCOT
  1282. r_z = r_z + YGENE(K,I)*YGENE(K,J)
  1283. ENDDO
  1284. REL(II,JJ)=REL(II,JJ)+COMJAC*r_z
  1285. ENDDO
  1286. ENDDO
  1287. *
  1288. 4080 CONTINUE
  1289. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1290. INTERR(1)=IB
  1291. CALL ERREUR(195)
  1292. noer=195
  1293. GOTO 9980
  1294. ENDIF
  1295. *
  1296. * REMPLISSAGE DE XMATRI
  1297. *
  1298. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1299. 3080 CONTINUE
  1300.  
  1301. IF(IRTD.EQ.0) THEN
  1302. MOTERR(1:8)=CMATE
  1303. MOTERR(9:16)=NOMFR(MFR/2+1)
  1304. INTERR(1)=IFOUR
  1305. CALL ERREUR(81)
  1306. ENDIF
  1307. 9980 CONTINUE
  1308. SEGSUP WRK1,WRK2,WRK3,WRK5,WRK55
  1309. GOTO 510
  1310. *
  1311. C_______________________________________________________________________
  1312. C
  1313. C JOINTS EN FORMULATION MILIEUX POREUX - SUITE
  1314. C_______________________________________________________________________
  1315. C
  1316. 185 CONTINUE
  1317.  
  1318. C
  1319. * CAS NON ISOTROPES NON PREVUS ACTUELLEMENT
  1320. IF (IMAT.EQ.1) THEN
  1321. IF (MATE.NE.1) GOTO 99
  1322. ELSE
  1323. GOTO 99
  1324. ENDIF
  1325. C
  1326. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  1327. C NBNO = NOMBRE DE FONCTIONS DE FORME
  1328. C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  1329. C
  1330. IF(MFR.EQ.57) IDECAP=2
  1331. IF(MFR.EQ.59) IDECAP=3
  1332. *
  1333. NCOT=0
  1334. NBNO=IPORE
  1335. NBBB=NBNN
  1336. NSTN=IDECAP
  1337. NSTMU=2
  1338. IF(IFOUR.EQ.2) NSTMU=3
  1339. LPP=(NBNO-NBBB)*3/2
  1340. LRN=IDECAP*LPP
  1341. LRB=LRE-IDECAP*NBNN
  1342. IELE=NUMGEO(MELE)
  1343. IF(IELE.EQ.29) NCOT=2
  1344. IF(IELE.EQ.30) NCOT=6
  1345. IF(IELE.EQ.31) NCOT=8
  1346. IF(NCOT.EQ.0) THEN
  1347. CALL ERREUR(5)
  1348. GO TO 510
  1349. ENDIF
  1350. *
  1351. SEGINI WRK1,WRK2,WRK3,WRK5,WRK55,WRK555
  1352. *
  1353. DO 3185 IB=1,NBELEM
  1354. *
  1355. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1356. *
  1357. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1358. *
  1359. * CALCUL DES AXES LOCAUX ET DES COORDONNES LOCALES
  1360. *
  1361. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1362. *
  1363. CALL ZERO (REL,LRE,LRE)
  1364. *
  1365. CALL INTDEL(XNTH,XNTB,XNTT,LPP,MELE)
  1366. *
  1367. * TRAITEMENT POUR NOEUDS MILIEUX PRESSION
  1368. *
  1369. FREF = 1.D6
  1370. CALL BNPOR2(YGENE,NCOT,IELE)
  1371. IF (IERR.NE.0) GOTO 9985
  1372. *
  1373. * BOUCLE SUR LES POINTS DE GAUSS
  1374. *
  1375. ISDJC=0
  1376. DO 4185 IGAU=1,NBPGAU
  1377. *
  1378. NSTB=LHOOK
  1379. CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  1380. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1)
  1381. IF (DJAC.EQ.0.D0) THEN
  1382. INTERR(1)=IB
  1383. CALL ERREUR(259)
  1384. GOTO 9985
  1385. ENDIF
  1386. IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  1387. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1388. *
  1389. MPTVAL=IVAMAT
  1390. C*D IF(IMAT.EQ.2) THEN
  1391. C*D GO TO 99
  1392. C*D ELSE IF (IMAT.EQ.1) THEN
  1393. *
  1394. DO 9185 IM=1,NMATT
  1395. IF (IVAL(IM).NE.0) THEN
  1396. MELVAL=IVAL(IM)
  1397. IBMN=MIN(IB ,VELCHE(/2))
  1398. IGMN=MIN(IGAU,VELCHE(/1))
  1399. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1400. ELSE
  1401. VALMAT(IM)=0.D0
  1402. ENDIF
  1403. 9185 CONTINUE
  1404. *
  1405. C*D IF(MATE.EQ.1) THEN
  1406. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1407. . CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1408.  
  1409. C*D ELSE
  1410. C*D GO TO 99
  1411. C*D ENDIF
  1412. C*D ENDIF
  1413. *
  1414. CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL)
  1415.  
  1416. EREF =1.D0
  1417. *
  1418. IF(MFR.EQ.57) THEN
  1419. COBB(1) = VALMAT(3)
  1420. COBB(2) = VALMAT(4)
  1421. CPBB(1) = VALMAT(5)
  1422. CPBB(2) = VALMAT(6)
  1423. KKBB(1,1)= VALMAT(7)
  1424. KKBB(1,2)= VALMAT(8)
  1425. KKBB(2,1)= VALMAT(9)
  1426. KKBB(2,2)= VALMAT(10)
  1427. *
  1428. ELSE IF(MFR.EQ.59) THEN
  1429. COBB(1) = VALMAT(3)
  1430. COBB(2) = VALMAT(4)
  1431. COBB(3) = VALMAT(5)
  1432. CPBB(1) = VALMAT(6)
  1433. CPBB(2) = VALMAT(7)
  1434. CPBB(3) = VALMAT(8)
  1435. KKBB(1,1)= VALMAT(9)
  1436. KKBB(1,2)= VALMAT(10)
  1437. KKBB(1,3)= VALMAT(11)
  1438. KKBB(2,1)= VALMAT(12)
  1439. KKBB(2,2)= VALMAT(13)
  1440. KKBB(2,3)= VALMAT(14)
  1441. KKBB(3,1)= VALMAT(15)
  1442. KKBB(3,2)= VALMAT(16)
  1443. KKBB(3,3)= VALMAT(17)
  1444. ENDIF
  1445. *
  1446. DO IPR=1,IDECAP
  1447. LPPDEC= (IPR-1)*LPP
  1448. DO J=1,LPP
  1449. JX=J+LPPDEC
  1450. XGENE(IPR,JX)= XGENE(IPR,JX)*XNTT(J)
  1451. ENDDO
  1452. ENDDO
  1453. *
  1454. DJACER=DJAC*EREF
  1455.  
  1456. DO IPR=1,IDECAP
  1457. LRBDEC=LRB + (IPR-1)*NBBB
  1458. LPPDEC= (IPR-1)*LPP
  1459. COMJAC=COBB(IPR)*DJACER
  1460. DO I=1,LRB
  1461. r_z = COMJAC*BGENE(NSTMU,I)
  1462. DO J=1,LPP
  1463. JJ=J+LRBDEC
  1464. JX=J+LPPDEC
  1465. REL(I,JJ)=REL(I,JJ)-r_z*XGENE(IPR,JX)
  1466. ENDDO
  1467. ENDDO
  1468. ENDDO
  1469. *
  1470.  
  1471. DO IPR=1,IDECAP
  1472. LRBDEC=LRB + (IPR-1)*NBBB
  1473. LPPDEC= (IPR-1)*LPP
  1474. COMJAC=CPBB(IPR)*DJACER
  1475. DO I=1,LRB
  1476. r_z = COMJAC*BGENE(NSTMU,I)
  1477. DO J=1,LPP
  1478. JJ=J+LRBDEC
  1479. JX=J+LPPDEC
  1480. REL(JJ,I)=REL(JJ,I)-r_z*XGENE(IPR,JX)
  1481. ENDDO
  1482. ENDDO
  1483. ENDDO
  1484. *
  1485. COMJAC=DJAC*EREF*EREF
  1486. CALL ZERO(XREL,LRN,LRN)
  1487. CALL BDBSTS(XGENE,COMJAC,KKBB,LRN,NSTN,XREL)
  1488.  
  1489. DO IPR=1,IDECAP
  1490. IRBDEC=LRB + (IPR-1)*NBBB
  1491. IPPDEC= (IPR-1)*LPP
  1492. DO JPR=1,IDECAP
  1493. JRBDEC=LRB + (JPR-1)*NBBB
  1494. JPPDEC= (JPR-1)*LPP
  1495. DO I=1,LPP
  1496. II=I+IRBDEC
  1497. IX=I+IPPDEC
  1498. DO J=1,LPP
  1499. JJ=J+JRBDEC
  1500. JX=J+JPPDEC
  1501.  
  1502. * IF(IGAU.EQ.1) THEN
  1503. * PRINT *,'I =',I,' IX=',IX,' II=',II
  1504. * PRINT *,'J =',J,' JX=',JX,' JJ=',JJ, ' XREL=',XREL(IX,JX)
  1505. * ENDIF
  1506.  
  1507. REL(II,JJ)=REL(II,JJ)-XREL(IX,JX)
  1508. ENDDO
  1509. ENDDO
  1510. ENDDO
  1511. ENDDO
  1512. *
  1513. DO IPR=1,IDECAP
  1514. COMJAC=KKBB(IPR,IPR)*DJAC*FREF
  1515. LRBDEC=LRB + (IPR-1)*NBBB
  1516. DO I=1,NBNN
  1517. II=I+LRBDEC
  1518. DO J=1,NBNN
  1519. JJ=J+LRBDEC
  1520. r_z = 0.D0
  1521. DO K=1,NCOT
  1522. r_z = r_z + YGENE(K,I)*YGENE(K,J)
  1523. ENDDO
  1524. REL(II,JJ)=REL(II,JJ)+COMJAC*r_z
  1525. ENDDO
  1526. ENDDO
  1527. ENDDO
  1528. *
  1529. 4185 CONTINUE
  1530. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1531. INTERR(1)=IB
  1532. CALL ERREUR(195)
  1533. noer=195
  1534. GOTO 9980
  1535. ENDIF
  1536. *
  1537. * REMPLISSAGE DE XMATRI
  1538. *
  1539. CALL REMPMS(REL,LRE,RE(1,1,IB))
  1540. 3185 CONTINUE
  1541.  
  1542. IF(IRTD.EQ.0) THEN
  1543. MOTERR(1:8)=CMATE
  1544. MOTERR(9:16)=NOMFR(MFR/2+1)
  1545. INTERR(1)=IFOUR
  1546. CALL ERREUR(81)
  1547. ENDIF
  1548. 9985 CONTINUE
  1549. SEGSUP WRK1,WRK2,WRK3,WRK5,WRK55,WRK555
  1550. GOTO 510
  1551. *
  1552. * ERREUR : CAS NON PREVU
  1553. *
  1554. 99 CONTINUE
  1555. MOTERR(1:4)=NOMTP(MELE)
  1556. MOTERR(5:12)='RIGI2 '
  1557. CALL ERREUR(86)
  1558. *
  1559. 510 CONTINUE
  1560. * WRITE (*,*) 'Sortie de RIGI2.'
  1561. * SEGDES,XMATRI
  1562. SEGSUP,MVELCH
  1563.  
  1564. c RETURN
  1565. END
  1566.  
  1567.  
  1568.  
  1569.  

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