Télécharger bsigm1.eso

Retour à la liste

Numérotation des lignes :

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

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