Télécharger bsigm1.eso

Retour à la liste

Numérotation des lignes :

  1. C BSIGM1 SOURCE KICH 18/01/12 21:15:10 9691
  2. SUBROUTINE BSIGM1(IPMAIL,LRE,NSTRS,NBPGAU,MELE,MFR,IVASTR,
  3. & IPMINT,IVACAR,IPORE,LHOOK,NFOR,IVAFOR,ADPG,BDPG,CDPG,
  4. & IIPDPG,NCAR1)
  5. *----------------------------------------------------------------------
  6. * ______________________________ *
  7. * | | *
  8. * | CALCUL DES FORCES AUX NOEUDS| *
  9. * |______________________________| *
  10. * *
  11. * massif, poreux, incompressibles *
  12. * *
  13. *---------------------------------------------------------------------*
  14. * *
  15. * ENTREES : *
  16. * ________ *
  17. * *
  18. * IPMAIL Pointeur sur un segment MELEME ACTIF E/S *
  19. * LRE Nombre de ddl dans la matrice de rigidite *
  20. * NSTRS Nombre de composante de contraintes/deformations *
  21. * NBPGAU Nombre de points d'integration pour les contraintes *
  22. * MELE Numero de l'element fini *
  23. * MFR Numero de la formulation *
  24. * IVASTR pointeur sur un segment MPTVAL contenant les *
  25. * les melvals de contraints *
  26. * IPMINT Pointeur sur un segment MINTE ACTIF E/S *
  27. * IVACAR pointeur sur un segment MPTVAL de caracteristiques *
  28. * IPORE Nombre de fonctions de forme *
  29. * LHOOK Taille de la matrice de hooke *
  30. * NFOR Nombre de composantes de forces *
  31. * *
  32. * SORTIES : *
  33. * ________ *
  34. * *
  35. * IVAFOR pointeur sur un segment MPTVAL contenant les *
  36. * les melvals de forces *
  37. * *
  38. * ADPG forces aux noeud support des *
  39. * BDPG deformations planes generalisees *
  40. * CDPG *
  41. * *
  42. *---------------------------------------------------------------------*
  43. IMPLICIT INTEGER(I-N)
  44. IMPLICIT REAL*8(A-H,O-Z)
  45.  
  46. -INC CCOPTIO
  47. -INC CCREEL
  48. -INC CCHAMP
  49. -INC CCGEOME
  50.  
  51. -INC SMCHAML
  52. -INC SMCHPOI
  53. -INC SMELEME
  54. -INC SMCOORD
  55. -INC SMMODEL
  56. -INC SMINTE
  57. C
  58. SEGMENT MWRK1
  59. REAL*8 XFORC(LRE), XFINC(LRE),XSTRS(NSTRS), XE(3,NBBB)
  60. REAL*8 SHPWRK(6,NBNO), BGENE(LHOOK,LRE)
  61. ENDSEGMENT
  62. *
  63. SEGMENT MWRK3
  64. REAL*8 BPSS(3,3),XEL(3,NBBB)
  65. ENDSEGMENT
  66. *
  67. SEGMENT MWRK5
  68. REAL*8 XGENE(NSTN,LRN)
  69. ENDSEGMENT
  70. *
  71. segment mwrk67
  72. real*8 valcar(nca1)
  73. endsegment
  74. *
  75. SEGMENT MPTVAL
  76. INTEGER IPOS(NS) ,NSOF(NS)
  77. INTEGER IVAL(NCOSOU)
  78. CHARACTER*16 TYVAL(NCOSOU)
  79. ENDSEGMENT
  80. *
  81. CHARACTER*8 CMATE,CELEM
  82. DIMENSION A(4,60),BB(3,60),xatef1(3,3),PP(4,4)
  83. logical drend
  84. *
  85. MELEME=IPMAIL
  86. NBNN=NUM(/1)
  87. NBELEM=NUM(/2)
  88. *
  89. IDECAP=0
  90. NHRM=NIFOUR
  91. IELE=NUMGEO(MELE)
  92. *
  93. MINTE=IPMINT
  94. C_______________________________________________________________________
  95. C
  96. C NUMERO DES ETIQUETTES :
  97. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  98. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  99. C 5 CONTINUE
  100. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  101. C 44 CONTINUE
  102. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  103. C_______________________________________________________________________
  104. C
  105. GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  106. 1 99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  107. 2 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  108. 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,79,79,
  109. 4 79,79,79,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  110. 5 99,99,99,99,99,99,99,80,80,80, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
  111. 6 4, 4),MELE
  112. *
  113. IF (MELE.EQ.183.OR.MELE.EQ.184.OR.
  114. . MELE.EQ.193.OR.MELE.EQ.194) GOTO 4
  115. IF(MELE.GE.173.AND.MELE.LE.182) GO TO 173
  116. IF(MELE.GE.185.AND.MELE.LE.190) GO TO 185
  117. IF (MELE.EQ.273.OR.MELE.EQ.274) GOTO 4
  118. *
  119. GOTO 99
  120. C_______________________________________________________________________
  121. C
  122. C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET ELEMENTS INCOMPRESSIBLES
  123. C_______________________________________________________________________
  124. C
  125. 4 CONTINUE
  126. DIM3=1.D0
  127. NBNO=NBNN
  128. NBBB=NBNN
  129. C
  130. C INTRODUCTION DES COORD DU POINT AUTOUR DUQUEL SE FAIT LE
  131. C MOUVEMENT DE LA SECTION EN DEFO PLANE GENERALISEE
  132. C Pas de rotation en 1D
  133. C ET INITIALISATION DES FORCES AU NOEUD SUPPORT DE LA DEFO
  134. C PLANE GENERALISEE
  135. IF (IIPDPG.GT.0)THEN
  136. IREF=(IIPDPG-1)*(IDIM+1)
  137. XDPGE=XCOOR(IREF+1)
  138. YDPGE=XCOOR(IREF+2)
  139. ELSE
  140. XDPGE=XZero
  141. YDPGE=XZero
  142. ENDIF
  143. ADPG=XZero
  144. BDPG=XZero
  145. CDPG=XZero
  146. C
  147. SEGINI MWRK1
  148. mwrk67=0
  149.  
  150. DO 3004 IB=1,NBELEM
  151. C
  152. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  153. C
  154. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  155. C
  156. C MISE A 0 DES FORCES
  157. C
  158. CALL ZERO(XFINC,1,LRE)
  159. C
  160. C BOUCLE SUR LES POINTS DE GAUSS
  161. C
  162. ISDJC=0
  163. DO 5004 IGAU=1,NBPGAU
  164. C
  165. C RECUPERATION DE L'EPAISSEUR
  166. C
  167. IF (IFOUR.EQ.-2)THEN
  168. MPTVAL=IVACAR
  169. IF (IVACAR.NE.0) THEN
  170. MELVAL=IVAL(1)
  171. IF (MELVAL.NE.0) THEN
  172. IGMN=MIN(IGAU,VELCHE(/1))
  173. IBMN=MIN(IB,VELCHE(/2))
  174. DIM3=VELCHE(IGMN,IBMN)
  175. ELSE
  176. DIM3=1.D0
  177. ENDIF
  178. ENDIF
  179. ENDIF
  180. *
  181. C
  182. C CALCUL DES COEFF DE MODIFICATION DE LA MATRICE B-BARRE (INCOMPRES)
  183. C
  184. IF (MFR.EQ.31.and.igau.eq.1) THEN
  185. C= NOM : ICT3, ICQ4, ICT6, ICQ8, ICC8, ICT4, ICP6, IC20, IC10, IC15
  186. C= MELE : 69 , 70 , 71 , 72 , 73 , 74 , 75 , 76 , 77 , 78
  187. CALL BBCAL2(IB,IGAU,IDIM,NBPGAU,IVACAR,
  188. 1 POIGAU,QSIGAU,ETAGAU,DZEGAU,MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,
  189. 2 A,BB,XE,SHPTOT,SHPWRK,BGENE,XDPGE,YDPGE,PP)
  190. ENDIF
  191. *
  192. CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  193. 1 MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,
  194. 2 XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  195.  
  196.  
  197.  
  198. IF (DJAC.EQ.0.D0) THEN
  199. INTERR(1)=IB
  200. CALL ERREUR(259)
  201. GOTO 9904
  202. ENDIF
  203. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  204. *
  205. DJAC=ABS(DJAC)*POIGAU(IGAU)
  206.  
  207. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  208. IF (MFR.EQ.31) THEN
  209. CALL BBAR(IGAU,NBPGAU, POIGAU,QSIGAU,ETAGAU,DZEGAU,
  210. & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  211. ENDIF
  212. C
  213. C ON CHERCHE LES CONTRAINTES
  214. C
  215. MPTVAL=IVASTR
  216. DO 6004 ICOMP=1,NSTRS
  217. MELVAL=IVAL(ICOMP)
  218. IGMN=MIN(IGAU,VELCHE(/1))
  219. IBMN=MIN(IB ,VELCHE(/2))
  220. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  221. 6004 CONTINUE
  222. C
  223. C CALCUL DE B*SIGMA
  224. C
  225. * initialise
  226. CALL ZERO(XFORC,1,LRE)
  227. * contribution point d integration
  228. CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  229. * matrice d'efficacite
  230. drend = .false.
  231. MPTVAL=IVACAR
  232. IF (IVACAR.GT.0) THEN
  233. segact mptval
  234. nca1 = ival(/1)
  235. if (mwrk67.eq.0) segini mwrk67
  236. if (nca1.ne.valcar(/1)) segadj mwrk67
  237. celem = 'MASSIF '
  238. IF(IVAL(NCAR1).GT.0.OR.IVAL(NCAR1+1).GT.0) THEN
  239. DO 9008 IM= 1,IVAL(/1)
  240. IF (IVAL(IM).GT.0) THEN
  241. MELVAL=IVAL(IM)
  242. IF (TYVAL(IM).EQ.'REAL*8') THEN
  243. IBMN=MIN(IB ,VELCHE(/2))
  244. IGMN=MIN(IGAU,VELCHE(/1))
  245. VALCAR(IM)=VELCHE(IGMN,IBMN)
  246. ELSE
  247. IBMN=MIN(IB ,IELCHE(/2))
  248. IGMN=MIN(IGAU,IELCHE(/1))
  249. VALCAR(IM)=IELCHE(IGMN,IBMN)
  250. ENDIF
  251. ELSE
  252. VALCAR(IM)=0.D0
  253. ENDIF
  254. 9008 CONTINUE
  255. nstep = 2
  256. if (ifour.eq.2) nstep = 3
  257. if (ival(ncar1).gt.0.and.tyval(ncar1).eq.'REAL*8') then
  258. drend = .true.
  259. do i = 1,nstep
  260. do j = 1, nstep
  261. xatef1(i,j) = 0.d0
  262. enddo
  263. xatef1(i,i) = valcar(ncar1)
  264. enddo
  265. endif
  266. if (ival(ncar1).eq.0.and.tyval(ncar1+1).eq.'REAL*8') then
  267. drend = .false.
  268. do i = 1,nstep
  269. do j = 1, nstep
  270. xatef1(i,j) = 0.d0
  271. enddo
  272. xatef1(1,1) = valcar(ncar1+7)
  273. xatef1(2,2) = valcar(ncar1+8)
  274. if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9)
  275. enddo
  276. endif
  277. call effi3(valcar,tyval,nca1,ncar1,xforc,lre,ib,igau,xatef1,
  278. & nstep,drend,celem)
  279. ENDIF
  280. ENDIF
  281. * stocke
  282. do ii = 1,LRE
  283. xfinc(ii) = xfinc(ii) + xforc(ii)
  284. enddo
  285. *
  286. 5004 CONTINUE
  287.  
  288. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  289. INTERR(1)=IB
  290. CALL ERREUR(195)
  291. GOTO 9904
  292. ENDIF
  293. C
  294. C EXTRACTION DES FORCES AU NOEUD SUPPORT DE LA DEF PLAN GENE
  295. C ON CALCULE LES RESULTANTES DES FORCES SUR CHAQUE ELEMENT
  296. C
  297. NFOFO=NFOR
  298. if (IIPDPG.gt.0) then
  299. IF (IFOUR.EQ.-3) THEN
  300. NFOFO=NFOR-3
  301. ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  302. BDPG=BDPG+XFINC(NBNN*NFOFO+2)
  303. CDPG=CDPG+XFINC(NBNN*NFOFO+3)
  304. ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ.9.OR.
  305. . IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  306. NFOFO=NFOR-1
  307. ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  308. ELSE IF (IFOUR.EQ.11) THEN
  309. NFOFO=NFOR-2
  310. ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  311. BDPG=BDPG+XFINC(NBNN*NFOFO+2)
  312. ENDIF
  313. endif
  314. C
  315. C ON RANGE XFORC DANS MELVAL
  316. C
  317. IE=0
  318. MPTVAL=IVAFOR
  319. DO 7004 IGAU=1,NBNN
  320. DO 7004 ICOMP=1,NFOFO
  321. IE=IE+1
  322. MELVAL=IVAL(ICOMP)
  323. IBMN=MIN(IB ,VELCHE(/2))
  324. VELCHE(IGAU,IBMN)=XFINC(IE)
  325. 7004 CONTINUE
  326. 3004 CONTINUE
  327.  
  328. 9904 CONTINUE
  329. SEGSUP MWRK1
  330. if (mwrk67.ne.0) segsup mwrk67
  331. GOTO 510
  332. C__________________________________________________________________
  333. C_______________________________________________________________________
  334. C
  335. C MILIEUX POREUX
  336. C_______________________________________________________________________
  337. C
  338. 79 CONTINUE
  339. C
  340. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  341. C NBNO = NOMBRE DE FONCTIONS DE FORME
  342. C
  343. DIM3=1.D0
  344. NBNO=IPORE
  345. NBBB=NBNN
  346. LRN = NBNO-NBBB
  347. LRB=LRE-LRN
  348. *
  349. NSTN=1
  350. SEGINI MWRK1,MWRK5
  351. C
  352. DO 3079 IB=1,NBELEM
  353. C
  354. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  355. C
  356. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  357. C
  358. C MISE A 0 DES FORCES
  359. C
  360. CALL ZERO(XFORC,1,LRE)
  361. C
  362. C BOUCLE SUR LES POINTS DE GAUSS
  363. C
  364. ISDJC=0
  365. DO 5079 IGAU=1,NBPGAU
  366. C
  367. C RECUPERATION DE L'EPAISSEUR
  368. C
  369. IF (IFOUR.EQ.-2)THEN
  370. MPTVAL=IVACAR
  371. IF (IVACAR.NE.0) THEN
  372. MELVAL=IVAL(1)
  373. IF (MELVAL.NE.0) THEN
  374. IGMN=MIN(IGAU,VELCHE(/1))
  375. IBMN=MIN(IB,VELCHE(/2))
  376. DIM3=VELCHE(IGMN,IBMN)
  377. ELSE
  378. DIM3=1.D0
  379. ENDIF
  380. ENDIF
  381. ENDIF
  382. C
  383. CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
  384. . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
  385. IF (DJAC.EQ.0.D0) THEN
  386. INTERR(1)=IB
  387. CALL ERREUR(259)
  388. GOTO 9979
  389. ENDIF
  390. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  391. DJAC=ABS(DJAC)*POIGAU(IGAU)
  392. C
  393. C ON CHERCHE LES CONTRAINTES
  394. C
  395. MPTVAL=IVASTR
  396. DO 6079 ICOMP=1,NSTRS
  397. MELVAL=IVAL(ICOMP)
  398. IGMN=MIN(IGAU,VELCHE(/1))
  399. IBMN=MIN(IB ,VELCHE(/2))
  400. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  401. 6079 CONTINUE
  402. C
  403. C CALCUL DE B*SIGMA
  404. C
  405. CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  406.  
  407. * ON AJOUTE LES TERMES EN FP
  408. * SIGNE - POUR ETRE COHERENT AVEC RIGI
  409. *
  410. r_z = XSTRS(NSTRS)*DJAC
  411. DO 6179 J=1,LRN
  412. JJ=LRB+J
  413. XFORC(JJ)=XFORC(JJ) - r_z*XGENE(1,J)
  414. 6179 CONTINUE
  415. *
  416. 5079 CONTINUE
  417. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  418. INTERR(1)=IB
  419. CALL ERREUR(195)
  420. GOTO 9979
  421. ENDIF
  422. C
  423. C ON RANGE XFORC DANS MELVAL
  424. C D'ABORD LES FORCES PUIS LES DEBITS
  425. C
  426. IE=0
  427. MPTVAL=IVAFOR
  428. DO 7079 IGAU=1,NBNN
  429. DO 7079 ICOMP=1,NFOR-1
  430. IE=IE+1
  431. MELVAL=IVAL(ICOMP)
  432. VELCHE(IGAU,IB)=XFORC(IE)
  433. 7079 CONTINUE
  434. *
  435. DO 7179 IGAU=1,NBSOM(IELE)
  436. IE=IE+1
  437. MELVAL=IVAL(NFOR)
  438. IGAV = IBSOM(NSPOS(IELE)+IGAU-1)
  439. VELCHE(IGAV,IB)=XFORC(IE)
  440. 7179 CONTINUE
  441. *
  442. 3079 CONTINUE
  443.  
  444. 9979 CONTINUE
  445. SEGSUP MWRK1,MWRK5
  446. GOTO 510
  447. C_______________________________________________________________________
  448. C__________________________________________________________________
  449. C
  450. C MILIEUX POREUX - SUITE
  451. C_______________________________________________________________________
  452. C
  453. 173 CONTINUE
  454. C
  455. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  456. C NBNO = NOMBRE DE FONCTIONS DE FORME
  457. C
  458. DIM3=1.D0
  459. NBNO=IPORE
  460. NBBB=NBNN
  461. IF(MELE.GE.173.AND.MELE.LE.177) THEN
  462. IDECAP = 2
  463. ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  464. IDECAP = 3
  465. ENDIF
  466. *
  467. NSTN=IDECAP
  468. NSTB=4
  469. IF(IFOUR.EQ.1.OR.IFOUR.EQ.2) NSTB=6
  470. LPP = NBNO-NBBB
  471. LRN=IDECAP*LPP
  472. LRB=LRE-LRN
  473.  
  474. SEGINI MWRK1,MWRK5
  475. C
  476. DO 3173 IB=1,NBELEM
  477. C
  478. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  479. C
  480. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  481. C
  482. C MISE A 0 DES FORCES
  483. C
  484. CALL ZERO(XFORC,1,LRE)
  485. C
  486. C BOUCLE SUR LES POINTS DE GAUSS
  487. C
  488. ISDJC=0
  489. DO 5173 IGAU=1,NBPGAU
  490. C
  491. C RECUPERATION DE L'EPAISSEUR
  492. C
  493. IF (IFOUR.EQ.-2)THEN
  494. MPTVAL=IVACAR
  495. IF (IVACAR.NE.0) THEN
  496. MELVAL=IVAL(1)
  497. IF (MELVAL.NE.0) THEN
  498. IGMN=MIN(IGAU,VELCHE(/1))
  499. IBMN=MIN(IB,VELCHE(/2))
  500. DIM3=VELCHE(IGMN,IBMN)
  501. ELSE
  502. DIM3=1.D0
  503. ENDIF
  504. ENDIF
  505. ENDIF
  506. C
  507. CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  508. & DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1)
  509. IF (DJAC.EQ.0.D0) THEN
  510. INTERR(1)=IB
  511. CALL ERREUR(259)
  512. GOTO 99173
  513. ENDIF
  514. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  515. DJAC=ABS(DJAC)*POIGAU(IGAU)
  516. C
  517. C ON CHERCHE LES CONTRAINTES
  518. C
  519. MPTVAL=IVASTR
  520. DO 6173 ICOMP=1,NSTRS
  521. MELVAL=IVAL(ICOMP)
  522. IGMN=MIN(IGAU,VELCHE(/1))
  523. IBMN=MIN(IB ,VELCHE(/2))
  524. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  525. 6173 CONTINUE
  526. C
  527. C CALCUL DE B*SIGMA
  528. C
  529. CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  530. *
  531. * ON AJOUTE LES TERMES EN FP
  532. * SIGNE - POUR ETRE COHERENT AVEC RIGI
  533. *
  534. DO 6273 IPR=1,IDECAP
  535. IPR1=(IPR-1)*LPP
  536. IPR2=NSTRS-IDECAP+IPR
  537. r_z = XSTRS(IPR2) * DJAC
  538. DO 6373 J=1,LPP
  539. JJ=LRB+IPR1+J
  540. XFORC(JJ)=XFORC(JJ)- r_z * XGENE(IPR,IPR1+J)
  541. 6373 CONTINUE
  542. 6273 CONTINUE
  543. *
  544. 5173 CONTINUE
  545.  
  546. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  547. INTERR(1)=IB
  548. CALL ERREUR(195)
  549. GOTO 99173
  550. ENDIF
  551. C
  552. C ON RANGE XFORC DANS MELVAL
  553. C D'ABORD LES FORCES PUIS LES DEBITS
  554. C
  555. IE=0
  556. MPTVAL=IVAFOR
  557. DO 7173 IGAU=1,NBNN
  558. DO 7173 ICOMP=1,NFOR-IDECAP
  559. IE=IE+1
  560. MELVAL=IVAL(ICOMP)
  561. VELCHE(IGAU,IB)=XFORC(IE)
  562. 7173 CONTINUE
  563. *
  564. DO 7273 IPR=1,IDECAP
  565. IPR1=NFOR-IDECAP+IPR
  566. DO 7373 IGAU=1,NBSOM(IELE)
  567. IE=IE+1
  568. MELVAL=IVAL(IPR1)
  569. IGAV = IBSOM(NSPOS(IELE)+IGAU-1)
  570. VELCHE(IGAV,IB)=XFORC(IE)
  571. 7373 CONTINUE
  572. 7273 CONTINUE
  573. *
  574. 3173 CONTINUE
  575. *
  576. 99173 CONTINUE
  577. SEGSUP MWRK1,MWRK5
  578. GOTO 510
  579. C__________________________________________________________________
  580. C_______________________________________________________________________
  581. C
  582. C JOINTS EN FORMULATION MILIEUX POREUX
  583. C_______________________________________________________________________
  584. C
  585. 80 CONTINUE
  586. C
  587. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  588. C NBNO = NOMBRE DE FONCTIONS DE FORME
  589. C
  590. NBNO=IPORE
  591. NBBB=NBNN
  592. LRN=(NBNO-NBBB)*3/2
  593. LRB=LRE-LRN
  594. NSTN=1
  595. NFAC=(3*NBBB-NBNO)/2
  596. NMIL=LRN-NBSOM(IELE)
  597. SEGINI MWRK1,MWRK3,MWRK5
  598. I195=0
  599. I259=0
  600. C
  601. DO 3080 IB=1,NBELEM
  602. C
  603. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  604. C
  605. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  606. C
  607. C CALCUL DES AXES LOCAUX ET DES CORDONNES LOCALES
  608. C
  609. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  610. C
  611. C MISE A 0 DES FORCES
  612. C
  613. CALL ZERO(XFORC,1,LRE)
  614. C
  615. C BOUCLE SUR LES POINTS DE GAUSS
  616. C
  617. ISDJC=0
  618. DO 5080 IGAU=1,NBPGAU
  619. C
  620. CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  621. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
  622. IF (DJAC.EQ.0.) THEN
  623. INTERR(1)=IB
  624. CALL ERREUR(259)
  625. GOTO 9980
  626. ENDIF
  627. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  628. DJAC=ABS(DJAC)*POIGAU(IGAU)
  629. C
  630. C ON CHERCHE LES CONTRAINTES
  631. C
  632. MPTVAL=IVASTR
  633. DO 6080 ICOMP=1,NSTRS
  634. MELVAL=IVAL(ICOMP)
  635. IGMN=MIN(IGAU,VELCHE(/1))
  636. IBMN=MIN(IB ,VELCHE(/2))
  637. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  638. 6080 CONTINUE
  639. C
  640. C CALCUL DE B*SIGMA
  641. C
  642. CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  643. *
  644. * ON AJOUTE LES TERMES EN FP
  645. * SIGNE - POUR ETRE COHERENT AVEC RIGI
  646. *
  647. r_z = XSTRS(NSTRS)*DJAC
  648. DO 6180 J=1,LRN
  649. JJ=LRB+J
  650. XFORC(JJ)=XFORC(JJ)-XGENE(1,J)*r_z
  651. 6180 CONTINUE
  652.  
  653. 5080 CONTINUE
  654. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  655. INTERR(1)=IB
  656. CALL ERREUR(195)
  657. GOTO 9980
  658. ENDIF
  659. C
  660. C ON RANGE XFORC DANS MELVAL
  661. C D'ABORD LES FORCES PUIS LES DEBITS
  662. C
  663. IE=0
  664. MPTVAL=IVAFOR
  665. DO 7080 IGAU=1,NFAC
  666. DO 7080 ICOMP=1,NFOR-1
  667. IE=IE+1
  668. MELVAL=IVAL(ICOMP)
  669. VELCHE(IGAU,IB)=XFORC(IE)
  670. 7080 CONTINUE
  671. *
  672. * debits ( d'abord sommets puis mileux des cotes ad-hoc )
  673. *
  674. MELVAL=IVAL(NFOR)
  675. DO 7180 IGAU=1,NBSOM(IELE)
  676. IE=IE+1
  677. IGAV = IBSOM(NSPOS(IELE)+IGAU-1)
  678. C* VELCHE(IGAV,IB)=XFORC(IE)*0.D0
  679. VELCHE(IGAV,IB)=0.D0
  680. 7180 CONTINUE
  681. *
  682. DO 7181 IGAU=1,NMIL
  683. IE=IE+1
  684. IGAV = NBBB - NMIL +IGAU
  685. VELCHE(IGAV,IB)=XFORC(IE)
  686. 7181 CONTINUE
  687. *
  688. 3080 CONTINUE
  689.  
  690. 9980 CONTINUE
  691. SEGSUP MWRK1,MWRK3,MWRK5
  692. GOTO 510
  693. C__________________________________________________________________
  694. C_______________________________________________________________________
  695. C
  696. C JOINTS EN FORMULATION MILIEUX POREUX - SUITE
  697. C_______________________________________________________________________
  698. C
  699. 185 CONTINUE
  700. C
  701. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  702. C NBNO = NOMBRE DE FONCTIONS DE FORME
  703. C
  704. IF (MELE.GE.185.AND.MELE.LE.187) THEN
  705. IDECAP = 2
  706. ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN
  707. IDECAP = 3
  708. ENDIF
  709. C
  710. NBNO=IPORE
  711. NSTN=IDECAP
  712. NSTB=2
  713. IF(IFOUR.EQ.1.OR.IFOUR.EQ.2) NSTB=3
  714. C
  715. NBBB=NBNN
  716. LPP=(NBNO-NBBB)*3/2
  717. LRN=IDECAP*LPP
  718. LRB=LRE-LRN
  719. NFAC=(3*NBBB-NBNO)/2
  720. NMIL=LPP-NBSOM(IELE)
  721. SEGINI MWRK1,MWRK3,MWRK5
  722. I195=0
  723. I259=0
  724. C
  725. DO 3185 IB=1,NBELEM
  726. C
  727. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  728. C
  729. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  730. C
  731. C CALCUL DES AXES LOCAUX ET DES CORDONNES LOCALES
  732. C
  733. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  734. C
  735. C MISE A 0 DES FORCES
  736. C
  737. CALL ZERO(XFORC,1,LRE)
  738. C
  739. C BOUCLE SUR LES POINTS DE GAUSS
  740. C
  741. ISDJC=0
  742. DO 5185 IGAU=1,NBPGAU
  743. C
  744. CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  745. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1)
  746. IF (DJAC.EQ.0.) THEN
  747. INTERR(1)=IB
  748. CALL ERREUR(259)
  749. GOTO 9985
  750. ENDIF
  751. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  752. DJAC=ABS(DJAC)*POIGAU(IGAU)
  753. C
  754. C ON CHERCHE LES CONTRAINTES
  755. C
  756. MPTVAL=IVASTR
  757. DO 6185 ICOMP=1,NSTRS
  758. MELVAL=IVAL(ICOMP)
  759. IGMN=MIN(IGAU,VELCHE(/1))
  760. IBMN=MIN(IB ,VELCHE(/2))
  761. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  762. 6185 CONTINUE
  763. C
  764. C CALCUL DE B*SIGMA
  765. C
  766. CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  767. *
  768. * ON AJOUTE LES TERMES EN FP
  769. * SIGNE - POUR ETRE COHERENT AVEC RIGI
  770. *
  771. DO 6285 IPR=1,IDECAP
  772. IPR1=(IPR-1)*LPP
  773. IPR2=NSTRS-IDECAP+IPR
  774. r_z = XSTRS(IPR2)*DJAC
  775. DO 6285 J=1,LPP
  776. JJ=LRB+IPR1+J
  777. XFORC(JJ)=XFORC(JJ)-XGENE(IPR,IPR1+J)*r_z
  778. 6285 CONTINUE
  779.  
  780. 5185 CONTINUE
  781. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  782. INTERR(1)=IB
  783. CALL ERREUR(195)
  784. GOTO 9985
  785. ENDIF
  786. C
  787. C ON RANGE XFORC DANS MELVAL
  788. C D'ABORD LES FORCES PUIS LES DEBITS
  789. C
  790. IE=0
  791. MPTVAL=IVAFOR
  792. DO 7185 IGAU=1,NFAC
  793. DO 7185 ICOMP=1,NFOR-IDECAP
  794. IE=IE+1
  795. MELVAL=IVAL(ICOMP)
  796. VELCHE(IGAU,IB)=XFORC(IE)
  797. 7185 CONTINUE
  798. *
  799. * debits ( d'abord sommets puis mileux des cotes ad-hoc )
  800. *
  801. DO 7485 IPR=1,IDECAP
  802. IPR1 = NFOR-IDECAP+IPR
  803. MELVAL=IVAL(IPR1)
  804.  
  805. DO 7285 IGAU=1,NBSOM(IELE)
  806. IE=IE+1
  807. IGAV = IBSOM(NSPOS(IELE)+IGAU-1)
  808. C* VELCHE(IGAV,IB)=XFORC(IE)*0.D0
  809. VELCHE(IGAV,IB)=0.D0
  810. 7285 CONTINUE
  811. *
  812. DO 7385 IGAU=1,NMIL
  813. IE=IE+1
  814. IGAV = NBBB - NMIL +IGAU
  815. VELCHE(IGAV,IB)=XFORC(IE)
  816. 7385 CONTINUE
  817. 7485 CONTINUE
  818. *
  819. 3185 CONTINUE
  820.  
  821. 9985 CONTINUE
  822. SEGSUP MWRK1,MWRK3,MWRK5
  823. GOTO 510
  824. C
  825. C
  826. 99 CONTINUE
  827. MOTERR(1:4)=NOMTP(MELE)
  828. MOTERR(5:12)='BSIGMA'
  829. CALL ERREUR(86)
  830. C
  831. 510 CONTINUE
  832.  
  833. RETURN
  834. END
  835.  
  836.  
  837.  
  838.  
  839.  
  840.  
  841.  

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