Télécharger corio1.eso

Retour à la liste

Numérotation des lignes :

corio1
  1. C CORIO1 SOURCE CB215821 24/04/12 21:15:29 11897
  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=4
  345. SEGINI NOMID
  346. LESFAC(1)='OMEG'
  347. LESFAC(2)='VX '
  348. LESFAC(3)='VY '
  349. LESFAC(4)='VZ '
  350. IVECT=1
  351. *
  352. NBTYPE=4
  353. SEGINI NOTYPE
  354. TYPE(1)='REAL*8'
  355. TYPE(2)='REAL*8'
  356. TYPE(3)='REAL*8'
  357. TYPE(4)='REAL*8'
  358. *
  359. ELSE
  360. NBROBL=4
  361. NBRFAC=6
  362. SEGINI NOMID
  363. LESOBL(1)='TORS'
  364. LESOBL(2)='INRY'
  365. LESOBL(3)='INRZ'
  366. LESOBL(4)='SECT'
  367. LESFAC(1)='SECY'
  368. LESFAC(2)='SECZ'
  369. LESFAC(3)='OMEG'
  370. LESFAC(4)='VX '
  371. LESFAC(5)='VY '
  372. LESFAC(6)='VZ '
  373. IVECT=1
  374. *
  375. NBTYPE=10
  376. SEGINI NOTYPE
  377. TYPE(1)='REAL*8'
  378. TYPE(2)='REAL*8'
  379. TYPE(3)='REAL*8'
  380. TYPE(4)='REAL*8'
  381. TYPE(5)='REAL*8'
  382. TYPE(6)='REAL*8'
  383. TYPE(7)='REAL*8'
  384. TYPE(8)='REAL*8'
  385. TYPE(9)='REAL*8'
  386. TYPE(10)='REAL*8'
  387. ENDIF
  388. *
  389. * caracteristiques pour les tuyaux
  390. ELSE IF (MFR.EQ.13) THEN
  391. NBROBL=2
  392. NBRFAC=5
  393. SEGINI NOMID
  394. LESOBL(1)='EPAI'
  395. LESOBL(2)='RAYO'
  396. LESFAC(1)='RACO'
  397. LESFAC(2)='OMEG'
  398. LESFAC(3)='VX '
  399. LESFAC(4)='VY '
  400. LESFAC(5)='VZ '
  401. IVECT=1
  402. *
  403. NBTYPE=7
  404. SEGINI NOTYPE
  405. TYPE(1)='REAL*8'
  406. TYPE(2)='REAL*8'
  407. TYPE(3)='REAL*8'
  408. TYPE(4)='REAL*8'
  409. TYPE(5)='REAL*8'
  410. TYPE(6)='REAL*8'
  411. TYPE(7)='REAL*8'
  412. *
  413. * caracteristiques pour les barres
  414. ELSE IF (MFR.EQ.27) THEN
  415. NBROBL=1
  416. SEGINI NOMID
  417. LESOBL(1)='SECT'
  418. *
  419. NBTYPE=1
  420. SEGINI NOTYPE
  421. TYPE(1)='REAL*8'
  422. *
  423. * epaisseur et excentrement dans le cas des coques
  424. ELSE IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  425. NBROBL=1
  426. NBRFAC=1
  427. SEGINI NOMID
  428. LESOBL(1)='EPAI'
  429. LESFAC(1)='EXCE'
  430. *
  431. NBTYPE=1
  432. SEGINI NOTYPE
  433. TYPE(1)='REAL*8'
  434. *
  435. ENDIF
  436. *
  437. MOCARA = nomid
  438. MOTYPC = notype
  439. NCARA = NBROBL
  440. NCARF = NBRFAC
  441. NCARR = NCARA+NCARF
  442.  
  443. * verification du support des composantes recherchees
  444. *
  445. IF (MOCARA.NE.0)THEN
  446. CALL QUESUQ(IMODEL,IPCHE1,4,0,MOCARA,IPLAZ,ISUPC,iret)
  447. IF (ISUPC.GT.1) GOTO 597
  448. ENDIF
  449.  
  450. C- Partionnement si necessaire de la matrice de coriolis
  451. C- determinant ainsi le nombre d'objets elementaires de MRIGID
  452. C-----------------------------------------------------------------------
  453. LTRK = oooval(1,4)
  454. IF (LTRK.EQ.0) LTRK = oooval(1,1)
  455. LTRK=MAX(LTRK,2**24)
  456. * Ajout a la taille en mots de la matrice des infos du segment
  457. LSEG = LRE*LRE*NBELE1 + 16
  458. NBLPRT = (LSEG-1)/LTRK + 1
  459. NBLMAX = (NBELE1-1)/NBLPRT + 1
  460. NBLPRT = (NBELE1-1)/NBLMAX + 1
  461. * write(ioimp,*) ' corio1 : nblprt nblmax = ',nblprt,nblmax,nbele1
  462.  
  463. C Ajout de la matrice de CORIOLIS a la matrice globale
  464. C-----------------------------------------------------------------------
  465. NRIGE0 = IRIGEL(/2)
  466. NRIGEL = NRIGE0 + NBLPRT
  467. SEGADJ,MRIGID
  468.  
  469. descr = IDESCR
  470. meleme = IPT1
  471. nbnn = NBNOE1
  472. nbelem = NBELE1
  473. nbsous = 0
  474. nbref = 0
  475. *
  476. * Boucle sur les PARTITIONS elementaires de la matrice
  477. ************************************************************************
  478. DO 5000 irige = 1, NBLPRT
  479.  
  480. IF (NBLPRT.GT.1) THEN
  481. C- Partitionnement du maillage support de la matrice elementaire
  482. C- (IPT1 peut etre desactive suite a l'appel a KOMCHA !)
  483. SEGACT,IPT1
  484. ielem = (irige-1)*NBLMAX
  485. nbelem = MIN(NBLMAX,NBELE1-ielem)
  486. * write(ioimp,*) ' creation segment ',nbnn,nbelem
  487. SEGINI,meleme
  488. itypel = IPT1.itypel
  489. DO ielt = 1, nbelem
  490. jelt = ielt + ielem
  491. DO inoe = 1, nbnn
  492. num(inoe,ielt) = IPT1.NUM(inoe,jelt)
  493. ENDDO
  494. icolor(ielt) = IPT1.ICOLOR(jelt)
  495. ENDDO
  496. C- Recopie du descripteur
  497. des1 = IDESCR
  498. SEGINI,descr=des1
  499. SEGDES,descr
  500. ENDIF
  501.  
  502. ipmail = meleme
  503. ipdesc = descr
  504.  
  505. C- Initialisation de la matrice de rigidite elementaire (xmatri)
  506. NELRIG = nbelem
  507. SEGINI,xmatri
  508. ipmatr = xmatri
  509.  
  510. C- Recuperation des valeurs des proprietes materiau et geometriques
  511. IVAMAT = 0
  512. IVACAR = 0
  513.  
  514. IF (MOMATR.NE.0) THEN
  515. CALL KOMCHA(IPCHE1,ipmail,CONM,MOMATR,MOTYPM,1,INFOS,3,
  516. & IVAMAT)
  517. IF (IERR.NE.0) GOTO 5100
  518. IF (ISUPM.EQ.1) THEN
  519. CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  520. IF (IERR.NE.0)THEN
  521. ISUPM = 0
  522. GOTO 5100
  523. ENDIF
  524. ENDIF
  525. ENDIF
  526. C
  527. IF (MOCARA.NE.0) THEN
  528. CALL KOMCHA(IPCHE1,ipmail,CONM,MOCARA,MOTYPC,1,INFOS,3,
  529. & IVACAR)
  530. IF (IERR.NE.0) GOTO 5100
  531. IF (ISUPC.EQ.1)THEN
  532. CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  533. IF (IERR.NE.0)THEN
  534. ISUPC = 0
  535. GOTO 5100
  536. ENDIF
  537. ENDIF
  538. ENDIF
  539.  
  540. C-----------------------------------------------------------------------
  541. C NUMERO DES ETIQUETTES :
  542. C ETIQUETTES DE 1 A 98 POUR TRAITEMENT SPECIFIQUE A L ELEMENT
  543. C LES ELEMENTS SONT GROUPES COMME SUIT :
  544. C - MASSIF,LIQUIDE 'SURFACE LIBRE' ----------------------> CORIO3
  545. C - COQ3/POUTRE,DKT,COQ4,COQ8,DST ------------------> CORIO2
  546. C ET POUTRE DE TIMOSCHENKO
  547. C______________________________________________________________________
  548. * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  549. GOTO ( 99, 99, 99, 11, 99, 11, 99, 11, 99, 11, 99
  550. * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  551. & , 99, 99, 11, 11, 11, 11, 99, 99, 99, 99, 99
  552. * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6
  553. & , 11, 11, 11, 11, 21, 21, 21, 99, 99, 99, 99
  554. * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  555. & , 99, 99, 99, 99, 99, 99, 99, 21, 21, 99, 21
  556. * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  557. & , 99, 21, 99, 99, 21, 99, 99, 99, 99, 99, 99
  558. * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  559. & , 21, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  560. * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  561. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  562. * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  563. & , 99, 99, 99, 99, 99, 99, 21, 99, 99, 99, 99
  564. * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3
  565. & , 99, 99, 99, 99, 21, 99, 99, 99, 99, 99, 99
  566. * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  567. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  568. * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  569. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  570. * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  571. & , 99, 21, 99, 99, 99, 99, 99, 99, 99, 99, 99
  572. * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  573. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  574. * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  575. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  576. * TE56 PY91 TRH6
  577. & , 99, 99, 99),MELE
  578. C
  579. 99 CONTINUE
  580. MOTERR(1: 4) = NOMTP(MELE)
  581. MOTERR(5:12) = 'CORI1'
  582. CALL ERREUR(86)
  583. GOTO 5100
  584.  
  585. C_______________________________________________________________________
  586. C
  587. C MASSIF
  588. C_______________________________________________________________________
  589. C
  590. 11 CONTINUE
  591. CALL CORIO3(ipmail,NDDL,LRE,NBPGAU,IPMINT,MELE,MFR,IVAMAT,
  592. & IVACAR,NMATT,ipmatr,VROT,NUMLI1,IIPDPG)
  593. C
  594. GOTO 5100
  595. C_______________________________________________________________________
  596. C
  597. C POUTRE, POUTRE DE TIMOSCHENKO, COQUE, BARRE
  598. C_______________________________________________________________________
  599. C
  600. 21 CONTINUE
  601. CALL CORIO2(ipmail,LRE,LW,MELE,IVAMAT,NMATT,IVACAR,NCARR,
  602. & IVECT,isous,NBPGAU,IPMINT,IPMIN1,NDDL,MATE,
  603. & CMATE,LHOTRA,ipmatr,VROT,NUMLI1,IIPDPG)
  604. GOTO 5100
  605. C_______________________________________________________________________
  606. C
  607. C DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  608. C_______________________________________________________________________
  609. 5100 CONTINUE
  610. C
  611. IF (ISUPM.EQ.1 .OR. NBLPRT.GT.1) THEN
  612. CALL DTMVAL(IVAMAT,3)
  613. ELSE
  614. CALL DTMVAL(IVAMAT,1)
  615. ENDIF
  616. C
  617. IF (ISUPC.EQ.1 .OR. NBLPRT.GT.1) THEN
  618. CALL DTMVAL(IVACAR,3)
  619. ELSE
  620. CALL DTMVAL(IVACAR,1)
  621. ENDIF
  622. xmatri = ipmatr
  623. IF (NBLPRT.GT.1) THEN
  624. meleme = ipmail
  625. SEGDES,meleme
  626. ENDIF
  627.  
  628. C- Sortie prematuree en cas d'erreur
  629. IF (IERR.NE.0) GOTO 597
  630.  
  631. C- Stockage de la matrice
  632. jrige = NRIGE0 + irige
  633. COERIG(jrige) = 1.
  634. IRIGEL(1,jrige) = ipmail
  635. IRIGEL(2,jrige) = 0
  636. IRIGEL(3,jrige) = ipdesc
  637. IRIGEL(4,jrige) = ipmatr
  638. IRIGEL(5,jrige) = NIFOUR
  639. IRIGEL(6,jrige) = 0
  640. C- Matrice antisymetrique si non 'HARM'
  641. IF (NUMLI1.EQ.0) THEN
  642. IRIGEL(7,jrige) = 1
  643. xmatri.symre=1
  644. ELSE
  645. IRIGEL(7,jrige) = 0
  646. xmatri.symre=0
  647. ENDIF
  648. SEGDES,xmatri
  649. IRIGEL(8,jrige) = 0
  650.  
  651. 5000 CONTINUE
  652. C- Fin de la boucle sur les partitions
  653.  
  654. 597 CONTINUE
  655. IF (MOMATR.NE.0) THEN
  656. nomid = MOMATR
  657. SEGSUP,NOMID
  658. c notype = NOTYPM
  659. notype = MOTYPM
  660. SEGSUP,notype
  661. ENDIF
  662. IF (MOCARA.NE.0) THEN
  663. nomid = MOCARA
  664. SEGSUP,NOMID
  665. c notype = NOTYPC
  666. notype = MOTYPC
  667. SEGSUP,notype
  668. ENDIF
  669. 598 CONTINUE
  670. IF (MODEPL.NE.0) THEN
  671. nomid = MODEPL
  672. SEGDES,nomid
  673. IF (lsupde) SEGSUP,nomid
  674. ENDIF
  675. IF (MOFORC.NE.0) THEN
  676. nomid = MOFORC
  677. SEGDES,nomid
  678. IF (lsupfo) SEGSUP,nomid
  679. ENDIF
  680. c* MINTE = IPMINT
  681. SEGDES,MINTE
  682. 599 CONTINUE
  683. c* IPT1 = IMAMOD
  684. SEGDES,IPT1
  685. SEGDES,IMODEL
  686.  
  687. C- En cas d'erreur
  688. IF (IERR.NE.0) GOTO 999
  689.  
  690. 500 CONTINUE
  691. C* Fin de la boucle sur les modeles elementaires
  692.  
  693. 999 CONTINUE
  694. IF (IERR.NE.0) THEN
  695. SEGSUP,MRIGID
  696. IPRIG = 0
  697. ELSE
  698. SEGDES,MRIGID
  699. IPRIG = MRIGID
  700. ENDIF
  701.  
  702. SEGDES,MMODEL
  703. C Desactivation XCOOR
  704. SEGDES MCOORD
  705.  
  706. RETURN
  707. END
  708.  
  709.  
  710.  
  711.  
  712.  
  713.  
  714.  
  715.  

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