Télécharger bsigm1.eso

Retour à la liste

Numérotation des lignes :

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

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