Télécharger ksigmp.eso

Retour à la liste

Numérotation des lignes :

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

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