Télécharger bsigm1.eso

Retour à la liste

Numérotation des lignes :

  1. C BSIGM1 SOURCE PV 18/03/28 21:15:01 9788
  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
  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. if (noer.eq.0) then
  291. CALL ERREUR(195)
  292. GOTO 9904
  293. else
  294. noer=195
  295. return
  296. endif
  297. ENDIF
  298. C
  299. C EXTRACTION DES FORCES AU NOEUD SUPPORT DE LA DEF PLAN GENE
  300. C ON CALCULE LES RESULTANTES DES FORCES SUR CHAQUE ELEMENT
  301. C
  302. NFOFO=NFOR
  303. if (IIPDPG.gt.0) then
  304. IF (IFOUR.EQ.-3) THEN
  305. NFOFO=NFOR-3
  306. ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  307. BDPG=BDPG+XFINC(NBNN*NFOFO+2)
  308. CDPG=CDPG+XFINC(NBNN*NFOFO+3)
  309. ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ.9.OR.
  310. . IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  311. NFOFO=NFOR-1
  312. ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  313. ELSE IF (IFOUR.EQ.11) THEN
  314. NFOFO=NFOR-2
  315. ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  316. BDPG=BDPG+XFINC(NBNN*NFOFO+2)
  317. ENDIF
  318. endif
  319. C
  320. C ON RANGE XFORC DANS MELVAL
  321. C
  322. IE=0
  323. MPTVAL=IVAFOR
  324. DO 7004 IGAU=1,NBNN
  325. DO 7004 ICOMP=1,NFOFO
  326. IE=IE+1
  327. MELVAL=IVAL(ICOMP)
  328. IBMN=MIN(IB ,VELCHE(/2))
  329. VELCHE(IGAU,IBMN)=XFINC(IE)
  330. 7004 CONTINUE
  331. 3004 CONTINUE
  332.  
  333. 9904 CONTINUE
  334. SEGSUP MWRK1
  335. if (mwrk67.ne.0) segsup mwrk67
  336. GOTO 510
  337. C__________________________________________________________________
  338. C_______________________________________________________________________
  339. C
  340. C MILIEUX POREUX
  341. C_______________________________________________________________________
  342. C
  343. 79 CONTINUE
  344. C
  345. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  346. C NBNO = NOMBRE DE FONCTIONS DE FORME
  347. C
  348. DIM3=1.D0
  349. NBNO=IPORE
  350. NBBB=NBNN
  351. LRN = NBNO-NBBB
  352. LRB=LRE-LRN
  353. *
  354. NSTN=1
  355. SEGINI MWRK1,MWRK5
  356. C
  357. DO 3079 IB=1,NBELEM
  358. C
  359. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  360. C
  361. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  362. C
  363. C MISE A 0 DES FORCES
  364. C
  365. CALL ZERO(XFORC,1,LRE)
  366. C
  367. C BOUCLE SUR LES POINTS DE GAUSS
  368. C
  369. ISDJC=0
  370. DO 5079 IGAU=1,NBPGAU
  371. C
  372. C RECUPERATION DE L'EPAISSEUR
  373. C
  374. IF (IFOUR.EQ.-2)THEN
  375. MPTVAL=IVACAR
  376. IF (IVACAR.NE.0) THEN
  377. MELVAL=IVAL(1)
  378. IF (MELVAL.NE.0) THEN
  379. IGMN=MIN(IGAU,VELCHE(/1))
  380. IBMN=MIN(IB,VELCHE(/2))
  381. DIM3=VELCHE(IGMN,IBMN)
  382. ELSE
  383. DIM3=1.D0
  384. ENDIF
  385. ENDIF
  386. ENDIF
  387. C
  388. CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
  389. . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
  390. IF (DJAC.EQ.0.D0) THEN
  391. INTERR(1)=IB
  392. CALL ERREUR(259)
  393. GOTO 9979
  394. ENDIF
  395. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  396. DJAC=ABS(DJAC)*POIGAU(IGAU)
  397. C
  398. C ON CHERCHE LES CONTRAINTES
  399. C
  400. MPTVAL=IVASTR
  401. DO 6079 ICOMP=1,NSTRS
  402. MELVAL=IVAL(ICOMP)
  403. IGMN=MIN(IGAU,VELCHE(/1))
  404. IBMN=MIN(IB ,VELCHE(/2))
  405. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  406. 6079 CONTINUE
  407. C
  408. C CALCUL DE B*SIGMA
  409. C
  410. CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  411.  
  412. * ON AJOUTE LES TERMES EN FP
  413. * SIGNE - POUR ETRE COHERENT AVEC RIGI
  414. *
  415. r_z = XSTRS(NSTRS)*DJAC
  416. DO 6179 J=1,LRN
  417. JJ=LRB+J
  418. XFORC(JJ)=XFORC(JJ) - r_z*XGENE(1,J)
  419. 6179 CONTINUE
  420. *
  421. 5079 CONTINUE
  422. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  423. INTERR(1)=IB
  424. if (noer.eq.0) then
  425. CALL ERREUR(195)
  426. GOTO 9979
  427. else
  428. noer=195
  429. return
  430. endif
  431. ENDIF
  432. C
  433. C ON RANGE XFORC DANS MELVAL
  434. C D'ABORD LES FORCES PUIS LES DEBITS
  435. C
  436. IE=0
  437. MPTVAL=IVAFOR
  438. DO 7079 IGAU=1,NBNN
  439. DO 7079 ICOMP=1,NFOR-1
  440. IE=IE+1
  441. MELVAL=IVAL(ICOMP)
  442. VELCHE(IGAU,IB)=XFORC(IE)
  443. 7079 CONTINUE
  444. *
  445. DO 7179 IGAU=1,NBSOM(IELE)
  446. IE=IE+1
  447. MELVAL=IVAL(NFOR)
  448. IGAV = IBSOM(NSPOS(IELE)+IGAU-1)
  449. VELCHE(IGAV,IB)=XFORC(IE)
  450. 7179 CONTINUE
  451. *
  452. 3079 CONTINUE
  453.  
  454. 9979 CONTINUE
  455. SEGSUP MWRK1,MWRK5
  456. GOTO 510
  457. C_______________________________________________________________________
  458. C__________________________________________________________________
  459. C
  460. C MILIEUX POREUX - SUITE
  461. C_______________________________________________________________________
  462. C
  463. 173 CONTINUE
  464. C
  465. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  466. C NBNO = NOMBRE DE FONCTIONS DE FORME
  467. C
  468. DIM3=1.D0
  469. NBNO=IPORE
  470. NBBB=NBNN
  471. IF(MELE.GE.173.AND.MELE.LE.177) THEN
  472. IDECAP = 2
  473. ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  474. IDECAP = 3
  475. ENDIF
  476. *
  477. NSTN=IDECAP
  478. NSTB=4
  479. IF(IFOUR.EQ.1.OR.IFOUR.EQ.2) NSTB=6
  480. LPP = NBNO-NBBB
  481. LRN=IDECAP*LPP
  482. LRB=LRE-LRN
  483.  
  484. SEGINI MWRK1,MWRK5
  485. C
  486. DO 3173 IB=1,NBELEM
  487. C
  488. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  489. C
  490. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  491. C
  492. C MISE A 0 DES FORCES
  493. C
  494. CALL ZERO(XFORC,1,LRE)
  495. C
  496. C BOUCLE SUR LES POINTS DE GAUSS
  497. C
  498. ISDJC=0
  499. DO 5173 IGAU=1,NBPGAU
  500. C
  501. C RECUPERATION DE L'EPAISSEUR
  502. C
  503. IF (IFOUR.EQ.-2)THEN
  504. MPTVAL=IVACAR
  505. IF (IVACAR.NE.0) THEN
  506. MELVAL=IVAL(1)
  507. IF (MELVAL.NE.0) THEN
  508. IGMN=MIN(IGAU,VELCHE(/1))
  509. IBMN=MIN(IB,VELCHE(/2))
  510. DIM3=VELCHE(IGMN,IBMN)
  511. ELSE
  512. DIM3=1.D0
  513. ENDIF
  514. ENDIF
  515. ENDIF
  516. C
  517. CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  518. & DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1)
  519. IF (DJAC.EQ.0.D0) THEN
  520. INTERR(1)=IB
  521. CALL ERREUR(259)
  522. GOTO 99173
  523. ENDIF
  524. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  525. DJAC=ABS(DJAC)*POIGAU(IGAU)
  526. C
  527. C ON CHERCHE LES CONTRAINTES
  528. C
  529. MPTVAL=IVASTR
  530. DO 6173 ICOMP=1,NSTRS
  531. MELVAL=IVAL(ICOMP)
  532. IGMN=MIN(IGAU,VELCHE(/1))
  533. IBMN=MIN(IB ,VELCHE(/2))
  534. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  535. 6173 CONTINUE
  536. C
  537. C CALCUL DE B*SIGMA
  538. C
  539. CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  540. *
  541. * ON AJOUTE LES TERMES EN FP
  542. * SIGNE - POUR ETRE COHERENT AVEC RIGI
  543. *
  544. DO 6273 IPR=1,IDECAP
  545. IPR1=(IPR-1)*LPP
  546. IPR2=NSTRS-IDECAP+IPR
  547. r_z = XSTRS(IPR2) * DJAC
  548. DO 6373 J=1,LPP
  549. JJ=LRB+IPR1+J
  550. XFORC(JJ)=XFORC(JJ)- r_z * XGENE(IPR,IPR1+J)
  551. 6373 CONTINUE
  552. 6273 CONTINUE
  553. *
  554. 5173 CONTINUE
  555.  
  556. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  557. INTERR(1)=IB
  558. if (noer.eq.0) then
  559. CALL ERREUR(195)
  560. GOTO 99173
  561. else
  562. noer=195
  563. return
  564. endif
  565. ENDIF
  566. C
  567. C ON RANGE XFORC DANS MELVAL
  568. C D'ABORD LES FORCES PUIS LES DEBITS
  569. C
  570. IE=0
  571. MPTVAL=IVAFOR
  572. DO 7173 IGAU=1,NBNN
  573. DO 7173 ICOMP=1,NFOR-IDECAP
  574. IE=IE+1
  575. MELVAL=IVAL(ICOMP)
  576. VELCHE(IGAU,IB)=XFORC(IE)
  577. 7173 CONTINUE
  578. *
  579. DO 7273 IPR=1,IDECAP
  580. IPR1=NFOR-IDECAP+IPR
  581. DO 7373 IGAU=1,NBSOM(IELE)
  582. IE=IE+1
  583. MELVAL=IVAL(IPR1)
  584. IGAV = IBSOM(NSPOS(IELE)+IGAU-1)
  585. VELCHE(IGAV,IB)=XFORC(IE)
  586. 7373 CONTINUE
  587. 7273 CONTINUE
  588. *
  589. 3173 CONTINUE
  590. *
  591. 99173 CONTINUE
  592. SEGSUP MWRK1,MWRK5
  593. GOTO 510
  594. C__________________________________________________________________
  595. C_______________________________________________________________________
  596. C
  597. C JOINTS EN FORMULATION MILIEUX POREUX
  598. C_______________________________________________________________________
  599. C
  600. 80 CONTINUE
  601. C
  602. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  603. C NBNO = NOMBRE DE FONCTIONS DE FORME
  604. C
  605. NBNO=IPORE
  606. NBBB=NBNN
  607. LRN=(NBNO-NBBB)*3/2
  608. LRB=LRE-LRN
  609. NSTN=1
  610. NFAC=(3*NBBB-NBNO)/2
  611. NMIL=LRN-NBSOM(IELE)
  612. SEGINI MWRK1,MWRK3,MWRK5
  613. I195=0
  614. I259=0
  615. C
  616. DO 3080 IB=1,NBELEM
  617. C
  618. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  619. C
  620. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  621. C
  622. C CALCUL DES AXES LOCAUX ET DES CORDONNES LOCALES
  623. C
  624. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  625. C
  626. C MISE A 0 DES FORCES
  627. C
  628. CALL ZERO(XFORC,1,LRE)
  629. C
  630. C BOUCLE SUR LES POINTS DE GAUSS
  631. C
  632. ISDJC=0
  633. DO 5080 IGAU=1,NBPGAU
  634. C
  635. CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  636. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
  637. IF (DJAC.EQ.0.) THEN
  638. INTERR(1)=IB
  639. CALL ERREUR(259)
  640. GOTO 9980
  641. ENDIF
  642. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  643. DJAC=ABS(DJAC)*POIGAU(IGAU)
  644. C
  645. C ON CHERCHE LES CONTRAINTES
  646. C
  647. MPTVAL=IVASTR
  648. DO 6080 ICOMP=1,NSTRS
  649. MELVAL=IVAL(ICOMP)
  650. IGMN=MIN(IGAU,VELCHE(/1))
  651. IBMN=MIN(IB ,VELCHE(/2))
  652. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  653. 6080 CONTINUE
  654. C
  655. C CALCUL DE B*SIGMA
  656. C
  657. CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  658. *
  659. * ON AJOUTE LES TERMES EN FP
  660. * SIGNE - POUR ETRE COHERENT AVEC RIGI
  661. *
  662. r_z = XSTRS(NSTRS)*DJAC
  663. DO 6180 J=1,LRN
  664. JJ=LRB+J
  665. XFORC(JJ)=XFORC(JJ)-XGENE(1,J)*r_z
  666. 6180 CONTINUE
  667.  
  668. 5080 CONTINUE
  669. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  670. INTERR(1)=IB
  671. if (noer.eq.0) then
  672. CALL ERREUR(195)
  673. GOTO 9980
  674. else
  675. noer=195
  676. return
  677. endif
  678. ENDIF
  679. C
  680. C ON RANGE XFORC DANS MELVAL
  681. C D'ABORD LES FORCES PUIS LES DEBITS
  682. C
  683. IE=0
  684. MPTVAL=IVAFOR
  685. DO 7080 IGAU=1,NFAC
  686. DO 7080 ICOMP=1,NFOR-1
  687. IE=IE+1
  688. MELVAL=IVAL(ICOMP)
  689. VELCHE(IGAU,IB)=XFORC(IE)
  690. 7080 CONTINUE
  691. *
  692. * debits ( d'abord sommets puis mileux des cotes ad-hoc )
  693. *
  694. MELVAL=IVAL(NFOR)
  695. DO 7180 IGAU=1,NBSOM(IELE)
  696. IE=IE+1
  697. IGAV = IBSOM(NSPOS(IELE)+IGAU-1)
  698. C* VELCHE(IGAV,IB)=XFORC(IE)*0.D0
  699. VELCHE(IGAV,IB)=0.D0
  700. 7180 CONTINUE
  701. *
  702. DO 7181 IGAU=1,NMIL
  703. IE=IE+1
  704. IGAV = NBBB - NMIL +IGAU
  705. VELCHE(IGAV,IB)=XFORC(IE)
  706. 7181 CONTINUE
  707. *
  708. 3080 CONTINUE
  709.  
  710. 9980 CONTINUE
  711. SEGSUP MWRK1,MWRK3,MWRK5
  712. GOTO 510
  713. C__________________________________________________________________
  714. C_______________________________________________________________________
  715. C
  716. C JOINTS EN FORMULATION MILIEUX POREUX - SUITE
  717. C_______________________________________________________________________
  718. C
  719. 185 CONTINUE
  720. C
  721. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  722. C NBNO = NOMBRE DE FONCTIONS DE FORME
  723. C
  724. IF (MELE.GE.185.AND.MELE.LE.187) THEN
  725. IDECAP = 2
  726. ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN
  727. IDECAP = 3
  728. ENDIF
  729. C
  730. NBNO=IPORE
  731. NSTN=IDECAP
  732. NSTB=2
  733. IF(IFOUR.EQ.1.OR.IFOUR.EQ.2) NSTB=3
  734. C
  735. NBBB=NBNN
  736. LPP=(NBNO-NBBB)*3/2
  737. LRN=IDECAP*LPP
  738. LRB=LRE-LRN
  739. NFAC=(3*NBBB-NBNO)/2
  740. NMIL=LPP-NBSOM(IELE)
  741. SEGINI MWRK1,MWRK3,MWRK5
  742. I195=0
  743. I259=0
  744. C
  745. DO 3185 IB=1,NBELEM
  746. C
  747. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  748. C
  749. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  750. C
  751. C CALCUL DES AXES LOCAUX ET DES CORDONNES LOCALES
  752. C
  753. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  754. C
  755. C MISE A 0 DES FORCES
  756. C
  757. CALL ZERO(XFORC,1,LRE)
  758. C
  759. C BOUCLE SUR LES POINTS DE GAUSS
  760. C
  761. ISDJC=0
  762. DO 5185 IGAU=1,NBPGAU
  763. C
  764. CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  765. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1)
  766. IF (DJAC.EQ.0.) THEN
  767. INTERR(1)=IB
  768. CALL ERREUR(259)
  769. GOTO 9985
  770. ENDIF
  771. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  772. DJAC=ABS(DJAC)*POIGAU(IGAU)
  773. C
  774. C ON CHERCHE LES CONTRAINTES
  775. C
  776. MPTVAL=IVASTR
  777. DO 6185 ICOMP=1,NSTRS
  778. MELVAL=IVAL(ICOMP)
  779. IGMN=MIN(IGAU,VELCHE(/1))
  780. IBMN=MIN(IB ,VELCHE(/2))
  781. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  782. 6185 CONTINUE
  783. C
  784. C CALCUL DE B*SIGMA
  785. C
  786. CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  787. *
  788. * ON AJOUTE LES TERMES EN FP
  789. * SIGNE - POUR ETRE COHERENT AVEC RIGI
  790. *
  791. DO 6285 IPR=1,IDECAP
  792. IPR1=(IPR-1)*LPP
  793. IPR2=NSTRS-IDECAP+IPR
  794. r_z = XSTRS(IPR2)*DJAC
  795. DO 6285 J=1,LPP
  796. JJ=LRB+IPR1+J
  797. XFORC(JJ)=XFORC(JJ)-XGENE(IPR,IPR1+J)*r_z
  798. 6285 CONTINUE
  799.  
  800. 5185 CONTINUE
  801. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  802. INTERR(1)=IB
  803. if (noer.eq.0) then
  804. CALL ERREUR(195)
  805. GOTO 9985
  806. else
  807. noer=195
  808. return
  809. endif
  810. ENDIF
  811. C
  812. C ON RANGE XFORC DANS MELVAL
  813. C D'ABORD LES FORCES PUIS LES DEBITS
  814. C
  815. IE=0
  816. MPTVAL=IVAFOR
  817. DO 7185 IGAU=1,NFAC
  818. DO 7185 ICOMP=1,NFOR-IDECAP
  819. IE=IE+1
  820. MELVAL=IVAL(ICOMP)
  821. VELCHE(IGAU,IB)=XFORC(IE)
  822. 7185 CONTINUE
  823. *
  824. * debits ( d'abord sommets puis mileux des cotes ad-hoc )
  825. *
  826. DO 7485 IPR=1,IDECAP
  827. IPR1 = NFOR-IDECAP+IPR
  828. MELVAL=IVAL(IPR1)
  829.  
  830. DO 7285 IGAU=1,NBSOM(IELE)
  831. IE=IE+1
  832. IGAV = IBSOM(NSPOS(IELE)+IGAU-1)
  833. C* VELCHE(IGAV,IB)=XFORC(IE)*0.D0
  834. VELCHE(IGAV,IB)=0.D0
  835. 7285 CONTINUE
  836. *
  837. DO 7385 IGAU=1,NMIL
  838. IE=IE+1
  839. IGAV = NBBB - NMIL +IGAU
  840. VELCHE(IGAV,IB)=XFORC(IE)
  841. 7385 CONTINUE
  842. 7485 CONTINUE
  843. *
  844. 3185 CONTINUE
  845.  
  846. 9985 CONTINUE
  847. SEGSUP MWRK1,MWRK3,MWRK5
  848. GOTO 510
  849. C
  850. C
  851. 99 CONTINUE
  852. MOTERR(1:4)=NOMTP(MELE)
  853. MOTERR(5:12)='BSIGMA'
  854. CALL ERREUR(86)
  855. C
  856. 510 CONTINUE
  857.  
  858. RETURN
  859. END
  860.  
  861.  
  862.  
  863.  
  864.  
  865.  
  866.  
  867.  

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