Télécharger ksigmp.eso

Retour à la liste

Numérotation des lignes :

  1. C KSIGMP SOURCE CB215821 19/08/20 21:19:00 10287
  2.  
  3. SUBROUTINE KSIGMP(IPMODL,IPCHE1,IPCHE2,IFLAM, IPRIGG)
  4.  
  5. c_______________________________________________________________________
  6. c
  7. c
  8. c construction de la matrice de raideur geometrique a partir d'un
  9. c mchaml de contraintes
  10. c
  11. c entr{es:
  12. c ________
  13. c
  14. c ipmodl pointeur sur un mmodel
  15. c ipche1 pointeur sur un mchaml de contraintes
  16. c ipche2 pointeur sur un mchaml de caracteristiques
  17. c iflam flag de flambage
  18. c
  19. c sorties:
  20. c ________
  21. c
  22. c iprigg pointeur sur un objet rigidite
  23. c = 0 en cas d'erreur
  24. c_______________________________________________________________________
  25. c
  26. IMPLICIT INTEGER(I-N)
  27. IMPLICIT REAL*8(A-H,O-Z)
  28.  
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC CCHAMP
  33. -INC CCREEL
  34.  
  35. -INC SMCHAML
  36. -INC SMCOORD
  37. -INC SMELEME
  38. -INC SMINTE
  39. -INC SMMODEL
  40. -INC SMRIGID
  41. C
  42. INTEGER oooval
  43.  
  44. SEGMENT NOTYPE
  45. CHARACTER*16 TYPE(NBTYPE)
  46. ENDSEGMENT
  47. C
  48. SEGMENT MPTVAL
  49. INTEGER IPOS(NS) ,NSOF(NS)
  50. INTEGER IVAL(NCOSOU)
  51. CHARACTER*16 TYVAL(NCOSOU)
  52. ENDSEGMENT
  53. c
  54. SEGMENT MWRK1
  55. REAL*8 REL(LRE,LRE) ,XE(3,NBBB) ,XSTRS(NSTRS)
  56. ENDSEGMENT
  57. C
  58. SEGMENT MWRK2
  59. REAL*8 SHPWRK(6,NBNO) ,BGENE(NSTRS,LRE)
  60. ENDSEGMENT
  61. C
  62. SEGMENT MWRK3
  63. REAL*8 WORK(LW)
  64. ENDSEGMENT
  65. C
  66. SEGMENT MWRK4
  67. REAL*8 BPSS(3,3) ,XEL(3,NBBB)
  68. ENDSEGMENT
  69. C
  70. SEGMENT MWRK5
  71. REAL*8 GEOM(20), tabw(6,9), tabrot(4,9), XX(3), YY(3)
  72. ENDSEGMENT
  73. C
  74. C segment pour shb8
  75. SEGMENT MWRK7
  76. REAL*8 PROPEL(1),out(1),d(1), work1(30)
  77. ENDSEGMENT
  78. C
  79. character*6 msorse
  80. CHARACTER*8 CMATE
  81. CHARACTER*(NCONCH) CONM
  82. PARAMETER ( NINF=3 )
  83. INTEGER INFOS(NINF)
  84. LOGICAL lsupfo,lsupde,lsupco,BDPGE
  85. INTEGER ISUP1,ISUP2
  86.  
  87. ISUP1 = 0
  88. ISUP2 = 0
  89.  
  90. IPRIGG = 0
  91.  
  92. IDIMP1 = IDIM+1
  93. C
  94. C verification du lieu support du mchaml de contraintes
  95. C
  96. CALL QUESUP(IPMODL,IPCHE1,3,0,ISUP1,IRET1C)
  97. IF (ISUP1.GT.1) RETURN
  98. C
  99. C verification du lieu support du mchaml de caracteristiques
  100. C
  101. IF (IPCHE2.NE.0) THEN
  102. CALL QUESUP(IPMODL,IPCHE2,3,0,ISUP2,iret2c)
  103. IF (ISUP2.GT.1) RETURN
  104. ENDIF
  105. c
  106. c_______________________________________________________________________
  107. c
  108. c initialisation du chapeau de l objet rigidite
  109. c_______________________________________________________________________
  110. c
  111. NRIGEL = 0
  112. SEGINI,MRIGID
  113. IFORIG = IFOMOD
  114. c* IFORIG = IFOUR
  115. ICHOLE = 0
  116. IMGEO1 = 0
  117. IMGEO2 = 0
  118. ISUPEQ = 0
  119. IF (IFLAM.NE.0) THEN
  120. MTYMAT = 'MASSE '
  121. ELSE
  122. MTYMAT = 'RIGIDITE'
  123. ENDIF
  124. c
  125. c_______________________________________________________________________
  126. c
  127. c activation du modele
  128. c_______________________________________________________________________
  129. c
  130. MMODEL = IPMODL
  131. SEGACT,MMODEL
  132. NSOUS = KMODEL(/1)
  133. c
  134. c boucle sur les modeles elementaires
  135. c
  136. DO 500 ISOUS = 1,NSOUS
  137. c
  138. c traitement du modele
  139. c
  140. IMODEL = KMODEL(ISOUS)
  141. IF (FORMOD(1).EQ.'CHARGEMENT') GOTO 500
  142. SEGACT,IMODEL
  143. C
  144. C INITIALISATIONS
  145. C
  146. IPMINT = 0
  147. IPMIN1 = 0
  148.  
  149. MOSTRS = 0
  150. MOCARA = 0
  151. MOTYPS = 0
  152. MOTYPC = 0
  153.  
  154. MODEPL = 0
  155. MOFORC = 0
  156. lsupde = .false.
  157. lsupfo = .false.
  158. lsupco = .false.
  159.  
  160. IDESCR = 0
  161.  
  162. C- Recuperation d'informations sur le maillage elementaire
  163. IPT1 = IMAMOD
  164. SEGACT,IPT1
  165. NBNOE1 = IPT1.NUM(/1)
  166. NBELE1 = IPT1.NUM(/2)
  167.  
  168. C- Quelques informations sur le modele
  169. IIPDPG = imodel.IPDPGE
  170. IIPDPG = IPTPOI(IIPDPG)
  171.  
  172. CONM = CONMOD
  173. CMATE = CMATEE
  174. C MATE = IMATEE
  175. c* INAT = INATUU
  176.  
  177. IRTD = 1
  178. CALL IDENT(IPT1,CONM,IPCHE1,IPCHE2, INFOS,IRTD)
  179. IF (IRTD.EQ.0) GOTO 599
  180. C
  181. C- Recuperation d'informations sur l'element fini
  182. MELE = NEFMOD
  183. c pour l'el. timo on utilise l'el. barr
  184. c IF (MELE .EQ. 84) MELE = 46
  185. c bp: comme il n y a plus elquoi, ce n'est pas ici que ca intervient...
  186.  
  187. c coque integree ou pas ?
  188. IF (INFMOD(/1).NE.0)THEN
  189. NPINT = INFMOD(1)
  190. IF (NPINT.NE.0) THEN
  191. CALL ERREUR(615)
  192. GOTO 599
  193. ENDIF
  194. ELSE
  195. NPINT = 0
  196. ENDIF
  197.  
  198. C LHOOK = INFELE(10)
  199. c* LHOO2 = LHOOK*LHOOK
  200. NSTRS = INFELE(16)
  201. MFR = INFELE(13)
  202. LW = INFELE(7)
  203. C NDDL = INFELE(15)
  204. LRE = INFELE(9)
  205. C IPORE = INFELE(8)
  206. NHRM = NIFOUR
  207.  
  208. IPPORE = 0
  209. IF (MFR.EQ.33) IPPORE = NBNOE1
  210.  
  211. c_______________________________________________________________________
  212. C segments d'integration *
  213. c_______________________________________________________________________
  214. C minte : 1er segment d'integration, il existe pour tous les e.f.
  215. C minte1: 2eme segment d'integration, uniquement pour certains e.f.
  216. C en particulier pour coq6 et coq8
  217. C nbpg:nb de points de gauss = nbpgau du segment minte
  218. C iele:no d'element geometrique associe a l'e.f. mele
  219. C nbff:nb de fonctions de forme = nbno du segment minte
  220. NBPGAU = INFELE( 6)
  221. C IELE = INFELE( 14)
  222. c* ICARA = INFELE( 5)
  223. IPMINT = INFMOD(5)
  224. c* IPMINT = INFELE(11)
  225. IPMIN1 = INFMOD(8)
  226. MINTE = IPMINT
  227. IF (IPMINT.NE.0) SEGACT,MINTE
  228.  
  229. c_______________________________________________________________________
  230. c
  231. C initialisation du segment descr, segment descripteur des *
  232. C des inconnues relatives a la matrice de rigidite *
  233. c_______________________________________________________________________
  234. if (lnomid(1).ne.0) then
  235. MODEPL = lnomid(1)
  236. else
  237. lsupde = .true.
  238. CALL IDPRIM(IMODEL,MFR,MODEPL,NDEPL,NDUM)
  239. endif
  240. nomid = MODEPL
  241. segact,nomid
  242. ndepl = lesobl(/2)
  243. c* ndum = lesfac(/2)
  244.  
  245. if (lnomid(2).ne.0) then
  246. moforc = lnomid(2)
  247. else
  248. lsupfo=.true.
  249. CALL IDDUAL(IMODEL,MFR,MOFORC,NFORC,NDUM)
  250. endif
  251. nomid = MOFORC
  252. segact,nomid
  253. nforc = lesobl(/2)
  254. c* ndum = lesfac(/2)
  255.  
  256. IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) CALL ERREUR(5)
  257.  
  258. C CB215821 : On copie RIGI2 pour les deformations planes generalisees
  259. IF (IIPDPG.GT.0) THEN
  260. IF (IFOUR.EQ.-3) THEN
  261. BDPGE=.TRUE.
  262. IREF=(IIPDPG-1)*(IDIM+1)
  263. C XDPGE=XCOOR(IREF+1)
  264. C YDPGE=XCOOR(IREF+2)
  265. ELSE IF (IFOUR.EQ. 7 .OR. IFOUR.EQ. 8 .OR. IFOUR.EQ. 9 .OR.
  266. & IFOUR.EQ.10 .OR. IFOUR.EQ.11 .OR. IFOUR.EQ.14) THEN
  267. BDPGE=.TRUE.
  268. C XDPGE=XZero
  269. C YDPGE=XZero
  270. ELSE
  271. CALL ERREUR(21)
  272. RETURN
  273. ENDIF
  274. ELSE
  275. BDPGE=.FALSE.
  276. C XDPGE=XZero
  277. C YDPGE=XZero
  278. ENDIF
  279.  
  280. NCOMP=NDEPL
  281. NBNNS=NBNOE1
  282. IF (MFR.EQ.33) NCOMP = NDEPL-1
  283. IF (MFR.EQ.19 .OR. MFR.EQ.21) NBNNS = NBNOE1/2
  284. C
  285. C REMPLISSAGE DU SEGMENT DESCRIPTEUR
  286. IF(BDPGE)THEN
  287. C CB215821 : En 'DPGE' on traite sans le Pt support
  288. NCOMP = NCOMP - 3
  289. LRE = LRE - 3
  290. ENDIF
  291. NLIGRP = LRE
  292. NLIGRD = LRE
  293. SEGINI,DESCR
  294.  
  295. IDDL = 1
  296. DO 1004 INOEUD=1,NBNNS
  297. DO 1005 ICOMP=1,NCOMP
  298. NOMID=MODEPL
  299. LISINC(IDDL)=LESOBL(ICOMP)
  300. NOMID=MOFORC
  301. LISDUA(IDDL)=LESOBL(ICOMP)
  302. NOELEP(IDDL)=INOEUD
  303. NOELED(IDDL)=INOEUD
  304. IDDL=IDDL+1
  305. 1005 CONTINUE
  306. 1004 CONTINUE
  307.  
  308. C cas des milieux poreux
  309. C
  310. C if (mfr.eq.33) then
  311. C ipos = nspos(iele)
  312. C do 1104 inoeud=1,nbsom(iele)
  313. C nomid=modepl
  314. C lisinc(iddl)=lesobl(ndepl)
  315. C nomid=moforc
  316. C lisdua(iddl)=lesobl(ndepl)
  317. C i = ibsom(ipos+inoeud-1)
  318. C noelep(iddl)=i
  319. C noeled(iddl)=i
  320. C iddl=iddl+1
  321. C 1104 continue
  322. C endif
  323.  
  324. C cas des element raccord
  325. C
  326. IF (MFR.EQ.19.OR.MFR.EQ.21) THEN
  327. CALL IDPRIM(IMODEL,MFR+1000,MODPL1,NDEPL,NDUM)
  328. CALL IDDUAL(IMODEL,MFR+1000,MOFRC1,NFORC,NDUM)
  329. DO 1106 INOEUD=NBNNS+1,NBNOE1
  330. DO 1107 ICOMP=1,NDEPL
  331. NOMID=MODPL1
  332. LISINC(IDDL)=LESOBL(ICOMP)
  333. NOMID=MOFRC1
  334. LISDUA(IDDL)=LESOBL(ICOMP)
  335. NOELEP(IDDL)=INOEUD
  336. NOELED(IDDL)=INOEUD
  337. IDDL=IDDL+1
  338. 1107 continue
  339. 1106 continue
  340. NOMID=MODPL1
  341. SEGSUP,NOMID
  342. NOMID=MOFRC1
  343. SEGSUP,NOMID
  344. ENDIF
  345.  
  346. SEGDES,DESCR
  347. IDESCR = DESCR
  348. c_______________________________________________________________________
  349. c
  350. C composantes de contraintes necessaires *
  351. c_______________________________________________________________________
  352. if (lnomid(4).ne.0) then
  353. MOSTRS = lnomid(4)
  354. else
  355. lsupco=.true.
  356. CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  357. endif
  358. nomid = MOSTRS
  359. segact,nomid
  360. nstr=lesobl(/2)
  361. c* nfac=lesfac(/2)
  362. c* write(6,*) 'mostrts',mostrs,nstr,nfac
  363. nbtype = 1
  364. SEGINI,notype
  365. TYPE(1)='REAL*8'
  366. MOTYPS = notype
  367.  
  368. ifai = 1
  369. if (mele.eq.260.and.IRET1C.eq.5) ifai = 0
  370. ISUP1L = 0
  371. IF (ISUP1.EQ.1.AND.ifai.eq.1) ISUP1L = 1
  372.  
  373. c____________________________________________________________________
  374. c
  375. C traitement des champs de caracteristiques *
  376. c____________________________________________________________________
  377. NBROBL = 0
  378. NBRFAC = 0
  379. IVECT = 0
  380. notype = 0
  381. nomid = 0
  382. C
  383. C v1x v1y dans le cas de la coque dst orthotrope
  384. C
  385. IF (MFR.EQ.9) THEN
  386. IF (MELE.EQ.93.AND.CMATE.NE.'ISOTROPE')THEN
  387. NBROBL=2
  388. SEGINI NOMID
  389. LESOBL(1)='V1X '
  390. LESOBL(2)='V1Y '
  391. C
  392. NBTYPE=1
  393. SEGINI NOTYPE
  394. TYPE(1)='REAL*8'
  395. ENDIF
  396. C
  397. C epaisseur dans le cas massif et coq2 en contraintes planes
  398. C
  399. ELSE IF ( (MFR.EQ.1.OR.MFR.EQ.3.OR.MFR.EQ.31) .AND.
  400. + IFOUR.EQ.-2 .AND. IPCHE2.NE.0) THEN
  401. NBRFAC=1
  402. SEGINI NOMID
  403. LESFAC(1)='DIM3'
  404. C
  405. NBTYPE=1
  406. SEGINI NOTYPE
  407. TYPE(1)='REAL*8'
  408. C
  409. C epaisseur et excentrement dans le cas des coques epaisses
  410. C
  411. ELSE IF (MFR.EQ.5 .OR. (MFR.EQ.3.AND.IFOUR.NE.-2)) THEN
  412. NBROBL=1
  413. NBRFAC=1
  414. SEGINI NOMID
  415. LESOBL(1)='EPAI'
  416. LESFAC(1)='EXCE'
  417.  
  418. NBTYPE=1
  419. SEGINI NOTYPE
  420. TYPE(1)='REAL*8'
  421. C
  422. C caracteristiques pour les poutres
  423. C
  424. ELSE IF (MFR.EQ.7 ) THEN
  425. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  426. NBROBL=2
  427. NBRFAC=1
  428. SEGINI NOMID
  429. LESOBL(1)='SECT'
  430. LESOBL(2)='INRZ'
  431. LESFAC(1)='SECY'
  432. C
  433. NBTYPE=1
  434. SEGINI NOTYPE
  435. TYPE(1)='REAL*8'
  436. ELSE
  437. NBROBL=4
  438. NBRFAC=6
  439. IVECT =1
  440. SEGINI NOMID
  441. LESOBL(1)='TORS'
  442. LESOBL(2)='INRY'
  443. LESOBL(3)='INRZ'
  444. LESOBL(4)='SECT'
  445. LESFAC(1)='SECY'
  446. LESFAC(2)='SECZ'
  447. LESFAC(3)='VECT'
  448. LESFAC(4)='VX '
  449. LESFAC(5)='VY '
  450. LESFAC(6)='VZ '
  451. C
  452. NBTYPE=10
  453. SEGINI NOTYPE
  454. TYPE(1)='REAL*8'
  455. TYPE(2)='REAL*8'
  456. TYPE(3)='REAL*8'
  457. TYPE(4)='REAL*8'
  458. TYPE(5)='REAL*8'
  459. TYPE(6)='REAL*8'
  460. TYPE(7)='POINTEURPOINT '
  461. TYPE(8)='REAL*8'
  462. TYPE(9)='REAL*8'
  463. TYPE(10)='REAL*8'
  464. ENDIF
  465. C
  466. C caracteristiques pour les tuyaux
  467. C
  468. ELSE IF (MFR.EQ.13) THEN
  469. NBROBL = 2
  470. NBRFAC = 6
  471. IVECT = 1
  472. SEGINI NOMID
  473. LESOBL(1)='EPAI'
  474. LESOBL(2)='RAYO'
  475. LESFAC(1)='RACO'
  476. LESFAC(2)='CISA'
  477. LESFAC(3)='VECT'
  478. LESFAC(4)='VX '
  479. LESFAC(5)='VY '
  480. LESFAC(6)='VZ '
  481. C
  482. NBTYPE = 8
  483. SEGINI NOTYPE
  484. TYPE(1)='REAL*8'
  485. TYPE(2)='REAL*8'
  486. TYPE(3)='REAL*8'
  487. TYPE(4)='REAL*8'
  488. TYPE(5)='POINTEURPOINT '
  489. TYPE(6)='REAL*8'
  490. TYPE(7)='REAL*8'
  491. TYPE(8)='REAL*8'
  492. ENDIF
  493. C
  494. MOCARA = NOMID
  495. MOTYPC = NOTYPE
  496. NCARA = NBROBL
  497. NCARF = NBRFAC
  498. NCARR = NCARA+NCARF
  499.  
  500. IF (MOCARA.NE.0 .AND. IPCHE2.EQ.0) THEN
  501. MOTERR(1:8) = 'CARACTER'
  502. MOTERR(9:12) = NOMTP(MELE)
  503. MOTERR(13:20)= 'KSIGMA'
  504. CALL ERREUR(145)
  505. GOTO 598
  506. ENDIF
  507.  
  508. ifai = 1
  509. IF (mele.EQ.260) ifai = 0
  510. ISUP2L = 0
  511. IF (ISUP2.EQ.1.AND.ifai.eq.1) ISUP2L = 1
  512.  
  513. C- Partionnement si necessaire de la matrice de capacite
  514. C- determinant ainsi le nombre d'objets elementaires de MRIGID
  515. LTRK = oooval(1,4)
  516. IF (LTRK.EQ.0) LTRK = oooval(1,1)
  517. C Ajout a la taille en mots de la matrice des infos du segment
  518. LSEG = LRE*LRE*NBELE1 + 16
  519. NBLPRT = (LSEG-1)/LTRK + 1
  520. NBLMAX = (NBELE1-1)/NBLPRT + 1
  521. NBLPRT = (NBELE1-1)/NBLMAX + 1
  522. C write(ioimp,*) ' capa1 : nblprt nblmax = ',nblprt,nblmax,nbele1
  523.  
  524. C Ajout de la matrice a la matrice globale
  525. C ========================================
  526. C NRIGE0 = IRIGEL(/2)
  527. C NRIGEL = NRIGE0 + NBLPRT
  528. C SEGADJ,MRIGID
  529.  
  530. descr = IDESCR
  531. meleme = IPT1
  532. NBNN = NBNOE1
  533. nbelem = NBELE1
  534. nbsous = 0
  535. nbref = 0
  536. C
  537. C ***********************************************************************
  538. C P H A S E 2
  539. C
  540. C Boucle sur les PARTITIONS elementaires de la matrice
  541. C
  542. C ***********************************************************************
  543. DO irige = 1, NBLPRT
  544.  
  545. IF (NBLPRT.GT.1) THEN
  546. C- Partitionnement du maillage support de la matrice elementaire
  547. C- (IPT1 peut etre desactive suite a l'appel a KOMCHA !)
  548. SEGACT,IPT1
  549. ielem = (irige-1)*NBLMAX
  550. nbelem = MIN(NBLMAX,NBELE1-ielem)
  551. C write(ioimp,*) ' creation segment ',nbnn,nbelem
  552. SEGINI,meleme
  553. itypel = IPT1.itypel
  554. DO ielt = 1, nbelem
  555. jelt = ielt + ielem
  556. DO inoe = 1, NBNN
  557. num(inoe,ielt) = IPT1.NUM(inoe,jelt)
  558. ENDDO
  559. icolor(ielt) = IPT1.ICOLOR(jelt)
  560. ENDDO
  561. C- Recopie du descripteur
  562. des1 = IDESCR
  563. SEGINI,descr=des1
  564. SEGDES,descr
  565. ENDIF
  566.  
  567. ipmail = meleme
  568. ipdesc = descr
  569.  
  570. C- Initialisation de la matrice de rigidite elementaire (xmatri)
  571. NELRIG = nbelem
  572. SEGINI,xmatri
  573. ipmatr = xmatri
  574.  
  575. C- Recuperation des valeurs des contraintes et proprietes geometriques
  576. IVASTR = 0
  577. IVACAR = 0
  578. IVECTL = IVECT
  579. NCARR1 = NCARR
  580. C
  581. CALL KOMCHA(IPCHE1,ipmail,CONM,MOSTRS,MOTYPS,1,INFOS,3,IVASTR)
  582. IF (IERR.NE.0) GOTO 597
  583. IF (ISUP1L.EQ.1) THEN
  584. CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE,MOSTRS,MELE)
  585. IF (IERR.NE.0) THEN
  586. ISUP1L = 0
  587. GOTO 597
  588. ENDIF
  589. ENDIF
  590.  
  591. IF (MOCARA.NE.0) THEN
  592. CALL KOMCHA(IPCHE2,ipmail,CONM,MOCARA,MOTYPC,1,
  593. & INFOS,3,IVACAR)
  594. IF (IERR.NE.0) GOTO 597
  595. IF (ISUP2L.EQ.1) THEN
  596. CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  597. IF (IERR.NE.0) THEN
  598. ISUP2L = 0
  599. GOTO 597
  600. ENDIF
  601. ENDIF
  602. IF (IVECT.EQ.1) THEN
  603. MPTVAL = IVACAR
  604. NCARR1 = NCARR - 3
  605. IF (IVAL(NCARR1).EQ.0) IVECTL = 2
  606. ENDIF
  607. ENDIF
  608.  
  609. c_______________________________________________________________________
  610. c
  611. c numero des etiquettes :
  612. c etiquettes de 1 a 98 pour traitement specifique a l element
  613. c dans la zone specifique a chaque element commencant par :
  614. c 5 continue
  615. c element 5 etiquettes 1005 2005 3005 4005 ...
  616. c 44 continue
  617. c element 44 etiquettes 1044 2044 3044 4044 ...
  618. c_______________________________________________________________________
  619. IF (MELE.LE.100) THEN
  620. GOTO (99,99,99, 4,99, 4,99, 4,99, 4,99,99,99, 4, 4, 4, 4,99,99,99,
  621. 1 99,99, 4, 4, 4, 4,27,28,29,99,99,99,99,99,99,99,99,99,99,99,
  622. 2 41,29,43,44,99,46,99,99,49,99,51,99,99,99,99,41,99,99,99,99,
  623. 3 99,99,99,99,99,99,99,99, 4, 4, 4, 4,99,99,99,99,99,99,99,99,
  624. 4 99,99,99,29,99,99,99,99,99,99,99,99,28,99,46,99,99,99,99,99
  625. 5 ),MELE
  626. ELSE IF (MELE.LE.200) THEN
  627. GOTO (99,99,99,99,99,99,99,99,99,99, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
  628. 1 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  629. 2 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  630. 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  631. 4 99,99, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99
  632. 5 ),MELE-100
  633. ELSE IF (MELE.LE.300) THEN
  634. GOTO (99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  635. 1 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  636. 2 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  637. & 260,
  638. 3 99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,
  639. 4 99,99, 4, 4,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99,99
  640. 5 ),MELE-200
  641. ENDIF
  642. c
  643. 99 CONTINUE
  644. C MOTERR(1:4) = NOMTP(MELE)
  645. C MOTERR(5:12) = 'KSIGMP '
  646. C CALL ERREUR(86)
  647. GOTO 510
  648. c
  649. c_______________________________________________________________________
  650. c
  651. c secteur de calcul pour les elements massifs
  652. c_______________________________________________________________________
  653. 4 CONTINUE
  654. NBNO = NBNN
  655. NBBB = NBNN
  656. SEGINI,MWRK1,MWRK2
  657. c recuperation de l'epaisseur
  658. DIM3 = 1.D0
  659. MEPDI3 = 0
  660. c* IF (IFOUR.EQ.-2.AND.IPCHE2.NE.0) THEN
  661. IF (IVACAR.NE.0) THEN
  662. MPTVAL = IVACAR
  663. MEPDI3 = IVAL(1)
  664. ENDIF
  665.  
  666. DO 3004 IB=1,NBELEM
  667. c
  668. c on cherche les coordonnees des noeuds de l element ib
  669. c
  670. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  671. CALL ZERO(REL,LRE,LRE)
  672. c
  673. c boucle sur les points de gauss
  674. c
  675. ISDJC = 0
  676. DO 4004 IGAU=1,NBPGAU
  677. c
  678. c recuperation de l'epaisseur
  679. IF (MEPDI3.NE.0) THEN
  680. MELVAL = MEPDI3
  681. IGMN=MIN(IGAU,VELCHE(/1))
  682. IBMN=MIN( IB,VELCHE(/2))
  683. DIM3=VELCHE(IGMN,IBMN)
  684. ENDIF
  685. c
  686. DO 100 IA=1,NBNN
  687. DO 100 IO=1,IDIMP1
  688. SHPWRK(IO,IA)=SHPTOT(IO,IA,IGAU)
  689. 100 CONTINUE
  690. CALL DEVOLU(XE,SHPWRK,MFR,NBNN,IFOUR,NIFOUR,IDIM,DIM3,
  691. & RR,DJAC)
  692. c
  693. c verification du signe du jacobien
  694. c
  695. IF (DJAC.LT.0.) ISDJC=ISDJC+1
  696. DJAC = ABS(DJAC)
  697. IF (DJAC.LT.XPETIT) THEN
  698. INTERR(1) = IB
  699. CALL ERREUR(259)
  700. GOTO 9004
  701. ENDIF
  702. DJAC = DJAC * POIGAU(IGAU)
  703. c
  704. c on recupere les contraintes
  705. c
  706. MPTVAL=IVASTR
  707. DO 5004 ICOMP=1,NSTR
  708. MELVAL=IVAL(ICOMP)
  709. IGMN = MIN(IGAU,VELCHE(/1))
  710. IBMN = MIN(IB ,VELCHE(/2))
  711. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  712. 5004 CONTINUE
  713. c
  714. IF (IFOUR.EQ.1) THEN
  715. IF (NIFOUR.EQ.0) THEN
  716. CALL THSIG1(SHPWRK,DJAC,XSTRS,NBNN,LRE,REL,RR)
  717. ELSE
  718. CALL THSIG2(SHPWRK,DJAC,XSTRS,NBNN,LRE,REL,NIFOUR,RR)
  719. ENDIF
  720. ELSE IF (IFOUR.EQ.0) THEN
  721. CALL THSIG3(SHPWRK,DJAC,XSTRS,NBNN,LRE,REL,RR)
  722. ELSE
  723. CALL THSIGH(SHPWRK,DJAC,XSTRS,NBNN,IDIM,LRE,REL)
  724. ENDIF
  725. c
  726. 4004 CONTINUE
  727.  
  728. IF (ISDJC.NE.0.AND.ISDJC.NE.NBPGAU) THEN
  729. INTERR(1) = IB
  730. CALL ERREUR(195)
  731. GOTO 9004
  732. ENDIF
  733. c
  734. c remplissage de xmatri
  735. c
  736. CALL REMPMT(REL,LRE,RE(1,1,ib))
  737. c
  738. 3004 CONTINUE
  739.  
  740. 9004 CONTINUE
  741. SEGSUP MWRK1,MWRK2
  742. GOTO 510
  743. c
  744. c_______________________________________________________________________
  745. c
  746. ccccccccccccccccccc element coq3
  747. c_______________________________________________________________________
  748. 27 CONTINUE
  749. NBBB = NBNN
  750. SEGINI,MWRK1,MWRK3,MWRK4
  751.  
  752. DO 3027 IB = 1, NBELEM
  753. c
  754. c on cherche les coordonnees des noeuds de l element ib
  755. c
  756. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  757. c
  758. CALL ZERO(REL,LRE,LRE)
  759. c
  760. c on cherche les contraintes
  761. c
  762. MPTVAL=IVASTR
  763. DO 5027 ICOMP=1,NSTR
  764. MELVAL=IVAL(ICOMP)
  765. IBMN=MIN(IB ,VELCHE(/2))
  766. XSTRS(ICOMP)=VELCHE(1,IBMN)
  767. 5027 CONTINUE
  768. c
  769. ccccccc on calcule k(sigma)
  770. c
  771. CALL COQ3KS(REL,XSTRS,XE,1.D0,WORK)
  772. c
  773. c remplissage de xmatri
  774. c
  775. CALL REMPMT(REL,LRE,RE(1,1,ib))
  776.  
  777. 3027 CONTINUE
  778.  
  779. C 9027 CONTINUE
  780. SEGSUP,MWRK1,MWRK3,MWRK4
  781. GOTO 510
  782. c
  783. c_______________________________________________________________________
  784. c
  785. c element dkt , dst
  786. c_______________________________________________________________________
  787. 28 CONTINUE
  788. DIM3 = 1.D0
  789. NBNO = NBNN
  790. IDI2=IDIM-1
  791. NBBB=NBNN
  792. SEGINI MWRK1,MWRK2,MWRK4,MWRK5
  793. XX(1)=.5D0
  794. XX(2)=.0D0
  795. XX(3)=.5D0
  796. YY(1)=.0D0
  797. YY(2)=.5D0
  798. YY(3)=.5D0
  799. C Pour la recuperation de l'epaisseur des elements DKT
  800. IEPDKT = 0
  801. IF (MFR.EQ.3 .AND. IFOUR.NE.-2) IEPDKT = IVACAR
  802. c*of 2011/06/22 : Quid de l'epaisseur pour les DST ????? EPAI = 0 ici !!
  803. C Pour la recuperation des axes d'orthotropie des elements DST
  804. IAODST = 0
  805. IF (MELE.EQ.93.AND.CMATE.NE.'ISOTROPE') IAODST = IVACAR
  806.  
  807. DO 3028 IB=1,NBELEM
  808.  
  809. c on cherche les coordonnees des noeuds de l element ib
  810. c
  811. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  812.  
  813. CALL ZERO(REL,LRE,LRE)
  814. CALL VPAST(XE,BPSS)
  815. c bpss stocke la matrice de passage
  816. CALL VCORLC (XE,XEL,BPSS)
  817. c
  818. c boucle sur les points de gauss
  819. c
  820. DO 4028 IGAU=1,NBPGAU
  821. c
  822. c recuperation de l'epaisseur (element DKT)
  823. IF (IEPDKT.NE.0) THEN
  824. MPTVAL=IEPDKT
  825. MELVAL=IVAL(1)
  826. IGMN=MIN(IGAU,VELCHE(/1))
  827. IBMN=MIN(IB,VELCHE(/2))
  828. EPAI=VELCHE(IGMN,IBMN)
  829. ELSE
  830. EPAI = XZERO
  831. ENDIF
  832. c
  833. call DKTSHP(IGAU,XEL,tabw,DJAC)
  834. call GEOCST(XEL,GEOM)
  835. call BBGFDK(XX(IGAU),YY(IGAU),GEOM,tabrot)
  836.  
  837. DO 6028 IC=1,NBNN
  838. DO 6028 ID=1,6
  839. SHPWRK(ID,IC)=SHPTOT(ID,IC,IGAU)
  840. 6028 CONTINUE
  841.  
  842. CALL DEVOLU(XEL,SHPWRK,MFR,NBNN,IFOUR,NIFOUR,IDI2,DIM3,
  843. & RR,DJAC)
  844. DJAC=DJAC*POIGAU(IGAU)
  845. c
  846. c on cherche les contraintes
  847. c
  848. MPTVAL=IVASTR
  849. DO 5028 ICOMP=1,NSTRS
  850. MELVAL=IVAL(ICOMP)
  851. IGMN=MIN(IGAU,VELCHE(/1))
  852. IBMN=MIN(IB ,VELCHE(/2))
  853. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  854. C write(6,*)' xstrs(icomp)',icomp,XSTRS(ICOMP)
  855. 5028 CONTINUE
  856.  
  857. C Recuperation des axes d'orthotropie (element DST)
  858. IF (IAODST.NE.0) THEN
  859. MPTVAL=IAODST
  860. MELVAL=IVAL(1)
  861. IBMN=MIN(IB ,VELCHE(/2))
  862. IGMN=MIN(IGAU,VELCHE(/1))
  863. COSA=VELCHE(IGMN,IBMN)
  864. MELVAL=IVAL(2)
  865. IBMN=MIN(IB ,VELCHE(/2))
  866. IGMN=MIN(IGAU,VELCHE(/1))
  867. SINA=VELCHE(IGMN,IBMN)
  868. CC=COSA*COSA
  869. SS=SINA*SINA
  870. CS=SINA*COSA
  871. C
  872. C chgt d'axes
  873. C
  874. SIG1=CC*XSTRS(1)+SS*XSTRS(2)-2.D0*CS*XSTRS(3)
  875. SIG2=CC*XSTRS(2)+SS*XSTRS(1)+2.D0*CS*XSTRS(3)
  876. SIG3=CS*(XSTRS(1)-XSTRS(2))+(CC-SS)*XSTRS(3)
  877. XSTRS(1)=SIG1
  878. XSTRS(2)=SIG2
  879. XSTRS(3)=SIG3
  880. ENDIF
  881. c
  882. CALL DKTHSH(SHPWRK,tabw,tabrot,DJAC,XSTRS,REL,EPAI)
  883. 4028 CONTINUE
  884.  
  885. CALL TRANSK(REL,BPSS,LRE,3,1)
  886. c
  887. c remplissage de xmatri
  888. c
  889. CALL REMPMT(REL,LRE,RE(1,1,ib))
  890. c
  891. 3028 CONTINUE
  892.  
  893. C 9028 CONTINUE
  894. SEGSUP,MWRK1,MWRK2,MWRK4,MWRK5
  895. GOTO 510
  896.  
  897. c_______________________________________________________________________
  898. c
  899. c element poutre
  900. c_______________________________________________________________________
  901. 29 CONTINUE
  902. NBBB = NBNN
  903. SEGINI,MWRK1,MWRK3
  904.  
  905. DO 3029 IB=1,NBELEM
  906. c
  907. c on cherche les coordonnees des noeuds de l elementib
  908. c
  909. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  910. c
  911. c il faudrait aussi modifier le vecteur local de la poutre
  912. c
  913. c mise a zero de la raideur geometrique
  914. c
  915. CALL ZERO(REL,LRE,LRE)
  916. c
  917. c rangement des caracteristiques dans work
  918. c
  919. MPTVAL=IVACAR
  920. DO 6029 IC=1,NCARR
  921. WORK(IC)=XZERO
  922. IF (IVAL(IC).NE.0) THEN
  923. MELVAL=IVAL(IC)
  924. IBMN=MIN(IB,VELCHE(/2))
  925. DO 4029 IGAU=1,NBNN
  926. IGMN=MIN(IGAU,VELCHE(/1))
  927. IF (IGMN.GT.0.AND.IBMN.GT.0) THEN
  928. WORK(IC)=WORK(IC)+VELCHE(IGMN,IBMN)
  929. ENDIF
  930. 4029 CONTINUE
  931. WORK(IC)=WORK(IC)/NBNN
  932. ENDIF
  933. 6029 CONTINUE
  934. c
  935. c cas ou on a lu le mot vecteur
  936. c
  937. IF (IVECTL.EQ.1) THEN
  938. MELVAL=IVAL(NCARR1)
  939. IBMN=MIN(IB,IELCHE(/2))
  940. IREF=(IELCHE(1,IBMN)-1)*(IDIM+1)
  941. DO 6129 IC=1,IDIM
  942. WORK(NCARR1+IC-1) = XCOOR(IREF+IC)
  943. 6129 CONTINUE
  944. c
  945. c cas du chamelem comverti
  946. c
  947. ELSE IF (IVECT.EQ.2) THEN
  948. DO 6429 IC=NCARR1+1,NCARR1+IDIM
  949. MELVAL=IVAL(IC)
  950. IF (MELVAL.NE.0) THEN
  951. IBMN=MIN(IB,VELCHE(/2))
  952. WORK(IC)=VELCHE(1,IBMN)
  953. ENDIF
  954. 6429 CONTINUE
  955. ENDIF
  956. c
  957. c cas des tuyaux - on calcule les caracteristiques de la poutre
  958. c equivalente
  959. c
  960. IF (MELE.EQ.42) THEN
  961. CISA=WORK(4)
  962. VX=WORK(5)
  963. VY=WORK(6)
  964. VZ=WORK(7)
  965. CALL TUYCAR(WORK,CISA,VX,VY,VZ,KERRE,0)
  966. IF (KERRE.EQ.77) THEN
  967. CALL ERREUR(77)
  968. GOTO 9029
  969. ENDIF
  970. ENDIF
  971. c
  972. c on cherche les contraintes - on les met dans work
  973. c
  974. IE = 9
  975. MPTVAL=IVASTR
  976. DO 7029 ID=1,2
  977. ID2=ID
  978. IF (NBPGAU.EQ.1.AND.ID.EQ.2) ID2=1
  979. DO 7029 ICOMP=1,NSTR
  980. IE = IE+1
  981. MELVAL=IVAL(ICOMP)
  982. IGMN=MIN(ID2 ,VELCHE(/1))
  983. IBMN=MIN(IB ,VELCHE(/2))
  984. WORK(IE)=VELCHE(IGMN,IBMN)
  985. 7029 CONTINUE
  986. c
  987. c on calcule la rigidite geometrique
  988. c
  989. IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  990. CALL POUKS2(REL,LRE,WORK(10),WORK,XE,WORK(22),KERRE)
  991. ELSE
  992. CALL POUKSG(REL,LRE,WORK(10),WORK,XE,WORK(22),KERRE)
  993. ENDIF
  994.  
  995. IF (KERRE.NE.0) THEN
  996. INTERR(1)=ISOUS
  997. INTERR(2)=IB
  998. CALL ERREUR(128)
  999. GOTO 9029
  1000. ENDIF
  1001. c
  1002. c remplissage de xmatri
  1003. c
  1004. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1005. C
  1006. 3029 CONTINUE
  1007. c
  1008. 9029 CONTINUE
  1009. SEGSUP,MWRK1,MWRK3
  1010. c
  1011. GOTO 510
  1012. c_______________________________________________________________________
  1013. c
  1014. c elements coq8 et coq6
  1015. c_______________________________________________________________________
  1016. 41 CONTINUE
  1017. NBBB=NBNN
  1018. LRI =NBNN*5
  1019. SEGINI,MWRK1,MWRK3
  1020. c
  1021. MINTE1 = IPMIN1
  1022. SEGACT,MINTE1
  1023. c
  1024. DO 3041 IB=1,NBELEM
  1025. c
  1026. c on cherche les coordonnees des noeuds de l elementib
  1027. c
  1028. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1029.  
  1030. CALL ZERO(REL,LRE,LRE)
  1031. c
  1032. c on cherche les caracteristiques de l element ib
  1033. c
  1034. MPTVAL = IVACAR
  1035. MELVAL = IVAL(1)
  1036. IF (MELVAL.NE.0) THEN
  1037. IBMN = MIN(IB ,VELCHE(/2))
  1038. DO IGAU = 1, NBNN
  1039. IGMN = MIN(IGAU,VELCHE(/1))
  1040. WORK(IGAU) = VELCHE(IGMN,IBMN)
  1041. ENDDO
  1042. ELSE
  1043. DO IGAU = 1, NBNN
  1044. WORK(IGAU)=XZERO
  1045. ENDDO
  1046. ENDIF
  1047. c
  1048. c on cherche les contraintes - on les met dans work
  1049. c
  1050. IE = 9
  1051. MPTVAL=IVASTR
  1052. DO 7041 IGAU=1,NBPGAU
  1053. DO 7041 ICOMP=1,NSTRS
  1054. MELVAL=IVAL(ICOMP)
  1055. IGMN=MIN(IGAU,VELCHE(/1))
  1056. IBMN=MIN(IB ,VELCHE(/2))
  1057. WORK(IE)=VELCHE(IGMN,IBMN)
  1058. IE=IE+1
  1059. 7041 CONTINUE
  1060. c
  1061. c on calcule la rigidite geometrique
  1062. c
  1063. CALL COQ8KS(REL,XE,SHPTOT,MINTE1.SHPTOT,
  1064. & NBPGAU,POIGAU,DZEGAU,
  1065. & WORK(1),WORK(9),NBNN,LRE,LRI,WORK(51))
  1066. c
  1067. c remplissage de xmatri
  1068. c
  1069. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1070. C
  1071. 3041 CONTINUE
  1072.  
  1073. C 9041 CONTINUE
  1074. SEGSUP,MWRK1,MWRK3
  1075. GO TO 510
  1076. c_______________________________________________________________________
  1077. c
  1078. c tuyau fissure
  1079. c_______________________________________________________________________
  1080. 43 CONTINUE
  1081. c ksigma n a pas de sens evident pour cet element
  1082. c on cree une matrice nulle
  1083. c DO 3043 IB=1,NBELEM
  1084. c do 4043 ic=1,lval
  1085. c re(ic,ic,ib)=XZERO
  1086. c 4043 continue
  1087. c 3043 CONTINUE
  1088. GOTO 510
  1089. c
  1090. c_______________________________________________________________________
  1091. c
  1092. c element coq2
  1093. c_______________________________________________________________________
  1094. c
  1095. 44 CONTINUE
  1096. DIM3=1.D0
  1097. NBBB=NBNN
  1098. SEGINI MWRK1,MWRK3,MWRK4
  1099. c
  1100. DO 3044 IB=1,NBELEM
  1101. c
  1102. c on cherche les coordonnees des noeuds de l element ib
  1103. c
  1104. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1105.  
  1106. CALL ZERO(REL,LRE,LRE)
  1107. c
  1108. c recuperation de l'epaisseur
  1109. c
  1110. IF (IFOUR.EQ.-2.AND.IPCHE2.NE.0) THEN
  1111. MPTVAL=IVACAR
  1112. MELVAL=IVAL(1)
  1113. IF (MELVAL.NE.0) THEN
  1114. IBMN=MIN(IB,VELCHE(/2))
  1115. DIM3=VELCHE(1,IBMN)
  1116. ELSE
  1117. DIM3 = 1.D0
  1118. ENDIF
  1119. ENDIF
  1120. c
  1121. c on cherche les contraintes on les met dans work...
  1122. c
  1123. JC = 0
  1124. MPTVAL=IVASTR
  1125. DO 5044 IGAU=1,NBPGAU
  1126. DO 5044 ICOMP=1,NSTRS
  1127. MELVAL=IVAL(ICOMP)
  1128. IGMN=MIN(IGAU,VELCHE(/1))
  1129. IBMN=MIN(IB ,VELCHE(/2))
  1130. JC=JC+1
  1131. WORK(JC)=VELCHE(IGMN,IBMN)
  1132. 5044 CONTINUE
  1133. c
  1134. c appel a coque2 ksigma...
  1135. c
  1136. AN=NHRM
  1137. CALL CQ2KSG(XE,1.D0,DIM3,IFOUR,AN,NBPGAU,WORK(1),WORK(19),
  1138. 1 WORK(22),QSIGAU,POIGAU,WORK(25),WORK(30),
  1139. 2 WORK(35),WORK(42),WORK(49),WORK(113),WORK(177),
  1140. 3 WORK(241),WORK(305),LRE,REL)
  1141. c
  1142. c remplissage de xmatri
  1143. c
  1144. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1145. c
  1146. 3044 CONTINUE
  1147. c
  1148. C 9044 CONTINUE
  1149. SEGSUP,MWRK1,MWRK3,MWRK4
  1150. GOTO 510
  1151. c
  1152. c_______________________________________________________________________
  1153. c
  1154. c elements barre et cercle (et TIMO)
  1155. c_______________________________________________________________________
  1156. 46 CONTINUE
  1157. C Cas particulier :
  1158. IF (MELE.EQ.95.AND.IFOUR.NE.0.AND.IFOUR.NE.1) GOTO 99
  1159. C
  1160. NBBB = NBNN
  1161. SEGINI MWRK1,MWRK3
  1162. c
  1163. DO 3046 IB=1,NBELEM
  1164. c
  1165. c on cherche les coordonnees des noeuds de l elementib
  1166. c
  1167. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1168. c
  1169. c mise a zero de la raideur geometrique
  1170. c
  1171. CALL ZERO(REL,LRE,LRE)
  1172. c
  1173. c on cherche l'effort
  1174. c
  1175. MPTVAL=IVASTR
  1176. MELVAL=IVAL(1)
  1177. NBPTEL=VELCHE(/1)
  1178. IBMN=MIN(IB,VELCHE(/2))
  1179. c
  1180. IF (NBPTEL.EQ.1) THEN
  1181. EFFORT=VELCHE(1,IBMN)
  1182. ELSE IF (NBPTEL.EQ.2) THEN
  1183. EFF1=VELCHE(1,IBMN)
  1184. EFF2=VELCHE(2,IBMN)
  1185. EFFORT=0.5D0*(EFF1+EFF2)
  1186. ENDIF
  1187. c
  1188. c on calcule la rigidite geometrique
  1189. c
  1190. IF (MELE.EQ.46.or.MELE.eq.84)
  1191. & CALL BARKSG(REL,LRE,EFFORT,XE,KERRE)
  1192. IF (MELE.EQ.95) CALL CERKSG(REL,LRE,EFFORT,XE,KERRE)
  1193. IF (KERRE.NE.0) THEN
  1194. INTERR(1)=ISOUS
  1195. INTERR(2)=IB
  1196. CALL ERREUR(128)
  1197. GO TO 9046
  1198. ENDIF
  1199. c
  1200. c remplissage de xmatri
  1201. c
  1202. c cas particulier TIMO : on saute les ddls de rotation
  1203. IF (MELE.EQ.84) THEN
  1204. NCOMPU=NCOMP/2
  1205. ii=0
  1206. iii=0
  1207. DO 841 INOEUD=1,NBNNS
  1208. DO 842 ICOMP=1,NCOMP
  1209. ii=ii+1
  1210. if(ii.gt.NCOMPU) goto 842
  1211. iii=iii+1
  1212. jj=0
  1213. jjj=0
  1214. DO 843 JNOEUD=1,NBNNS
  1215. DO 844 JCOMP=1,NCOMP
  1216. jj=jj+1
  1217. if(jj.gt.ii) goto 842
  1218. if(jj.gt.NCOMPU) goto 844
  1219. jjj=jjj+1
  1220. RE(ii,jj,ib)=REL(iii,jjj)
  1221. RE(jj,ii,ib)=REL(iii,jjj)
  1222. 844 CONTINUE
  1223. 843 CONTINUE
  1224. 842 CONTINUE
  1225. 841 CONTINUE
  1226. ELSE
  1227. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1228. ENDIF
  1229. C
  1230. 3046 CONTINUE
  1231.  
  1232. 9046 CONTINUE
  1233. SEGSUP,MWRK1,MWRK3
  1234. GOTO 510
  1235.  
  1236. c_______________________________________________________________________
  1237. c
  1238. c element coq4
  1239. c_______________________________________________________________________
  1240. 49 CONTINUE
  1241. NBBB=NBNN
  1242. NBNO=NBNN
  1243. SEGINI,MWRK1,MWRK2,MWRK4
  1244.  
  1245. DO 3049 IB=1,NBELEM
  1246. c
  1247. c on cherche les coordonnees des noeuds de l element ib
  1248. c
  1249. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1250.  
  1251. CALL ZERO(REL,LRE,LRE)
  1252. CALL CQ4LOC(XE,XEL,BPSS,IRRT,0)
  1253. C
  1254. C attention : rien de prevu en cas d'excentrement
  1255. C
  1256. CALL BCOQ4(5,XEL,SHPTOT,SHPWRK,BGENE,DJAC,XZERO,0,IRRT,0)
  1257. c
  1258. MPTVAL=IVASTR
  1259. DO 5049 ICOMP=1,NSTRS
  1260. MELVAL=IVAL(ICOMP)
  1261. IGMN=MIN(5,VELCHE(/1))
  1262. IBMN=MIN(IB ,VELCHE(/2))
  1263. XSTRS(ICOMP)=VELCHE(IGMN,IBMN)
  1264. 5049 CONTINUE
  1265. c
  1266. CALL CQ4KSG(DJAC,XSTRS,SHPWRK, REL)
  1267. CALL TRANSK(REL,BPSS,LRE,4,0)
  1268. c
  1269. c remplissage de xmatri
  1270. c
  1271. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1272. C
  1273. 3049 CONTINUE
  1274.  
  1275. C 9049 CONTINUE
  1276. SEGSUP,MWRK1,MWRK2,MWRK4
  1277. GOTO 510
  1278.  
  1279. c_______________________________________________________________________
  1280. c
  1281. c element cof3
  1282. c_______________________________________________________________________
  1283. c
  1284. 51 CONTINUE
  1285. c
  1286. NBBB=NBNN
  1287. SEGINI,MWRK1,MWRK3,MWRK4
  1288. c
  1289. CALL ERREUR(19)
  1290. GOTO 9051
  1291.  
  1292. C DO 3051 IB=1,NBELEM
  1293. Cc
  1294. Cc on cherche les coordonnees des noeuds de l element ib
  1295. Cc
  1296. C CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1297. C
  1298. C CALL ZERO(REL,LRE,LRE)
  1299. C
  1300. C MPTVAL=IVACAR
  1301. C MELVAL=IVAL(1)
  1302. C IF (MELVAL.NE.0) THEN
  1303. C IBMN=MIN(IB ,VELCHE(/2))
  1304. C EPAI=VELCHE(1,IBMN)
  1305. C ELSE
  1306. C EPAI=XZERO
  1307. C ENDIF
  1308. Cc
  1309. Cc on cherche les contraintes on les met dans work...
  1310. Cc
  1311. C JC=0
  1312. C MPTVAL=IVASTR
  1313. C DO 5051 IGAU=1,NBPGAU
  1314. C DO 5051 ICOMP=1,NSTRS
  1315. C MELVAL=IVAL(ICOMP)
  1316. C IGMN=MIN(IGAU,VELCHE(/1))
  1317. C IBMN=MIN(IB ,VELCHE(/2))
  1318. C JC=JC+1
  1319. C WORK(JC)=VELCHE(IGMN,IBMN)
  1320. C 5051 CONTINUE
  1321. Cc
  1322. Cc appel a coque2 ksigma...
  1323. Cc
  1324. C AN=NHRM
  1325. CC call cq3ksg(xe,epai,an,nbpgau,work(1),work(19),work(22),
  1326. CC 1 work(25),work(30),work(35),work(42),work(49),
  1327. CC 2 work(113),work(177),work(241),work(305),rel)
  1328. Cc
  1329. Cc remplissage de xmatri
  1330. Cc
  1331. C CALL REMPMT(REL,LRE,RE(1,1,ib))
  1332. Cc
  1333. C 3051 CONTINUE
  1334.  
  1335. 9051 CONTINUE
  1336. SEGSUP MWRK1,MWRK3,MWRK4
  1337. GOTO 510
  1338.  
  1339. c_______________________________________________________________________
  1340. c
  1341. c element shb8
  1342. c_______________________________________________________________________
  1343. 260 CONTINUE
  1344. NBBB=NBNN
  1345. SEGINI,MWRK1,MWRK7
  1346. C write(6,*) ' nbnn nbpgau nstrs lre' , NBNN,nbpgau,nstrs,lre
  1347.  
  1348. DO 3260 IB=1,NBELEM
  1349. c
  1350. c on cherche les coordonnees des noeuds de l element ib
  1351. c
  1352. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  1353.  
  1354. MPTVAL=IVASTR
  1355. IE=0
  1356. do 3268 igau=1,nbpgau
  1357. DO 3268 ICOMP=1,NSTRS
  1358. iE=IE+1
  1359. MELVAL=IVAL(ICOMP)
  1360. IGMN=MIN(IGAU,VELCHE(/1))
  1361. IBMN=MIN(IB ,VELCHE(/2))
  1362. work1(ie)=VELCHE(IGMN,IBMN)
  1363. C write(6,*)' xstrs(icomp)',icomp,XSTRS(ICOMP)
  1364. 3268 CONTINUE
  1365. propel(1)=0.
  1366. call shb8 (9,xe,D,propel,work1,rel,out)
  1367.  
  1368. C remplissage de xmatri
  1369. CALL REMPMT(REL,LRE,RE(1,1,ib))
  1370. C
  1371. 3260 CONTINUE
  1372. c
  1373. C 9260 CONTINUE
  1374. SEGSUP,MWRK1,MWRK7
  1375. GOTO 510
  1376.  
  1377. c_______________________________________________________________________
  1378. c
  1379. c desactivation des segments propres a la zone geometrique isous
  1380. c_______________________________________________________________________
  1381. c
  1382. 510 CONTINUE
  1383. 597 CONTINUE
  1384. IF (ISUP1L.EQ.1 .OR. nblprt.GT.1) THEN
  1385. CALL DTMVAL(IVASTR,3)
  1386. ELSE
  1387. CALL DTMVAL(IVASTR,1)
  1388. ENDIF
  1389. IF (ISUP2L.EQ.1 .OR. nblprt.GT.1) THEN
  1390. CALL DTMVAL(IVACAR,3)
  1391. ELSE
  1392. CALL DTMVAL(IVACAR,1)
  1393. ENDIF
  1394. xmatri = ipmatr
  1395. SEGDES,xmatri
  1396.  
  1397. C- Sortie prematuree en cas d'erreur
  1398. IF (IERR.NE.0) GOTO 598
  1399.  
  1400. C- Stockage de la matrice
  1401. nrigel=irigel(/2) +1
  1402. segadj,mrigid
  1403. C jrige = NRIGE0 + irige
  1404. jrige=nrigel
  1405. COERIG(jrige) = 1.
  1406. IRIGEL(1,jrige) = ipmail
  1407. IRIGEL(2,jrige) = 0
  1408. IRIGEL(3,jrige) = ipdesc
  1409. IRIGEL(4,jrige) = ipmatr
  1410. IRIGEL(5,jrige) = NIFOUR
  1411. IRIGEL(6,jrige) = 0
  1412. IRIGEL(7,jrige) = 0
  1413. IRIGEL(8,jrige) = 0
  1414.  
  1415. ENDDO
  1416. C- Fin de la boucle sur les partitions
  1417. C
  1418. 598 CONTINUE
  1419. IF (MOSTRS.NE.0) THEN
  1420. nomid = MOSTRS
  1421. IF (lsupco) SEGSUP,nomid
  1422. notype = MOTYPS
  1423. SEGSUP,notype
  1424. ENDIF
  1425. IF (MOCARA.NE.0) THEN
  1426. NOMID = MOCARA
  1427. SEGSUP,NOMID
  1428. notype = MOTYPC
  1429. SEGSUP,notype
  1430. ENDIF
  1431. C
  1432. NOMID=MODEPL
  1433. IF (lsupde) SEGSUP,NOMID
  1434. NOMID = MOFORC
  1435. IF (lsupfo) SEGSUP,NOMID
  1436.  
  1437. 599 CONTINUE
  1438.  
  1439. IF (IERR.NE.0) GOTO 999
  1440. C
  1441. 500 CONTINUE
  1442. C* Fin de la boucle sur les modeles elementaires
  1443.  
  1444. 999 CONTINUE
  1445. IF (IERR.NE.0) THEN
  1446. ktrace = -1
  1447. CALL DERIGI(MRIGID,ktrace,msorse)
  1448. SEGSUP,MRIGID
  1449. IPRIGG = 0
  1450. ELSE
  1451. if(irigel(/2).eq.0) then
  1452. call erreur (86)
  1453. return
  1454. endif
  1455. SEGDES,MRIGID
  1456. IPRIGG = MRIGID
  1457. ENDIF
  1458.  
  1459. END
  1460.  
  1461.  
  1462.  

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