Télécharger rigi2.eso

Retour à la liste

Numérotation des lignes :

  1. C RIGI2 SOURCE PV 18/04/24 21:15:14 9815
  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,NOER)
  5. *---------------------------------------------------------------------*
  6. * __________________________ *
  7. * | | *
  8. * | CALCUL DE LA RIGIDITE | *
  9. * |________________________| *
  10. * *
  11. * massif, liquide, 'surface libre', poreux et joints poreux, *
  12. * incompressible *
  13. * *
  14. *---------------------------------------------------------------------*
  15. * *
  16. * ENTREES : *
  17. * ________ *
  18. * *
  19. * MATE Numero du materiau *
  20. * MELE Numero de l'element fini *
  21. * IPMAIL Pointeur sur un segment MELEME *
  22. * IPMINT Pointeur sur un segment MINTE *
  23. * NBPGAU Nombre de point d'integration pour la rigidite *
  24. * LRE Nombre de ddl dans la matrice de rigidite *
  25. * NSTRS Nombre de composante de contraintes/deformations *
  26. * IVAMAT Pointeur sur un segment MPTVAL pour le materiau ou *
  27. * pour une matrice de hooke *
  28. * IVACAR Pointeur sur un segment MPTVAL de caractéristiques *
  29. * CMATE Nom du materiau *
  30. * MFR Numero de la formulation element fini *
  31. * NBGMAT Taille maxi des melval du materiau (pt de gauss) *
  32. * NELMAT Taille maxi des melval du materiau (No d'element) *
  33. * IMAT (2 il y a une matrice de HOOKE,1 non ) *
  34. * NMATT Nombre de composante de materiau (IMAT=1) *
  35. * LHOOK Dimension de la matrice de Hooke *
  36. * IPORE Nombre de fonctions de forme *
  37. * NDDL Nombre de degre de liberte *
  38. * *
  39. * SORTIES : *
  40. * ________ *
  41. * *
  42. * IPMATR pointeur sur la rigidite de la sous-zone *
  43. * *
  44. *---------------------------------------------------------------------*
  45. IMPLICIT INTEGER(I-N)
  46. IMPLICIT REAL*8(A-H,O-Z)
  47. *
  48. -INC 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. if (noer.eq.0) CALL ERREUR(195)
  401. noer=195
  402. GOTO 9904
  403. ENDIF
  404. C
  405. C REMPLISSAGE DE XMATRI
  406. C
  407. c CALL REMPMT(RINT,LRE,RE)
  408. DO 4100 IBK=1,LRE
  409. DO 4100 IAK=1,LRE
  410. RE(IAK,IBK,IB)=RINT(IAK,IBK)
  411. 4100 CONTINUE
  412. * do i = 1,8
  413. * write(6,*) re(13,3*i-2),re(13,3*i-1),re(13,3*i)
  414. * enddo
  415. *
  416. 3004 CONTINUE
  417. c
  418. IF(IRTD.EQ.0) THEN
  419. MOTERR(1:8)=CMATE
  420. MOTERR(9:16)=NOMFR(MFR/2+1)
  421. INTERR(1)=IFOUR
  422. CALL ERREUR(81)
  423. ENDIF
  424. 9904 CONTINUE
  425. C* IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) .AND.IMAT.EQ.1) THEN
  426. IF (IPMIN2.NE.0) THEN
  427. SEGDES MINTE2
  428. SEGSUP WRK8
  429. ENDIF
  430. SEGSUP WRK1,WRK2
  431. * IF (MWRKIC.NE.0) SEGSUP,MWRKIC
  432. IF (MWRK67.NE.0) SEGSUP,MWRK67
  433. GOTO 510
  434. C_______________________________________________________________________
  435. C
  436. C SECTEUR DE CALCUL POUR LES ELEMENTS LIQUIDES
  437. C_______________________________________________________________________
  438. C
  439. 35 CONTINUE
  440. NBNO=NBNN
  441. NBBB=NBNN
  442. NSTRS=NDDL
  443. SEGINI WRK1,WRK2
  444. c
  445. DO 3035 IB=1,NBELEM
  446. C
  447. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  448. C
  449. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  450. CALL ZERO (REL,LRE,LRE)
  451. C
  452. C BOUCLE SUR LES POINTS DE GAUSS
  453. C
  454. ISDJC=0
  455. DO 4035 IGAU=1,NBPGAU
  456.  
  457. MPTVAL=IVAMAT
  458. DO 9035 IM=1,5
  459. IF (IVAL(IM).NE.0) THEN
  460. MELVAL=IVAL(IM)
  461. IGMN=MIN(IGAU,VELCHE(/1))
  462. IBMN=MIN(IB,VELCHE(/2))
  463. VALMAT(IM)=VELCHE(IGMN,IBMN)
  464. ELSE
  465. VALMAT(IM)=0.D0
  466. ENDIF
  467. 9035 CONTINUE
  468. C
  469. C CALCUL DES COEFFICIENTS DE NORMALISATION
  470. C
  471. RHO =VALMAT(1)
  472. C =VALMAT(2)
  473. RHOREF=VALMAT(3)
  474. CREF =VALMAT(4)
  475. RLCAR =VALMAT(5)
  476. C
  477. COEFPR=(RHOREF*CREF*CREF)/RLCAR
  478. VKL =(COEFPR*COEFPR)/(RHO*C*C)
  479.  
  480. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE,
  481. 1 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  482. IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  483.  
  484. DJAC=ABS(DJAC)*POIGAU(IGAU)
  485. CALL NKLNST(BGENE,DJAC,VKL,LRE,NSTRS,REL)
  486. 4035 CONTINUE
  487. *
  488. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  489. INTERR(1)=IB
  490. CALL ERREUR(195)
  491. noer=195
  492. GOTO 9935
  493. ENDIF
  494. C
  495. C REMPLISSAGE DE XMATRI
  496. C
  497. CALL REMPMT(REL,LRE,RE(1,1,IB))
  498. 3035 CONTINUE
  499. *
  500. 9935 CONTINUE
  501. SEGSUP WRK1,WRK2
  502. GOTO 510
  503. C_______________________________________________________________________
  504. C
  505. C SECTEUR DE CALCUL POUR LES ELEMENTS DE SURFACE LIBRE
  506. C_______________________________________________________________________
  507. C
  508. 48 CONTINUE
  509. NBNO=NBNN
  510. NBBB=NBNN
  511. NSTRS=NDDL
  512. SEGINI WRK1,WRK2
  513. c
  514. DO 3048 IB=1,NBELEM
  515. C
  516. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  517. C
  518. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  519. CALL ZERO (REL,LRE,LRE)
  520. C
  521. MPTVAL=IVAMAT
  522. DO 9048 IM=1,6
  523. IF (IVAL(IM).NE.0) THEN
  524. MELVAL=IVAL(IM)
  525. IBMN=MIN(IB ,VELCHE(/2))
  526. VALMAT(IM)=VELCHE(1,IBMN)
  527. ELSE
  528. VALMAT(IM)=0.D0
  529. ENDIF
  530. 9048 CONTINUE
  531. C
  532. RHO =VALMAT(1)
  533. G =VALMAT(6)
  534. VKS =RHO*G
  535. C
  536. C BOUCLE SUR LES POINTS DE GAUSS
  537. C
  538. ISDJC=0
  539. DO 4048 IGAU=1,NBPGAU
  540. CALL NMATST(IGAU,MELE,MFR,NBNN,LRE,IFOUR,NIFOUR,NSTRS,1.D0,XE,
  541. 1 SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  542. IF(DJAC.LT.0.0) ISDJC=ISDJC+1
  543.  
  544. DJAC=ABS(DJAC)*POIGAU(IGAU)
  545. CALL NKSNST(BGENE,DJAC,VKS,LRE,NSTRS,REL)
  546. 4048 CONTINUE
  547. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  548. INTERR(1)=IB
  549. CALL ERREUR(195)
  550. noer=195
  551. GOTO 9948
  552. ENDIF
  553. C
  554. C REMPLISSAGE DE XMATRI
  555. C
  556. CALL REMPMT(REL,LRE,RE(1,1,ib))
  557. 3048 CONTINUE
  558. C
  559. 9948 CONTINUE
  560. SEGSUP WRK1,WRK2
  561. GOTO 510
  562. C_______________________________________________________________________
  563. C
  564. C MILIEUX POREUX
  565. C_______________________________________________________________________
  566. C
  567. 79 CONTINUE
  568. C
  569. C* Cas non pevus actuellement
  570. IF (IMAT.EQ.1) THEN
  571. IF (MATE.LT.1.OR.MATE.GT.4) GOTO 99
  572. ELSE
  573. GOTO 99
  574. ENDIF
  575. C
  576. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  577. C NBNO = NOMBRE DE FONCTIONS DE FORME
  578. C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  579. C
  580. DIM3=1.D0
  581. NCOT=0
  582. NBNO=IPORE
  583. NBBB=NBNN
  584. NSTN=1
  585. **************** AM 08/01/01
  586. ***** NSTMU=2
  587. ***** IF(IFOUR.GE.0) NSTMU=3
  588. NSTMU=3
  589. LRN = NBNO-NBBB
  590. LRB=LRE-NBNN
  591.  
  592. IELE=NUMGEO(MELE)
  593. IF(IELE.EQ.6 ) NCOT=3
  594. IF(IELE.EQ.10) NCOT=4
  595. IF(IELE.EQ.15) NCOT=12
  596. IF(IELE.EQ.17) NCOT=9
  597. IF(IELE.EQ.24) NCOT=6
  598. IF(NCOT.EQ.0) THEN
  599. CALL ERREUR(5)
  600. GOTO 510
  601. ENDIF
  602. *
  603. * CAS NON ISOTROPES
  604. * RECUPERATION DES FONCTIONS DE FORME ET LEURS DERIVEES
  605. * AU CENTRE DE L'ELEMENT POUR LE CALCUL DES AXES LOCAUX
  606. *
  607. IPMIN2 = 0
  608. IF ( (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1 ) THEN
  609. CALL RESHPT(1,NBNO,IELE,MELE,0,IPMIN2,IRT1)
  610. MINTE2=IPMIN2
  611. SEGACT MINTE2
  612. SEGINI WRK8
  613. NSTMU=LHOOK
  614. ENDIF
  615. *
  616. SEGINI WRK1,WRK2,WRK5,WRK55
  617. *
  618. DO 3079 IB=1,NBELEM
  619. *
  620. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  621. *
  622. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  623. *
  624. * CALCUL DES AXES LOCAUX DANS LES CAS NON ISOTROPES
  625. *
  626. C* IF((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4)
  627. C* . .AND.IMAT.EQ.1)THEN
  628. IF (IPMIN2.NE.0) THEN
  629. NBSH=MINTE2.SHPTOT(/2)
  630. CALL RLOCAL (XE,MINTE2.SHPTOT,NBSH,NBNN,TXR)
  631. if (nbsh.eq.-1) then
  632. call erreur(525)
  633. goto 9979
  634. endif
  635. ENDIF
  636. *
  637. CALL ZERO (REL,LRE,LRE)
  638. *
  639. * TRAITEMENT POUR NOEUDS MILIEUX PRESSION
  640. *
  641. FREF = 1.D6
  642. CALL BNPOR2(YGENE,NCOT,IELE)
  643. IF(IERR.NE.0) GOTO 9979
  644. *
  645. * DO 27895 IOI=1,NCOT
  646. * WRITE(6,28927) IOI
  647. *28927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3)
  648. * WRITE(6,28928) (YGENE(IOI,J),J=1,NBNN)
  649. *28928 FORMAT(8(1X,1PE10.3))
  650. *27895 CONTINUE
  651. C
  652. C BOUCLE SUR LES POINTS DE GAUSS
  653. C
  654. ISDJC=0
  655. DO 4079 IGAU=1,NBPGAU
  656. C
  657. C RECUPERATION DE L'EPAISSEUR
  658. C
  659. IF (IFOUR.EQ.-2)THEN
  660. MPTVAL=IVACAR
  661. IF (IVACAR.NE.0) THEN
  662. MELVAL=IVAL(1)
  663. IF (MELVAL.NE.0) THEN
  664. IGMN=MIN(IGAU,VELCHE(/1))
  665. IBMN=MIN(IB,VELCHE(/2))
  666. DIM3=VELCHE(IGMN,IBMN)
  667. ELSE
  668. DIM3=1.D0
  669. ENDIF
  670. ENDIF
  671. ENDIF
  672. C
  673. CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
  674. . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
  675. IF (DJAC.EQ.0.D0) THEN
  676. INTERR(1)=IB
  677. CALL ERREUR(259)
  678. GOTO 9979
  679. ENDIF
  680. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  681. DJAC=ABS(DJAC)*POIGAU(IGAU)
  682. C
  683. * IF(IGAU.EQ.1) THEN
  684. * DO 27892 IOI=1,LHOOK
  685. * WRITE(6,28920) IOI
  686. *28920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3)
  687. * WRITE(6,28921) (BGENE(IOI,J),J=1,LRE)
  688. *28921 FORMAT(8(1X,1PE10.3))
  689. *27892 CONTINUE
  690. * DO 27893 IOI=1,NSTN
  691. * WRITE(6,28922) IOI
  692. *28922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3)
  693. * WRITE(6,28923) (XGENE(IOI,J),J=1,LRN)
  694. *28923 FORMAT(8(1X,1PE10.3))
  695. *27893 CONTINUE
  696. * ENDIF
  697.  
  698. MPTVAL=IVAMAT
  699. C*D IF(IMAT.EQ.2) THEN
  700. C*D GO TO 99
  701. C*D ELSE IF (IMAT.EQ.1) THEN
  702. *
  703. DO 9079 IM=1,NMATT
  704. IF (IVAL(IM).NE.0) THEN
  705. MELVAL=IVAL(IM)
  706. IBMN=MIN(IB ,VELCHE(/2))
  707. IGMN=MIN(IGAU,VELCHE(/1))
  708. VALMAT(IM)=VELCHE(IGMN,IBMN)
  709. ELSE
  710. VALMAT(IM)=0.D0
  711. ENDIF
  712. 9079 CONTINUE
  713. *
  714. IF(MATE.EQ.1) THEN
  715. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  716. . CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  717. DO 4879 I=1,NSTMU
  718. COBMA(I) =VALMAT(3)
  719. 4879 CONTINUE
  720. XMOB =VALMAT(4)
  721. *
  722. ELSE IF(MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  723. IF(IGAU.LE.NBGMAT)
  724. . CALL PORMAO(VALMAT,CMATE,IFOUR,IDIM,TXR,XLOC,XGLOB,D1HO,
  725. . ROTH,DDHOOK,LHOOK,COBMA,XMOB,1,IRTD)
  726. C*D ELSE
  727. C*D GO TO 99
  728. ENDIF
  729. *
  730. C*D ENDIF
  731. *
  732. CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE,
  733. . IGAU,IMAT,0.D0)
  734. EREF =1.D0
  735. DJACER=DJAC*EREF
  736. DO 4179 I=1,LRB
  737. DO 4179 J=1,LRN
  738. JJ=J+LRB
  739. r_z = DJACER*XGENE(1,J)
  740. DO 4179 K=1,NSTMU
  741. REL(JJ,I)=REL(JJ,I)-COBMA(K)*r_z*BGENE(K,I)
  742. 4179 CONTINUE
  743. *
  744. IF(XMOB.EQ.0.D0) THEN
  745. UNSURM=0.D0
  746. ELSE
  747. UNSURM=1.D0 / XMOB
  748. ENDIF
  749. COMJAC=UNSURM*DJAC*EREF*EREF
  750. DO 4279 I=1,LRN
  751. II=I+LRB
  752. r_z = COMJAC*XGENE(1,I)
  753. DO 4279 J=1,I
  754. JJ=J+LRB
  755. REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J)
  756. 4279 CONTINUE
  757. C
  758. COMJAC=UNSURM*DJAC*FREF
  759. DO 4379 I=1,NBNN
  760. II=I+LRB
  761. DO 4379 J=1,I
  762. JJ=J+LRB
  763. DO 4379 K=1,NCOT
  764. REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J)
  765. 4379 CONTINUE
  766. *
  767. 4079 CONTINUE
  768. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  769. INTERR(1)=IB
  770. CALL ERREUR(195)
  771. noer=195
  772. GOTO 9979
  773. ENDIF
  774. C
  775. C REMPLISSAGE DE XMATRI
  776. C
  777. CALL REMPMT(REL,LRE,RE(1,1,ib))
  778. *
  779. 3079 CONTINUE
  780. c
  781. IF(IRTD.EQ.0) THEN
  782. MOTERR(1:8)=CMATE
  783. MOTERR(9:16)=NOMFR(MFR/2+1)
  784. INTERR(1)=IFOUR
  785. CALL ERREUR(81)
  786. ENDIF
  787. 9979 CONTINUE
  788. SEGSUP WRK1,WRK2,WRK5,WRK55
  789. C* IF ((MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4).AND.IMAT.EQ.1) THEN
  790. IF (IPMIN2.NE.0) THEN
  791. SEGDES MINTE2
  792. SEGSUP WRK8
  793. ENDIF
  794. GOTO 510
  795. C_______________________________________________________________________
  796. C
  797. C MILIEUX POREUX - SUITE
  798. C_______________________________________________________________________
  799. C
  800. 173 CONTINUE
  801. C
  802. C CAS NON ISOTROPES NON PREVUS ACTUELLEMENT
  803. IF (IMAT.EQ.1) THEN
  804. IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4) THEN
  805. CALL ERREUR(251)
  806. GO TO 510
  807. ENDIF
  808. ELSE
  809. C* ELSE IF (IMAT.EQ.2) THEN
  810. GO TO 99
  811. ENDIF
  812. C
  813. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  814. C NBNO = NOMBRE DE FONCTIONS DE FORME
  815. C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  816. C
  817. IF(MFR.EQ.57) IDECAP=2
  818. IF(MFR.EQ.59) IDECAP=3
  819. *
  820. DIM3=1.D0
  821. NCOT=0
  822. NBNO=IPORE
  823. NBBB=NBNN
  824. NSTN=IDECAP
  825. *
  826. **************** AM 08/01/01
  827. ***** NSTMU=2
  828. ***** IF(IFOUR.GE.0) NSTMU=3
  829. *
  830. NSTMU=3
  831. LPP=NBNO-NBBB
  832. LRN = IDECAP*LPP
  833. **** LRB=LRE-LRN
  834. LRB=LRE-(IDECAP*NBBB)
  835. IELE=NUMGEO(MELE)
  836. *
  837. IF(IELE.EQ.6 ) NCOT=3
  838. IF(IELE.EQ.10) NCOT=4
  839. IF(IELE.EQ.15) NCOT=12
  840. IF(IELE.EQ.17) NCOT=9
  841. IF(IELE.EQ.24) NCOT=6
  842. IF(NCOT.EQ.0) THEN
  843. CALL ERREUR(5)
  844. GO TO 510
  845. ENDIF
  846. *
  847. SEGINI WRK1,WRK2,WRK5,WRK55,WRK555
  848.  
  849. DO 3173 IB=1,NBELEM
  850. *
  851. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  852. *
  853. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  854. *
  855. CALL ZERO (REL,LRE,LRE)
  856. *
  857. * TRAITEMENT POUR NOEUDS MILIEUX PRESSION
  858. *
  859. FREF = 1.D6
  860. CALL BNPOR2(YGENE,NCOT,IELE)
  861. IF(IERR.NE.0) GO TO 9973
  862.  
  863. * DO 17895 IOI=1,NCOT
  864. * WRITE(6,78927) IOI
  865. *78927 FORMAT(2X,' MATRICE YGENE - LIGNE ',I3)
  866. * WRITE(6,78928) (YGENE(IOI,J),J=1,NBNN)
  867. *78928 FORMAT(8(1X,1PE10.3))
  868. *17895 CONTINUE
  869. C
  870. C BOUCLE SUR LES POINTS DE GAUSS
  871. C
  872. ISDJC=0
  873. DO 4173 IGAU=1,NBPGAU
  874. C
  875. C RECUPERATION DE L'EPAISSEUR
  876. C
  877. IF (IFOUR.EQ.-2)THEN
  878. MPTVAL=IVACAR
  879. IF (IVACAR.NE.0) THEN
  880. MELVAL=IVAL(1)
  881. IF (MELVAL.NE.0) THEN
  882. IGMN=MIN(IGAU,VELCHE(/1))
  883. IBMN=MIN(IB,VELCHE(/2))
  884. DIM3=VELCHE(IGMN,IBMN)
  885. ELSE
  886. DIM3=1.D0
  887. ENDIF
  888. ENDIF
  889. ENDIF
  890. C
  891. NSTB=LHOOK
  892. CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  893. . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1)
  894. IF(DJAC.EQ.0.D0) THEN
  895. INTERR(1)=IB
  896. CALL ERREUR(259)
  897. GOTO 9973
  898. ENDIF
  899. IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  900. DJAC=ABS(DJAC)*POIGAU(IGAU)
  901. C
  902. * IF(IGAU.EQ.1) THEN
  903. * DO 17892 IOI=1,LHOOK
  904. * WRITE(6,78920) IOI
  905. *78920 FORMAT(2X,' MATRICE BGENE - LIGNE ',I3)
  906. * WRITE(6,78921) (BGENE(IOI,J),J=1,LRE)
  907. *78921 FORMAT(8(1X,1PE10.3))
  908. *17892 CONTINUE
  909. * DO 17893 IOI=1,NSTN
  910. * WRITE(6,78922) IOI
  911. *78922 FORMAT(2X,' MATRICE XGENE - LIGNE ',I3)
  912. * WRITE(6,78923) (XGENE(IOI,J),J=1,LRN)
  913. *78923 FORMAT(8(1X,1PE10.3))
  914. *17893 CONTINUE
  915. * ENDIF
  916.  
  917. MPTVAL=IVAMAT
  918. C*D IF(IMAT.EQ.2) THEN
  919. C*D GO TO 99
  920. C*D ELSE IF (IMAT.EQ.1) THEN
  921. *
  922. DO 9173 IM=1,NMATT
  923. IF (IVAL(IM).NE.0) THEN
  924. MELVAL=IVAL(IM)
  925. IBMN=MIN(IB ,VELCHE(/2))
  926. IGMN=MIN(IGAU,VELCHE(/1))
  927. VALMAT(IM)=VELCHE(IGMN,IBMN)
  928. ELSE
  929. VALMAT(IM)=0.D0
  930. ENDIF
  931. 9173 CONTINUE
  932. *
  933. C*D IF(MATE.EQ.1) THEN
  934. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  935. . CALL DOHMAS(VALMAT,CMATE,IFOUR,LHOOK,1,DDHOOK,IRTD)
  936. *
  937. C*D ELSE
  938. C*D GO TO 99
  939. C*D ENDIF
  940. C*D ENDIF
  941. *
  942. CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL)
  943. EREF =1.D0
  944. *
  945. IF(MFR.EQ.57) THEN
  946. COBB(1) = VALMAT(3)
  947. COBB(2) = VALMAT(4)
  948. CPBB(1) = VALMAT(5)
  949. CPBB(2) = VALMAT(6)
  950. KKBB(1,1)= VALMAT(7)
  951. KKBB(1,2)= VALMAT(8)
  952. KKBB(2,1)= VALMAT(9)
  953. KKBB(2,2)= VALMAT(10)
  954. *
  955. ELSE IF(MFR.EQ.59) THEN
  956. COBB(1) = VALMAT(3)
  957. COBB(2) = VALMAT(4)
  958. COBB(3) = VALMAT(5)
  959. CPBB(1) = VALMAT(6)
  960. CPBB(2) = VALMAT(7)
  961. CPBB(3) = VALMAT(8)
  962. KKBB(1,1)= VALMAT(9)
  963. KKBB(1,2)= VALMAT(10)
  964. KKBB(1,3)= VALMAT(11)
  965. KKBB(2,1)= VALMAT(12)
  966. KKBB(2,2)= VALMAT(13)
  967. KKBB(2,3)= VALMAT(14)
  968. KKBB(3,1)= VALMAT(15)
  969. KKBB(3,2)= VALMAT(16)
  970. KKBB(3,3)= VALMAT(17)
  971. ENDIF
  972. *
  973. DJACER=DJAC*EREF
  974.  
  975. DO 6673 IPR=1,IDECAP
  976. LRBDEC=LRB + (IPR-1)*NBBB
  977. LPPDEC= (IPR-1)*LPP
  978. COMJAC=COBB(IPR)*DJACER
  979. DO 4973 I=1,LRB
  980. DO 4973 J=1,LPP
  981. JJ=J+LRBDEC
  982. JX=J+LPPDEC
  983. r_z = COMJAC*XGENE(IPR,JX)
  984. DO 4973 K=1,NSTMU
  985. REL(I,JJ)=REL(I,JJ)-r_z*BGENE(K,I)
  986. 4973 CONTINUE
  987. 6673 CONTINUE
  988. *
  989. DO 6674 IPR=1,IDECAP
  990. LRBDEC=LRB + (IPR-1)*NBBB
  991. LPPDEC= (IPR-1)*LPP
  992. COMJAC=CPBB(IPR)*DJACER
  993. DO 4974 I=1,LRB
  994. DO 4974 J=1,LPP
  995. JJ=J+LRBDEC
  996. JX=J+LPPDEC
  997. r_z = COMJAC*XGENE(IPR,JX)
  998. DO 4974 K=1,NSTMU
  999. * ici - pour bsig
  1000. REL(JJ,I)=REL(JJ,I)-r_z*BGENE(K,I)
  1001. 4974 CONTINUE
  1002. 6674 CONTINUE
  1003. *
  1004. COMJAC=DJAC*EREF*EREF
  1005. CALL ZERO(XREL,LRN,LRN)
  1006. CALL BDBSTS(XGENE,COMJAC,KKBB,LRN,NSTN,XREL)
  1007.  
  1008. DO 6873 IPR=1,IDECAP
  1009. IRBDEC=LRB + (IPR-1)*NBBB
  1010. IPPDEC= (IPR-1)*LPP
  1011. DO 6873 JPR=1,IDECAP
  1012. JRBDEC=LRB + (JPR-1)*NBBB
  1013. JPPDEC= (JPR-1)*LPP
  1014. DO 4273 I=1,LPP
  1015. II=I+IRBDEC
  1016. IX=I+IPPDEC
  1017. DO 4273 J=1,LPP
  1018. JJ=J+JRBDEC
  1019. JX=J+JPPDEC
  1020.  
  1021. * IF(IGAU.EQ.1) THEN
  1022. * PRINT *,'I =',I,' IX=',IX,' II=',II
  1023. * PRINT *,'J =',J,' JX=',JX,' JJ=',JJ, ' XREL=',XREL(IX,JX)
  1024. * ENDIF
  1025.  
  1026. REL(II,JJ)=REL(II,JJ)-XREL(IX,JX)
  1027. 4273 CONTINUE
  1028. 6873 CONTINUE
  1029. C
  1030. DO 6973 IPR=1,IDECAP
  1031. COMJAC=KKBB(IPR,IPR)*DJAC*FREF
  1032. LRBDEC=LRB + (IPR-1)*NBBB
  1033. DO 4373 I=1,NBNN
  1034. II=I+LRBDEC
  1035. DO 4373 J=1,NBNN
  1036. JJ=J+LRBDEC
  1037. DO 4374 K=1,NCOT
  1038. REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J)
  1039. 4374 CONTINUE
  1040. 4373 CONTINUE
  1041. 6973 CONTINUE
  1042. *
  1043. 4173 CONTINUE
  1044. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1045. INTERR(1)=IB
  1046. CALL ERREUR(195)
  1047. noer=195
  1048. GOTO 9973
  1049. ENDIF
  1050. C
  1051. C REMPLISSAGE DE XMATRI
  1052. C
  1053. CALL REMPMS(REL,LRE,RE(1,1,ib))
  1054. 3173 CONTINUE
  1055. c
  1056. IF(IRTD.EQ.0) THEN
  1057. MOTERR(1:8)=CMATE
  1058. MOTERR(9:16)=NOMFR(MFR/2+1)
  1059. INTERR(1)=IFOUR
  1060. CALL ERREUR(81)
  1061. ENDIF
  1062. 9973 CONTINUE
  1063. SEGSUP WRK1,WRK2,WRK5,WRK55,WRK555
  1064. GOTO 510
  1065. C_______________________________________________________________________
  1066. C
  1067. C JOINTS EN FORMULATION MILIEUX POREUX
  1068. C_______________________________________________________________________
  1069. C
  1070. 80 CONTINUE
  1071. C
  1072. * CAS NON PREVUS
  1073. IF (IMAT.EQ.1) THEN
  1074. IF (MATE.NE.1) GOTO 99
  1075. ELSE IF (IMAT.EQ.2) THEN
  1076. GOTO 99
  1077. ENDIF
  1078. C
  1079. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  1080. C NBNO = NOMBRE DE FONCTIONS DE FORME
  1081. C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  1082. C
  1083. NCOT=0
  1084. NBNO=IPORE
  1085. NBBB=NBNN
  1086. NSTN=1
  1087. NSTMU=2
  1088. IF(IFOUR.EQ.2) NSTMU=3
  1089. LRN=(NBNO-NBBB)*3/2
  1090. LPP=LRN
  1091. LRB=LRE-NBNN
  1092. IELE=NUMGEO(MELE)
  1093. IF(IELE.EQ.29) NCOT=2
  1094. IF(IELE.EQ.30) NCOT=6
  1095. IF(IELE.EQ.31) NCOT=8
  1096. IF(NCOT.EQ.0) THEN
  1097. CALL ERREUR(5)
  1098. GO TO 510
  1099. ENDIF
  1100. *
  1101. SEGINI WRK1,WRK2,WRK3,WRK5,WRK55
  1102. *
  1103. DO 3080 IB=1,NBELEM
  1104. *
  1105. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1106. *
  1107. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1108. *
  1109. * CALCUL DES AXES LOCAUX ET DES COORDONNES LOCALES
  1110. *
  1111. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1112. *
  1113. CALL ZERO (REL,LRE,LRE)
  1114. *
  1115. CALL INTDEL(XNTH,XNTB,XNTT,LRN,MELE)
  1116. *
  1117. * TRAITEMENT POUR NOEUDS MILIEUX PRESSION
  1118. *
  1119. FREF = 1.D6
  1120. CALL BNPOR2(YGENE,NCOT,IELE)
  1121. IF (IERR.NE.0) GOTO 9980
  1122. *
  1123. * BOUCLE SUR LES POINTS DE GAUSS
  1124. *
  1125. ISDJC=0
  1126. DO 4080 IGAU=1,NBPGAU
  1127. *
  1128. CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  1129. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
  1130. IF (DJAC.EQ.0.D0) THEN
  1131. INTERR(1)=IB
  1132. CALL ERREUR(259)
  1133. GOTO 9980
  1134. ENDIF
  1135. IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  1136. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1137. *
  1138. MPTVAL=IVAMAT
  1139. C*D IF(IMAT.EQ.2) THEN
  1140. C*D GO TO 99
  1141. C*D ELSE IF (IMAT.EQ.1) THEN
  1142. *
  1143. DO 9080 IM=1,NMATT
  1144. IF (IVAL(IM).NE.0) THEN
  1145. MELVAL=IVAL(IM)
  1146. IBMN=MIN(IB ,VELCHE(/2))
  1147. IGMN=MIN(IGAU,VELCHE(/1))
  1148. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1149. ELSE
  1150. VALMAT(IM)=0.D0
  1151. ENDIF
  1152. 9080 CONTINUE
  1153. *
  1154. C*D IF(MATE.EQ.1) THEN
  1155. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1156. . CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1157.  
  1158. C*D ELSE
  1159. C*D GO TO 99
  1160. C*D ENDIF
  1161. C*D ENDIF
  1162. *
  1163. CALL BDBS1(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL,MFR,IFOUR,MATE,
  1164. . IGAU,IMAT,0.D0)
  1165. EREF =1.D0
  1166. *
  1167. COBMA(NSTMU)=VALMAT(3)
  1168. XMOB=VALMAT(4)
  1169. *
  1170. IF(XMOB.EQ.0.D0) THEN
  1171. UNSURM=0.D0
  1172. ELSE
  1173. UNSURM=1.D0 / XMOB
  1174. ENDIF
  1175. *
  1176. DJACER=DJAC*EREF
  1177. DO 4180 I=1,LRB
  1178. DO 4180 J=1,LRN
  1179. JJ=J+LRB
  1180. r_z = DJACER*XGENE(1,J)*XNTT(J)
  1181. REL(JJ,I)=REL(JJ,I)-r_z*COBMA(NSTMU)*BGENE(NSTMU,I)
  1182. 4180 CONTINUE
  1183. *
  1184. COMJAC=UNSURM*DJAC*EREF*EREF
  1185. DO 4280 I=1,LRN
  1186. II=I+LRB
  1187. r_z = COMJAC*XGENE(1,I)*XNTT(I)
  1188. DO 4280 J=1,I
  1189. JJ=J+LRB
  1190. REL(II,JJ)=REL(II,JJ)-r_z*XGENE(1,J)*XNTT(J)
  1191. 4280 CONTINUE
  1192. *
  1193. COMJAC=UNSURM*DJAC*FREF
  1194. DO 4380 I=1,NBNN
  1195. II=I+LRB
  1196. DO 4380 J=1,I
  1197. JJ=J+LRB
  1198. DO 4380 K=1,NCOT
  1199. REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J)
  1200. 4380 CONTINUE
  1201. *
  1202. 4080 CONTINUE
  1203. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1204. INTERR(1)=IB
  1205. CALL ERREUR(195)
  1206. noer=195
  1207. GOTO 9980
  1208. ENDIF
  1209. *
  1210. * REMPLISSAGE DE XMATRI
  1211. *
  1212. CALL REMPMT(REL,LRE,RE(1,1,IB))
  1213. 3080 CONTINUE
  1214.  
  1215. IF(IRTD.EQ.0) THEN
  1216. MOTERR(1:8)=CMATE
  1217. MOTERR(9:16)=NOMFR(MFR/2+1)
  1218. INTERR(1)=IFOUR
  1219. CALL ERREUR(81)
  1220. ENDIF
  1221. 9980 CONTINUE
  1222. SEGSUP WRK1,WRK2,WRK3,WRK5,WRK55
  1223. GOTO 510
  1224. *
  1225. C_______________________________________________________________________
  1226. C
  1227. C JOINTS EN FORMULATION MILIEUX POREUX - SUITE
  1228. C_______________________________________________________________________
  1229. C
  1230. 185 CONTINUE
  1231.  
  1232. C
  1233. * CAS NON ISOTROPES NON PREVUS ACTUELLEMENT
  1234. IF (IMAT.EQ.1) THEN
  1235. IF (MATE.NE.1) GOTO 99
  1236. ELSE
  1237. GOTO 99
  1238. ENDIF
  1239. C
  1240. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  1241. C NBNO = NOMBRE DE FONCTIONS DE FORME
  1242. C ON ENLEVE LA PRESSION POREUSE DES CONTRAINTES
  1243. C
  1244. IF(MFR.EQ.57) IDECAP=2
  1245. IF(MFR.EQ.59) IDECAP=3
  1246. *
  1247. NCOT=0
  1248. NBNO=IPORE
  1249. NBBB=NBNN
  1250. NSTN=IDECAP
  1251. NSTMU=2
  1252. IF(IFOUR.EQ.2) NSTMU=3
  1253. LPP=(NBNO-NBBB)*3/2
  1254. LRN=IDECAP*LPP
  1255. LRB=LRE-IDECAP*NBNN
  1256. IELE=NUMGEO(MELE)
  1257. IF(IELE.EQ.29) NCOT=2
  1258. IF(IELE.EQ.30) NCOT=6
  1259. IF(IELE.EQ.31) NCOT=8
  1260. IF(NCOT.EQ.0) THEN
  1261. CALL ERREUR(5)
  1262. GO TO 510
  1263. ENDIF
  1264. *
  1265. SEGINI WRK1,WRK2,WRK3,WRK5,WRK55,WRK555
  1266. *
  1267. DO 3185 IB=1,NBELEM
  1268. *
  1269. * ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  1270. *
  1271. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1272. *
  1273. * CALCUL DES AXES LOCAUX ET DES COORDONNES LOCALES
  1274. *
  1275. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  1276. *
  1277. CALL ZERO (REL,LRE,LRE)
  1278. *
  1279. CALL INTDEL(XNTH,XNTB,XNTT,LPP,MELE)
  1280. *
  1281. * TRAITEMENT POUR NOEUDS MILIEUX PRESSION
  1282. *
  1283. FREF = 1.D6
  1284. CALL BNPOR2(YGENE,NCOT,IELE)
  1285. IF (IERR.NE.0) GOTO 9985
  1286. *
  1287. * BOUCLE SUR LES POINTS DE GAUSS
  1288. *
  1289. ISDJC=0
  1290. DO 4185 IGAU=1,NBPGAU
  1291. *
  1292. NSTB=LHOOK
  1293. CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  1294. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1)
  1295. IF (DJAC.EQ.0.D0) THEN
  1296. INTERR(1)=IB
  1297. CALL ERREUR(259)
  1298. GOTO 9985
  1299. ENDIF
  1300. IF(DJAC.LT.0.D0) ISDJC=ISDJC+1
  1301. DJAC=ABS(DJAC)*POIGAU(IGAU)
  1302. *
  1303. MPTVAL=IVAMAT
  1304. C*D IF(IMAT.EQ.2) THEN
  1305. C*D GO TO 99
  1306. C*D ELSE IF (IMAT.EQ.1) THEN
  1307. *
  1308. DO 9185 IM=1,NMATT
  1309. IF (IVAL(IM).NE.0) THEN
  1310. MELVAL=IVAL(IM)
  1311. IBMN=MIN(IB ,VELCHE(/2))
  1312. IGMN=MIN(IGAU,VELCHE(/1))
  1313. VALMAT(IM)=VELCHE(IGMN,IBMN)
  1314. ELSE
  1315. VALMAT(IM)=0.D0
  1316. ENDIF
  1317. 9185 CONTINUE
  1318. *
  1319. C*D IF(MATE.EQ.1) THEN
  1320. IF (IGAU.LE.NBGMAT.AND.(IB.LE.NELMAT.OR.NBGMAT.GT.1))
  1321. . CALL DOUO88(VALMAT,CMATE,IFOUR,LHOOK,DDHOOK,IRTD)
  1322.  
  1323. C*D ELSE
  1324. C*D GO TO 99
  1325. C*D ENDIF
  1326. C*D ENDIF
  1327. *
  1328. CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,LHOOK,REL)
  1329.  
  1330. EREF =1.D0
  1331. *
  1332. IF(MFR.EQ.57) THEN
  1333. COBB(1) = VALMAT(3)
  1334. COBB(2) = VALMAT(4)
  1335. CPBB(1) = VALMAT(5)
  1336. CPBB(2) = VALMAT(6)
  1337. KKBB(1,1)= VALMAT(7)
  1338. KKBB(1,2)= VALMAT(8)
  1339. KKBB(2,1)= VALMAT(9)
  1340. KKBB(2,2)= VALMAT(10)
  1341. *
  1342. ELSE IF(MFR.EQ.59) THEN
  1343. COBB(1) = VALMAT(3)
  1344. COBB(2) = VALMAT(4)
  1345. COBB(3) = VALMAT(5)
  1346. CPBB(1) = VALMAT(6)
  1347. CPBB(2) = VALMAT(7)
  1348. CPBB(3) = VALMAT(8)
  1349. KKBB(1,1)= VALMAT(9)
  1350. KKBB(1,2)= VALMAT(10)
  1351. KKBB(1,3)= VALMAT(11)
  1352. KKBB(2,1)= VALMAT(12)
  1353. KKBB(2,2)= VALMAT(13)
  1354. KKBB(2,3)= VALMAT(14)
  1355. KKBB(3,1)= VALMAT(15)
  1356. KKBB(3,2)= VALMAT(16)
  1357. KKBB(3,3)= VALMAT(17)
  1358. ENDIF
  1359. *
  1360. DO 6684 IPR=1,IDECAP
  1361. LPPDEC= (IPR-1)*LPP
  1362. DO 6684 J=1,LPP
  1363. JX=J+LPPDEC
  1364. XGENE(IPR,JX)= XGENE(IPR,JX)*XNTT(J)
  1365. 6684 CONTINUE
  1366. *
  1367. *
  1368. DJACER=DJAC*EREF
  1369.  
  1370. DO 6685 IPR=1,IDECAP
  1371. LRBDEC=LRB + (IPR-1)*NBBB
  1372. LPPDEC= (IPR-1)*LPP
  1373. COMJAC=COBB(IPR)*DJACER
  1374. DO 4585 I=1,LRB
  1375. DO 4585 J=1,LPP
  1376. JJ=J+LRBDEC
  1377. JX=J+LPPDEC
  1378. r_z = COMJAC*XGENE(IPR,JX)
  1379. REL(I,JJ)=REL(I,JJ)-r_z*BGENE(NSTMU,I)
  1380. 4585 CONTINUE
  1381. 6685 CONTINUE
  1382. *
  1383.  
  1384. DO 6686 IPR=1,IDECAP
  1385. LRBDEC=LRB + (IPR-1)*NBBB
  1386. LPPDEC= (IPR-1)*LPP
  1387. COMJAC=CPBB(IPR)*DJACER
  1388. DO 4586 I=1,LRB
  1389. DO 4586 J=1,LPP
  1390. JJ=J+LRBDEC
  1391. JX=J+LPPDEC
  1392. r_z = COMJAC*XGENE(IPR,JX)
  1393. REL(JJ,I)=REL(JJ,I)-r_z*BGENE(NSTMU,I)
  1394. 4586 CONTINUE
  1395. 6686 CONTINUE
  1396. *
  1397. COMJAC=DJAC*EREF*EREF
  1398. CALL ZERO(XREL,LRN,LRN)
  1399. CALL BDBSTS(XGENE,COMJAC,KKBB,LRN,NSTN,XREL)
  1400.  
  1401. DO 6885 IPR=1,IDECAP
  1402. IRBDEC=LRB + (IPR-1)*NBBB
  1403. IPPDEC= (IPR-1)*LPP
  1404. DO 6885 JPR=1,IDECAP
  1405. JRBDEC=LRB + (JPR-1)*NBBB
  1406. JPPDEC= (JPR-1)*LPP
  1407. DO 4285 I=1,LPP
  1408. II=I+IRBDEC
  1409. IX=I+IPPDEC
  1410. DO 4285 J=1,LPP
  1411. JJ=J+JRBDEC
  1412. JX=J+JPPDEC
  1413.  
  1414. * IF(IGAU.EQ.1) THEN
  1415. * PRINT *,'I =',I,' IX=',IX,' II=',II
  1416. * PRINT *,'J =',J,' JX=',JX,' JJ=',JJ, ' XREL=',XREL(IX,JX)
  1417. * ENDIF
  1418.  
  1419. REL(II,JJ)=REL(II,JJ)-XREL(IX,JX)
  1420. 4285 CONTINUE
  1421. 6885 CONTINUE
  1422. *
  1423.  
  1424. DO 6975 IPR=1,IDECAP
  1425. COMJAC=KKBB(IPR,IPR)*DJAC*FREF
  1426. LRBDEC=LRB + (IPR-1)*NBBB
  1427. DO 4385 I=1,NBNN
  1428. II=I+LRBDEC
  1429. DO 4385 J=1,NBNN
  1430. JJ=J+LRBDEC
  1431. DO 4375 K=1,NCOT
  1432. REL(II,JJ)=REL(II,JJ)+COMJAC*YGENE(K,I)*YGENE(K,J)
  1433. 4375 CONTINUE
  1434. 4385 CONTINUE
  1435. 6975 CONTINUE
  1436. *
  1437. 4185 CONTINUE
  1438. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  1439. INTERR(1)=IB
  1440. CALL ERREUR(195)
  1441. noer=195
  1442. GOTO 9980
  1443. ENDIF
  1444. *
  1445. * REMPLISSAGE DE XMATRI
  1446. *
  1447. CALL REMPMS(REL,LRE,RE(1,1,IB))
  1448. 3185 CONTINUE
  1449.  
  1450. IF(IRTD.EQ.0) THEN
  1451. MOTERR(1:8)=CMATE
  1452. MOTERR(9:16)=NOMFR(MFR/2+1)
  1453. INTERR(1)=IFOUR
  1454. CALL ERREUR(81)
  1455. ENDIF
  1456. 9985 CONTINUE
  1457. SEGSUP WRK1,WRK2,WRK3,WRK5,WRK55,WRK555
  1458. GOTO 510
  1459. *
  1460. * ERREUR : CAS NON PREVU
  1461. *
  1462. 99 CONTINUE
  1463. MOTERR(1:4)=NOMTP(MELE)
  1464. MOTERR(5:12)='RIGI2 '
  1465. CALL ERREUR(86)
  1466. *
  1467. 510 CONTINUE
  1468. * WRITE (*,*) 'Sortie de RIGI2.'
  1469. * SEGDES,XMATRI
  1470. SEGSUP,MVELCH
  1471.  
  1472. RETURN
  1473. END
  1474.  
  1475.  
  1476.  
  1477.  
  1478.  
  1479.  
  1480.  
  1481.  
  1482.  

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