Télécharger ksigmp.eso

Retour à la liste

Numérotation des lignes :

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

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