Télécharger bsigmp.eso

Retour à la liste

Numérotation des lignes :

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

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