Télécharger gyro2.eso

Retour à la liste

Numérotation des lignes :

  1. C GYRO2 SOURCE PV 17/10/03 21:15:37 9581
  2.  
  3. SUBROUTINE GYRO2 (IPMODL,IPCHE1, IPRIG)
  4. *
  5. *_______________________________________________________________________
  6. *
  7. * appelé par GYROS
  8. *
  9. * Creation d'une matrice de couplage gyroscopique
  10. * dans le repère inertiel ou fixe (éléments POUTR, TIMO, TUYAU)
  11. *
  12. * entrees :
  13. * ========
  14. * ipmodl pointeur sur un mmodel
  15. * ipche1 pointeur sur un mchaml de caracteristiques
  16. *
  17. * sorties :
  18. * =========
  19. * iprig pointeur sur la matrice d'amortissement construite
  20. * =0 sinon en cas d'erreur (et IERR non nul)
  21. *
  22. *_______________________________________________________________________
  23.  
  24. IMPLICIT INTEGER(I-N)
  25. IMPLICIT REAL*8(A-H,O-Z)
  26.  
  27.  
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC CCHAMP
  31. -INC CCGEOME
  32. -INC CCREEL
  33.  
  34. -INC SMRIGID
  35. -INC SMCHAML
  36. -INC SMELEME
  37. -INC SMCOORD
  38. -INC SMINTE
  39. -INC SMMODEL
  40.  
  41. INTEGER oooval
  42.  
  43. SEGMENT NOTYPE
  44. CHARACTER*16 TYPE(NBTYPE)
  45. ENDSEGMENT
  46.  
  47. SEGMENT MPTVAL
  48. INTEGER IPOS(NS),NSOF(NS)
  49. INTEGER IVAL(NCOSOU)
  50. CHARACTER*16 TYVAL(NCOSOU)
  51. ENDSEGMENT
  52.  
  53. CHARACTER*8 CMATE
  54. CHARACTER*(NCONCH) CONM
  55.  
  56. PARAMETER ( INTYP = 4 )
  57.  
  58. PARAMETER (NINF=3)
  59. INTEGER INFOS(NINF)
  60. LOGICAL lsupde,lsupfo
  61.  
  62. IPRIG = 0
  63. C
  64. C ACTIVATION DU MODELE
  65. C
  66. MMODEL = IPMODL
  67. SEGACT,MMODEL
  68. NSOUS=KMODEL(/1)
  69. C
  70. C CREATION DE L'OBJET MATRICE DE COUPLAGE GYROSCOPIQUE
  71. C
  72. NRIGEL = 0
  73. SEGINI,MRIGID
  74. MTYMAT = 'AMORTISS'
  75. IFORIG = IFOMOD
  76. * IFORIG = IFOUR
  77. ICHOLE = 0
  78. IMGEO1 = 0
  79. IMGEO2 = 0
  80. ISUPEQ = 0
  81. C
  82. C_______________________________________________________________________
  83. C
  84. C DEBUT DE LA BOUCLE SUR LES DIFFERENT MODELES ELEMENTAIRES
  85. C_______________________________________________________________________
  86. C
  87. DO 500 ISOUS=1,NSOUS
  88. C
  89. IMODEL = KMODEL(ISOUS)
  90. SEGACT,IMODEL
  91.  
  92. C- Initialisations
  93. IPMINT = 0
  94.  
  95. MOMATR = 0
  96. MOCARA = 0
  97. MOTYPM = 0
  98. MOTYPC = 0
  99. ISUPM = 0
  100. ISUPC = 0
  101.  
  102. MODEPL = 0
  103. MOFORC = 0
  104. lsupde = .false.
  105. lsupfo = .false.
  106.  
  107. IDESCR = 0
  108.  
  109. C- Recuperation d'informations sur le maillage elementaire
  110. IIPDPG = imodel.IPDPGE
  111. IIPDPG = IPTPOI(IIPDPG)
  112. IPT1 = imodel.IMAMOD
  113. SEGACT,IPT1
  114. NBNOE1 = IPT1.NUM(/1)
  115. NBELE1 = IPT1.NUM(/2)
  116.  
  117. C- Quelques informations sur le modele
  118. CONM = CONMOD
  119. CMATE = CMATEE
  120. MATE = IMATEE
  121. c* INAT = INATUU
  122. C- Creation du tableau INFOS
  123. iret = 1
  124. CALL IDENT(IPT1,CONM,IPCHE1,0,INFOS,iret)
  125. IF (iret.EQ.0) GOTO 599
  126.  
  127. C- Recuperation d'informations sur l'element fini
  128. MELE = NEFMOD
  129. C
  130. NPINT = 1
  131. IF (INFMOD(/1).NE.0) NPINT = INFMOD(1)
  132. C-- Support des champs
  133. IPLAZ = 4
  134. IF (NPINT.EQ.12345) IPLAZ = 1
  135.  
  136. MFR = INFELE(13)
  137. LRE = INFELE(9)
  138. LW = INFELE(7)
  139. LHOOK = INFELE(10)
  140. NDDL = INFELE(15)
  141. c* IELE = INFELE(14)
  142. c* ICARA = INFELE(5)
  143. IPMINT = INFMOD(2+IPLAZ)
  144. c* IPMINT = INFELE(11)
  145. IPMIN1 = INFMOD(8)
  146. IPPORE = 0
  147. IF (MFR.EQ.33) IPPORE = NBNOE1
  148. C
  149. C- RECHERCHE DES NOMS D'INCONNUES ET DES DUAUX
  150. if (lnomid(1).ne.0) then
  151. MODEPL =lnomid(1)
  152. else
  153. lsupde = .true.
  154. CALL IDPRIM(IMODEL,MFR,MODEPL,NDEPL,ndum)
  155. endif
  156. nomid = MODEPL
  157. SEGACT,nomid
  158. NDEPL = lesobl(/2)
  159. c* ndum = lesfac(/2)
  160.  
  161. IF (lnomid(2).ne.0) then
  162. MOFORC = lnomid(2)
  163. ELSE
  164. lsupfo = .true.
  165. CALL IDDUAL(IMODEL,MFR,MOFORC,NFORC,NDUM)
  166. ENDIF
  167. nomid = MOFORC
  168. SEGACT,nomid
  169. NFORC = lesobl(/2)
  170. c* ndum=lesfac(/2)
  171. C
  172. IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN
  173. CALL ERREUR(5)
  174. GOTO 598
  175. ENDIF
  176. C
  177. C- REMPLISSAGE DU SEGMENT DESCRIPTEUR
  178. NLIGRP = LRE
  179. NLIGRD = LRE
  180. SEGINI,DESCR
  181.  
  182. NCOMP = NDEPL
  183. NBNNS = NBNOE1
  184. IF (MFR.EQ.33) NCOMP = NDEPL-1
  185. IF (IFOUR.EQ.-3) THEN
  186. NCOMP = NDEPL-3
  187. ENDIF
  188. c* ? IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS = NBNOE1/2
  189. IDDL = 1
  190. DO 1004 INOEUD=1,NBNNS
  191. DO 1005 ICOMP=1,NCOMP
  192. NOMID=MODEPL
  193. LISINC(IDDL)=LESOBL(ICOMP)
  194. NOMID=MOFORC
  195. LISDUA(IDDL)=LESOBL(ICOMP)
  196. NOELEP(IDDL)=INOEUD
  197. NOELED(IDDL)=INOEUD
  198. IDDL=IDDL+1
  199. 1005 CONTINUE
  200. 1004 CONTINUE
  201. *
  202. SEGDES,DESCR
  203. IDESCR = DESCR
  204.  
  205. C- Recuperation des noms de composantes MATERIAU
  206. nbrobl = 0
  207. nbrfac = 0
  208. nomid = 0
  209. notype = 0
  210. LHOTRA = 0
  211. C
  212. C rho dans les cas poutre,tuyau
  213. IF (MFR.EQ.7.OR.MFR.EQ.13) THEN
  214. IF (CMATE.NE.'SECTION') THEN
  215. nbrobl = 1
  216. SEGINI,nomid
  217. lesobl(1)='RHO '
  218. nbtype = 1
  219. SEGINI,notype
  220. type(1) = 'REAL*8'
  221. ELSE
  222. LHOTRA = LHOOK
  223. nbrobl=2
  224. SEGINI,nomid
  225. lesobl(1)='MODS'
  226. lesobl(2)='MATS'
  227. nbtype = 2
  228. SEGINI,notype
  229. type(1) = 'POINTEURMMODEL'
  230. type(2) = 'POINTEURMCHAML'
  231. ENDIF
  232. ENDIF
  233. MOMATR = nomid
  234. MOTYPM = notype
  235. NMATR = nbrobl
  236. NMATF = nbrfac
  237. NMATT = NMATR+NMATF
  238. C-- Verification du support des composantes recherchees
  239. IF (MOMATR.NE.0) THEN
  240. CALL QUESUQ(IMODEL,IPCHE1,INTYP,0,MOMATR,IPLAZ,ISUPM,iret)
  241. IF (ISUPM.GT.1) GOTO 597
  242. ENDIF
  243.  
  244. C- Recuperation des noms de composantes CARACTERISTIQUES
  245. nbrobl = 0
  246. nbrfac = 0
  247. nomid = 0
  248. notype = 0
  249. IVECT = 0
  250. * caracteristiques pour les poutres
  251. IF (MFR.EQ.7 ) THEN
  252. IF (CMATE.EQ.'SECTION') THEN
  253. nbrfac = 2
  254. SEGINI,nomid
  255. lesfac(1) = 'OMEG'
  256. lesfac(2) = 'VECT'
  257. IVECT = 1
  258. *
  259. nbtype = 2
  260. SEGINI,notype
  261. type(1) = 'REAL*8'
  262. type(2) = 'POINTEURPOINT '
  263. ELSE
  264. nbrobl = 4
  265. nbrfac = 4
  266. SEGINI,nomid
  267. lesobl(1) = 'TORS'
  268. lesobl(2) = 'INRY'
  269. lesobl(3) = 'INRZ'
  270. lesobl(4) = 'SECT'
  271. lesfac(1) = 'SECY'
  272. lesfac(2) = 'SECZ'
  273. lesfac(3) = 'OMEG'
  274. lesfac(4) = 'VECT'
  275. IVECT = 1
  276. *
  277. nbtype = 8
  278. SEGINI,notype
  279. type(1) = 'REAL*8'
  280. type(2) = 'REAL*8'
  281. type(3) = 'REAL*8'
  282. type(4) = 'REAL*8'
  283. type(5) = 'REAL*8'
  284. type(6) = 'REAL*8'
  285. type(7) = 'REAL*8'
  286. type(8) = 'POINTEURPOINT '
  287. ENDIF
  288. * caracteristiques pour les tuyaux
  289. ELSE IF (MFR.EQ.13) THEN
  290. nbrobl = 2
  291. nbrfac = 3
  292. SEGINI,nomid
  293. lesobl(1) = 'EPAI'
  294. lesobl(2) = 'RAYO'
  295. lesfac(1) = 'RACO'
  296. lesfac(2) = 'OMEG'
  297. lesfac(3) = 'VECT'
  298. IVECT = 1
  299. *
  300. nbtype = 5
  301. SEGINI,notype
  302. type(1) = 'REAL*8'
  303. type(2) = 'REAL*8'
  304. type(3) = 'REAL*8'
  305. type(4) = 'REAL*8'
  306. type(5) = 'POINTEURPOINT '
  307. ENDIF
  308.  
  309. MOCARA = nomid
  310. MOTYPC = notype
  311. NCARA = nbrobl
  312. NCARF = nbrfac
  313. NCARR = NCARA+NCARF
  314.  
  315. C--- Verification du support des composantes recherchées
  316. IF (MOCARA.NE.0) THEN
  317. CALL QUESUQ(IMODEL,IPCHE1,INTYP,0,MOCARA,IPLAZ,ISUPC,iret)
  318. IF (ISUPC.GT.1) GOTO 597
  319. ENDIF
  320. C
  321. C- Activation du segment MINTE
  322. MINTE = IPMINT
  323. SEGACT,MINTE
  324. NBPGAU = POIGAU(/1)
  325. C
  326. C- Partionnement si necessaire de la matrice d'amortissement
  327. C- determinant ainsi le nombre d'objets elementaires de MRIGID
  328. LTRK = oooval(1,4)
  329. IF (LTRK.EQ.0) LTRK = oooval(1,1)
  330. * Ajout a la taille en mots de la matrice des infos du segment
  331. LSEG = LRE*LRE*NBELE1 + 16
  332. NBLPRT = (LSEG-1)/LTRK + 1
  333. NBLMAX = (NBELE1-1)/NBLPRT + 1
  334. nblprt = (NBELE1-1)/NBLMAX + 1
  335. c* write(ioimp,*) ' gyro2 : nblprt nblmax = ',nblprt,nblmax,nbele1
  336.  
  337. C-- Ajout de la matrice de couplage GYROSCOPIQUE a la matrice globale
  338. NRIGE0 = IRIGEL(/2)
  339. NRIGEL = NRIGE0 + nblprt
  340. SEGADJ,MRIGID
  341.  
  342. descr = IDESCR
  343. meleme = IPT1
  344. nbnn = NBNOE1
  345. nbelem = NBELE1
  346. nbsous = 0
  347. nbref = 0
  348.  
  349. * Boucle sur les PARTITIONS elementaires de la matrice
  350. *------------------------------------------------------
  351. DO 5000 irige = 1, nblprt
  352.  
  353. IF (nblprt.GT.1) THEN
  354. C-- Partitionnement du maillage support de la matrice elementaire
  355. C- (IPT1 peut etre desactive suite a l'appel a KOMCHA !)
  356. SEGACT,IPT1
  357. ielem = (irige-1)*NBLMAX
  358. nbelem = MIN(NBLMAX,NBELE1-ielem)
  359. * write(ioimp,*) ' creation segment ',nbnn,nbelem
  360. SEGINI,meleme
  361. itypel = IPT1.itypel
  362. DO ielt = 1, nbelem
  363. jelt = ielt + ielem
  364. DO inoe = 1, nbnn
  365. num(inoe,ielt) = IPT1.NUM(inoe,jelt)
  366. ENDDO
  367. icolor(ielt) = IPT1.ICOLOR(jelt)
  368. ENDDO
  369. C-- Recopie du descripteur
  370. des1 = IDESCR
  371. SEGINI,descr=des1
  372. SEGDES,descr
  373. ENDIF
  374. C* Voir le cas IFOUR.EQ.-3
  375. ipmail = meleme
  376. ipdesc = descr
  377. ipt2 = meleme
  378.  
  379. C-- Initialisation de la matrice de rigidite elementaire (xmatri)
  380. NELRIG = nbelem
  381. SEGINI,xmatri
  382. ipmatr = xmatri
  383.  
  384. C-- Recuperation des valeurs des proprietes materiau et geometriques
  385. ivamat = 0
  386. ivacar = 0
  387. IF (MOMATR.NE.0) THEN
  388. CALL KOMCHA(IPCHE1,ipmail,CONM,MOMATR,MOTYPM,1,
  389. & INFOS,NINF,ivamat)
  390. IF (IERR.NE.0) GOTO 5099
  391. IF (ISUPM.EQ.1) THEN
  392. CALL VALCHE(ivamat,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  393. IF (IERR.NE.0) THEN
  394. ISUPM = 0
  395. GOTO 5099
  396. ENDIF
  397. ENDIF
  398. ENDIF
  399. IF (MOCARA.NE.0) THEN
  400. CALL KOMCHA(IPCHE1,ipmail,CONM,MOCARA,MOTYPC,1,
  401. & INFOS,NINF,ivacar)
  402. IF (IERR.NE.0) GOTO 5099
  403. IF (ISUPC.EQ.1) THEN
  404. CALL VALCHE(ivacar,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  405. IF (IERR.NE.0) THEN
  406. ISUPC = 0
  407. GOTO 5099
  408. ENDIF
  409. ENDIF
  410. ENDIF
  411.  
  412. C_______________________________________________________________________
  413. C
  414. C NUMERO DES ETIQUETTES :
  415. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  416. C LES ELEMENTS SONT GROUPES COMME SUIT :
  417. C_______________________________________________________________________
  418. * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  419. GOTO ( 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  420. * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  421. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  422. * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6
  423. & , 99, 99, 99, 99, 99, 99, 21, 99, 99, 99, 99
  424. * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  425. & , 99, 99, 99, 99, 99, 99, 99, 99, 21, 99, 99
  426. * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  427. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  428. * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  429. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  430. * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  431. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  432. * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  433. & , 99, 99, 99, 99, 99, 99, 21, 99, 99, 99, 99
  434. * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3
  435. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  436. * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  437. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  438. * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  439. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  440. * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  441. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  442. * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  443. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  444. * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  445. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  446. * TE56 PY91 TRH6
  447. & , 99, 99, 99),MELE
  448. C
  449. 99 CONTINUE
  450. MOTERR(1:4)=NOMTP(MELE)
  451. MOTERR(5:12)='GYROS'
  452. CALL ERREUR(86)
  453. GOTO 5099
  454. C_______________________________________________________________________
  455. C
  456. C POUTRE, POUTRE DE TIMOSCHENKO
  457. C_______________________________________________________________________
  458. C
  459. 21 CONTINUE
  460. CALL GYRO3(ipmail,LRE,LW,MELE,ivamat,NMATT,ivacar,NCARR,
  461. & IVECT,ISOUS,NBPGAU,IPMINT,IPMIN1,NDDL,MATE,
  462. & CMATE,LHOTRA,ipmatr,IIPDPG)
  463. GOTO 5100
  464. C_______________________________________________________________________
  465. C
  466. C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  467. C_______________________________________________________________________
  468. 5100 CONTINUE
  469. 5099 CONTINUE
  470. c* xmatri = ipmatr
  471. IF (nblprt.GT.1) THEN
  472. c* meleme = ipmail
  473. SEGDES,meleme
  474. ENDIF
  475. IF (ISUPM.EQ.1 .OR. nblprt.GT.1) THEN
  476. CALL DTMVAL(ivamat,3)
  477. ELSE
  478. CALL DTMVAL(ivamat,1)
  479. ENDIF
  480. IF (ISUPC.EQ.1 .OR. nblprt.GT.1) THEN
  481. CALL DTMVAL(ivacar,3)
  482. ELSE
  483. CALL DTMVAL(ivacar,1)
  484. ENDIF
  485.  
  486. C- Sortie prematuree en cas d'erreur
  487. IF (IERR.NE.0) GOTO 596
  488.  
  489. C- Stockage de la matrice
  490. jrige = NRIGE0 + irige
  491. COERIG(jrige) = 1.
  492. IRIGEL(1,jrige) = ipt2
  493. IRIGEL(2,jrige) = 0
  494. IRIGEL(3,jrige) = ipdesc
  495. IRIGEL(4,jrige) = ipmatr
  496. IRIGEL(5,jrige) = NIFOUR
  497. IRIGEL(6,jrige) = 0
  498. C-- Matrice antisymetrique
  499. IRIGEL(7,jrige) = 1
  500. xmatri.symre = 1
  501. SEGDES,xmatri
  502. IRIGEL(8,jrige) = 0
  503.  
  504. 5000 CONTINUE
  505. C- Fin de la boucle sur les partitions
  506.  
  507. 596 CONTINUE
  508. c* MINTE = IPMINT
  509. SEGDES,MINTE
  510. 597 CONTINUE
  511. IF (MOMATR.NE.0) THEN
  512. nomid = MOMATR
  513. SEGSUP,nomid
  514. notype = MOTYPM
  515. SEGSUP,notype
  516. ENDIF
  517. IF (MOCARA.NE.0) THEN
  518. nomid = MOCARA
  519. SEGSUP,nomid
  520. notype = MOTYPC
  521. SEGSUP,notype
  522. ENDIF
  523. 598 CONTINUE
  524. NOMID = MODEPL
  525. SEGDES,NOMID
  526. IF (lsupde) SEGSUP,NOMID
  527. NOMID = MOFORC
  528. SEGDES,NOMID
  529. IF (lsupfo) SEGSUP,NOMID
  530. 599 CONTINUE
  531. SEGDES,IPT1
  532. SEGDES,IMODEL
  533.  
  534. C- Sortie prematuree en cas d'erreur
  535. IF (IERR.NE.0) GOTO 999
  536.  
  537. 500 CONTINUE
  538. C- Fin de la boucle sur les modeles elementaires
  539.  
  540. 999 CONTINUE
  541. IF (IERR.NE.0) THEN
  542. SEGSUP,MRIGID
  543. IPRIG = 0
  544. ELSE
  545. SEGDES,MRIGID
  546. IPRIG = MRIGID
  547. ENDIF
  548. SEGDES,MMODEL
  549.  
  550. RETURN
  551. END
  552.  
  553.  
  554.  

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