Télécharger bsigmp.eso

Retour à la liste

Numérotation des lignes :

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

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