Télécharger corio1.eso

Retour à la liste

Numérotation des lignes :

corio1
  1. C CORIO1 SOURCE PV 22/07/28 21:15:02 11419
  2. SUBROUTINE CORIO1 (IPMODL,IPCHE1,IPROTA,NUMLI1,NUMLI2, IPRIG)
  3.  
  4. *_______________________________________________________________________
  5. *
  6. * appelé par CORIOL ( opérateur CORIOLIS )
  7. *
  8. * Creation d'une matrice d'amortissement de couplage gyroscopique
  9. * dans le repère tournant (éléments BARR,POUT,TIMO,TUYAU,COQUES 3D)
  10. *
  11. * entrees :
  12. * ========
  13. * ipmodl pointeur sur un mmodel
  14. * ipche1 pointeur sur un mchaml de caracteristique
  15. * iprota point = vecteur vitesse de rotation
  16. *
  17. * sorties :
  18. * =========
  19. * iprig pointeur sur la matrice construite
  20. * = 0 en cas d'erreur (IERR non nul aussi)
  21. *
  22. * Didier COMBESCURE mars 2003
  23. *_______________________________________________________________________
  24.  
  25. IMPLICIT INTEGER(I-N)
  26. IMPLICIT REAL*8(A-H,O-Z)
  27.  
  28.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC CCHAMP
  32. -INC CCGEOME
  33. -INC CCREEL
  34.  
  35. -INC SMRIGID
  36. -INC SMCHAML
  37. -INC SMELEME
  38. -INC SMCOORD
  39. -INC SMINTE
  40. -INC SMMODEL
  41.  
  42. INTEGER oooval
  43.  
  44. SEGMENT NOTYPE
  45. CHARACTER*16 TYPE(NBTYPE)
  46. ENDSEGMENT
  47. C
  48. SEGMENT MPTVAL
  49. INTEGER IPOS(NS),NSOF(NS)
  50. INTEGER IVAL(NCOSOU)
  51. CHARACTER*16 TYVAL(NCOSOU)
  52. ENDSEGMENT
  53. C
  54. CHARACTER*8 CMATE
  55. CHARACTER*(NCONCH) CONM
  56. PARAMETER (NINF=3)
  57. INTEGER INFOS(NINF)
  58. DIMENSION VROT(3)
  59. LOGICAL lsupfo,lsupde
  60. C
  61. IPRIG = 0
  62.  
  63. C Activation XCOOR
  64. SEGACT MCOORD
  65.  
  66. C____________________________________________________________________
  67. C
  68. C LECTURE DU VECTEUR ROTATION ET MULTIPLICATION PAR 2 (pour Coriolis)
  69. C____________________________________________________________________
  70. C
  71. c
  72. C Cas 3D (idim=3)
  73. IF (IFOUR.EQ.2) THEN
  74. IF (IPROTA.EQ.0) THEN
  75. VROT(1) = 0.D0
  76. VROT(2) = 0.D0
  77. VROT(3) = 2.D0
  78. ELSE
  79. VROT(1) = 2.D0 * XCOOR((4*IPROTA) - 3)
  80. VROT(2) = 2.D0 * XCOOR((4*IPROTA) - 2)
  81. VROT(3) = 2.D0 * XCOOR((4*IPROTA) - 1)
  82. ENDIF
  83. C Cas Axi et 2D Fourier (idim=2)
  84. ELSEIF ((IFOUR.EQ.0) .OR. (IFOUR.EQ.1)) THEN
  85. IF (IPROTA.EQ.0) THEN
  86. VROT(1) = 0.D0
  87. VROT(2) = 2.D0
  88. VROT(3) = 0.D0
  89. ELSE
  90. VROT(1) = 0.D0
  91. VROT(2) = 2.D0*XCOOR((3*IPROTA) - 1)
  92. VROT(3) = 0.D0
  93. ENDIF
  94. C Pas d'autres cas ...
  95. C --> ERREUR "Fonction indisponible pour ce mode de calcul"
  96. ELSE
  97. CALL ERREUR(710)
  98. RETURN
  99. ENDIF
  100.  
  101.  
  102. c_______________________________________________________________________
  103. c
  104. c initialisation du chapeau de l objet rigidite
  105. c_______________________________________________________________________
  106. NRIGEL = 0
  107. SEGINI,MRIGID
  108. IFORIG = IFOUR
  109. ICHOLE = 0
  110. IMGEO1 = 0
  111. IMGEO2 = 0
  112. ISUPEQ = 0
  113. IF (NUMLI2.EQ.0) THEN
  114. MTYMAT = 'AMORTISS'
  115. ELSE
  116. MTYMAT = 'MASSE'
  117. ENDIF
  118.  
  119. C-----------------------------------------------------------------------
  120. C ACTIVATION DU MODELE
  121. C-----------------------------------------------------------------------
  122. MMODEL = IPMODL
  123. SEGACT,MMODEL
  124. NSOUS = KMODEL(/1)
  125. C
  126. C-----------------------------------------------------------------------
  127. C DEBUT DE LA BOUCLE SUR LES DIFFERENTES SOUS ZONES
  128. C-----------------------------------------------------------------------
  129. DO 500 ISOUS = 1, NSOUS
  130. C
  131. IMODEL = KMODEL(ISOUS)
  132. SEGACT,IMODEL
  133.  
  134. C- Quelques initialisations
  135. IPMINT = 0
  136.  
  137. MOMATR = 0
  138. MOCARA = 0
  139. MOTYPM = 0
  140. MOTYPC = 0
  141. ISUPM = 0
  142. ISUPC = 0
  143.  
  144. MODEPL = 0
  145. MOFORC = 0
  146. lsupde = .false.
  147. lsupfo = .false.
  148.  
  149. IDESCR = 0
  150.  
  151. C- Recuperation d'informations sur le maillage elementaire
  152. IPT1 = IMAMOD
  153. SEGACT,IPT1
  154. NBNOE1 = IPT1.NUM(/1)
  155. NBELE1 = IPT1.NUM(/2)
  156.  
  157. C- Quelques informations sur le modele
  158. IIPDPG = imodel.IPDPGE
  159. IIPDPG = IPTPOI(IIPDPG)
  160. CONM = CONMOD
  161. CMATE = CMATEE
  162. MATE = IMATEE
  163. c* INAT = INATUU
  164. c- Tableau infos
  165. iret = 1
  166. CALL IDENT(IPT1,CONM,IPCHE1,0, INFOS,iret)
  167. IF (iret.EQ.0) GOTO 599
  168.  
  169. C- Recuperation d'informations sur l'element fini
  170. MELE = NEFMOD
  171.  
  172. NPINT = 1
  173. IF (INFMOD(/1).NE.0) NPINT = INFMOD(1)
  174. C support des champs
  175. IPLAZ = 4
  176. IF (NPINT.EQ.12345) IPLAZ = 1
  177.  
  178. MFR =INFELE(13)
  179. LRE = INFELE(9)
  180. NDDL = INFELE(15)
  181. IF (IFOUR.EQ.1) THEN
  182. LRE = 2*LRE
  183. NDDL = 2*NDDL
  184. ENDIF
  185. LW = INFELE(7)
  186. LHOOK = INFELE(10)
  187. IELE = INFELE(14)
  188. IPMINT = INFMOD(2+IPLAZ)
  189. C* IPMINT = INFELE(11)
  190. IPMIN1 = INFMOD(8)
  191. C* ICARA = INFELE(5)
  192. IPPORE = 0
  193. IF (MFR.EQ.33) IPPORE = NBNOE1
  194. C
  195. C INITIALISATION DE MINTE
  196. MINTE = IPMINT
  197. SEGACT,MINTE
  198. NBPGAU = POIGAU(/1)
  199. *
  200. C- RECHERCHE DES NOMS D'INCONNUES ET DES DUAUX
  201. C-----------------------------------------------------------------------
  202. if (lnomid(1).ne.0) then
  203. MODEPL = lnomid(1)
  204. else
  205. lsupde=.true.
  206. CALL IDPRIM(IMODEL,MFR,MODEPL,NDEPL,NDUM)
  207. endif
  208. nomid = MODEPL
  209. SEGACT,nomid
  210. ndepl = lesobl(/2)
  211. c* ndum=lesfac(/2)
  212.  
  213. if (lnomid(2).ne.0) then
  214. MOFORC = lnomid(2)
  215. else
  216. CALL IDDUAL(IMODEL,MFR,MOFORC,NFORC,NDUM)
  217. lsupfo=.true.
  218. endif
  219. nomid = MOFORC
  220. SEGACT,nomid
  221. nforc=lesobl(/2)
  222. c* ndum=lesfac(/2)
  223. C
  224. IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN
  225. CALL ERREUR(5)
  226. GOTO 598
  227. ENDIF
  228. C
  229. C REMPLISSAGE DU SEGMENT DESCRIPTEUR
  230. C-------------------------------------
  231. NLIGRP = LRE
  232. NLIGRD = LRE
  233. SEGINI,DESCR
  234. IDESCR = DESCR
  235. C
  236. NCOMP = NDEPL
  237. IF (MFR.EQ.33) NCOMP = NDEPL-1
  238. NBNNS = NBNOE1
  239. IF (MFR.EQ.19.OR.MFR.EQ.21) NBNNS = NBNOE1/2
  240.  
  241. IDDL=1
  242. DO 1004 inoe =1, NBNNS
  243. DO 1005 ICOMP=1,NCOMP
  244. IF (IFOUR.NE.1) THEN
  245. NOMID=MODEPL
  246. LISINC(IDDL)=LESOBL(ICOMP)
  247. NOMID=MOFORC
  248. LISDUA(IDDL)=LESOBL(ICOMP)
  249. NOELEP(IDDL) = inoe
  250. NOELED(IDDL) = inoe
  251. ELSE
  252. NOMID=MODEPL
  253. I = 2*IDDL
  254. LISINC(I-1)=LESOBL(ICOMP)
  255. IF (LESOBL(ICOMP).EQ.'UR ') THEN
  256. LISINC(I)='IUR '
  257. ELSEIF (LESOBL(ICOMP).EQ.'UZ ') THEN
  258. LISINC(I)='IUZ '
  259. ELSEIF (LESOBL(ICOMP).EQ.'UT ') THEN
  260. LISINC(I)='IUT '
  261. ELSEIF (LESOBL(ICOMP).EQ.'RT ') THEN
  262. LISINC(I)='IRT '
  263. ENDIF
  264. NOMID=MOFORC
  265. LISDUA(I-1)=LESOBL(ICOMP)
  266. IF (LESOBL(ICOMP).EQ.'FR ') THEN
  267. LISDUA(I)='IFR '
  268. ELSEIF (LESOBL(ICOMP).EQ.'FZ ') THEN
  269. LISDUA(I)='IFZ '
  270. ELSEIF (LESOBL(ICOMP).EQ.'FT ') THEN
  271. LISDUA(I)='IFT '
  272. ELSEIF (LESOBL(ICOMP).EQ.'MT ') THEN
  273. LISDUA(I)='IMT '
  274. ENDIF
  275. NOELEP(I-1) = inoe
  276. NOELED(I-1) = inoe
  277. NOELEP(I) = inoe
  278. NOELED(I) = inoe
  279. ENDIF
  280. IDDL=IDDL+1
  281. 1005 CONTINUE
  282. 1004 CONTINUE
  283.  
  284. SEGDES,DESCR
  285. IDESCR = DESCR
  286. C
  287. C- Recuperation des composantes MATERIAU
  288. C-----------------------------------------------------------------------
  289. NBROBL = 0
  290. NBRFAC = 0
  291. nomid = 0
  292. notype = 0
  293. LHOTRA = 0
  294. *
  295. * rho dans les cas poutre,tuyau, massif, coque
  296. *
  297. IF (MFR.EQ.1.OR.MFR.EQ.27.OR.MFR.EQ.7.OR.MFR.EQ.13.OR.
  298. & MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  299. *
  300. IF (CMATE.NE.'SECTION') THEN
  301. NBROBL = 1
  302. SEGINI,nomid
  303. LESOBL(1)='RHO '
  304. NBTYPE = 1
  305. SEGINI NOTYPE
  306. TYPE(1)='REAL*8'
  307. ELSE
  308. LHOTRA=LHOOK
  309. NBROBL=2
  310. SEGINI,nomid
  311. LESOBL(1)='MODS'
  312. LESOBL(2)='MATS'
  313. NBTYPE=2
  314. SEGINI NOTYPE
  315. TYPE(1) = 'POINTEURMMODEL'
  316. TYPE(2) = 'POINTEURMCHAML'
  317. ENDIF
  318. ENDIF
  319. C
  320. MOMATR = nomid
  321. MOTYPM = notype
  322. NMATR = NBROBL
  323. NMATF = NBRFAC
  324. NMATT = NMATR+NMATF
  325. *
  326. * verification du support des composantes recherchees
  327. *
  328. IF (MOMATR.NE.0) THEN
  329. CALL QUESUQ(IMODEL,IPCHE1,4,0,MOMATR,IPLAZ,ISUPM,iret)
  330. IF (ISUPM.GT.1) GOTO 597
  331. ENDIF
  332. *
  333. C- Recuperation des composantes CARACTERISTIQUES
  334. C-----------------------------------------------------------------------
  335. NBROBL = 0
  336. NBRFAC = 0
  337. nomid = 0
  338. notype = 0
  339. IVECT = 0
  340. *
  341. * caracteristiques pour les poutres
  342. IF (MFR.EQ.7 ) THEN
  343. IF (CMATE.EQ.'SECTION') THEN
  344. NBRFAC=2
  345. SEGINI NOMID
  346. LESFAC(1)='OMEG'
  347. LESFAC(2)='VECT'
  348. IVECT=1
  349. *
  350. NBTYPE=2
  351. SEGINI NOTYPE
  352. TYPE(1)='REAL*8'
  353. TYPE(2)='POINTEURPOINT '
  354. *
  355. ELSE
  356. NBROBL=4
  357. NBRFAC=4
  358. SEGINI NOMID
  359. LESOBL(1)='TORS'
  360. LESOBL(2)='INRY'
  361. LESOBL(3)='INRZ'
  362. LESOBL(4)='SECT'
  363. LESFAC(1)='SECY'
  364. LESFAC(2)='SECZ'
  365. LESFAC(3)='OMEG'
  366. LESFAC(4)='VECT'
  367. IVECT=1
  368. *
  369. NBTYPE=8
  370. SEGINI NOTYPE
  371. TYPE(1)='REAL*8'
  372. TYPE(2)='REAL*8'
  373. TYPE(3)='REAL*8'
  374. TYPE(4)='REAL*8'
  375. TYPE(5)='REAL*8'
  376. TYPE(6)='REAL*8'
  377. TYPE(7)='REAL*8'
  378. TYPE(8)='POINTEURPOINT '
  379. ENDIF
  380. *
  381. * caracteristiques pour les tuyaux
  382. ELSE IF (MFR.EQ.13) THEN
  383. NBROBL=2
  384. NBRFAC=3
  385. SEGINI NOMID
  386. LESOBL(1)='EPAI'
  387. LESOBL(2)='RAYO'
  388. LESFAC(1)='RACO'
  389. LESFAC(2)='OMEG'
  390. LESFAC(3)='VECT'
  391. IVECT=1
  392. *
  393. NBTYPE=5
  394. SEGINI NOTYPE
  395. TYPE(1)='REAL*8'
  396. TYPE(2)='REAL*8'
  397. TYPE(3)='REAL*8'
  398. TYPE(4)='REAL*8'
  399. TYPE(5)='POINTEURPOINT '
  400. *
  401. * caracteristiques pour les barres
  402. ELSE IF (MFR.EQ.27) THEN
  403. NBROBL=1
  404. SEGINI NOMID
  405. LESOBL(1)='SECT'
  406. *
  407. NBTYPE=1
  408. SEGINI NOTYPE
  409. TYPE(1)='REAL*8'
  410. *
  411. * epaisseur et excentrement dans le cas des coques
  412. ELSE IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  413. NBROBL=1
  414. NBRFAC=1
  415. SEGINI NOMID
  416. LESOBL(1)='EPAI'
  417. LESFAC(1)='EXCE'
  418. *
  419. NBTYPE=1
  420. SEGINI NOTYPE
  421. TYPE(1)='REAL*8'
  422. *
  423. ENDIF
  424. *
  425. MOCARA = nomid
  426. MOTYPC = notype
  427. NCARA = NBROBL
  428. NCARF = NBRFAC
  429. NCARR = NCARA+NCARF
  430.  
  431. * verification du support des composantes recherchees
  432. *
  433. IF (MOCARA.NE.0)THEN
  434. CALL QUESUQ(IMODEL,IPCHE1,4,0,MOCARA,IPLAZ,ISUPC,iret)
  435. IF (ISUPC.GT.1) GOTO 597
  436. ENDIF
  437.  
  438. C- Partionnement si necessaire de la matrice de coriolis
  439. C- determinant ainsi le nombre d'objets elementaires de MRIGID
  440. C-----------------------------------------------------------------------
  441. LTRK = oooval(1,4)
  442. IF (LTRK.EQ.0) LTRK = oooval(1,1)
  443. LTRK=MAX(LTRK,2**24)
  444. * Ajout a la taille en mots de la matrice des infos du segment
  445. LSEG = LRE*LRE*NBELE1 + 16
  446. NBLPRT = (LSEG-1)/LTRK + 1
  447. NBLMAX = (NBELE1-1)/NBLPRT + 1
  448. NBLPRT = (NBELE1-1)/NBLMAX + 1
  449. * write(ioimp,*) ' corio1 : nblprt nblmax = ',nblprt,nblmax,nbele1
  450.  
  451. C Ajout de la matrice de CORIOLIS a la matrice globale
  452. C-----------------------------------------------------------------------
  453. NRIGE0 = IRIGEL(/2)
  454. NRIGEL = NRIGE0 + NBLPRT
  455. SEGADJ,MRIGID
  456.  
  457. descr = IDESCR
  458. meleme = IPT1
  459. nbnn = NBNOE1
  460. nbelem = NBELE1
  461. nbsous = 0
  462. nbref = 0
  463. *
  464. * Boucle sur les PARTITIONS elementaires de la matrice
  465. ************************************************************************
  466. DO 5000 irige = 1, NBLPRT
  467.  
  468. IF (NBLPRT.GT.1) THEN
  469. C- Partitionnement du maillage support de la matrice elementaire
  470. C- (IPT1 peut etre desactive suite a l'appel a KOMCHA !)
  471. SEGACT,IPT1
  472. ielem = (irige-1)*NBLMAX
  473. nbelem = MIN(NBLMAX,NBELE1-ielem)
  474. * write(ioimp,*) ' creation segment ',nbnn,nbelem
  475. SEGINI,meleme
  476. itypel = IPT1.itypel
  477. DO ielt = 1, nbelem
  478. jelt = ielt + ielem
  479. DO inoe = 1, nbnn
  480. num(inoe,ielt) = IPT1.NUM(inoe,jelt)
  481. ENDDO
  482. icolor(ielt) = IPT1.ICOLOR(jelt)
  483. ENDDO
  484. C- Recopie du descripteur
  485. des1 = IDESCR
  486. SEGINI,descr=des1
  487. SEGDES,descr
  488. ENDIF
  489.  
  490. ipmail = meleme
  491. ipdesc = descr
  492.  
  493. C- Initialisation de la matrice de rigidite elementaire (xmatri)
  494. NELRIG = nbelem
  495. SEGINI,xmatri
  496. ipmatr = xmatri
  497.  
  498. C- Recuperation des valeurs des proprietes materiau et geometriques
  499. IVAMAT = 0
  500. IVACAR = 0
  501.  
  502. IF (MOMATR.NE.0) THEN
  503. CALL KOMCHA(IPCHE1,ipmail,CONM,MOMATR,MOTYPM,1,INFOS,3,
  504. & IVAMAT)
  505. IF (IERR.NE.0) GOTO 5100
  506. IF (ISUPM.EQ.1) THEN
  507. CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  508. IF (IERR.NE.0)THEN
  509. ISUPM = 0
  510. GOTO 5100
  511. ENDIF
  512. ENDIF
  513. ENDIF
  514. C
  515. IF (MOCARA.NE.0) THEN
  516. CALL KOMCHA(IPCHE1,ipmail,CONM,MOCARA,MOTYPC,1,INFOS,3,
  517. & IVACAR)
  518. IF (IERR.NE.0) GOTO 5100
  519. IF (ISUPC.EQ.1)THEN
  520. CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  521. IF (IERR.NE.0)THEN
  522. ISUPC = 0
  523. GOTO 5100
  524. ENDIF
  525. ENDIF
  526. ENDIF
  527.  
  528. C-----------------------------------------------------------------------
  529. C NUMERO DES ETIQUETTES :
  530. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  531. C LES ELEMENTS SONT GROUPES COMME SUIT :
  532. C - MASSIF,LIQUIDE 'SURFACE LIBRE' ----------------------> CORIO3
  533. C - COQ3/POUTRE,DKT,COQ4,COQ8,DST ------------------> CORIO2
  534. C ET POUTRE DE TIMOSCHENKO
  535. C______________________________________________________________________
  536. * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  537. GOTO ( 99, 99, 99, 11, 99, 11, 99, 11, 99, 11, 99
  538. * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  539. & , 99, 99, 11, 11, 11, 11, 99, 99, 99, 99, 99
  540. * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6
  541. & , 11, 11, 11, 11, 21, 21, 21, 99, 99, 99, 99
  542. * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  543. & , 99, 99, 99, 99, 99, 99, 99, 21, 21, 99, 21
  544. * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  545. & , 99, 21, 99, 99, 21, 99, 99, 99, 99, 99, 99
  546. * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  547. & , 21, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  548. * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  549. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  550. * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  551. & , 99, 99, 99, 99, 99, 99, 21, 99, 99, 99, 99
  552. * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3
  553. & , 99, 99, 99, 99, 21, 99, 99, 99, 99, 99, 99
  554. * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  555. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  556. * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  557. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  558. * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  559. & , 99, 21, 99, 99, 99, 99, 99, 99, 99, 99, 99
  560. * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  561. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  562. * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  563. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  564. * TE56 PY91 TRH6
  565. & , 99, 99, 99),MELE
  566. C
  567. 99 CONTINUE
  568. MOTERR(1: 4) = NOMTP(MELE)
  569. MOTERR(5:12) = 'CORI1'
  570. CALL ERREUR(86)
  571. GOTO 5100
  572.  
  573. C_______________________________________________________________________
  574. C
  575. C MASSIF
  576. C_______________________________________________________________________
  577. C
  578. 11 CONTINUE
  579. CALL CORIO3(ipmail,NDDL,LRE,NBPGAU,IPMINT,MELE,MFR,IVAMAT,
  580. & IVACAR,NMATT,ipmatr,VROT,NUMLI1,IIPDPG)
  581. C
  582. GOTO 5100
  583. C_______________________________________________________________________
  584. C
  585. C POUTRE, POUTRE DE TIMOSCHENKO, COQUE, BARRE
  586. C_______________________________________________________________________
  587. C
  588. 21 CONTINUE
  589. CALL CORIO2(ipmail,LRE,LW,MELE,IVAMAT,NMATT,IVACAR,NCARR,
  590. & IVECT,isous,NBPGAU,IPMINT,IPMIN1,NDDL,MATE,
  591. & CMATE,LHOTRA,ipmatr,VROT,NUMLI1,IIPDPG)
  592. GOTO 5100
  593. C_______________________________________________________________________
  594. C
  595. C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  596. C_______________________________________________________________________
  597. 5100 CONTINUE
  598. C
  599. IF (ISUPM.EQ.1 .OR. NBLPRT.GT.1) THEN
  600. CALL DTMVAL(IVAMAT,3)
  601. ELSE
  602. CALL DTMVAL(IVAMAT,1)
  603. ENDIF
  604. C
  605. IF (ISUPC.EQ.1 .OR. NBLPRT.GT.1) THEN
  606. CALL DTMVAL(IVACAR,3)
  607. ELSE
  608. CALL DTMVAL(IVACAR,1)
  609. ENDIF
  610. xmatri = ipmatr
  611. IF (NBLPRT.GT.1) THEN
  612. meleme = ipmail
  613. SEGDES,meleme
  614. ENDIF
  615.  
  616. C- Sortie prematuree en cas d'erreur
  617. IF (IERR.NE.0) GOTO 597
  618.  
  619. C- Stockage de la matrice
  620. jrige = NRIGE0 + irige
  621. COERIG(jrige) = 1.
  622. IRIGEL(1,jrige) = ipmail
  623. IRIGEL(2,jrige) = 0
  624. IRIGEL(3,jrige) = ipdesc
  625. IRIGEL(4,jrige) = ipmatr
  626. IRIGEL(5,jrige) = NIFOUR
  627. IRIGEL(6,jrige) = 0
  628. C- Matrice antisymetrique si non 'HARM'
  629. IF (NUMLI1.EQ.0) THEN
  630. IRIGEL(7,jrige) = 1
  631. xmatri.symre=1
  632. ELSE
  633. IRIGEL(7,jrige) = 0
  634. xmatri.symre=0
  635. ENDIF
  636. SEGDES,xmatri
  637. IRIGEL(8,jrige) = 0
  638.  
  639. 5000 CONTINUE
  640. C- Fin de la boucle sur les partitions
  641.  
  642. 597 CONTINUE
  643. IF (MOMATR.NE.0) THEN
  644. nomid = MOMATR
  645. SEGSUP,NOMID
  646. c notype = NOTYPM
  647. notype = MOTYPM
  648. SEGSUP,notype
  649. ENDIF
  650. IF (MOCARA.NE.0) THEN
  651. nomid = MOCARA
  652. SEGSUP,NOMID
  653. c notype = NOTYPC
  654. notype = MOTYPC
  655. SEGSUP,notype
  656. ENDIF
  657. 598 CONTINUE
  658. IF (MODEPL.NE.0) THEN
  659. nomid = MODEPL
  660. SEGDES,nomid
  661. IF (lsupde) SEGSUP,nomid
  662. ENDIF
  663. IF (MOFORC.NE.0) THEN
  664. nomid = MOFORC
  665. SEGDES,nomid
  666. IF (lsupfo) SEGSUP,nomid
  667. ENDIF
  668. c* MINTE = IPMINT
  669. SEGDES,MINTE
  670. 599 CONTINUE
  671. c* IPT1 = IMAMOD
  672. SEGDES,IPT1
  673. SEGDES,IMODEL
  674.  
  675. C- En cas d'erreur
  676. IF (IERR.NE.0) GOTO 999
  677.  
  678. 500 CONTINUE
  679. C* Fin de la boucle sur les modeles elementaires
  680.  
  681. 999 CONTINUE
  682. IF (IERR.NE.0) THEN
  683. SEGSUP,MRIGID
  684. IPRIG = 0
  685. ELSE
  686. SEGDES,MRIGID
  687. IPRIG = MRIGID
  688. ENDIF
  689.  
  690. SEGDES,MMODEL
  691. C Desactivation XCOOR
  692. SEGDES MCOORD
  693.  
  694. RETURN
  695. END
  696.  
  697.  
  698.  
  699.  
  700.  
  701.  

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