Télécharger rigi2.eso

Retour à la liste

Numérotation des lignes :

  1. C RIGI2 SOURCE BP208322 17/03/01 21:18:09 9325
  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)
  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 CCOPTIO
  49. -INC CCHAMP
  50. -INC CCREEL
  51. -INC SMCHAML
  52. -INC SMINTE
  53. -INC SMELEME
  54. -INC SMRIGID
  55. -INC SMCOORD
  56. -INC SMLREEL
  57. *
  58. SEGMENT WRK1
  59. REAL*8 DDHOOK(LHOOK,LHOOK) ,DDHOMU(LHOOK,LHOOK)
  60. REAL*8 REL(LRE,LRE) ,RINT(LRE,LRE) , XE(3,NBBB)
  61. ENDSEGMENT
  62. *
  63. SEGMENT WRK2
  64. REAL*8 SHPWRK(6,NBNO) ,BGENE(LHOOK,LRE)
  65. ENDSEGMENT
  66. *
  67. SEGMENT WRK3
  68. REAL*8 BPSS(3,3),XEL(3,NBBB)
  69. REAL*8 XNTH(LPP,LPP),XNTB(LPP,LPP),XNTT(LPP)
  70. ENDSEGMENT
  71. *
  72. SEGMENT WRK5
  73. REAL*8 XGENE(NSTN,LRN)
  74. ENDSEGMENT
  75. *
  76. SEGMENT WRK55
  77. REAL*8 YGENE(NCOT,NBNN),COBMA(LHOOK)
  78. ENDSEGMENT
  79. *
  80. SEGMENT WRK555
  81. REAL*8 XREL(LRN,LRN),COBB(NSTN),CPBB(NSTN),KKBB(NSTN,NSTN)
  82. ENDSEGMENT
  83. *
  84. SEGMENT WRK8
  85. REAL*8 XLOC(3,3),XGLOB(3,3),TXR(IDIM,IDIM)
  86. REAL*8 D1HO(LHOOK,LHOOK),ROTH(LHOOK,LHOOK)
  87. ENDSEGMENT
  88. *
  89. * SEGMENT MWRKIC
  90. * REAL*8 A(4,60),BB(3,60)
  91. * ? REAL*8 A(4,3*NBNO),BB(3,3*NBNO)
  92. * ENDSEGMENT
  93. *
  94. SEGMENT,MVELCH
  95. REAL*8 VALMAT(NV1)
  96. ENDSEGMENT
  97. *
  98. segment mwrk67
  99. real*8 valcar(nca1), xatef1(3,3)
  100. endsegment
  101. *
  102. SEGMENT MPTVAL
  103. INTEGER IPOS(NS) ,NSOF(NS)
  104. INTEGER IVAL(NCOSOU)
  105. CHARACTER*16 TYVAL(NCOSOU)
  106. ENDSEGMENT
  107. *
  108. DIMENSION A(4,60),BB(3,60)
  109. CHARACTER*8 CMATE,celem
  110. logical drend,BDPGE
  111. *
  112. * WRITE (*,*) 'Entrée dans RIGI2.'
  113. * SEGACT MCOORD
  114. MELEME=IPMAIL
  115. NBNN=NUM(/1)
  116. NBELEM=NUM(/2)
  117. *
  118. NV1=NMATT
  119. SEGINI,MVELCH
  120. *
  121. XMATRI=IPMATR
  122. c* NLIGRD=LRE
  123. c* NLIGRP=LRE
  124.  
  125. C Introduction du point autour duquel se fait le mouvement
  126. C de la section en defo plane generalisee
  127. C IIPDPG = numero du noeud/point support si defini pour le modele
  128. C NDPGE > 0 si prise en compte du point support
  129. IF (IIPDPG.GT.0) THEN
  130. IF (IFOUR.EQ.-3) THEN
  131. BDPGE=.TRUE.
  132. IREF=(IIPDPG-1)*(IDIM+1)
  133. XDPGE=XCOOR(IREF+1)
  134. YDPGE=XCOOR(IREF+2)
  135. ELSE IF (IFOUR.EQ. 7 .OR. IFOUR.EQ. 8 .OR. IFOUR.EQ. 9 .OR.
  136. & IFOUR.EQ.10 .OR. IFOUR.EQ.11 .OR. IFOUR.EQ.14) THEN
  137. BDPGE=.TRUE.
  138. XDPGE=XZero
  139. YDPGE=XZero
  140. else
  141. write(ioimp,*) 'EPSI2 : ERREUR NDPGE'
  142. call erreur(5)
  143. return
  144. ENDIF
  145. ELSE
  146. BDPGE=.FALSE.
  147. XDPGE=XZero
  148. YDPGE=XZero
  149. ENDIF
  150. *
  151. NHRM=NIFOUR
  152. *
  153. MINTE=IPMINT
  154. IRTD=1
  155. IDECAP=0
  156. C_______________________________________________________________________
  157. C
  158. C NUMERO DES ETIQUETTES :
  159. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  160. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  161. C 5 CONTINUE
  162. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  163. C 44 CONTINUE
  164. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  165. C_______________________________________________________________________
  166. C
  167. GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  168. 1 99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,35,35,35,35,35,35,
  169. 2 99,99,99,99,99,99,99,48,99,99,99,99,48,48,99,99,99,99,99,99,
  170. 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4,99,99, 4,99,99,79,79,
  171. 4 79,79,79,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  172. 5 99,99,99,99,99,99,99,80,80,80, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
  173. 6 4, 4),MELE
  174. *
  175. IF(MELE.GE.173.AND.MELE.LE.182) GO TO 173
  176. IF(MELE.GE.185.AND.MELE.LE.190) GO TO 185
  177. IF (MELE.EQ.183.OR.MELE.EQ.184.OR.
  178. . MELE.EQ.193.OR.MELE.EQ.194) GOTO 4
  179.  
  180. GOTO 99
  181. C_______________________________________________________________________
  182. C
  183. C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET INCOMPRESSIBLES
  184. C_______________________________________________________________________
  185. C
  186. 4 CONTINUE
  187. DIM3=1.D0
  188. *
  189. * CAS ORTHOTROPE ( 2) ANISOTROPE ( 3) UNIDIRICTIONNEL (4)
  190. *
  191. * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES AU CENTRE DE
  192. * L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
  193. IPMIN2 = 0
  194. IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND. IMAT.EQ.1) THEN
  195. NLG=NUMGEO(MELE)
  196. CALL RESHPT(1,NBNN,NLG,MELE,0,IPMIN2,IRT1)
  197. MINTE2=IPMIN2
  198. SEGACT MINTE2
  199. SEGINI WRK8
  200. ENDIF
  201.  
  202. NBNO=NBNN
  203. NBBB=NBNN
  204. SEGINI WRK1,WRK2
  205.  
  206. * MWRKIC = 0
  207. * IF (MFR.EQ.31) SEGINI,MWRKIC
  208. * Initialisation en cas de matrice d'efficacite
  209. MWRK67 = 0
  210. celem = ' '
  211. IF (IVACAR.GT.0) THEN
  212. MPTVAL=IVACAR
  213. SEGACT,MPTVAL
  214. IF (IVAL(NCAR1).GT.0 .OR. IVAL(NCAR1+1).GT.0) THEN
  215. nca1 = IVAL(/1)
  216. SEGINI,MWRK67
  217. celem = 'MASSIF '
  218. nstep = 2
  219. if (ifour.eq.2) nstep = 3
  220. drend = .false.
  221. irend = 0
  222. if (ival(ncar1).gt.0.and.tyval(ncar1).eq.'REAL*8') then
  223. drend = .true.
  224. irend = 1
  225. endif
  226. if (ival(ncar1).eq.0.and.tyval(ncar1+1).eq.'REAL*8') then
  227. drend = .false.
  228. irend = 2
  229. endif
  230. ENDIF
  231. ENDIF
  232.  
  233. DO 3004 IB=1,NBELEM
  234. C
  235. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  236. C
  237. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  238. C
  239. C CALCUL DES AXES LOCAUX DANS LE CAS DES MATERIAUX ORTHOTROPE ,
  240. C ANISOTROPE ET UNIDIRECTIONNEL
  241. C
  242. C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1)THEN
  243. IF (IPMIN2.NE.0) THEN
  244. NBSH=MINTE2.SHPTOT(/2)
  245. CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  246. if (nbsh.eq.-1) then
  247. call erreur(525)
  248. goto 9904
  249. endif
  250. ENDIF
  251. C
  252. CALL ZERO (RINT,LRE,LRE)
  253. C
  254. C= EF InCompressibles : CALCUL DES COEFF UTILES A LA MATRICE B-BARRE
  255. IF (MFR.EQ.31) THEN
  256. CALL BBCALC(XE,MELE,NBNN,IDIM,NBPGAU,POIGAU,
  257. 1 QSIGAU,ETAGAU,DZEGAU,NSTRS,
  258. 2 LRE,IFOUR,A,BB,NHRM,SHPTOT,SHPWRK,XDPGE,YDPGE)
  259. ENDIF
  260. C
  261. C BOUCLE SUR LES POINTS DE GAUSS
  262. C
  263. ISDJC=0
  264. DO 4004 IGAU=1,NBPGAU
  265. C
  266. C RECUPERATION DE L'EPAISSEUR
  267. C
  268. IF (IFOUR.EQ.-2)THEN
  269. MPTVAL=IVACAR
  270. IF (IVACAR.NE.0) THEN
  271. MELVAL=IVAL(1)
  272. IF (MELVAL.NE.0) THEN
  273. IGMN=MIN(IGAU,VELCHE(/1))
  274. IBMN=MIN(IB,VELCHE(/2))
  275. DIM3=VELCHE(IGMN,IBMN)
  276. ELSE
  277. DIM3=1.D0
  278. ENDIF
  279. ENDIF
  280. ENDIF
  281. *
  282. CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  283. 1 MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,XE,
  284. 2 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  285.  
  286. IF (DJAC.EQ.0.D0) THEN
  287. INTERR(1)=IB
  288. CALL ERREUR(259)
  289. GOTO 9904
  290. ENDIF
  291. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  292. DJAC=ABS(DJAC)*POIGAU(IGAU)
  293.  
  294. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  295. IF (MFR.EQ.31) THEN
  296. CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  297. & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  298. ENDIF
  299. C
  300. MPTVAL=IVAMAT
  301. IF(IMAT.EQ.2) THEN
  302. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1)) THEN
  303. MELVAL=IVAL(1)
  304. IBMN=MIN(IB ,IELCHE(/2))
  305. IGMN=MIN(IGAU,IELCHE(/1))
  306. MLREEL=IELCHE(IGMN,IBMN)
  307. SEGACT MLREEL
  308. CALL DOHOOO(PROG,LHOOK,DDHOOK)
  309. SEGDES MLREEL
  310. ENDIF
  311. ELSE IF (IMAT.EQ.1) THEN
  312. DO 9004 IM=1,NMATT
  313. IF (IVAL(IM).NE.0) THEN
  314. MELVAL=IVAL(IM)
  315. IBMN=MIN(IB ,VELCHE(/2))
  316. IGMN=MIN(IGAU,VELCHE(/1))
  317. if (ibmn.gt.0.and.igmn.gt.0) then
  318. VALMAT(IM)=VELCHE(IGMN,IBMN)
  319. else
  320. VALMAT(IM)=0.D0
  321. endif
  322. ELSE
  323. VALMAT(IM)=0.D0
  324. ENDIF
  325. 9004 CONTINUE
  326. IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)THEN
  327. IF(IGAU.LE.NBGMAT)
  328. 1 CALL DOHMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
  329. 2 ROTH,DDHOOK,LHOOK,1,IRTD)
  330. ELSE
  331. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  332. 1 CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  333. ENDIF
  334. ENDIF
  335. C
  336. C CHOIX POUR BDB/DEFO PLANE GENE --- PRODUIT MATRICIEL NORMAL
  337. C /MASSIF ------------ PRODUIT PAR BLOC
  338. C
  339. * initialise
  340. CALL ZERO (REL,LRE,LRE)
  341. * calcul rigidite elementaire
  342. IF (BDPGE) THEN
  343. CALL BDBST(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL)
  344. ELSE
  345. CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,NSTRS,REL,MFR,IFOUR,MATE,
  346. 1 IGAU,IMAT,0.D0)
  347. ENDIF
  348.  
  349. * matrice d'efficacite
  350. IF (MWRK67.NE.0) THEN
  351. MPTVAL=IVACAR
  352. DO 9008 IM= 1,IVAL(/1)
  353. IF (IVAL(IM).GT.0) THEN
  354. MELVAL=IVAL(IM)
  355. IF (TYVAL(IM).EQ.'REAL*8') THEN
  356. IBMN=MIN(IB ,VELCHE(/2))
  357. IGMN=MIN(IGAU,VELCHE(/1))
  358. VALCAR(IM)=VELCHE(IGMN,IBMN)
  359. ELSE
  360. IBMN=MIN(IB ,IELCHE(/2))
  361. IGMN=MIN(IGAU,IELCHE(/1))
  362. VALCAR(IM)=IELCHE(IGMN,IBMN)
  363. ENDIF
  364. ELSE
  365. VALCAR(IM)=0.D0
  366. ENDIF
  367. 9008 CONTINUE
  368. do i = 1,nstep
  369. do j = 1, nstep
  370. xatef1(i,j) = 0.d0
  371. enddo
  372. enddo
  373. if (irend.eq.1) then
  374. xatef1(1,1) = valcar(ncar1)
  375. xatef1(2,2) = valcar(ncar1)
  376. if (nstep.eq.3) xatef1(3,3) = valcar(ncar1)
  377. else if (irend.eq.2) then
  378. xatef1(1,1) = valcar(ncar1+7)
  379. xatef1(2,2) = valcar(ncar1+8)
  380. if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9)
  381. endif
  382. call effi2(valcar,tyval,nca1,ncar1,rel,lre,ib,igau,xatef1,
  383. & nstep,drend,celem)
  384. ENDIF
  385. * stocke
  386. do jj = 1,LRE
  387. do ii = 1,LRE
  388. rint(ii,jj) = rint(ii,jj) + rel(ii,jj)
  389. enddo
  390. enddo
  391. *
  392. 4004 CONTINUE
  393. *
  394. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  395. INTERR(1)=IB
  396. CALL ERREUR(195)
  397. GOTO 9904
  398. ENDIF
  399. C
  400. C REMPLISSAGE DE XMATRI
  401. C
  402. c CALL REMPMT(RINT,LRE,RE)
  403. DO 4100 IBK=1,LRE
  404. DO 4100 IAK=1,LRE
  405. RE(IAK,IBK,IB)=RINT(IAK,IBK)
  406. 4100 CONTINUE
  407. * do i = 1,8
  408. * write(6,*) re(13,3*i-2),re(13,3*i-1),re(13,3*i)
  409. * enddo
  410. *
  411. 3004 CONTINUE
  412. c
  413. IF(IRTD.EQ.0) THEN
  414. MOTERR(1:8)=CMATE
  415. MOTERR(9:16)=NOMFR(MFR/2+1)
  416. INTERR(1)=IFOUR
  417. CALL ERREUR(81)
  418. ENDIF
  419. 9904 CONTINUE
  420. C* IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND.IMAT.EQ.1) THEN
  421. IF (IPMIN2.NE.0) THEN
  422. SEGDES MINTE2
  423. SEGSUP WRK8
  424. ENDIF
  425. SEGSUP WRK1,WRK2
  426. * IF (MWRKIC.NE.0) SEGSUP,MWRKIC
  427. IF (MWRK67.NE.0) SEGSUP,MWRK67
  428. GOTO 510
  429. C_______________________________________________________________________
  430. C
  431. C SECTEUR DE CALCUL POUR LES ELEMENTS LIQUIDES
  432. C_______________________________________________________________________
  433. C
  434. 35 CONTINUE
  435. NBNO=NBNN
  436. NBBB=NBNN
  437. NSTRS=NDDL
  438. SEGINI WRK1,WRK2
  439. c
  440. DO 3035 IB=1,NBELEM
  441. C
  442. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  443. C
  444. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  445. CALL ZERO (REL,LRE,LRE)
  446. C
  447. C BOUCLE SUR LES POINTS DE GAUSS
  448. C
  449. ISDJC=0
  450. DO 4035 IGAU=1,NBPGAU
  451.  
  452. MPTVAL=IVAMAT
  453. DO 9035 IM=1,5
  454. IF (IVAL(IM).NE.0) THEN
  455. MELVAL=IVAL(IM)
  456. IGMN=MIN(IGAU,VELCHE(/1))
  457. IBMN=MIN(IB,VELCHE(/2))
  458. VALMAT(IM)=VELCHE(IGMN,IBMN)
  459. ELSE
  460. VALMAT(IM)=0.D0
  461. ENDIF
  462. 9035 CONTINUE
  463. C
  464. C CALCUL DES COEFFICIENTS DE NORMALISATION
  465. C
  466. RHO =VALMAT(1)
  467. C =VALMAT(2)
  468. RHOREF=VALMAT(3)
  469. CREF =VALMAT(4)
  470. RLCAR =VALMAT(5)
  471. C
  472. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  473. VKL =(COEFPR*COEFPR)/(RHO*C*C)
  474.  
  475. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE,
  476. 1 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  477. IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  478.  
  479. DJAC=ABS(DJAC)*POIGAU(IGAU)
  480. CALL NKLNST(BGENE,DJAC,VKL,LRE,NSTRS,REL)
  481. 4035 CONTINUE
  482. *
  483. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  484. INTERR(1)=IB
  485. CALL ERREUR(195)
  486. GOTO 9935
  487. ENDIF
  488. C
  489. C REMPLISSAGE DE XMATRI
  490. C
  491. CALL REMPMT(REL,LRE,RE(1,1,IB))
  492. 3035 CONTINUE
  493. *
  494. 9935 CONTINUE
  495. SEGSUP WRK1,WRK2
  496. GOTO 510
  497. C_______________________________________________________________________
  498. C
  499. C SECTEUR DE CALCUL POUR LES ELEMENTS DE SURFACE LIBRE
  500. C_______________________________________________________________________
  501. C
  502. 48 CONTINUE
  503. NBNO=NBNN
  504. NBBB=NBNN
  505. NSTRS=NDDL
  506. SEGINI WRK1,WRK2
  507. c
  508. DO 3048 IB=1,NBELEM
  509. C
  510. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  511. C
  512. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  513. CALL ZERO (REL,LRE,LRE)
  514. C
  515. MPTVAL=IVAMAT
  516. DO 9048 IM=1,6
  517. IF (IVAL(IM).NE.0) THEN
  518. MELVAL=IVAL(IM)
  519. IBMN=MIN(IB ,VELCHE(/2))
  520. VALMAT(IM)=VELCHE(1,IBMN)
  521. ELSE
  522. VALMAT(IM)=0.D0
  523. ENDIF
  524. 9048 CONTINUE
  525. C
  526. RHO =VALMAT(1)
  527. G =VALMAT(6)
  528. VKS =RHO*G
  529. C
  530. C BOUCLE SUR LES POINTS DE GAUSS
  531. C
  532. ISDJC=0
  533. DO 4048 IGAU=1,NBPGAU
  534. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE,
  535. 1 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  536. IF(DJAC.LT.0.0) ISDJC=ISDJC+1
  537.  
  538. DJAC=ABS(DJAC)*POIGAU(IGAU)
  539. CALL NKSNST(BGENE,DJAC,VKS,LRE,NSTRS,REL)
  540. 4048 CONTINUE
  541. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  542. INTERR(1)=IB
  543. CALL ERREUR(195)
  544. GOTO 9948
  545. ENDIF
  546. C
  547. C REMPLISSAGE DE XMATRI
  548. C
  549. CALL REMPMT(REL,LRE,RE(1,1,ib))
  550. 3048 CONTINUE
  551. C
  552. 9948 CONTINUE
  553. SEGSUP WRK1,WRK2
  554. GOTO 510
  555. C_______________________________________________________________________
  556. C
  557. C MILIEUX POREUX
  558. C_______________________________________________________________________
  559. C
  560. 79 CONTINUE
  561. C
  562. C* Cas non pevus actuellement
  563. IF (IMAT.EQ.1) THEN
  564. IF (MATE.LT.1.OR.MATE.GT.4) GOTO 99
  565. ELSE
  566. GOTO 99
  567. ENDIF
  568. C
  569. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  570. C NBNO = NOMBRE DE FONCTIONS DE FORME
  571. C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  572. C
  573. DIM3=1.D0
  574. NCOT=0
  575. NBNO=IPORE
  576. NBBB=NBNN
  577. NSTN=1
  578. **************** AM 08/01/01
  579. ***** NSTMU=2
  580. ***** IF(IFOUR.GE.0) NSTMU=3
  581. NSTMU=3
  582. LRN = NBNO-NBBB
  583. LRB=LRE-NBNN
  584.  
  585. IELE=NUMGEO(MELE)
  586. IF(IELE.EQ.6 ) NCOT=3
  587. IF(IELE.EQ.10) NCOT=4
  588. IF(IELE.EQ.15) NCOT=12
  589. IF(IELE.EQ.17) NCOT=9
  590. IF(IELE.EQ.24) NCOT=6
  591. IF(NCOT.EQ.0) THEN
  592. CALL ERREUR(5)
  593. GOTO 510
  594. ENDIF
  595. *
  596. * CAS NON ISOTROPES
  597. * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES
  598. * AU CENTRE DE L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
  599. *
  600. IPMIN2 = 0
  601. IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1 ) THEN
  602. CALL RESHPT(1,NBNO,IELE,MELE,0,IPMIN2,IRT1)
  603. MINTE2=IPMIN2
  604. SEGACT MINTE2
  605. SEGINI WRK8
  606. NSTMU=LHOOK
  607. ENDIF
  608. *
  609. SEGINI WRK1,WRK2,WRK5,WRK55
  610. *
  611. DO 3079 IB=1,NBELEM
  612. *
  613. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  614. *
  615. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  616. *
  617. * CALCUL DES AXES LOCAUX DANS LES CAS NON ISOTROPES
  618. *
  619. C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)
  620. C* . .AND.IMAT.EQ.1)THEN
  621. IF (IPMIN2.NE.0) THEN
  622. NBSH=MINTE2.SHPTOT(/2)
  623. CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  624. if (nbsh.eq.-1) then
  625. call erreur(525)
  626. goto 9979
  627. endif
  628. ENDIF
  629. *
  630. CALL ZERO (REL,LRE,LRE)
  631. *
  632. * TRAITEMENT POUR NOEUDS MILIEUX PRESSION
  633. *
  634. FREF = 1.D6
  635. CALL BNPOR2(YGENE,NCOT,IELE)
  636. IF(IERR.NE.0) GOTO 9979
  637. *
  638. * DO 27895 IOI=1,NCOT
  639. * WRITE(6,28927) IOI
  640. *28927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3)
  641. * WRITE(6,28928) (YGENE(IOI,J),J=1,NBNN)
  642. *28928 FORMAT(8(1X,1PE10.3))
  643. *27895 CONTINUE
  644. C
  645. C BOUCLE SUR LES POINTS DE GAUSS
  646. C
  647. ISDJC=0
  648. DO 4079 IGAU=1,NBPGAU
  649. C
  650. C RECUPERATION DE L'EPAISSEUR
  651. C
  652. IF (IFOUR.EQ.-2)THEN
  653. MPTVAL=IVACAR
  654. IF (IVACAR.NE.0) THEN
  655. MELVAL=IVAL(1)
  656. IF (MELVAL.NE.0) THEN
  657. IGMN=MIN(IGAU,VELCHE(/1))
  658. IBMN=MIN(IB,VELCHE(/2))
  659. DIM3=VELCHE(IGMN,IBMN)
  660. ELSE
  661. DIM3=1.D0
  662. ENDIF
  663. ENDIF
  664. ENDIF
  665. C
  666. CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
  667. . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
  668. IF (DJAC.EQ.0.D0) THEN
  669. INTERR(1)=IB
  670. CALL ERREUR(259)
  671. GOTO 9979
  672. ENDIF
  673. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  674. DJAC=ABS(DJAC)*POIGAU(IGAU)
  675. C
  676. * IF(IGAU.EQ.1) THEN
  677. * DO 27892 IOI=1,LHOOK
  678. * WRITE(6,28920) IOI
  679. *28920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3)
  680. * WRITE(6,28921) (BGENE(IOI,J),J=1,LRE)
  681. *28921 FORMAT(8(1X,1PE10.3))
  682. *27892 CONTINUE
  683. * DO 27893 IOI=1,NSTN
  684. * WRITE(6,28922) IOI
  685. *28922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3)
  686. * WRITE(6,28923) (XGENE(IOI,J),J=1,LRN)
  687. *28923 FORMAT(8(1X,1PE10.3))
  688. *27893 CONTINUE
  689. * ENDIF
  690.  
  691. MPTVAL=IVAMAT
  692. C*D IF(IMAT.EQ.2) THEN
  693. C*D GO TO 99
  694. C*D ELSE IF (IMAT.EQ.1) THEN
  695. *
  696. DO 9079 IM=1,NMATT
  697. IF (IVAL(IM).NE.0) THEN
  698. MELVAL=IVAL(IM)
  699. IBMN=MIN(IB ,VELCHE(/2))
  700. IGMN=MIN(IGAU,VELCHE(/1))
  701. VALMAT(IM)=VELCHE(IGMN,IBMN)
  702. ELSE
  703. VALMAT(IM)=0.D0
  704. ENDIF
  705. 9079 CONTINUE
  706. *
  707. IF(MATE.EQ.1) THEN
  708. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  709. . CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  710. DO 4879 I=1,NSTMU
  711. COBMA(I) =VALMAT(3)
  712. 4879 CONTINUE
  713. XMOB =VALMAT(4)
  714. *
  715. ELSE IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  716. IF(IGAU.LE.NBGMAT)
  717. . CALL PORMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
  718. . ROTH,DDHOOK,LHOOK,COBMA,XMOB,1,IRTD)
  719. C*D ELSE
  720. C*D GO TO 99
  721. ENDIF
  722. *
  723. C*D ENDIF
  724. *
  725. CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE,
  726. . IGAU,IMAT,0.D0)
  727. EREF =1.D0
  728. DJACER=DJAC*EREF
  729. DO 4179 I=1,LRB
  730. DO 4179 J=1,LRN
  731. JJ=J+LRB
  732. r_z = DJACER*XGENE(1,J)
  733. DO 4179 K=1,NSTMU
  734. REL(JJ,I)=REL(JJ,I)-COBMA(K)*r_z*BGENE(K,I)
  735. 4179 CONTINUE
  736. *
  737. IF(XMOB.EQ.0.D0) THEN
  738. UNSURM=0.D0
  739. ELSE
  740. UNSURM=1.D0 / XMOB
  741. ENDIF
  742. COMJAC=UNSURM*DJAC*EREF*EREF
  743. DO 4279 I=1,LRN
  744. II=I+LRB
  745. r_z = COMJAC*XGENE(1,I)
  746. DO 4279 J=1,I
  747. JJ=J+LRB
  748. REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J)
  749. 4279 CONTINUE
  750. C
  751. COMJAC=UNSURM*DJAC*FREF
  752. DO 4379 I=1,NBNN
  753. II=I+LRB
  754. DO 4379 J=1,I
  755. JJ=J+LRB
  756. DO 4379 K=1,NCOT
  757. REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J)
  758. 4379 CONTINUE
  759. *
  760. 4079 CONTINUE
  761. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  762. INTERR(1)=IB
  763. CALL ERREUR(195)
  764. GOTO 9979
  765. ENDIF
  766. C
  767. C REMPLISSAGE DE XMATRI
  768. C
  769. CALL REMPMT(REL,LRE,RE(1,1,ib))
  770. *
  771. 3079 CONTINUE
  772. c
  773. IF(IRTD.EQ.0) THEN
  774. MOTERR(1:8)=CMATE
  775. MOTERR(9:16)=NOMFR(MFR/2+1)
  776. INTERR(1)=IFOUR
  777. CALL ERREUR(81)
  778. ENDIF
  779. 9979 CONTINUE
  780. SEGSUP WRK1,WRK2,WRK5,WRK55
  781. C* IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1) THEN
  782. IF (IPMIN2.NE.0) THEN
  783. SEGDES MINTE2
  784. SEGSUP WRK8
  785. ENDIF
  786. GOTO 510
  787. C_______________________________________________________________________
  788. C
  789. C MILIEUX POREUX - SUITE
  790. C_______________________________________________________________________
  791. C
  792. 173 CONTINUE
  793. C
  794. C CAS NON ISOTROPES NON PREVUS ACTUELLEMENT
  795. IF (IMAT.EQ.1) THEN
  796. IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  797. CALL ERREUR(251)
  798. GO TO 510
  799. ENDIF
  800. ELSE
  801. C* ELSE IF (IMAT.EQ.2) THEN
  802. GO TO 99
  803. ENDIF
  804. C
  805. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  806. C NBNO = NOMBRE DE FONCTIONS DE FORME
  807. C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  808. C
  809. IF(MFR.EQ.57) IDECAP=2
  810. IF(MFR.EQ.59) IDECAP=3
  811. *
  812. DIM3=1.D0
  813. NCOT=0
  814. NBNO=IPORE
  815. NBBB=NBNN
  816. NSTN=IDECAP
  817. *
  818. **************** AM 08/01/01
  819. ***** NSTMU=2
  820. ***** IF(IFOUR.GE.0) NSTMU=3
  821. *
  822. NSTMU=3
  823. LPP=NBNO-NBBB
  824. LRN = IDECAP*LPP
  825. **** LRB=LRE-LRN
  826. LRB=LRE-(IDECAP*NBBB)
  827. IELE=NUMGEO(MELE)
  828. *
  829. IF(IELE.EQ.6 ) NCOT=3
  830. IF(IELE.EQ.10) NCOT=4
  831. IF(IELE.EQ.15) NCOT=12
  832. IF(IELE.EQ.17) NCOT=9
  833. IF(IELE.EQ.24) NCOT=6
  834. IF(NCOT.EQ.0) THEN
  835. CALL ERREUR(5)
  836. GO TO 510
  837. ENDIF
  838. *
  839. SEGINI WRK1,WRK2,WRK5,WRK55,WRK555
  840.  
  841. DO 3173 IB=1,NBELEM
  842. *
  843. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  844. *
  845. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  846. *
  847. CALL ZERO (REL,LRE,LRE)
  848. *
  849. * TRAITEMENT POUR NOEUDS MILIEUX PRESSION
  850. *
  851. FREF = 1.D6
  852. CALL BNPOR2(YGENE,NCOT,IELE)
  853. IF(IERR.NE.0) GO TO 9973
  854.  
  855. * DO 17895 IOI=1,NCOT
  856. * WRITE(6,78927) IOI
  857. *78927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3)
  858. * WRITE(6,78928) (YGENE(IOI,J),J=1,NBNN)
  859. *78928 FORMAT(8(1X,1PE10.3))
  860. *17895 CONTINUE
  861. C
  862. C BOUCLE SUR LES POINTS DE GAUSS
  863. C
  864. ISDJC=0
  865. DO 4173 IGAU=1,NBPGAU
  866. C
  867. C RECUPERATION DE L'EPAISSEUR
  868. C
  869. IF (IFOUR.EQ.-2)THEN
  870. MPTVAL=IVACAR
  871. IF (IVACAR.NE.0) THEN
  872. MELVAL=IVAL(1)
  873. IF (MELVAL.NE.0) THEN
  874. IGMN=MIN(IGAU,VELCHE(/1))
  875. IBMN=MIN(IB,VELCHE(/2))
  876. DIM3=VELCHE(IGMN,IBMN)
  877. ELSE
  878. DIM3=1.D0
  879. ENDIF
  880. ENDIF
  881. ENDIF
  882. C
  883. NSTB=LHOOK
  884. CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  885. . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1)
  886. IF(DJAC.EQ.0.D0) THEN
  887. INTERR(1)=IB
  888. CALL ERREUR(259)
  889. GOTO 9973
  890. ENDIF
  891. IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  892. DJAC=ABS(DJAC)*POIGAU(IGAU)
  893. C
  894. * IF(IGAU.EQ.1) THEN
  895. * DO 17892 IOI=1,LHOOK
  896. * WRITE(6,78920) IOI
  897. *78920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3)
  898. * WRITE(6,78921) (BGENE(IOI,J),J=1,LRE)
  899. *78921 FORMAT(8(1X,1PE10.3))
  900. *17892 CONTINUE
  901. * DO 17893 IOI=1,NSTN
  902. * WRITE(6,78922) IOI
  903. *78922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3)
  904. * WRITE(6,78923) (XGENE(IOI,J),J=1,LRN)
  905. *78923 FORMAT(8(1X,1PE10.3))
  906. *17893 CONTINUE
  907. * ENDIF
  908.  
  909. MPTVAL=IVAMAT
  910. C*D IF(IMAT.EQ.2) THEN
  911. C*D GO TO 99
  912. C*D ELSE IF (IMAT.EQ.1) THEN
  913. *
  914. DO 9173 IM=1,NMATT
  915. IF (IVAL(IM).NE.0) THEN
  916. MELVAL=IVAL(IM)
  917. IBMN=MIN(IB ,VELCHE(/2))
  918. IGMN=MIN(IGAU,VELCHE(/1))
  919. VALMAT(IM)=VELCHE(IGMN,IBMN)
  920. ELSE
  921. VALMAT(IM)=0.D0
  922. ENDIF
  923. 9173 CONTINUE
  924. *
  925. C*D IF(MATE.EQ.1) THEN
  926. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  927. . CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  928. *
  929. C*D ELSE
  930. C*D GO TO 99
  931. C*D ENDIF
  932. C*D ENDIF
  933. *
  934. CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL)
  935. EREF =1.D0
  936. *
  937. IF(MFR.EQ.57) THEN
  938. COBB(1) = VALMAT(3)
  939. COBB(2) = VALMAT(4)
  940. CPBB(1) = VALMAT(5)
  941. CPBB(2) = VALMAT(6)
  942. KKBB(1,1)= VALMAT(7)
  943. KKBB(1,2)= VALMAT(8)
  944. KKBB(2,1)= VALMAT(9)
  945. KKBB(2,2)= VALMAT(10)
  946. *
  947. ELSE IF(MFR.EQ.59) THEN
  948. COBB(1) = VALMAT(3)
  949. COBB(2) = VALMAT(4)
  950. COBB(3) = VALMAT(5)
  951. CPBB(1) = VALMAT(6)
  952. CPBB(2) = VALMAT(7)
  953. CPBB(3) = VALMAT(8)
  954. KKBB(1,1)= VALMAT(9)
  955. KKBB(1,2)= VALMAT(10)
  956. KKBB(1,3)= VALMAT(11)
  957. KKBB(2,1)= VALMAT(12)
  958. KKBB(2,2)= VALMAT(13)
  959. KKBB(2,3)= VALMAT(14)
  960. KKBB(3,1)= VALMAT(15)
  961. KKBB(3,2)= VALMAT(16)
  962. KKBB(3,3)= VALMAT(17)
  963. ENDIF
  964. *
  965. DJACER=DJAC*EREF
  966.  
  967. DO 6673 IPR=1,IDECAP
  968. LRBDEC=LRB + (IPR-1)*NBBB
  969. LPPDEC= (IPR-1)*LPP
  970. COMJAC=COBB(IPR)*DJACER
  971. DO 4973 I=1,LRB
  972. DO 4973 J=1,LPP
  973. JJ=J+LRBDEC
  974. JX=J+LPPDEC
  975. r_z = COMJAC*XGENE(IPR,JX)
  976. DO 4973 K=1,NSTMU
  977. REL(I,JJ)=REL(I,JJ)-r_z*BGENE(K,I)
  978. 4973 CONTINUE
  979. 6673 CONTINUE
  980. *
  981. DO 6674 IPR=1,IDECAP
  982. LRBDEC=LRB + (IPR-1)*NBBB
  983. LPPDEC= (IPR-1)*LPP
  984. COMJAC=CPBB(IPR)*DJACER
  985. DO 4974 I=1,LRB
  986. DO 4974 J=1,LPP
  987. JJ=J+LRBDEC
  988. JX=J+LPPDEC
  989. r_z = COMJAC*XGENE(IPR,JX)
  990. DO 4974 K=1,NSTMU
  991. * ici - pour bsig
  992. REL(JJ,I)=REL(JJ,I)-r_z*BGENE(K,I)
  993. 4974 CONTINUE
  994. 6674 CONTINUE
  995. *
  996. COMJAC=DJAC*EREF*EREF
  997. CALL ZERO(XREL,LRN,LRN)
  998. CALL BDBSTS(XGENE,COMJAC,KKBB,LRN,NSTN,XREL)
  999.  
  1000. DO 6873 IPR=1,IDECAP
  1001. IRBDEC=LRB + (IPR-1)*NBBB
  1002. IPPDEC= (IPR-1)*LPP
  1003. DO 6873 JPR=1,IDECAP
  1004. JRBDEC=LRB + (JPR-1)*NBBB
  1005. JPPDEC= (JPR-1)*LPP
  1006. DO 4273 I=1,LPP
  1007. II=I+IRBDEC
  1008. IX=I+IPPDEC
  1009. DO 4273 J=1,LPP
  1010. JJ=J+JRBDEC
  1011. JX=J+JPPDEC
  1012.  
  1013. * IF(IGAU.EQ.1) THEN
  1014. * PRINT *,'I =',I,' IX=',IX,' II=',II
  1015. * PRINT *,'J =',J,' JX=',JX,' JJ=',JJ, ' XREL=',XREL(IX,JX)
  1016. * ENDIF
  1017.  
  1018. REL(II,JJ)=REL(II,JJ)-XREL(IX,JX)
  1019. 4273 CONTINUE
  1020. 6873 CONTINUE
  1021. C
  1022. DO 6973 IPR=1,IDECAP
  1023. COMJAC=KKBB(IPR,IPR)*DJAC*FREF
  1024. LRBDEC=LRB + (IPR-1)*NBBB
  1025. DO 4373 I=1,NBNN
  1026. II=I+LRBDEC
  1027. DO 4373 J=1,NBNN
  1028. JJ=J+LRBDEC
  1029. DO 4374 K=1,NCOT
  1030. REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J)
  1031. 4374 CONTINUE
  1032. 4373 CONTINUE
  1033. 6973 CONTINUE
  1034. *
  1035. 4173 CONTINUE
  1036. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1037. INTERR(1)=IB
  1038. CALL ERREUR(195)
  1039. GOTO 9973
  1040. ENDIF
  1041. C
  1042. C REMPLISSAGE DE XMATRI
  1043. C
  1044. CALL REMPMS(REL,LRE,RE(1,1,ib))
  1045. 3173 CONTINUE
  1046. c
  1047. IF(IRTD.EQ.0) THEN
  1048. MOTERR(1:8)=CMATE
  1049. MOTERR(9:16)=NOMFR(MFR/2+1)
  1050. INTERR(1)=IFOUR
  1051. CALL ERREUR(81)
  1052. ENDIF
  1053. 9973 CONTINUE
  1054. SEGSUP WRK1,WRK2,WRK5,WRK55,WRK555
  1055. GOTO 510
  1056. C_______________________________________________________________________
  1057. C
  1058. C JOINTS EN FORMULATION MILIEUX POREUX
  1059. C_______________________________________________________________________
  1060. C
  1061. 80 CONTINUE
  1062. C
  1063. * CAS NON PREVUS
  1064. IF (IMAT.EQ.1) THEN
  1065. IF (MATE.NE.1) GOTO 99
  1066. ELSE IF (IMAT.EQ.2) THEN
  1067. GOTO 99
  1068. ENDIF
  1069. C
  1070. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  1071. C NBNO = NOMBRE DE FONCTIONS DE FORME
  1072. C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  1073. C
  1074. NCOT=0
  1075. NBNO=IPORE
  1076. NBBB=NBNN
  1077. NSTN=1
  1078. NSTMU=2
  1079. IF(IFOUR.EQ.2) NSTMU=3
  1080. LRN=(NBNO-NBBB)*3/2
  1081. LPP=LRN
  1082. LRB=LRE-NBNN
  1083. IELE=NUMGEO(MELE)
  1084. IF(IELE.EQ.29) NCOT=2
  1085. IF(IELE.EQ.30) NCOT=6
  1086. IF(IELE.EQ.31) NCOT=8
  1087. IF(NCOT.EQ.0) THEN
  1088. CALL ERREUR(5)
  1089. GO TO 510
  1090. ENDIF
  1091. *
  1092. SEGINI WRK1,WRK2,WRK3,WRK5,WRK55
  1093. *
  1094. DO 3080 IB=1,NBELEM
  1095. *
  1096. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1097. *
  1098. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1099. *
  1100. * CALCUL DES AXES LOCAUX ET DES COORDONNES LOCALES
  1101. *
  1102. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1103. *
  1104. CALL ZERO (REL,LRE,LRE)
  1105. *
  1106. CALL INTDEL(XNTH,XNTB,XNTT,LRN,MELE)
  1107. *
  1108. * TRAITEMENT POUR NOEUDS MILIEUX PRESSION
  1109. *
  1110. FREF = 1.D6
  1111. CALL BNPOR2(YGENE,NCOT,IELE)
  1112. IF (IERR.NE.0) GOTO 9980
  1113. *
  1114. * BOUCLE SUR LES POINTS DE GAUSS
  1115. *
  1116. ISDJC=0
  1117. DO 4080 IGAU=1,NBPGAU
  1118. *
  1119. CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  1120. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
  1121. IF (DJAC.EQ.0.D0) THEN
  1122. INTERR(1)=IB
  1123. CALL ERREUR(259)
  1124. GOTO 9980
  1125. ENDIF
  1126. IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  1127. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1128. *
  1129. MPTVAL=IVAMAT
  1130. C*D IF(IMAT.EQ.2) THEN
  1131. C*D GO TO 99
  1132. C*D ELSE IF (IMAT.EQ.1) THEN
  1133. *
  1134. DO 9080 IM=1,NMATT
  1135. IF (IVAL(IM).NE.0) THEN
  1136. MELVAL=IVAL(IM)
  1137. IBMN=MIN(IB ,VELCHE(/2))
  1138. IGMN=MIN(IGAU,VELCHE(/1))
  1139. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1140. ELSE
  1141. VALMAT(IM)=0.D0
  1142. ENDIF
  1143. 9080 CONTINUE
  1144. *
  1145. C*D IF(MATE.EQ.1) THEN
  1146. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1147. . CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1148.  
  1149. C*D ELSE
  1150. C*D GO TO 99
  1151. C*D ENDIF
  1152. C*D ENDIF
  1153. *
  1154. CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE,
  1155. . IGAU,IMAT,0.D0)
  1156. EREF =1.D0
  1157. *
  1158. COBMA(NSTMU)=VALMAT(3)
  1159. XMOB=VALMAT(4)
  1160. *
  1161. IF(XMOB.EQ.0.D0) THEN
  1162. UNSURM=0.D0
  1163. ELSE
  1164. UNSURM=1.D0 / XMOB
  1165. ENDIF
  1166. *
  1167. DJACER=DJAC*EREF
  1168. DO 4180 I=1,LRB
  1169. DO 4180 J=1,LRN
  1170. JJ=J+LRB
  1171. r_z = DJACER*XGENE(1,J)*XNTT(J)
  1172. REL(JJ,I)=REL(JJ,I)-r_z*COBMA(NSTMU)*BGENE(NSTMU,I)
  1173. 4180 CONTINUE
  1174. *
  1175. COMJAC=UNSURM*DJAC*EREF*EREF
  1176. DO 4280 I=1,LRN
  1177. II=I+LRB
  1178. r_z = COMJAC*XGENE(1,I)*XNTT(I)
  1179. DO 4280 J=1,I
  1180. JJ=J+LRB
  1181. REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J)*XNTT(J)
  1182. 4280 CONTINUE
  1183. *
  1184. COMJAC=UNSURM*DJAC*FREF
  1185. DO 4380 I=1,NBNN
  1186. II=I+LRB
  1187. DO 4380 J=1,I
  1188. JJ=J+LRB
  1189. DO 4380 K=1,NCOT
  1190. REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J)
  1191. 4380 CONTINUE
  1192. *
  1193. 4080 CONTINUE
  1194. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1195. INTERR(1)=IB
  1196. CALL ERREUR(195)
  1197. GOTO 9980
  1198. ENDIF
  1199. *
  1200. * REMPLISSAGE DE XMATRI
  1201. *
  1202. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1203. 3080 CONTINUE
  1204.  
  1205. IF(IRTD.EQ.0) THEN
  1206. MOTERR(1:8)=CMATE
  1207. MOTERR(9:16)=NOMFR(MFR/2+1)
  1208. INTERR(1)=IFOUR
  1209. CALL ERREUR(81)
  1210. ENDIF
  1211. 9980 CONTINUE
  1212. SEGSUP WRK1,WRK2,WRK3,WRK5,WRK55
  1213. GOTO 510
  1214. *
  1215. C_______________________________________________________________________
  1216. C
  1217. C JOINTS EN FORMULATION MILIEUX POREUX - SUITE
  1218. C_______________________________________________________________________
  1219. C
  1220. 185 CONTINUE
  1221.  
  1222. C
  1223. * CAS NON ISOTROPES NON PREVUS ACTUELLEMENT
  1224. IF (IMAT.EQ.1) THEN
  1225. IF (MATE.NE.1) GOTO 99
  1226. ELSE
  1227. GOTO 99
  1228. ENDIF
  1229. C
  1230. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  1231. C NBNO = NOMBRE DE FONCTIONS DE FORME
  1232. C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  1233. C
  1234. IF(MFR.EQ.57) IDECAP=2
  1235. IF(MFR.EQ.59) IDECAP=3
  1236. *
  1237. NCOT=0
  1238. NBNO=IPORE
  1239. NBBB=NBNN
  1240. NSTN=IDECAP
  1241. NSTMU=2
  1242. IF(IFOUR.EQ.2) NSTMU=3
  1243. LPP=(NBNO-NBBB)*3/2
  1244. LRN=IDECAP*LPP
  1245. LRB=LRE-IDECAP*NBNN
  1246. IELE=NUMGEO(MELE)
  1247. IF(IELE.EQ.29) NCOT=2
  1248. IF(IELE.EQ.30) NCOT=6
  1249. IF(IELE.EQ.31) NCOT=8
  1250. IF(NCOT.EQ.0) THEN
  1251. CALL ERREUR(5)
  1252. GO TO 510
  1253. ENDIF
  1254. *
  1255. SEGINI WRK1,WRK2,WRK3,WRK5,WRK55,WRK555
  1256. *
  1257. DO 3185 IB=1,NBELEM
  1258. *
  1259. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1260. *
  1261. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1262. *
  1263. * CALCUL DES AXES LOCAUX ET DES COORDONNES LOCALES
  1264. *
  1265. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1266. *
  1267. CALL ZERO (REL,LRE,LRE)
  1268. *
  1269. CALL INTDEL(XNTH,XNTB,XNTT,LPP,MELE)
  1270. *
  1271. * TRAITEMENT POUR NOEUDS MILIEUX PRESSION
  1272. *
  1273. FREF = 1.D6
  1274. CALL BNPOR2(YGENE,NCOT,IELE)
  1275. IF (IERR.NE.0) GOTO 9985
  1276. *
  1277. * BOUCLE SUR LES POINTS DE GAUSS
  1278. *
  1279. ISDJC=0
  1280. DO 4185 IGAU=1,NBPGAU
  1281. *
  1282. NSTB=LHOOK
  1283. CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  1284. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1)
  1285. IF (DJAC.EQ.0.D0) THEN
  1286. INTERR(1)=IB
  1287. CALL ERREUR(259)
  1288. GOTO 9985
  1289. ENDIF
  1290. IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  1291. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1292. *
  1293. MPTVAL=IVAMAT
  1294. C*D IF(IMAT.EQ.2) THEN
  1295. C*D GO TO 99
  1296. C*D ELSE IF (IMAT.EQ.1) THEN
  1297. *
  1298. DO 9185 IM=1,NMATT
  1299. IF (IVAL(IM).NE.0) THEN
  1300. MELVAL=IVAL(IM)
  1301. IBMN=MIN(IB ,VELCHE(/2))
  1302. IGMN=MIN(IGAU,VELCHE(/1))
  1303. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1304. ELSE
  1305. VALMAT(IM)=0.D0
  1306. ENDIF
  1307. 9185 CONTINUE
  1308. *
  1309. C*D IF(MATE.EQ.1) THEN
  1310. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1311. . CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1312.  
  1313. C*D ELSE
  1314. C*D GO TO 99
  1315. C*D ENDIF
  1316. C*D ENDIF
  1317. *
  1318. CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL)
  1319.  
  1320. EREF =1.D0
  1321. *
  1322. IF(MFR.EQ.57) THEN
  1323. COBB(1) = VALMAT(3)
  1324. COBB(2) = VALMAT(4)
  1325. CPBB(1) = VALMAT(5)
  1326. CPBB(2) = VALMAT(6)
  1327. KKBB(1,1)= VALMAT(7)
  1328. KKBB(1,2)= VALMAT(8)
  1329. KKBB(2,1)= VALMAT(9)
  1330. KKBB(2,2)= VALMAT(10)
  1331. *
  1332. ELSE IF(MFR.EQ.59) THEN
  1333. COBB(1) = VALMAT(3)
  1334. COBB(2) = VALMAT(4)
  1335. COBB(3) = VALMAT(5)
  1336. CPBB(1) = VALMAT(6)
  1337. CPBB(2) = VALMAT(7)
  1338. CPBB(3) = VALMAT(8)
  1339. KKBB(1,1)= VALMAT(9)
  1340. KKBB(1,2)= VALMAT(10)
  1341. KKBB(1,3)= VALMAT(11)
  1342. KKBB(2,1)= VALMAT(12)
  1343. KKBB(2,2)= VALMAT(13)
  1344. KKBB(2,3)= VALMAT(14)
  1345. KKBB(3,1)= VALMAT(15)
  1346. KKBB(3,2)= VALMAT(16)
  1347. KKBB(3,3)= VALMAT(17)
  1348. ENDIF
  1349. *
  1350. DO 6684 IPR=1,IDECAP
  1351. LPPDEC= (IPR-1)*LPP
  1352. DO 6684 J=1,LPP
  1353. JX=J+LPPDEC
  1354. XGENE(IPR,JX)= XGENE(IPR,JX)*XNTT(J)
  1355. 6684 CONTINUE
  1356. *
  1357. *
  1358. DJACER=DJAC*EREF
  1359.  
  1360. DO 6685 IPR=1,IDECAP
  1361. LRBDEC=LRB + (IPR-1)*NBBB
  1362. LPPDEC= (IPR-1)*LPP
  1363. COMJAC=COBB(IPR)*DJACER
  1364. DO 4585 I=1,LRB
  1365. DO 4585 J=1,LPP
  1366. JJ=J+LRBDEC
  1367. JX=J+LPPDEC
  1368. r_z = COMJAC*XGENE(IPR,JX)
  1369. REL(I,JJ)=REL(I,JJ)-r_z*BGENE(NSTMU,I)
  1370. 4585 CONTINUE
  1371. 6685 CONTINUE
  1372. *
  1373.  
  1374. DO 6686 IPR=1,IDECAP
  1375. LRBDEC=LRB + (IPR-1)*NBBB
  1376. LPPDEC= (IPR-1)*LPP
  1377. COMJAC=CPBB(IPR)*DJACER
  1378. DO 4586 I=1,LRB
  1379. DO 4586 J=1,LPP
  1380. JJ=J+LRBDEC
  1381. JX=J+LPPDEC
  1382. r_z = COMJAC*XGENE(IPR,JX)
  1383. REL(JJ,I)=REL(JJ,I)-r_z*BGENE(NSTMU,I)
  1384. 4586 CONTINUE
  1385. 6686 CONTINUE
  1386. *
  1387. COMJAC=DJAC*EREF*EREF
  1388. CALL ZERO(XREL,LRN,LRN)
  1389. CALL BDBSTS(XGENE,COMJAC,KKBB,LRN,NSTN,XREL)
  1390.  
  1391. DO 6885 IPR=1,IDECAP
  1392. IRBDEC=LRB + (IPR-1)*NBBB
  1393. IPPDEC= (IPR-1)*LPP
  1394. DO 6885 JPR=1,IDECAP
  1395. JRBDEC=LRB + (JPR-1)*NBBB
  1396. JPPDEC= (JPR-1)*LPP
  1397. DO 4285 I=1,LPP
  1398. II=I+IRBDEC
  1399. IX=I+IPPDEC
  1400. DO 4285 J=1,LPP
  1401. JJ=J+JRBDEC
  1402. JX=J+JPPDEC
  1403.  
  1404. * IF(IGAU.EQ.1) THEN
  1405. * PRINT *,'I =',I,' IX=',IX,' II=',II
  1406. * PRINT *,'J =',J,' JX=',JX,' JJ=',JJ, ' XREL=',XREL(IX,JX)
  1407. * ENDIF
  1408.  
  1409. REL(II,JJ)=REL(II,JJ)-XREL(IX,JX)
  1410. 4285 CONTINUE
  1411. 6885 CONTINUE
  1412. *
  1413.  
  1414. DO 6975 IPR=1,IDECAP
  1415. COMJAC=KKBB(IPR,IPR)*DJAC*FREF
  1416. LRBDEC=LRB + (IPR-1)*NBBB
  1417. DO 4385 I=1,NBNN
  1418. II=I+LRBDEC
  1419. DO 4385 J=1,NBNN
  1420. JJ=J+LRBDEC
  1421. DO 4375 K=1,NCOT
  1422. REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J)
  1423. 4375 CONTINUE
  1424. 4385 CONTINUE
  1425. 6975 CONTINUE
  1426. *
  1427. 4185 CONTINUE
  1428. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1429. INTERR(1)=IB
  1430. CALL ERREUR(195)
  1431. GOTO 9980
  1432. ENDIF
  1433. *
  1434. * REMPLISSAGE DE XMATRI
  1435. *
  1436. CALL REMPMS(REL,LRE,RE(1,1,IB))
  1437. 3185 CONTINUE
  1438.  
  1439. IF(IRTD.EQ.0) THEN
  1440. MOTERR(1:8)=CMATE
  1441. MOTERR(9:16)=NOMFR(MFR/2+1)
  1442. INTERR(1)=IFOUR
  1443. CALL ERREUR(81)
  1444. ENDIF
  1445. 9985 CONTINUE
  1446. SEGSUP WRK1,WRK2,WRK3,WRK5,WRK55,WRK555
  1447. GOTO 510
  1448. *
  1449. * ERREUR : CAS NON PREVU
  1450. *
  1451. 99 CONTINUE
  1452. MOTERR(1:4)=NOMTP(MELE)
  1453. MOTERR(5:12)='RIGI2 '
  1454. CALL ERREUR(86)
  1455. *
  1456. 510 CONTINUE
  1457. * WRITE (*,*) 'Sortie de RIGI2.'
  1458. * SEGDES,XMATRI
  1459. SEGSUP,MVELCH
  1460.  
  1461. RETURN
  1462. END
  1463.  
  1464.  
  1465.  
  1466.  

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