Télécharger bsigmp.eso

Retour à la liste

Numérotation des lignes :

bsigmp
  1. C BSIGMP SOURCE CB215821 20/11/25 13:18:56 10792
  2.  
  3. SUBROUTINE BSIGMP(IPMOD0,IPCHE1,IPCHE2,IPCHE3,IMAT,
  4. 1 IPCHP4,IRET,noer)
  5. C_______________________________________________________________________
  6. C
  7. C Entrees:
  8. C ________
  9. C
  10. C IPMOD0 Pointeur sur un MMODEL
  11. C IPCHE1 Pointeur sur un MCHAML de contraintes
  12. C IPCHE2 Pointeur sur un MCHAML de caracteristiques (FACULTATIF)
  13. C IPCHE3 POINTEUR SUR UN MCHAML DE HOOKE (FACULTATIF)
  14. C IMAT Flag de HOOKE (2 si oui, 1 sinon)
  15. C
  16. C SORTIES:
  17. C ________
  18. C
  19. C IPCHP4 Pointeur sur un CHPOINT de forces aux noeuds
  20. C IRET = 1 OU 0 suivant succes ou pas (Message d'erreur
  21. C imprime dans ce cas)
  22. C
  23. C Passage aux nouveaux CHAMELEMs par I.Monnier le 13.06.90
  24. C_______________________________________________________________________
  25. C
  26. IMPLICIT INTEGER(I-N)
  27. IMPLICIT REAL*8(A-H,O-Z)
  28. *
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC CCHAMP
  33.  
  34. -INC SMMODEL
  35. -INC SMCHAML
  36. -INC SMCHPOI
  37. -INC SMELEME
  38. -INC SMINTE
  39. -INC SMLENTI
  40. -INC SMCOORD
  41. C
  42. SEGMENT INFO
  43. INTEGER INFELL(JG)
  44. ENDSEGMENT
  45. *
  46. SEGMENT NOTYPE
  47. CHARACTER*16 TYPE(NBTYPE)
  48. ENDSEGMENT
  49. *
  50. SEGMENT MPTVAL
  51. INTEGER IPOS(NS) ,NSOF(NS)
  52. INTEGER IVAL(NCOSOU)
  53. CHARACTER*16 TYVAL(NCOSOU)
  54. ENDSEGMENT
  55. *
  56. SEGMENT LIMODE(NK100)
  57. *
  58. PARAMETER ( NINF=3 )
  59. INTEGER INFOS(NINF)
  60. CHARACTER*8 CMATE
  61. CHARACTER*(NCONCH) CONM
  62. LOGICAL BDPGE,ldpge,lsupfo,lsupco,lsupma,dcmate
  63. *
  64.  
  65. C On a besoin du MCOORD dans DOXE plus loin
  66. SEGACT,MCOORD
  67.  
  68. isup1 = 0
  69. isup2 = 0
  70. isup3 = 0
  71. IRET = 0
  72. IPCHP4 = 0
  73. mchaml=0
  74. *
  75. llent2 = 0
  76. klent2 = 0
  77. *
  78. * On deroule le modele initial IPMOD0 et on ne garde que les sous-
  79. * modeles d interet -> on cree un nouveau modele IPMODL
  80. mmodel = IPMOD0
  81. NSOUS = mmodel.kmodel(/1)
  82. IPMODL = IPMOD0
  83.  
  84. mchelm = IPCHE1
  85. NSCZ = mchelm.imache(/1)
  86.  
  87. N1 = 100
  88. segini mmode1
  89. k1 = 0
  90. DO 160 im = 1, NSOUS
  91. imodel = mmodel.kmodel(im)
  92. IF (imodel.nefmod.EQ.22.OR.imodel.nefmod.EQ.259) GOTO 160
  93. IF (imodel.formod(1).EQ.'LIAISON') GOTO 160
  94. if(formod(1)(1:9).eq.'MECANIQUE'.or.
  95. &formod(1)(1:6).eq.'POREUX'.or.formod(1)(1:7).eq.'LIQUIDE') then
  96. k1 = k1 + 1
  97. if (k1.gt.n1) then
  98. n1 = n1 + 100
  99. segadj mmode1
  100. endif
  101. mmode1.kmodel(k1) = imodel
  102. else
  103. endif
  104. 160 CONTINUE
  105.  
  106. if (k1.gt.0) then
  107. n1 = k1
  108. segadj mmode1
  109. IPMODL = mmode1
  110. endif
  111.  
  112.  
  113. *
  114. * Verification du lieu support des MCHAML
  115. *
  116. * Contraintes :
  117. CALL QUESUP(IPMODL,IPCHE1,3,0,ISUP1,iret1C)
  118. IF (ISUP1.GT.1) RETURN
  119. * Caracteristiques :
  120. IF (IPCHE2.NE.0) THEN
  121. CALL QUESUP(IPMODL,IPCHE2,3,0,ISUP2,ir)
  122. IF (ISUP2.GT.1) RETURN
  123. ENDIF
  124. * Matrice.Hooke :
  125. IF (IPCHE3.NE.0) THEN
  126. CALL QUESUP(IPMODL,IPCHE3,3,1,ISUP3,ir)
  127. IF (ISUP3.NE.0) RETURN
  128. ENDIF
  129.  
  130. C_______________________________________________________________________
  131. C
  132. C ACTIVATION DU MODELE
  133. C_______________________________________________________________________
  134. C
  135. mmodel = IPMODL
  136. NSOUS = mmodel.kmodel(/1)
  137. C
  138. C ACTIVATION DES CONTRAINTES
  139. C
  140. mchel1 = IPCHE1
  141. *
  142. C INITIALISATION DU MCHELM DE FORCES
  143. C
  144. N1 = NSOUS
  145. L1 = 6
  146. N3 = 5
  147. CALL oooprl(1)
  148. SEGINI,mchelm
  149. IPCHE5 = mchelm
  150. mchelm.IFOCHE = IFOUR
  151. mchelm.TITCHE = 'FORCES'
  152. C
  153. C Cas des modes de calcul GENERALISES (2D et 1D) pour la mecanique :
  154. C On cree un CHPOINT local pour les forces sur les points supports :
  155. ICHPGE = 0
  156. IF (IFOUR.EQ.-3) THEN
  157. BDPGE = .TRUE.
  158. NFORDG = 3
  159. NC = NFORDG
  160. SEGINI,msoupo
  161. msoupo.NOCOMP(1) = 'FZ '
  162. msoupo.NOCOMP(2) = 'MY '
  163. msoupo.NOCOMP(3) = 'MX '
  164. ELSE IF (IFOUR.EQ.11) THEN
  165. BDPGE = .TRUE.
  166. NFORDG = 2
  167. NC = NFORDG
  168. SEGINI,msoupo
  169. msoupo.NOCOMP(1) = 'FZ '
  170. msoupo.NOCOMP(2) = 'FY '
  171. ELSE IF (IFOUR.EQ.9.OR.IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  172. BDPGE = .TRUE.
  173. NFORDG = 1
  174. NC = NFORDG
  175. SEGINI,msoupo
  176. msoupo.NOCOMP(1) = 'FZ '
  177. ELSE IF (IFOUR.EQ.7.OR.IFOUR.EQ.8) THEN
  178. BDPGE = .TRUE.
  179. NFORDG = 1
  180. NC = NFORDG
  181. SEGINI,msoupo
  182. msoupo.NOCOMP(1) = 'FY '
  183. ELSE
  184. BDPGE = .FALSE.
  185. NFORDG = 0
  186. ENDIF
  187. C On finit de remplir le CHPOINT en cas de DPGE :
  188. IF (BDPGE) THEN
  189. NSOUPO = 1
  190. NAT = 1
  191. SEGINI,mchpoi
  192. mchpoi.MTYPOI = ' '
  193. mchpoi.MOCHDE = ' '
  194. mchpoi.JATTRI(1) = 2
  195. mchpoi.IPCHP(1) = msoupo
  196. mchpoi.IFOPOI = IFOUR
  197. C On cree un maillage de POI1 avec les points supports (sans redondance)
  198. nbnn = 1
  199. nbelem = NSOUS
  200. nbref = 0
  201. nbsous = 0
  202. SEGINI,meleme
  203. meleme.itypel = 1
  204. N_DPGE = 0
  205. K_DPGE = 0
  206. DO im = 1, NSOUS
  207. imodel = mmodel.kmodel(im)
  208. iipdpg = imodel.IPDPGE
  209. iipdpg = IPTPOI(iipdpg)
  210. IF (iipdpg.GT.0) THEN
  211. N_DPGE = N_DPGE + 1
  212. meleme.num(1,N_DPGE) = iipdpg
  213. K_DPGE = im
  214. GOTO 1180
  215. ENDIF
  216. ENDDO
  217. K_DPGE = NSOUS+1
  218. 1180 CONTINUE
  219. DO im = K_DPGE+1, NSOUS
  220. imodel = mmodel.kmodel(im)
  221. iipdpg = imodel.IPDPGE
  222. iipdpg = IPTPOI(iipdpg)
  223. IF (iipdpg.LE.0) GOTO 1190
  224. DO jm = 1, N_DPGE
  225. IF (iipdpg.EQ.meleme.num(1,jm)) GOTO 1190
  226. ENDDO
  227. N_DPGE = N_DPGE + 1
  228. meleme.num(1,N_DPGE) = iipdpg
  229. 1190 CONTINUE
  230. ENDDO
  231. IF (N_DPGE.NE.NSOUS) THEN
  232. nbelem = N_DPGE
  233. SEGADJ,meleme
  234. ENDIF
  235. msoupo.IGEOC = meleme
  236. C On cree les valeurs de forces GENE nulles au depart :
  237. N = N_DPGE
  238. NC = NFORDG
  239. SEGINI,mpoval
  240. msoupo.IPOVAL = mpoval
  241. ICHPGE = mchpoi
  242. ENDIF
  243. CALL oooprl(0)
  244. K_DPGE = 0
  245. C
  246. C_______________________________________________________________________
  247. C
  248. C BOUCLE SUR LES SOUS ZONES
  249. C_______________________________________________________________________
  250. C
  251. ISOUS = 0
  252. *
  253. DO 200 KISOUS = 1, NSOUS
  254. *
  255. * INITIALISATION
  256. *
  257. IVAMAT=0
  258. IVACAR=0
  259. IVASTR=0
  260. IVAFOR=0
  261. MOMATR=0
  262. MOCARA=0
  263. MOSTRS=0
  264. MOFORC=0
  265. lsupfo=.false.
  266. lsupco=.false.
  267. lsupma=.true.
  268. IPMINT=0
  269. C
  270. C TRAITEMENT DU MODELE
  271. C
  272. imodel = mmodel.kmodel(KISOUS)
  273. c* IF (imodel.formod(1).EQ.'LIAISON' .OR. nefmod.EQ.22) GOTO 200
  274. *
  275. ISOUS = ISOUS+1
  276. MELE = imodel.NEFMOD
  277. IPMAIL = imodel.IMAMOD
  278. CONM = imodel.CONMOD
  279. IIPDPG = imodel.IPDPGE
  280. IIPDPG = IPTPOI(IIPDPG)
  281. C
  282. C CREATION DU TABLEAU INFOS
  283. C
  284. CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  285. IF (IRTD.EQ.0) GOTO 9991
  286. C
  287. C COQUE INTEGREE OU PAS ?
  288. C
  289. IF (INFMOD(/1).NE.0)THEN
  290. NPINT = INFMOD(1)
  291. ELSE
  292. NPINT = 0
  293. ENDIF
  294. C
  295. C NATURE DU MATERIAU
  296. C
  297. CMATE = CMATEE
  298. MATE = IMATEE
  299. INAT = INATUU
  300. dcmate = .FALSE.
  301. DO im = 1, imodel.matmod(/2)
  302. IF (imodel.matmod(im).EQ.'IMPEDANCE') dcmate = .TRUE.
  303. ENDDO
  304. C____________________________________________________________________
  305. C
  306. C ACTIVATION DU MELEME
  307. C
  308. MELEME = IPMAIL
  309. if (dcmate) then
  310. if (itypel.eq.1) mele = 45
  311. if (itypel.eq.2) mele = 2
  312. endif
  313. NBNN = meleme.NUM(/1)
  314. NBELEM = meleme.NUM(/2)
  315. C_______________________________________________________________________
  316. C
  317. C INFORMATIONS SUR L'ELEMENT FINI
  318. C_______________________________________________________________________
  319. C
  320. IF (infmod(/1).lt.5) then
  321. CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  322. IF (IERR.NE.0) GOTO 9991
  323. INFO=IPINF
  324. NBPGAU= INFELL(4)
  325. MINTE = INFELL(11)
  326. MINTE1= INFELL(12)
  327. MFR = INFELL(13)
  328. NSTRS = INFELL(16)
  329. LHOOK = INFELL(10)
  330. LW = INFELL(7)
  331. LRE = INFELL(9)
  332. IPORE = INFELL(8)
  333. SEGSUP INFO
  334. ELSE
  335. NBPGAU= INFELE(4)
  336. MINTE = infmod(5)
  337. MINTE1= INFmod(8)
  338. MFR = INFELE(13)
  339. NSTRS = INFELE(16)
  340. LHOOK = INFELE(10)
  341. LW = INFELE(7)
  342. LRE = INFELE(9)
  343. IPORE = INFELE(8)
  344. ENDIF
  345. *
  346. IPMINT= MINTE
  347. IPMIN1= MINTE1
  348. NHRM = NIFOUR
  349. IPPORE =0
  350. IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) IPPORE = NBNN
  351.  
  352. C Informations en DPGE pour le (sous-)modele courant
  353. C Si ldpge est VRAI, alors ndpge = NFORDG, sinon ndpge = 0.
  354. CALL INFDPG(MFR,IFOUR, ldpge,ndpge)
  355. C
  356. * if(mele.ne.260) then
  357. * NBNO=SHPTOT(/2)
  358. * endif
  359. C
  360. IMACHE(ISOUS) = IPMAIL
  361. INFCHE(ISOUS,1)=0
  362. INFCHE(ISOUS,2)=0
  363. INFCHE(ISOUS,3)=NIFOUR
  364. INFCHE(ISOUS,4)=0
  365. INFCHE(ISOUS,5)=0
  366. C__________________________________
  367. C
  368. C NOMS DE COMPOSANTES NECESSAIRES ( CONTRAINTES )
  369. C_______________________________________________________________________
  370. C
  371. if(lnomid(4).ne.0) then
  372. mostrs=lnomid(4)
  373. nomid=mostrs
  374. nstr=lesobl(/2)
  375. nfac=lesfac(/2)
  376. else
  377. lsupco=.true.
  378. CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  379. nomid=mostrs
  380. segact nomid
  381. endif
  382. C
  383. if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
  384. * recherche composante FMOD
  385. if (llent2.eq.0) then
  386. jg = NSOUS
  387. jgl2 = jg
  388. segini mlent2
  389. llent2 = mlent2
  390. endif
  391. do im2 = 1, mchel1.imache(/1)
  392. if (mchel1.imache(im2).eq.imamod.and.
  393. & mchel1.conche(im2).eq.conmod) then
  394. mcham2 = mchel1.ichaml(im2)
  395. do in2 = 1, mcham2.nomche(/2)
  396. if (mcham2.nomche(in2)(1:4).eq.'FMOD') then
  397. melva2 = mcham2.ielval(in2)
  398. if (klent2 + melva2.ielche(/2).gt.jgl2) then
  399. jgl2 = jgl2 + melva2.ielche(/2)
  400. jg = jgl2
  401. segadj mlent2
  402. endif
  403. do iel2 = 1,melva2.ielche(/2)
  404. klent2 = klent2 + 1
  405. mlent2.lect(klent2) = melva2.ielche(1,iel2)
  406. enddo
  407. goto 11
  408. endif
  409. enddo
  410. endif
  411. enddo
  412. 11 continue
  413. *JK truande le test komcha
  414. IF(NSTRS.LT.1) THEN
  415. CALL ERREUR(922)
  416. GO TO 9990
  417. ENDIF
  418. mostrs0 = mostrs
  419. if (ifomod.eq.6) then
  420. nbrobl = 1
  421. nbrfac = 1
  422. segini nomid
  423. lesobl(1) = 'EFFX'
  424. lesfac(1) = 'IFFX'
  425. else
  426. nbrobl = 1
  427. nbrfac = 0
  428. segini nomid
  429. lesobl(1) = 'EFFX'
  430. endif
  431. mostrs = nomid
  432. else
  433. IF(NSTR+NFAC.NE.NSTRS) THEN
  434. CALL ERREUR(922)
  435. GO TO 9990
  436. ENDIF
  437. endif
  438. C
  439. C VERIFICATION DE LEUR PRESENCE
  440. C
  441. NBTYPE=1
  442. SEGINI NOTYPE
  443. TYPE(1)='REAL*8'
  444. MOTYPE=NOTYPE
  445. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVASTR)
  446. SEGSUP NOTYPE
  447. IF (IERR.NE.0) GOTO 9991
  448. C
  449. if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
  450. mptval = ivastr
  451. segact mptval*mod
  452. ns = ipos(/1)
  453. ncosou = 0
  454. jg = ival(/1)
  455. segini mlenti
  456. do ico = 1,ival(/1)
  457. if (ival(ico).gt.0) then
  458. ncosou = ncosou + 1
  459. lect(ncosou) = ival(ico)
  460. endif
  461. enddo
  462. segadj mptval
  463. do ico = 1,ncosou
  464. ival(ico) = lect(ico)
  465. enddo
  466. segsup mlenti
  467. segsup nomid
  468. mostrs = mostrs0
  469. endif
  470. C
  471. IF (ISUP1.EQ.1) THEN
  472. ifai=1
  473. if( mele.eq.260.and.iret1c.eq.5) ifai=0
  474. IF (ifai.eq.1) CALL VALCHE(IVASTR,NSTRS,IPMINT,IPPORE,
  475. & MOSTRS,MELE)
  476. ENDIF
  477. C_______________________________________________________________________
  478. C
  479. C NOMS DE COMPOSANTES NECESSAIRES ( FORCES )
  480. C_______________________________________________________________________
  481. C
  482. if(lnomid(2).ne.0) then
  483. MOFORC = lnomid(2)
  484. NOMID=MOFORC
  485. nforc=lesobl(/2)
  486. NFACF=LESFAC(/2)
  487. else
  488. lsupfo=.true.
  489. CALL IDFORC(MFR,IFOUR,MOFORC,NFORC,NFACF)
  490. NOMID=MOFORC
  491. SEGACT NOMID
  492. endif
  493. C
  494. C CREATION DU MCHAML
  495. C
  496. C CAS PARTICULIER DE LA DEFO PLANE GENE : RIEN SUR FZ MY MX
  497. C
  498. C* NFOREF=NFORC
  499. C* IF (ldpge) NFOREF = NFOREF - ndpge
  500. NFOREF = NFORC - ndpge
  501. c N2=NFOREF
  502. c bp: les composantes facultatives peuvent elles aussi exister !
  503. * on ajustera apres bsigmx la taille reellement utilisee par la force
  504. N2=NFOREF+NFACF
  505. if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
  506. * write(6,*) 'bs',n2,ncosou,nforef,nfacf
  507. if (ncosou.lt.n2) then
  508. *jk : rustique
  509. nfacf = 0
  510. n2 = ncosou
  511. nforef = ncosou
  512. endif
  513. endif
  514. C
  515. C
  516. C TAILLES DE MELVAL
  517. C
  518. N1EL=NBELEM
  519. N1PTEL=NBNN
  520. NBPTEL=NBPGAU
  521. NEL =N1EL
  522. C
  523. C CREATION DU MELVAL DE FORCES
  524. C
  525. NS=1
  526. * NCOSOU=NFOREF
  527. NCOSOU=NFOREF+NFACF
  528.  
  529. CALL oooprl(1)
  530. SEGINI MCHAML
  531.  
  532. SEGINI MPTVAL
  533. DO 100 ICOMP=1,NCOSOU
  534. N2PTEL=0
  535. N2EL =0
  536. SEGINI MELVAL
  537. IELVAL(ICOMP)=MELVAL
  538. IVAL(ICOMP)=MELVAL
  539. 100 CONTINUE
  540. CALL oooprl(0)
  541.  
  542. ICHAML(ISOUS)=MCHAML
  543. IVAFOR=MPTVAL
  544.  
  545.  
  546. DO 110 ICOMP=1,NFOREF
  547. NOMCHE(ICOMP)=LESOBL(ICOMP)
  548. TYPCHE(ICOMP)='REAL*8'
  549. 110 CONTINUE
  550.  
  551. if(NFACF .ne. 0) then
  552. IFAC = 0
  553. DO 111 ICOMP=(NFOREF+1),N2
  554. IFAC = IFAC + 1
  555. NOMCHE(ICOMP)=LESFAC(IFAC)
  556. TYPCHE(ICOMP)='REAL*8'
  557. 111 CONTINUE
  558. endif
  559. C____________________________________________________________________
  560. C
  561. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES *
  562. C____________________________________________________________________
  563. NBROBL=0
  564. NBRFAC=0
  565. NOMID=0
  566. IVECT=0
  567. *
  568. * EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES
  569. *
  570. IF((MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.63.OR.
  571. + (MELE.GE.79.AND.MELE.LE.83)).AND.
  572. + IFOUR.EQ.-2)THEN
  573. *
  574. NBRFAC=1
  575. SEGINI NOMID
  576. LESFAC(1)='DIM3'
  577. *
  578. NBTYPE=1
  579. SEGINI NOTYPE
  580. TYPE(1)='REAL*8'
  581. *
  582. * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  583. *
  584. ELSEIF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  585. NBROBL=1
  586. IF(MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
  587. NBRFAC=2
  588. ELSE
  589. NBRFAC=1
  590. ENDIF
  591. SEGINI NOMID
  592. LESOBL(1)='EPAI'
  593. LESFAC(1)='EXCE'
  594. IF(MFR.EQ.3.AND.IFOUR.EQ.-2) LESFAC(2)='DIM3'
  595. *
  596. NBTYPE=1
  597. SEGINI NOTYPE
  598. TYPE(1)='REAL*8'
  599. *
  600. * SECTION POUR LES BARRES
  601. *
  602. ELSE IF (MFR.EQ.27) THEN
  603. IF(.NOT.dcmate) THEN
  604. NBROBL=1
  605. SEGINI NOMID
  606. LESOBL(1)='SECT'
  607. *
  608. NBTYPE=1
  609. SEGINI NOTYPE
  610. TYPE(1)='REAL*8'
  611. ENDIF
  612. *
  613. * section, excentrements et orientation pour les barres excentrees
  614. *
  615. ELSE IF (MFR.EQ.49) THEN
  616. NBROBL=6
  617. SEGINI NOMID
  618. LESOBL(1)='SECT'
  619. LESOBL(2)='EXCZ'
  620. LESOBL(3)='EXCY'
  621. LESOBL(4)='VX '
  622. LESOBL(5)='VY '
  623. LESOBL(6)='VZ '
  624. *
  625. NBTYPE=1
  626. SEGINI NOTYPE
  627. TYPE(1)='REAL*8'
  628. *
  629. * raideurs locales et orientation pour l'element LIA2
  630. * de liaison a 2 noeuds
  631. *
  632. ELSE IF (MFR.EQ.51) THEN
  633. NBROBL=9
  634. SEGINI NOMID
  635. LESOBL(1)='RLUX'
  636. LESOBL(2)='RLUY'
  637. LESOBL(3)='RLUZ'
  638. LESOBL(4)='RLRX'
  639. LESOBL(5)='RLRY'
  640. LESOBL(6)='RLRZ'
  641. LESOBL(7)='VX '
  642. LESOBL(8)='VY '
  643. LESOBL(9)='VZ '
  644. *
  645. NBTYPE=1
  646. SEGINI NOTYPE
  647. TYPE(1)='REAL*8'
  648. *
  649. * CARACTERISTIQUES POUR LES POUTRES
  650. *
  651. ELSE IF (MFR.EQ.7 ) THEN
  652. if (dcmate) then
  653. NBRFAC=4
  654. SEGINI NOMID
  655. LESFAC(1)='TORS'
  656. LESFAC(2)='INRY'
  657. LESFAC(3)='INRZ'
  658. LESFAC(4)='VECT'
  659. IVECT=1
  660. *
  661. NBTYPE=4
  662. SEGINI NOTYPE
  663. MOTYPE=NOTYPE
  664. TYPE(1)='REAL*8'
  665. TYPE(2)='REAL*8'
  666. TYPE(3)='REAL*8'
  667. TYPE(4)='POINTEURPOINT '
  668. else
  669. IF (CMATE.EQ.'SECTION') THEN
  670. NBRFAC=1
  671. SEGINI NOMID
  672. LESFAC='VECT'
  673. IVECT=1
  674. *
  675. NBTYPE=1
  676. SEGINI NOTYPE
  677. TYPE(1)='POINTEURPOINT '
  678. *
  679. ELSEIF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  680. NBROBL=2
  681. NBRFAC=1
  682. SEGINI NOMID
  683. LESOBL(1)='SECT'
  684. LESOBL(2)='INRZ'
  685. LESFAC(1)='SECY'
  686. *
  687. NBTYPE=1
  688. SEGINI NOTYPE
  689. TYPE(1)='REAL*8'
  690. *
  691. ELSE
  692. NBROBL=4
  693. NBRFAC=3
  694. SEGINI NOMID
  695. LESOBL(1)='TORS'
  696. LESOBL(2)='INRY'
  697. LESOBL(3)='INRZ'
  698. LESOBL(4)='SECT'
  699. LESFAC(1)='SECY'
  700. LESFAC(2)='SECZ'
  701. LESFAC(3)='VECT'
  702. IVECT=1
  703. *
  704. NBTYPE=7
  705. SEGINI NOTYPE
  706. TYPE(1)='REAL*8'
  707. TYPE(2)='REAL*8'
  708. TYPE(3)='REAL*8'
  709. TYPE(4)='REAL*8'
  710. TYPE(5)='REAL*8'
  711. TYPE(6)='REAL*8'
  712. TYPE(7)='POINTEURPOINT '
  713. ENDIF
  714. endif
  715. *
  716. * CARACTERISTIQUES POUR LES TUYAUX
  717. *
  718. ELSE IF (MFR.EQ.13) THEN
  719. NBROBL=2
  720. NBRFAC=3
  721. SEGINI NOMID
  722. LESOBL(1)='EPAI'
  723. LESOBL(2)='RAYO'
  724. LESFAC(1)='RACO'
  725. LESFAC(2)='CISA'
  726. LESFAC(3)='VECT'
  727. IVECT=1
  728. *
  729. NBTYPE=5
  730. SEGINI NOTYPE
  731. TYPE(1)='REAL*8'
  732. TYPE(2)='REAL*8'
  733. TYPE(3)='REAL*8'
  734. TYPE(4)='REAL*8'
  735. TYPE(5)='POINTEURPOINT '
  736. *
  737. * CARACTERISTIQUES POUR LES LINESPRING
  738. *
  739. ELSE IF (MFR.EQ.15) THEN
  740. NBROBL=5
  741. SEGINI NOMID
  742. LESOBL(1)='EPAI'
  743. LESOBL(2)='FISS'
  744. LESOBL(3)='VX '
  745. LESOBL(4)='VY '
  746. LESOBL(5)='VZ '
  747. *
  748. NBTYPE=1
  749. SEGINI NOTYPE
  750. TYPE(1)='REAL*8'
  751. *
  752. * CARACTERISTIQUES POUR LES TUYAUX FISSURES
  753. *
  754. ELSE IF (MFR.EQ.17) THEN
  755. NBROBL=9
  756. SEGINI NOMID
  757. LESOBL(1)='RAYO'
  758. LESOBL(2)='EPAI'
  759. LESOBL(3)='VX '
  760. LESOBL(4)='VY '
  761. LESOBL(5)='VZ '
  762. LESOBL(6)='VXF '
  763. LESOBL(7)='VYF '
  764. LESOBL(8)='VZF '
  765. LESOBL(9)='ANGL'
  766. *
  767. NBTYPE=1
  768. SEGINI NOTYPE
  769. TYPE(1)='REAL*8'
  770. *
  771. * CARACTERISTIQUES DES ELEMENTS HOMOGENEISES
  772. *
  773. ELSE IF (MFR.EQ.37) THEN
  774. IF(IFOUR.EQ.1.OR.IFOUR.EQ.0) THEN
  775. NBROBL=4
  776. SEGINI NOMID
  777. LESOBL(1)='SCEL'
  778. LESOBL(2)='SFLU'
  779. LESOBL(3)='EPS '
  780. LESOBL(4)='XINE'
  781. ELSE
  782. NBROBL=3
  783. SEGINI NOMID
  784. LESOBL(1)='SCEL'
  785. LESOBL(2)='SFLU'
  786. LESOBL(3)='EPS '
  787. ENDIF
  788. *
  789. NBTYPE=1
  790. SEGINI NOTYPE
  791. TYPE(1)='REAL*8'
  792. *
  793. C CARACTERISTIQUE POUR LES JOINTS GENE
  794. C
  795. ELSE IF (MFR.EQ.55) THEN
  796. NBROBL=0
  797. NBRFAC=1
  798. SEGINI NOMID
  799. LESFAC(1)='EPAI'
  800. C
  801. NBTYPE=1
  802. SEGINI NOTYPE
  803. TYPE(1)='REAL*8'
  804. c
  805. c element coaxial COS2 (3D pour liaison acier-beton)
  806. c
  807. ELSE IF( MFR.EQ.78) THEN
  808. NBROBL=1
  809. NBRFAC=0
  810. SEGINI NOMID
  811. LESOBL(1)='SECT'
  812. NBTYPE=1
  813. SEGINI NOTYPE
  814. TYPE(1)='REAL*8'
  815. ENDIF
  816.  
  817. MOCARA=NOMID
  818. * rendement kich 09/01 /// a remettre en cause avec phases (kich 04/09)
  819. if (MOCARA.EQ.0) then
  820. nbtype = 0
  821. segini notype
  822. nbrobl = 0
  823. nbrfac = 0
  824. segini nomid
  825. mocara = nomid
  826. endif
  827. motype = notype
  828. *
  829. ifac = nbrfac
  830. NCAR1=NBROBL + NBRFAC + 1
  831. NBRFAC= nbrfac + 10
  832. segadj nomid
  833. lesfac(ifac + 1) = 'REND'
  834. lesfac(ifac + 2) = 'W1X '
  835. lesfac(ifac + 3) = 'W1Y '
  836. lesfac(ifac + 4) = 'W1Z '
  837. lesfac(ifac + 5) = 'W2X '
  838. lesfac(ifac + 6) = 'W2Y '
  839. lesfac(ifac + 7) = 'W2Z '
  840. lesfac(ifac + 8) = 'REN1'
  841. lesfac(ifac + 9) = 'REN2'
  842. lesfac(ifac + 10)= 'REN3'
  843. nbtype = nbtype + 1
  844. segadj notype
  845. type(nbtype) = 'REAL*8'
  846. *
  847. NCARA=NBROBL
  848. NCARF=NBRFAC
  849. NCARR=NCARA+NCARF
  850. *
  851. C* IF (MOCARA.NE.0) THEN
  852. IF (IPCHE2.NE.0) THEN
  853. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,
  854. $ IVACAR)
  855. SEGSUP NOTYPE
  856. IF (IERR.NE.0) GOTO 9990
  857. IF (ISUP2.EQ.1.and.mele.ne.260) THEN
  858. CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  859. IF (IERR.NE.0)THEN
  860. ISUP2=0
  861. GOTO 9990
  862. ENDIF
  863. ENDIF
  864. ELSE IF (NCARA.GT.0) THEN
  865. SEGSUP NOTYPE
  866. MOTERR(1:8)='CARACTER'
  867. MOTERR(9:12)=NOMTP(MELE)
  868. MOTERR(13:20)='BSIGMA'
  869. CALL ERREUR(145)
  870. GOTO 9990
  871. ENDIF
  872. C* ENDIF
  873. *
  874. * ponderer par la prop de phase
  875. IF (IPCHE2.NE.0.AND.CONMOD(17:24).ne.' ') THEN
  876. * rechercher le melval
  877. iptm = 0
  878. MCHEL6 = IPCHE2
  879. do ima = 1,mchel6.imache(/1)
  880. if (mchel6.imache(ima).eq.imamod) then
  881. mcham6 = mchel6.ichaml(ima)
  882. do ic = 1,mcham6.nomche(/2)
  883. if (mcham6.nomche(ic)(1:4).eq.conmod(17:20)) then
  884. iptm = mcham6.ielval (ic)
  885. goto 20
  886. endif
  887. enddo
  888. endif
  889. enddo
  890. * avertissement
  891. 20 if (iptm.eq.0)
  892. & write(6,*) ' proportion phase non trouvee ',conmod(17:24)
  893. * ponderation
  894. if (iptm.gt.0) then
  895. if(ivacar.ne.0) then
  896. mptval = ivacar
  897. segact mptval*mod
  898. if (ival(ncar1).gt.0) then
  899. melva1 = ival(ncar1)
  900. melva2 = iptm
  901. n1ptel = max(melva1.velche(/1),melva2.velche(/1))
  902. n1el = max(melva1.velche(/2),melva2.velche(/2))
  903. n2ptel = melva1.ielche(/1)
  904. n2el = melva1.ielche(/2)
  905. segini melval
  906. do jptel = 1,n1ptel
  907. do jel = 1,n1el
  908. i1 = min(jptel,melva1.velche(/1))
  909. j1 = min(jel,melva1.velche(/2))
  910. i2 = min(jptel,melva2.velche(/1))
  911. j2 = min(jel,melva2.velche(/2))
  912. velche(jptel,jel) = melva1.velche(i1,j1)*
  913. & melva2.velche(i2,j2)
  914. enddo
  915. enddo
  916. ival(ncar1) = melval
  917. else if (ival(ncar1+7).gt.0.or.ival(ncar1+8).gt.0.or.
  918. & ival(ncar1+9).gt.0) then
  919. else
  920. ival(ncar1) = iptm
  921. tyval(ncar1) = 'REAL*8'
  922. melval = iptm
  923. endif
  924. endif
  925. endif
  926. ENDIF
  927.  
  928. C____________________________________________________________________
  929. C
  930. * RANGEMENT DE LA MATRICE DE HOOKE DANS UN TABLEAU DE TRAVAIL *
  931. * UNIQUEMENT DANS LE CAS DE L'ELEMENT COQUE DST
  932. C____________________________________________________________________
  933. *
  934. NBGMAT = 0
  935. NELMAT = 0
  936. NMATR = 0
  937. NMATF = 0
  938. NMATT = 0
  939. IF(MELE.EQ.93.or.mele.eq.260)THEN
  940. IF (IMAT.EQ.2) THEN
  941. NBRFAC=0
  942. IF(CMATE.NE.'ISOTROPE')THEN
  943. NBROBL=3
  944. SEGINI NOMID
  945. LESOBL(1)='MAHO'
  946. LESOBL(2)='V1X '
  947. LESOBL(3)='V1Y '
  948. NBTYPE=3
  949. SEGINI NOTYPE
  950. TYPE(1)='POINTEURLISTREEL'
  951. TYPE(2)='REAL*8'
  952. TYPE(3)='REAL*8'
  953. ELSE
  954. NBROBL=1
  955. SEGINI NOMID
  956. LESOBL(1)='MAHO'
  957. NBTYPE=1
  958. SEGINI NOTYPE
  959. TYPE(1)='POINTEURLISTREEL'
  960. ENDIF
  961. MOMATR=NOMID
  962. MOTYPE=NOTYPE
  963. CALL KOMCHA(IPCHE3,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  964. SEGSUP NOTYPE
  965. IF (IERR.NE.0) GOTO 9990
  966. MPTVAL=IVAMAT
  967. MELVAL=IVAL(1)
  968. NBGMAT=IELCHE(/1)
  969. NELMAT=IELCHE(/2)
  970. NMATR=NBROBL
  971. NMATF=NBRFAC
  972. NMATT=NMATR+NMATF
  973. ELSE
  974. C____________________________________________________________________
  975. *
  976. * SINON TRAITEMENT DES CHAMPS DE MATERIAU
  977. C____________________________________________________________________
  978. *
  979. NBROBL=0
  980. NBRFAC=0
  981. IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN
  982. NBROBL=2
  983. SEGINI NOMID
  984. MOMATR=NOMID
  985. LESOBL(1)='YOUN'
  986. LESOBL(2)='NU '
  987. ELSEIF(FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ORTHOTRO')THEN
  988. IF(INAT.EQ.67) THEN
  989. NBROBL=6
  990. SEGINI NOMID
  991. MOMATR=NOMID
  992. LESOBL(1)='YG1 '
  993. LESOBL(2)='YG2 '
  994. LESOBL(3)='NU12'
  995. LESOBL(4)='G12 '
  996. LESOBL(5)='V1X '
  997. LESOBL(6)='V1Y '
  998. ELSE
  999. if(lnomid(6).ne.0) then
  1000. nomid=lnomid(6)
  1001. momatr=nomid
  1002. nbrobl=lesobl(/2)
  1003. nbrfac=lesfac(/2)
  1004. lsupma=.false.
  1005. else
  1006. CALL IDMATR(MFR,IMODEL,MOMATR,NBROBL,NBRFAC)
  1007. endif
  1008. ENDIF
  1009. ENDIF
  1010. NMATR=NBROBL
  1011. NMATF=NBRFAC
  1012. NMATT=NMATR+NMATF
  1013. *
  1014. IF (MOMATR.NE.0) THEN
  1015. NBTYPE=1
  1016. SEGINI NOTYPE
  1017. TYPE(1)='REAL*8'
  1018. MOTYPE=NOTYPE
  1019. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  1020. SEGSUP NOTYPE
  1021. IF (IERR.NE.0) GOTO 9990
  1022. *
  1023. IF (ISUP2.EQ.1.and.mele.ne.260) THEN
  1024. CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  1025. IF (IERR.NE.0)THEN
  1026. ISUP2=0
  1027. GOTO 9990
  1028. ENDIF
  1029. ENDIF
  1030. *
  1031. MPTVAL=IVAMAT
  1032. NBGMAT = 0
  1033. NELMAT = 0
  1034. DO 1108 IM=1,NMATT
  1035. IF(IVAL(IM).NE.0)THEN
  1036. MELVAL=IVAL(IM)
  1037. NBGMAT=MAX(NBGMAT,VELCHE(/1))
  1038. NELMAT=MAX(NELMAT,VELCHE(/2))
  1039. ENDIF
  1040. 1108 CONTINUE
  1041. ENDIF
  1042. ENDIF
  1043. ENDIF
  1044. C
  1045. C================================================
  1046. C
  1047. C CAS D'UN JOINT UNIDIMENSIONNEL JOI1
  1048. C Chargement des vecteurs situes dans les caracteristiques materiau
  1049. C
  1050. C================================================
  1051. IF(MFR.EQ.75) THEN
  1052. IF(IFOUR.EQ.2) THEN
  1053. NBROBL=6
  1054. NBRFAC=0
  1055. SEGINI NOMID
  1056. MOMATR=NOMID
  1057. LESOBL(1)='V1X'
  1058. LESOBL(2)='V1Y'
  1059. LESOBL(3)='V1Z'
  1060. LESOBL(4)='V2X'
  1061. LESOBL(5)='V2Y'
  1062. LESOBL(6)='V2Z'
  1063. NMATR=NBROBL
  1064. NMATF=NBRFAC
  1065. ELSE IF(IFOUR.EQ.-2.OR.IFOUR.EQ.-1) THEN
  1066. NBROBL=2
  1067. NBRFAC=0
  1068. SEGINI NOMID
  1069. MOMATR=NOMID
  1070. LESOBL(1)='V1X'
  1071. LESOBL(2)='V1Y'
  1072. NMATR=NBROBL
  1073. NMATF=NBRFAC
  1074. ENDIF
  1075. NBTYPE=1
  1076. SEGINI NOTYPE
  1077. TYPE(1)='REAL*8'
  1078. MOTYPE=NOTYPE
  1079. *
  1080. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOMATR,MOTYPE,1,INFOS,3,IVAMAT)
  1081. SEGSUP NOTYPE
  1082. IF (IERR.NE.0) GOTO 9990
  1083. *
  1084. NMATT=NMATR+NMATF
  1085. * C
  1086. IF(ISUP1.EQ.1)THEN
  1087. CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  1088. IF(IERR.NE.0)THEN
  1089. ISUP1=0
  1090. GOTO 9990
  1091. ENDIF
  1092. ENDIF
  1093. MPTVAL=IVAMAT
  1094. NBGMAT = 0
  1095. NELMAT = 0
  1096. DO 11265 IM=1,NMATT
  1097. IF(IVAL(IM).NE.0)THEN
  1098. MELVAL=IVAL(IM)
  1099. IF (CMATE.EQ.'SECTION') THEN
  1100. NBGMAT=MAX(NBGMAT,IELCHE(/1))
  1101. NELMAT=MAX(NELMAT,IELCHE(/2))
  1102. ELSE
  1103. NBGMAT=MAX(NBGMAT,VELCHE(/1))
  1104. NELMAT=MAX(NELMAT,VELCHE(/2))
  1105. ENDIF
  1106. ENDIF
  1107. 11265 CONTINUE
  1108. nmattd=nmatt
  1109. ivamtd= ivamat
  1110. ENDIF
  1111.  
  1112. C_______________________________________________________________________
  1113. C
  1114. C NUMERO DES ETIQUETTES :
  1115. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  1116. C Les elements sont groupes comme suit :
  1117. C - massif, poreux, joints poreux,incompressibles --> BSIGM1
  1118. C - coq3,dkt,coq4,coq8,coq2,jot3,joi4,joi2,joi3 ----> BSIGM2
  1119. C - poutre,tuyau,linespring,tuyau fissure,barre ----> BSIGM3
  1120. c et poutre Timoschenko, cos2, coa2
  1121. C_______________________________________________________________________
  1122. C
  1123. IF (MELE.LE.100)
  1124. &GOTO (99,29,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  1125. 1 99,99, 4, 4, 4, 4,27,27,29,29,99,99,99,99,99,99,99,99,99,99,
  1126. 2 27,29,29,27,29,29,99,99,27,29,99,99,99,99,99,27,99,99,99,99,
  1127. 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
  1128. 4 4, 4, 4,29,27,27,27,27,99,99,99,99,27,99,29,29,99,99,99,99
  1129. 5 ),MELE
  1130. IF (MELE.LE.200)
  1131. &GOTO (99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
  1132. 1 4, 4,29,29,29,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  1133. 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  1134. 3 34,34,34,34,34,34,34,34,34,34,34,34, 4, 4, 4, 4, 4, 4, 4, 4,
  1135. 4 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,34,34,34,34,34,34,34,34,34,34
  1136. 5 ),MELE-100
  1137. IF (MELE.LE.300)
  1138. &GOTO (34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  1139. 1 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  1140. 2 34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,34,
  1141. 3 34,34,34,34,29,29,29,29,99,99,29,29, 4, 4),MELE-200
  1142. C
  1143. C CASE OF THE NEW JOINT ELEMENTS (JCT3 AND JCI4)
  1144. C (JGI2 2D GENERALIZED)
  1145. C (JGT3 AND JGI4 GENERALIZED)
  1146. C
  1147. 34 CONTINUE
  1148. IF (MELE.GE.168.AND.MELE.LE.172) GOTO 27
  1149. *
  1150. C Elements mecaniques 1D (M1Dx)
  1151. IF (MELE.EQ.193.OR.MELE.EQ.194) GOTO 4
  1152. *
  1153. * elemment shb8
  1154. IF ( mele.eq.260) goto 29
  1155. c
  1156. C_______________________________________________________________________
  1157. C POUR les XFEM on fait un cas particuliers
  1158. IF(MFR.EQ.63) THEN
  1159.  
  1160. CALL BSIGMX (IMODEL,IVACAR,IVASTR,ncar1,NFORC,
  1161. & IVAFOR,ADPG,BDPG,CDPG,IIPDPG,IRETER)
  1162. IF(IRETER.NE.0) RETURN
  1163.  
  1164. MPTVAL = IVAFOR
  1165. N1TOT = IPOS(/1)
  1166. N1SUP = N1TOT - 1
  1167. N2TOT = IVAL(/1)
  1168. * si le nombre de sous-zones fournies par BSIGMX doit augmenter...
  1169. c write(6,*) N1TOT,N1SUP,N2TOT,N1,NFOREF,NFACF
  1170. IF (N1SUP.ge.1) THEN
  1171. N1 = N1 + N1SUP
  1172. segadj,MCHELM
  1173. ENDIF
  1174.  
  1175. I2TOT = 0
  1176. I1NN = 1
  1177. DO I1=1,(1+N1SUP)
  1178.  
  1179. * -cas ou la zone est vide
  1180. if (IPOS(I1).eq.0) then
  1181. N1 = N1 - 1
  1182. segadj,MCHELM
  1183. I2TOT = I2TOT + NSOF(I1)
  1184. if(I1.eq.I1NN) I1NN=I1NN+1
  1185.  
  1186. * -cas ou il faut remplir ICHAML avec MCHAM1 = copie du MCHAML pere
  1187. else
  1188. N2=NFOREF+NFACF
  1189. segini,MCHAM1=MCHAML
  1190. * la 1ere fois est reperee par I1NN
  1191. if(I1.ne.I1NN) ISOUS = ISOUS + 1
  1192. ICHAML(ISOUS) = MCHAM1
  1193. c write(6,*) 'bsigmp: creation de ICHAML(',ISOUS,')=',MCHAM1
  1194. IMACHE(ISOUS) = IPOS(I1)
  1195. N2 = NSOF(I1)
  1196. segadj,MCHAM1
  1197. do i2=1,N2
  1198. I2TOT = I2TOT + 1
  1199. MCHAM1.IELVAL(i2) = IVAL(I2TOT)
  1200. enddo
  1201. endif
  1202. ENDDO
  1203.  
  1204. * Quand on a fini avec cette zone on n oublie pas de supprimer
  1205. * le MCHAML pere des MCHAM1.
  1206. c * Dans le cas ou ils n ont pas ete utilises,
  1207. c * les MELVAL du MCHAML pere peuvent etre supprimes aussi.
  1208. c if (IPOS(1).eq.0) then
  1209. c DO IB=1,IELVAL(/1)
  1210. c MELVAL=IELVAL(IB)
  1211. c SEGSUP MELVAL
  1212. c ENDDO
  1213. c endif
  1214. * -> cela semble etre une erreur car les melval sont utilises !!!
  1215. SEGSUP MCHAML
  1216.  
  1217. GO TO 510
  1218. ENDIF
  1219. C fin des XFEM _________________________________________________________
  1220. C
  1221. 99 CONTINUE
  1222. MOTERR(1:4)=NOMTP(MELE)
  1223. MOTERR(5:12)='BSIGMA'
  1224. CALL ERREUR(86)
  1225. GOTO 9990
  1226. C_______________________________________________________________________
  1227. C
  1228. C massifs, poreux, joints poreux, incompressibles
  1229. C_______________________________________________________________________
  1230. C
  1231. 4 CONTINUE
  1232. IF (MFR.EQ.71) THEN
  1233. CALL BSIGEL(IPMAIL,IPMINT,NBPGAU,IVASTR,NSTRS,LRE,LHOOK,
  1234. & IVAFOR,NFORC)
  1235. ELSE IF (MFR.EQ.73) THEN
  1236. CALL BSIGDI(IPMAIL,IPMINT,NBPGAU,IVASTR,NSTRS,LRE,LHOOK,
  1237. & IVAFOR,NFORC)
  1238. ELSE
  1239. CALL BSIGM1(IPMAIL,LRE,NSTRS,NBPGAU,MELE,MFR,IVASTR,IPMINT,
  1240. & IVACAR,IPORE,LHOOK,NFORC,IVAFOR,ADPG,BDPG,CDPG,
  1241. & IIPDPG,ncar1,noer)
  1242. if (noer.eq.195) return
  1243. ENDIF
  1244. GOTO 510
  1245. C_______________________________________________________________________
  1246. C
  1247. C coq3,dkt,coq4,coq8,coq2,dst,jot3,joi4,joi2,joi3
  1248. C_______________________________________________________________________
  1249. C
  1250. 27 CONTINUE
  1251. if (dcmate) goto 29
  1252. CALL BSIGM2(IPMAIL,LRE,NSTRS,IVASTR,LW,NBPGAU,IVACAR,CMATE,NBPTEL,
  1253. & MELE,MFR,IPMINT,IPMIN1,IVAMAT,NMATT,NBGMAT,NELMAT,IMAT,NPINT,
  1254. & NFORC,IVAFOR,ADPG,BDPG,CDPG,IIPDPG)
  1255. GOTO 510
  1256. C_______________________________________________________________________
  1257. C
  1258. C poutre,tuyau,linespring,tuyau fissure,barre,poutre Timoschenko
  1259. C joi1, zone_cohesive, cos2, coa2
  1260. C_______________________________________________________________________
  1261. C
  1262. 29 CONTINUE
  1263. ncaru = ncar1 - 1
  1264. CALL BSIGM3(IPMAIL,LRE,NSTRS,LW,IVACAR,ncaru,IVECT,MELE,CMATE,
  1265. &IVASTR,ISOUS,NBPGAU,NBPTEL,IPMINT,NFORC,IVAFOR,ADPG,BDPG,CDPG
  1266. &,IIPDPG,ivamat,NMATT,MFR,dcmate)
  1267. GOTO 510
  1268. C_______________________________________________________________________
  1269. C
  1270. C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
  1271. C_______________________________________________________________________
  1272. C
  1273. 510 CONTINUE
  1274. C
  1275. C Cas des modes de calculs GENEralises :
  1276. C
  1277. IF (ldpge) THEN
  1278. K_DPGE = K_DPGE + 1
  1279. mchpoi = ICHPGE
  1280. msoupo = mchpoi.ipchp(1)
  1281. ipt1 = msoupo.IGEOC
  1282. DO im = 1, N_DPGE
  1283. IF (iipdpg.EQ.ipt1.num(1,im)) GOTO 300
  1284. ENDDO
  1285. write(ioimp,*) 'BSIGMP - incoherence iipdpg / ipt1'
  1286. CALL erreur(5)
  1287. 300 CONTINUE
  1288. mpoval = msoupo.IPOVAL
  1289. mpoval.vpocha(im,1) = mpoval.vpocha(im,1) + ADPG
  1290. IF (NFORDG.GE.2) THEN
  1291. mpoval.vpocha(im,2) = mpoval.vpocha(im,2) + BDPG
  1292. IF (NFORDG.GE.3) THEN
  1293. mpoval.vpocha(im,3) = mpoval.vpocha(im,3) + CDPG
  1294. ENDIF
  1295. ENDIF
  1296. ENDIF
  1297. C
  1298. *
  1299. IF(ISUP1.EQ.1)THEN
  1300. CALL DTMVAL(IVASTR,3)
  1301. ELSE
  1302. CALL DTMVAL(IVASTR,1)
  1303. ENDIF
  1304. *
  1305. CALL DTMVAL(IVAFOR,1)
  1306. *
  1307. IF(ISUP2.EQ.1.AND.IMAT.NE.2)THEN
  1308. CALL DTMVAL(IVAMAT,3)
  1309. ELSE
  1310. CALL DTMVAL(IVAMAT,1)
  1311. ENDIF
  1312. *
  1313. IF(ISUP2.EQ.1)THEN
  1314. CALL DTMVAL(IVACAR,3)
  1315. ELSE
  1316. CALL DTMVAL(IVACAR,1)
  1317. ENDIF
  1318. *
  1319. NOMID=MOSTRS
  1320. if(MOSTRS.NE.0.AND.lsupco)SEGSUP NOMID
  1321. NOMID=MOFORC
  1322. if(MOFORC.NE.0.AND.lsupfo)SEGSUP NOMID
  1323. NOMID=MOCARA
  1324. IF (MOCARA.NE.0) SEGSUP NOMID
  1325. NOMID=MOMATR
  1326. IF (MOMATR.NE.0.and.lsupma) SEGSUP NOMID
  1327. *
  1328. IF (IERR.NE.0) GO TO 9991
  1329. C
  1330. 200 CONTINUE
  1331. C_______________________________________________________________________
  1332. C
  1333. C TRANSFORMATION DU CHAMELEM EN CHPOINT
  1334. C_______________________________________________________________________
  1335. C
  1336. CALL CHAMPO(IPCHE5,0,IPCHP4,IRET)
  1337.  
  1338. C IPCHE5 est maintenant inutile !
  1339. DO III=1,ICHAML(/1)
  1340. MCHAML=ICHAML(III)
  1341. DO JJJ=1,IELVAL(/1)
  1342. MELVAL=IELVAL(JJJ)
  1343. SEGSUP,MELVAL
  1344. ENDDO
  1345. SEGSUP,MCHAML
  1346. ENDDO
  1347. SEGSUP,MCHELM
  1348.  
  1349. C
  1350. C CAS des modes de calculs GENERALISEs :
  1351. C ON ADDITIONNE LE CHPOINT RESULTANT DE LA TRANSFORMATION DU CHAMELEM
  1352. C ET LE PETIT CHPOINT DES FORCES INTERNES AUx NOEUDs supports
  1353. C
  1354. IF (BDPGE) THEN
  1355. IF (K_DPGE.NE.0) THEN
  1356. CALL ADCHPO(ICHPGE,IPCHP4,IPCHP6,1D0,1D0)
  1357. CALL DTCHPO(IPCHP4)
  1358. IPCHP4 = IPCHP6
  1359. ENDIF
  1360. CALL DTCHPO(ICHPGE)
  1361. ENDIF
  1362. C
  1363. IF (llent2.gt.0) then
  1364. ipc1 = ipchp4
  1365. jg = klent2
  1366. segadj mlent2
  1367. do ipj= 1,jg
  1368. ipcj = mlent2.lect(ipj)
  1369. if (ipcj.gt.0) then
  1370. call adchpo(ipc1,ipcj,ipc2,1.D0,1.D0)
  1371. call dtchpo(ipc1)
  1372. ipc1 = ipc2
  1373. endif
  1374. enddo
  1375. ipchp4 = ipc1
  1376. segsup mlent2
  1377. ENDIF
  1378.  
  1379. C* Fin normale
  1380. IRET = 1
  1381. GOTO 9000
  1382. *
  1383. * ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  1384. *
  1385. 9990 CONTINUE
  1386. *
  1387. IF(ISUP1.EQ.1)THEN
  1388. CALL DTMVAL(IVASTR,3)
  1389. ELSE
  1390. CALL DTMVAL(IVASTR,1)
  1391. ENDIF
  1392. *
  1393. CALL DTMVAL(IVAFOR,3)
  1394. *
  1395. IF(ISUP2.EQ.1.AND.IMAT.NE.2)THEN
  1396. CALL DTMVAL(IVAMAT,3)
  1397. ELSE
  1398. CALL DTMVAL(IVAMAT,1)
  1399. ENDIF
  1400. *
  1401. IF(ISUP2.EQ.1)THEN
  1402. CALL DTMVAL(IVACAR,3)
  1403. ELSE
  1404. CALL DTMVAL(IVACAR,1)
  1405. ENDIF
  1406. *
  1407. NOMID=MOSTRS
  1408. if(MOSTRS.NE.0.AND.lsupco)SEGSUP NOMID
  1409. NOMID=MOFORC
  1410. if(MOFORC.NE.0.AND.lsupfo)SEGSUP NOMID
  1411. NOMID=MOCARA
  1412. IF (MOCARA.NE.0) SEGSUP NOMID
  1413. NOMID=MOMATR
  1414. IF (MOMATR.NE.0.and.lsupma) SEGSUP NOMID
  1415. 9991 CONTINUE
  1416. 9992 CONTINUE
  1417. IRET = 0
  1418.  
  1419. C Dernieres desactivations avant de quitter :
  1420. 9000 CONTINUE
  1421. mmodel = IPMODL
  1422. SEGSUP,MMODEL
  1423.  
  1424. END
  1425.  
  1426.  
  1427.  
  1428.  
  1429.  
  1430.  
  1431.  
  1432.  
  1433.  

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