Télécharger rigi2.eso

Retour à la liste

Numérotation des lignes :

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

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