Télécharger gyro2.eso

Retour à la liste

Numérotation des lignes :

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

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