Télécharger bsigmp.eso

Retour à la liste

Numérotation des lignes :

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

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