Télécharger bsigm1.eso

Retour à la liste

Numérotation des lignes :

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

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