Télécharger bsigm1.eso

Retour à la liste

Numérotation des lignes :

bsigm1
  1. C BSIGM1 SOURCE SP204843 25/07/03 21:15:05 12308
  2. SUBROUTINE BSIGM1(IPMAIL,LRE,NSTRS,NBPGAU,MELE,MFR,IVASTR,
  3. & IPMINT,IVACAR,IPORE,LHOOK,NFOR,IVAFOR,ADPG,BDPG,CDPG,
  4. & IIPDPG,NCAR1,MELPHA,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 PPARAM
  47. -INC CCOPTIO
  48. -INC CCREEL
  49. -INC CCHAMP
  50. -INC CCGEOME
  51.  
  52. -INC SMCHAML
  53. -INC SMCHPOI
  54. -INC SMELEME
  55. -INC SMCOORD
  56. -INC SMMODEL
  57. -INC SMINTE
  58.  
  59. -INC TMPTVAL
  60.  
  61. SEGMENT MWRK1
  62. REAL*8 XFORC(LRE), XFINC(LRE),XSTRS(NSTRS), XE(3,NBBB)
  63. REAL*8 SHPWRK(6,NBNO), BGENE(LHOOK,LRE)
  64. ENDSEGMENT
  65. *
  66. SEGMENT MWRK3
  67. REAL*8 BPSS(3,3),XEL(3,NBBB)
  68. ENDSEGMENT
  69. *
  70. SEGMENT MWRK5
  71. REAL*8 XGENE(NSTN,LRN)
  72. ENDSEGMENT
  73. *
  74. segment mwrk67
  75. real*8 valcar(nca1)
  76. endsegment
  77. *
  78. CHARACTER*8 CMATE,CELEM,MO8
  79. DIMENSION A(4,60),BB(3,60),xatef1(3,3),PP(4,4)
  80. logical drend
  81. *
  82. MELEME=IPMAIL
  83. NBNN=NUM(/1)
  84. NBELEM=NUM(/2)
  85. *
  86. IDECAP=0
  87. NHRM=NIFOUR
  88. IELE=NUMGEO(MELE)
  89. *
  90. MINTE=IPMINT
  91. C_______________________________________________________________________
  92. C
  93. C NUMERO DES ETIQUETTES :
  94. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  95. C DANS LA ZONE SPECIFIQUE A CHAQUE ELEMENT COMMENCANT PAR :
  96. C 5 CONTINUE
  97. C ELEMENT 5 ETIQUETTES 1005 2005 3005 4005 ...
  98. C 44 CONTINUE
  99. C ELEMENT 44 ETIQUETTES 1044 2044 3044 4044 ...
  100. C_______________________________________________________________________
  101. C
  102. IF(MELE.GE.1.AND.MELE.LE.100) THEN
  103. C CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8
  104. GOTO ( 99, 99, 99, 4, 99, 4, 99, 4, 99, 4
  105. C QUA9 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6
  106. 1 , 99, 99, 99, 4, 4, 4, 4, 99, 99, 99
  107. C LIA8 MULT TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP
  108. 2 , 99, 99, 4, 4, 4, 4, 99, 99, 99, 99
  109. C FAC3 FAC4 FAC6 FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5
  110. 3 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  111. C COQ8 TUYA TUFI COQ2 POI1 BARR RACO LSU2 COQ4 LISM
  112. 4 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  113. C COF3 RES2 LSU3 LSU4 LICO COQ6 CVS2 CVS3 CVT3 CVT6
  114. 5 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  115. C CVQ4 CVQ8 THP5 TH13 THP6 TH15 THC8 TH20 ICT3 ICQ4
  116. 6 , 99, 99, 99, 99, 99, 99, 99, 99, 4, 4
  117. C ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10 IC15 TRIP QUAP
  118. 7 , 4, 4, 4, 4, 4, 4, 4, 4, 79, 79
  119. C CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4 JOI6 JOI8
  120. 8 , 79, 79, 79, 79, 99, 99, 99, 99, 99, 99
  121. C LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3 HYQ4
  122. 9 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99)
  123. c cccccc
  124. . ,MELE
  125. ELSEIF(MELE.GE.101.AND.MELE.LE.200) THEN
  126. C HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  127. GOTO ( 99, 99, 99, 99, 99, 99, 99, 80, 80, 80
  128. C POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12
  129. 1 , 4, 4, 4, 4, 4, 4, 4, 4, 4, 4
  130. C PO13 PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3
  131. 2 , 4, 4, 99, 99, 99, 99, 99, 99, 99, 99
  132. C QUF4 CUF8 PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18
  133. 3 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  134. C MT10 MP14 SEF3 TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6
  135. 4 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  136. C TR21 QU36 C216 P126 TE56 PY91 TRH6 BSE2 BTR4 BQU5
  137. 5 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  138. C BCU9 BPR7 BTE5 BPY6 FRO4 SEGS POJS JCT3 JCI4 JGI2
  139. 6 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  140. C JGT3 JGI4 TRIQ QUAQ CUBQ TETQ PRIQ TRIR QUAR CUBR
  141. 7 , 99, 99, 173, 173, 173, 173, 173, 173, 173, 173
  142. C TETR PRIR Q4RI Q8RI JOQ3 JOQ6 JOQ8 JOR3 JOR6 JOR8
  143. 8 , 173, 173, 4, 4, 185, 185, 185, 185, 185, 185
  144. C T1D2 T1D3 M1D2 M1D3 LC03 LC07 LC09 LC27 LC21 LC15
  145. 9 , 99, 99, 4, 4, 99, 99, 99, 99, 99, 99)
  146. c cccccc
  147. . ,MELE-100
  148. ELSEIF(MELE.GE.201.AND.MELE.LE.300) THEN
  149. C LC19 LS03 LS07 LS09 LS27 LS21 LS15 LS19 BS03 BS07
  150. GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  151. C BS09 BS27 BS21 BS15 BS19 MC03 MC07 MC09 MC27 MC21
  152. 1 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  153. C MC15 MC19 M103 M107 M109 M127 M121 M115 M119 MS03
  154. 2 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  155. C MS07 MS09 MS27 MS21 MS15 MS19 QC03 QC07 QC09 QC27
  156. 3 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  157. C QC21 QC15 QC19 Q103 Q107 Q109 Q127 Q121 Q115 Q119
  158. 4 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  159. C QS03 QS07 QS09 QS27 QS21 QS15 QS19 CIFL SURE SHB8
  160. 5 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  161. C CAF2 CAF3 XQ4R XC8R JOI1 ZCO2 ZCO3 ZCO4 TUY2 TUY3
  162. 6 , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  163. C COS2 COA2 ICY5 IC13 CU27 PR21 TE15 PY19 C20R P15R
  164. 7 , 99, 99, 4, 4, 4, 4, 4, 4, 4, 4)
  165. c cccccc
  166. . ,MELE-200
  167. ELSE
  168. GOTO 99
  169. ENDIF
  170. C
  171. C_______________________________________________________________________
  172. C
  173. C SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS ET ELEMENTS INCOMPRESSIBLES
  174. C_______________________________________________________________________
  175. C
  176. 4 CONTINUE
  177. DIM3=1.D0
  178. NBNO=NBNN
  179. NBBB=NBNN
  180. C
  181. C INTRODUCTION DES COORD DU POINT AUTOUR DUQUEL SE FAIT LE
  182. C MOUVEMENT DE LA SECTION EN DEFO PLANE GENERALISEE
  183. C Pas de rotation en 1D
  184. C ET INITIALISATION DES FORCES AU NOEUD SUPPORT DE LA DEFO
  185. C PLANE GENERALISEE
  186. IF (IIPDPG.GT.0)THEN
  187. IREF=(IIPDPG-1)*(IDIM+1)
  188. XDPGE=XCOOR(IREF+1)
  189. YDPGE=XCOOR(IREF+2)
  190. ELSE
  191. XDPGE=XZero
  192. YDPGE=XZero
  193. ENDIF
  194. ADPG=XZero
  195. BDPG=XZero
  196. CDPG=XZero
  197. C
  198. SEGINI MWRK1
  199. mwrk67=0
  200.  
  201. if (melpha.gt.0) melva1 = melpha
  202.  
  203. DO 3004 IB=1,NBELEM
  204. C
  205. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  206. C
  207. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  208. C
  209. C MISE A 0 DES FORCES
  210. C
  211. CALL ZERO(XFINC,1,LRE)
  212. C
  213. C BOUCLE SUR LES POINTS DE GAUSS
  214. C
  215. C CALCUL DES COEFF DE MODIFICATION DE LA MATRICE B-BARRE (INCOMPRES)
  216. IF (MFR.EQ.31) THEN
  217. CALL BBCALC(MELE,NBNN,MFR,IDIM,XE,
  218. & NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  219. & NSTRS,LRE,IFOUR,NHRM,A,BB,SHPTOT,SHPWRK,
  220. & BGENE,XDPGE,YDPGE,PP,NOER)
  221. IF (NOER.NE.0) THEN
  222. CALL ERREUR(noer)
  223. RETURN
  224. ENDIF
  225. ENDIF
  226.  
  227. ISDJC=0
  228. DO 5004 IGAU=1,NBPGAU
  229. C
  230. C RECUPERATION DE L'EPAISSEUR
  231. C
  232. DIM3=1.D0
  233. IF (IFOUR.EQ.-2)THEN
  234. MPTVAL=IVACAR
  235. IF (IVACAR.NE.0) THEN
  236. MELVAL=IVAL(1)
  237. IF (MELVAL.NE.0) THEN
  238. IGMN=MIN(IGAU,VELCHE(/1))
  239. IBMN=MIN(IB,VELCHE(/2))
  240. DIM3=VELCHE(IGMN,IBMN)
  241. ENDIF
  242. ENDIF
  243. ENDIF
  244. *
  245. CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  246. 1 MELE,MFR,NBNN,LRE,IFOUR,NSTRS,NHRM,DIM3,
  247. 2 XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  248.  
  249. IF (DJAC.EQ.0.D0) THEN
  250. INTERR(1)=IB
  251. if (noer.eq.0) then
  252. CALL ERREUR(259)
  253. GOTO 9904
  254. else
  255. noer=259
  256. return
  257. endif
  258. ENDIF
  259. IF (DJAC.LT.0.D0) ISDJC=ISDJC+1
  260. *
  261. DJAC=ABS(DJAC)*POIGAU(IGAU)
  262.  
  263. C En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  264. IF (MFR.EQ.31) THEN
  265. CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  266. & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  267. ENDIF
  268. C
  269. C ON CHERCHE LES CONTRAINTES
  270. C
  271. MPTVAL=IVASTR
  272. DO 6004 ICOMP=1,NSTRS
  273. MELVAL=IVAL(ICOMP)
  274. IGMN=MIN(IGAU,VELCHE(/1))
  275. IBMN=MIN(IB ,VELCHE(/2))
  276. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  277. 6004 CONTINUE
  278. C
  279. C CALCUL DE B*SIGMA
  280. C
  281. * initialise
  282. CALL ZERO(XFORC,1,LRE)
  283. * contribution point d integration
  284. CALL BSIG(BGENE,XSTRS,NSTRS,LRE,DJAC,XFORC)
  285. * matrice d'efficacite
  286. drend = .false.
  287. MPTVAL=IVACAR
  288. IF (IVACAR.GT.0) THEN
  289. nca1 = ival(/1)
  290. if (mwrk67.eq.0) segini mwrk67
  291. if (nca1.ne.valcar(/1)) segadj mwrk67
  292. celem = 'MASSIF '
  293. IF(IVAL(NCAR1).GT.0.OR.IVAL(NCAR1+1).GT.0) THEN
  294. DO 9008 IM= 1,IVAL(/1)
  295. IF (IVAL(IM).GT.0) THEN
  296. MELVAL=IVAL(IM)
  297.  
  298. C Pour optimisation et eviter _gfortran_compare_string inefficace
  299. MO8=TYVAL(IM)(1:8)
  300. IF (MO8.EQ.'REAL*8 ') THEN
  301. IBMN=MIN(IB ,VELCHE(/2))
  302. IGMN=MIN(IGAU,VELCHE(/1))
  303. VALCAR(IM)=VELCHE(IGMN,IBMN)
  304. ELSE
  305. IBMN=MIN(IB ,IELCHE(/2))
  306. IGMN=MIN(IGAU,IELCHE(/1))
  307. VALCAR(IM)=IELCHE(IGMN,IBMN)
  308. ENDIF
  309. ELSE
  310. VALCAR(IM)=0.D0
  311. ENDIF
  312. 9008 CONTINUE
  313. nstep = 2
  314. if (ifour.eq.2) nstep = 3
  315. MO8=TYVAL(ncar1)(1:8)
  316. if (ival(ncar1).gt.0.and.MO8.eq.'REAL*8 ') then
  317. drend = .true.
  318. do i = 1,nstep
  319. do j = 1, nstep
  320. xatef1(i,j) = 0.d0
  321. enddo
  322. xatef1(i,i) = valcar(ncar1)
  323. enddo
  324. endif
  325. MO8=TYVAL(ncar1+1)(1:8)
  326. if (ival(ncar1).eq.0.and.MO8.eq.'REAL*8 ') then
  327. drend = .false.
  328. do i = 1,nstep
  329. do j = 1, nstep
  330. xatef1(i,j) = 0.d0
  331. enddo
  332. xatef1(1,1) = valcar(ncar1+7)
  333. xatef1(2,2) = valcar(ncar1+8)
  334. if (nstep.eq.3) xatef1(3,3) = valcar(ncar1+9)
  335. enddo
  336. endif
  337. call effi3(valcar,tyval,nca1,ncar1,xforc,lre,ib,igau,xatef1,
  338. & nstep,drend,celem)
  339. ENDIF
  340. ENDIF
  341.  
  342. * ponderation par la phase
  343. IF (MELPHA.GT.0) THEN
  344. IBMN=MIN(IB ,melva1.VELCHE(/2))
  345. IGMN=MIN(IGAU,melva1.VELCHE(/1))
  346. coe1 = melva1.velche(igmn,ibmn)
  347. CALL OPTABj(1,1,2,1,xforc,0.d0,xforc,LRE,1,LRE,2,0,coe1,IRETO)
  348. ENDIF
  349.  
  350. * stocke
  351. C do ii = 1,LRE
  352. C xfinc(ii) = xfinc(ii) + xforc(ii)
  353. C enddo
  354. C On realise l'addition en FORTRAN pur (plus rapide)
  355. CALL OPTABj(1,1,3,2,xfinc,xforc,xfinc,LRE,LRE,LRE,0,0,0.D0,IRETO)
  356. *
  357. 5004 CONTINUE
  358.  
  359. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  360. INTERR(1)=IB
  361. if (noer.eq.0) then
  362. CALL ERREUR(195)
  363. GOTO 9904
  364. else
  365. noer=195
  366. return
  367. endif
  368. ENDIF
  369. C
  370. C EXTRACTION DES FORCES AU NOEUD SUPPORT DE LA DEF PLAN GENE
  371. C ON CALCULE LES RESULTANTES DES FORCES SUR CHAQUE ELEMENT
  372. C
  373. NFOFO=NFOR
  374. if (IIPDPG.gt.0) then
  375. IF (IFOUR.EQ.-3) THEN
  376. NFOFO=NFOR-3
  377. ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  378. BDPG=BDPG+XFINC(NBNN*NFOFO+2)
  379. CDPG=CDPG+XFINC(NBNN*NFOFO+3)
  380. ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ.9.OR.
  381. . IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  382. NFOFO=NFOR-1
  383. ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  384. ELSE IF (IFOUR.EQ.11) THEN
  385. NFOFO=NFOR-2
  386. ADPG=ADPG+XFINC(NBNN*NFOFO+1)
  387. BDPG=BDPG+XFINC(NBNN*NFOFO+2)
  388. ENDIF
  389. endif
  390. C
  391. C ON RANGE XFORC DANS MELVAL
  392. C
  393. IE=0
  394. MPTVAL=IVAFOR
  395. DO IGAU=1,NBNN
  396. DO ICOMP=1,NFOFO
  397. IE=IE+1
  398. MELVAL=IVAL(ICOMP)
  399. IBMN=MIN(IB ,VELCHE(/2))
  400. VELCHE(IGAU,IBMN)=XFINC(IE)
  401. ENDDO
  402. ENDDO
  403. 3004 CONTINUE
  404.  
  405. 9904 CONTINUE
  406. SEGSUP MWRK1
  407. if (mwrk67.ne.0) segsup mwrk67
  408. GOTO 510
  409. C__________________________________________________________________
  410. C_______________________________________________________________________
  411. C
  412. C MILIEUX POREUX
  413. C_______________________________________________________________________
  414. C
  415. 79 CONTINUE
  416. C
  417. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  418. C NBNO = NOMBRE DE FONCTIONS DE FORME
  419. C
  420. DIM3=1.D0
  421. NBNO=IPORE
  422. NBBB=NBNN
  423. LRN = NBNO-NBBB
  424. LRB=LRE-LRN
  425. *
  426. NSTN=1
  427. SEGINI MWRK1,MWRK5
  428. C
  429. DO 3079 IB=1,NBELEM
  430. C
  431. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  432. C
  433. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  434. C
  435. C MISE A 0 DES FORCES
  436. C
  437. CALL ZERO(XFORC,1,LRE)
  438. C
  439. C BOUCLE SUR LES POINTS DE GAUSS
  440. C
  441. ISDJC=0
  442. DO 5079 IGAU=1,NBPGAU
  443. C
  444. C RECUPERATION DE L'EPAISSEUR
  445. C
  446. IF (IFOUR.EQ.-2)THEN
  447. MPTVAL=IVACAR
  448. IF (IVACAR.NE.0) THEN
  449. MELVAL=IVAL(1)
  450. IF (MELVAL.NE.0) THEN
  451. IGMN=MIN(IGAU,VELCHE(/1))
  452. IBMN=MIN(IB,VELCHE(/2))
  453. DIM3=VELCHE(IGMN,IBMN)
  454. ELSE
  455. DIM3=1.D0
  456. ENDIF
  457. ENDIF
  458. ENDIF
  459. C
  460. CALL BNPORE(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,NHRM,
  461. . DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,1)
  462. IF (DJAC.EQ.0.D0) THEN
  463. INTERR(1)=IB
  464. if (noer.eq.0) then
  465. CALL ERREUR(259)
  466. GOTO 9979
  467. else
  468. noer=259
  469. return
  470. endif
  471. ENDIF
  472. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  473. DJAC=ABS(DJAC)*POIGAU(IGAU)
  474. C
  475. C ON CHERCHE LES CONTRAINTES
  476. C
  477. MPTVAL=IVASTR
  478. DO 6079 ICOMP=1,NSTRS
  479. MELVAL=IVAL(ICOMP)
  480. IGMN=MIN(IGAU,VELCHE(/1))
  481. IBMN=MIN(IB ,VELCHE(/2))
  482. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  483. 6079 CONTINUE
  484. C
  485. C CALCUL DE B*SIGMA
  486. C
  487. CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  488.  
  489. * ON AJOUTE LES TERMES EN FP
  490. * SIGNE - POUR ETRE COHERENT AVEC RIGI
  491. *
  492. r_z = XSTRS(NSTRS)*DJAC
  493. DO 6179 J=1,LRN
  494. JJ=LRB+J
  495. XFORC(JJ)=XFORC(JJ) - r_z*XGENE(1,J)
  496. 6179 CONTINUE
  497. *
  498. 5079 CONTINUE
  499. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  500. INTERR(1)=IB
  501. if (noer.eq.0) then
  502. CALL ERREUR(195)
  503. GOTO 9979
  504. else
  505. noer=195
  506. return
  507. endif
  508. ENDIF
  509. C
  510. C ON RANGE XFORC DANS MELVAL
  511. C D'ABORD LES FORCES PUIS LES DEBITS
  512. C
  513. IE=0
  514. MPTVAL=IVAFOR
  515. DO IGAU=1,NBNN
  516. DO ICOMP=1,NFOR-1
  517. IE=IE+1
  518. MELVAL=IVAL(ICOMP)
  519. VELCHE(IGAU,IB)=XFORC(IE)
  520. ENDDO
  521. ENDDO
  522. *
  523. DO 7179 IGAU=1,NBSOM(IELE)
  524. IE=IE+1
  525. MELVAL=IVAL(NFOR)
  526. IGAV = IBSOM(NSPOS(IELE)+IGAU-1)
  527. VELCHE(IGAV,IB)=XFORC(IE)
  528. 7179 CONTINUE
  529. *
  530. 3079 CONTINUE
  531.  
  532. 9979 CONTINUE
  533. SEGSUP MWRK1,MWRK5
  534. GOTO 510
  535. C_______________________________________________________________________
  536. C__________________________________________________________________
  537. C
  538. C MILIEUX POREUX - SUITE
  539. C_______________________________________________________________________
  540. C
  541. 173 CONTINUE
  542. C
  543. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  544. C NBNO = NOMBRE DE FONCTIONS DE FORME
  545. C
  546. DIM3=1.D0
  547. NBNO=IPORE
  548. NBBB=NBNN
  549. IF(MELE.GE.173.AND.MELE.LE.177) THEN
  550. IDECAP = 2
  551. ELSE IF (MELE.GE.178.AND.MELE.LE.182) THEN
  552. IDECAP = 3
  553. ENDIF
  554. *
  555. NSTN=IDECAP
  556. NSTB=4
  557. IF(IFOUR.EQ.1.OR.IFOUR.EQ.2) NSTB=6
  558. LPP = NBNO-NBBB
  559. LRN=IDECAP*LPP
  560. LRB=LRE-LRN
  561.  
  562. SEGINI MWRK1,MWRK5
  563. C
  564. DO 3173 IB=1,NBELEM
  565. C
  566. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  567. C
  568. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  569. C
  570. C MISE A 0 DES FORCES
  571. C
  572. CALL ZERO(XFORC,1,LRE)
  573. C
  574. C BOUCLE SUR LES POINTS DE GAUSS
  575. C
  576. ISDJC=0
  577. DO 5173 IGAU=1,NBPGAU
  578. C
  579. C RECUPERATION DE L'EPAISSEUR
  580. C
  581. IF (IFOUR.EQ.-2)THEN
  582. MPTVAL=IVACAR
  583. IF (IVACAR.NE.0) THEN
  584. MELVAL=IVAL(1)
  585. IF (MELVAL.NE.0) THEN
  586. IGMN=MIN(IGAU,VELCHE(/1))
  587. IBMN=MIN(IB,VELCHE(/2))
  588. DIM3=VELCHE(IGMN,IBMN)
  589. ELSE
  590. DIM3=1.D0
  591. ENDIF
  592. ENDIF
  593. ENDIF
  594. C
  595. CALL BNQORE(IGAU,NBNO,NBBB,LRE,IFOUR,NSTB,NSTN,NHRM,
  596. & DIM3,XE,SHPTOT,SHPWRK,BGENE,XGENE,DJAC,IDECAP,LHOOK,1)
  597. IF (DJAC.EQ.0.D0) THEN
  598. INTERR(1)=IB
  599. if (noer.eq.0) then
  600. CALL ERREUR(259)
  601. GOTO 99173
  602. else
  603. noer=259
  604. return
  605. endif
  606. ENDIF
  607. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  608. DJAC=ABS(DJAC)*POIGAU(IGAU)
  609. C
  610. C ON CHERCHE LES CONTRAINTES
  611. C
  612. MPTVAL=IVASTR
  613. DO 6173 ICOMP=1,NSTRS
  614. MELVAL=IVAL(ICOMP)
  615. IGMN=MIN(IGAU,VELCHE(/1))
  616. IBMN=MIN(IB ,VELCHE(/2))
  617. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  618. 6173 CONTINUE
  619. C
  620. C CALCUL DE B*SIGMA
  621. C
  622. CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  623. *
  624. * ON AJOUTE LES TERMES EN FP
  625. * SIGNE - POUR ETRE COHERENT AVEC RIGI
  626. *
  627. DO 6273 IPR=1,IDECAP
  628. IPR1=(IPR-1)*LPP
  629. IPR2=NSTRS-IDECAP+IPR
  630. r_z = XSTRS(IPR2) * DJAC
  631. DO 6373 J=1,LPP
  632. JJ=LRB+IPR1+J
  633. XFORC(JJ)=XFORC(JJ)- r_z * XGENE(IPR,IPR1+J)
  634. 6373 CONTINUE
  635. 6273 CONTINUE
  636. *
  637. 5173 CONTINUE
  638.  
  639. IF(ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  640. INTERR(1)=IB
  641. if (noer.eq.0) then
  642. CALL ERREUR(195)
  643. GOTO 99173
  644. else
  645. noer=195
  646. return
  647. endif
  648. ENDIF
  649. C
  650. C ON RANGE XFORC DANS MELVAL
  651. C D'ABORD LES FORCES PUIS LES DEBITS
  652. C
  653. IE=0
  654. MPTVAL=IVAFOR
  655. DO IGAU=1,NBNN
  656. DO ICOMP=1,NFOR-IDECAP
  657. IE=IE+1
  658. MELVAL=IVAL(ICOMP)
  659. VELCHE(IGAU,IB)=XFORC(IE)
  660. ENDDO
  661. ENDDO
  662. *
  663. DO 7273 IPR=1,IDECAP
  664. IPR1=NFOR-IDECAP+IPR
  665. DO 7373 IGAU=1,NBSOM(IELE)
  666. IE=IE+1
  667. MELVAL=IVAL(IPR1)
  668. IGAV = IBSOM(NSPOS(IELE)+IGAU-1)
  669. VELCHE(IGAV,IB)=XFORC(IE)
  670. 7373 CONTINUE
  671. 7273 CONTINUE
  672. *
  673. 3173 CONTINUE
  674. *
  675. 99173 CONTINUE
  676. SEGSUP MWRK1,MWRK5
  677. GOTO 510
  678. C__________________________________________________________________
  679. C_______________________________________________________________________
  680. C
  681. C JOINTS EN FORMULATION MILIEUX POREUX
  682. C_______________________________________________________________________
  683. C
  684. 80 CONTINUE
  685. C
  686. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  687. C NBNO = NOMBRE DE FONCTIONS DE FORME
  688. C
  689. NBNO=IPORE
  690. NBBB=NBNN
  691. LRN=(NBNO-NBBB)*3/2
  692. LRB=LRE-LRN
  693. NSTN=1
  694. NFAC=(3*NBBB-NBNO)/2
  695. NMIL=LRN-NBSOM(IELE)
  696. SEGINI MWRK1,MWRK3,MWRK5
  697. I195=0
  698. I259=0
  699. C
  700. DO 3080 IB=1,NBELEM
  701. C
  702. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  703. C
  704. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  705. C
  706. C CALCUL DES AXES LOCAUX ET DES CORDONNES LOCALES
  707. C
  708. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  709. C
  710. C MISE A 0 DES FORCES
  711. C
  712. CALL ZERO(XFORC,1,LRE)
  713. C
  714. C BOUCLE SUR LES POINTS DE GAUSS
  715. C
  716. ISDJC=0
  717. DO 5080 IGAU=1,NBPGAU
  718. C
  719. CALL BNPORJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  720. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,1)
  721. IF (DJAC.EQ.0.) THEN
  722. INTERR(1)=IB
  723. if (noer.eq.0) then
  724. CALL ERREUR(259)
  725. GOTO 9980
  726. else
  727. noer=259
  728. return
  729. endif
  730. ENDIF
  731. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  732. DJAC=ABS(DJAC)*POIGAU(IGAU)
  733. C
  734. C ON CHERCHE LES CONTRAINTES
  735. C
  736. MPTVAL=IVASTR
  737. DO 6080 ICOMP=1,NSTRS
  738. MELVAL=IVAL(ICOMP)
  739. IGMN=MIN(IGAU,VELCHE(/1))
  740. IBMN=MIN(IB ,VELCHE(/2))
  741. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  742. 6080 CONTINUE
  743. C
  744. C CALCUL DE B*SIGMA
  745. C
  746. CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  747. *
  748. * ON AJOUTE LES TERMES EN FP
  749. * SIGNE - POUR ETRE COHERENT AVEC RIGI
  750. *
  751. r_z = XSTRS(NSTRS)*DJAC
  752. DO 6180 J=1,LRN
  753. JJ=LRB+J
  754. XFORC(JJ)=XFORC(JJ)-XGENE(1,J)*r_z
  755. 6180 CONTINUE
  756.  
  757. 5080 CONTINUE
  758. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  759. INTERR(1)=IB
  760. if (noer.eq.0) then
  761. CALL ERREUR(195)
  762. GOTO 9980
  763. else
  764. noer=195
  765. return
  766. endif
  767. ENDIF
  768. C
  769. C ON RANGE XFORC DANS MELVAL
  770. C D'ABORD LES FORCES PUIS LES DEBITS
  771. C
  772. MPTVAL=IVAFOR
  773. C
  774. IE=0
  775. DO IGAU=1,NFAC
  776. DO ICOMP=1,NFOR-1
  777. IE=IE+1
  778. MELVAL=IVAL(ICOMP)
  779. VELCHE(IGAU,IB)=XFORC(IE)
  780. ENDDO
  781. ENDDO
  782. *
  783. * debits ( d'abord sommets puis mileux des cotes ad-hoc )
  784. *
  785. MELVAL=IVAL(NFOR)
  786. IGMN = NSPOS(IELE)-1
  787. DO IGAU=1,NBSOM(IELE)
  788. IE = IE+1
  789. IGAV = IBSOM(IGMN + IGAU)
  790. C* VELCHE(IGAV,IB)=XFORC(IE)*0.D0
  791. VELCHE(IGAV,IB)=0.D0
  792. ENDDO
  793. *
  794. IGMN = NBBB - NMIL
  795. DO IGAU=1,NMIL
  796. IE=IE+1
  797. IGAV = IGMN + IGAU
  798. VELCHE(IGAV,IB)=XFORC(IE)
  799. ENDDO
  800. *
  801. 3080 CONTINUE
  802.  
  803. 9980 CONTINUE
  804. SEGSUP MWRK1,MWRK3,MWRK5
  805. GOTO 510
  806. C__________________________________________________________________
  807. C_______________________________________________________________________
  808. C
  809. C JOINTS EN FORMULATION MILIEUX POREUX - SUITE
  810. C_______________________________________________________________________
  811. C
  812. 185 CONTINUE
  813. C
  814. C POUR CES ELEMENTS NBBB = NOMBRE DE NOEUDS
  815. C NBNO = NOMBRE DE FONCTIONS DE FORME
  816. C
  817. IF (MELE.GE.185.AND.MELE.LE.187) THEN
  818. IDECAP = 2
  819. ELSE IF (MELE.GE.188.AND.MELE.LE.190) THEN
  820. IDECAP = 3
  821. ENDIF
  822. C
  823. NBNO=IPORE
  824. NSTN=IDECAP
  825. NSTB=2
  826. IF(IFOUR.EQ.1.OR.IFOUR.EQ.2) NSTB=3
  827. C
  828. NBBB=NBNN
  829. LPP=(NBNO-NBBB)*3/2
  830. LRN=IDECAP*LPP
  831. LRB=LRE-LRN
  832. NFAC=(3*NBBB-NBNO)/2
  833. NMIL=LPP-NBSOM(IELE)
  834. SEGINI MWRK1,MWRK3,MWRK5
  835. I195=0
  836. I259=0
  837. C
  838. DO 3185 IB=1,NBELEM
  839. C
  840. C ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  841. C
  842. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  843. C
  844. C CALCUL DES AXES LOCAUX ET DES CORDONNES LOCALES
  845. C
  846. CALL JOPLOC(XE,SHPTOT,NBBB,NBNO,IFOUR,XEL,BPSS)
  847. C
  848. C MISE A 0 DES FORCES
  849. C
  850. CALL ZERO(XFORC,1,LRE)
  851. C
  852. C BOUCLE SUR LES POINTS DE GAUSS
  853. C
  854. ISDJC=0
  855. DO 5185 IGAU=1,NBPGAU
  856. C
  857. CALL BNPQRJ(IGAU,NBNO,NBBB,LRE,IFOUR,LHOOK,NSTN,XE,XEL,
  858. . SHPTOT,SHPWRK,BPSS,BGENE,XGENE,DJAC,IDECAP,NSTB,1)
  859. IF (DJAC.EQ.0.) THEN
  860. INTERR(1)=IB
  861. if (noer.eq.0) then
  862. CALL ERREUR(259)
  863. GOTO 9985
  864. else
  865. noer=259
  866. return
  867. endif
  868. ENDIF
  869. IF(DJAC.LT.0.) ISDJC=ISDJC+1
  870. DJAC=ABS(DJAC)*POIGAU(IGAU)
  871. C
  872. C ON CHERCHE LES CONTRAINTES
  873. C
  874. MPTVAL=IVASTR
  875. DO 6185 ICOMP=1,NSTRS
  876. MELVAL=IVAL(ICOMP)
  877. IGMN=MIN(IGAU,VELCHE(/1))
  878. IBMN=MIN(IB ,VELCHE(/2))
  879. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  880. 6185 CONTINUE
  881. C
  882. C CALCUL DE B*SIGMA
  883. C
  884. CALL BSIG(BGENE,XSTRS,LHOOK,LRE,DJAC,XFORC)
  885. *
  886. * ON AJOUTE LES TERMES EN FP
  887. * SIGNE - POUR ETRE COHERENT AVEC RIGI
  888. *
  889. DO IPR=1,IDECAP
  890. IPR1=(IPR-1)*LPP
  891. IPR2=NSTRS-IDECAP+IPR
  892. r_z = XSTRS(IPR2)*DJAC
  893. DO J=1,LPP
  894. JJ=LRB+IPR1+J
  895. XFORC(JJ)=XFORC(JJ)-XGENE(IPR,IPR1+J)*r_z
  896. ENDDO
  897. ENDDO
  898.  
  899. 5185 CONTINUE
  900. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  901. INTERR(1)=IB
  902. if (noer.eq.0) then
  903. CALL ERREUR(195)
  904. GOTO 9985
  905. else
  906. noer=195
  907. return
  908. endif
  909. ENDIF
  910. C
  911. C ON RANGE XFORC DANS MELVAL
  912. C D'ABORD LES FORCES PUIS LES DEBITS
  913. C
  914. IE=0
  915. MPTVAL=IVAFOR
  916. JCOMP = NFOR-IDECAP
  917. DO IGAU=1,NFAC
  918. DO ICOMP=1,JCOMP
  919. IE=IE+1
  920. MELVAL=IVAL(ICOMP)
  921. VELCHE(IGAU,IB)=XFORC(IE)
  922. ENDDO
  923. ENDDO
  924. *
  925. * debits ( d'abord sommets puis mileux des cotes ad-hoc )
  926. *
  927. DO 7485 IPR=1,IDECAP
  928. IPR1 = NFOR-IDECAP+IPR
  929. MELVAL=IVAL(IPR1)
  930.  
  931. DO 7285 IGAU=1,NBSOM(IELE)
  932. IE=IE+1
  933. IGAV = IBSOM(NSPOS(IELE)+IGAU-1)
  934. C* VELCHE(IGAV,IB)=XFORC(IE)*0.D0
  935. VELCHE(IGAV,IB)=0.D0
  936. 7285 CONTINUE
  937. *
  938. DO 7385 IGAU=1,NMIL
  939. IE=IE+1
  940. IGAV = NBBB - NMIL +IGAU
  941. VELCHE(IGAV,IB)=XFORC(IE)
  942. 7385 CONTINUE
  943. 7485 CONTINUE
  944. *
  945. 3185 CONTINUE
  946.  
  947. 9985 CONTINUE
  948. SEGSUP MWRK1,MWRK3,MWRK5
  949. GOTO 510
  950. C
  951. 99 CONTINUE
  952. MOTERR(1:4)=NOMTP(MELE)
  953. MOTERR(5:12)='BSIGMA'
  954. CALL ERREUR(86)
  955. C
  956. 510 CONTINUE
  957.  
  958. c RETURN
  959. END
  960.  
  961.  
  962.  
  963.  

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