Télécharger bsigm1.eso

Retour à la liste

Numérotation des lignes :

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

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