Télécharger ksigmp.eso

Retour à la liste

Numérotation des lignes :

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

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