Télécharger rigi2.eso

Retour à la liste

Numérotation des lignes :

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

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