Télécharger bsigm1.eso

Retour à la liste

Numérotation des lignes :

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

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