Télécharger amor1.eso

Retour à la liste

Numérotation des lignes :

  1. C AMOR1 SOURCE FANDEUR 17/03/10 21:15:00 9342
  2.  
  3. SUBROUTINE AMOR1(MODORI,IPCHE1,ICAS,IPRIG)
  4.  
  5. *---------------------------------------------------------------------*
  6. * *
  7. * OPERATEUR AMORTISSEMENT VISQUEUX *
  8. * *
  9. *---------------------------------------------------------------------*
  10. * *
  11. * CE SOUS-PROGRAMME SERT A TRAITER ET A METTRE EN FORME *
  12. * LES INFORMATIONS NECESSAIRES POUR LES CALCULS *
  13. * *
  14. *---------------------------------------------------------------------*
  15. * *
  16. * ENTREES : *
  17. * ________ *
  18. * *
  19. * IPMODL Pointeur sur le modele *
  20. * IPCHE1 Pointeur sur le chamelem de carateristiques *
  21. * ICAS 1 si matrice d amortissement *
  22. * 2 si matrice de rigidite antisymetrique *
  23. * 3 si matrice d amortissement en frequentiel *
  24. * (amortissement corotatif) *
  25. * *
  26. * SORTIES : *
  27. * ________ *
  28. * *
  29. * IPRIG pointeur sur la rigidite construite *
  30. * =0 en cas d'erreur (et IERR non nul) *
  31. * *
  32. *---------------------------------------------------------------------*
  33.  
  34. IMPLICIT INTEGER(I-N)
  35. IMPLICIT REAL*8(A-H,O-Z)
  36. *
  37. -INC CCOPTIO
  38. -INC CCHAMP
  39. -INC CCGEOME
  40. -INC CCREEL
  41. *
  42. -INC SMCHAML
  43. -INC SMINTE
  44. -INC SMELEME
  45. -INC SMRIGID
  46. -INC SMMODEL
  47. -INC SMCOORD
  48. -INC SMLREEL
  49. *
  50. INTEGER oooval
  51.  
  52. SEGMENT INFO
  53. INTEGER INFELL(JG)
  54. ENDSEGMENT
  55. *
  56. SEGMENT NOTYPE
  57. CHARACTER*16 TYPE(NBTYPE)
  58. ENDSEGMENT
  59. *
  60. SEGMENT MPTVAL
  61. INTEGER IPOS(NS) ,NSOF(NS)
  62. INTEGER IVAL(NCOSOU)
  63. CHARACTER*16 TYVAL(NCOSOU)
  64. ENDSEGMENT
  65. *
  66. segment modsta
  67. integer pimoda(nmoda),pistat(nstat)
  68. integer ivmoda(nmoda),ivstat(nstat)
  69. endsegment
  70. *
  71. CHARACTER*8 CMATE
  72. CHARACTER*(NCONCH) CONM
  73.  
  74. PARAMETER ( INTTYP=3 )
  75. * INTTYP DEFINIT LE TYPE DE POINTS D'INTEGRATION
  76. * UTILISE PAR RIGI
  77. PARAMETER ( NINF=3 )
  78. INTEGER INFOS(NINF)
  79. *
  80. LOGICAL lsupfo,lsupde,BDPGE,brend,lsupma,dcmate,dcmat2
  81. *
  82. IPRIG = 0
  83. *
  84. * ACTIVATION DU MODELE
  85. * --------------------
  86. * MODORI = Modele initial complet
  87. * IPMODL = Modele "deroule" (uniquement "MECANIQUE", "LIQUIDE" ou "POREUX")
  88. CALL PIMODL(MODORI,IPMODL)
  89. IF (IPMODL.EQ.0) RETURN
  90. *
  91. * VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUES
  92. * ZZZZZZZZ PEUT ETRE A FAIRE PLUTOT SUR LES SOUS-ZONES
  93. *
  94. ISUP1 = 0
  95. CALL QUESUP(IPMODL,IPCHE1,INTTYP,0,ISUP1,IRET1)
  96. IF (ISUP1.GT.1) RETURN
  97. *
  98. ISUPM = ISUP1
  99. ISUPC = ISUP1
  100. IPCHE2 = 0
  101. * IPMODL est ACTIF en retour (nouveau pointeur pouvant etre detruit)
  102. MMODEL=IPMODL
  103. NSOUS = KMODEL(/1)
  104. *
  105. * INITIALISATION DU CHAPEAU DE L'OBJET RIGIDITE
  106. * ---------------------------------------------
  107. JRIGE = 0
  108. NRIGEL = 0
  109. SEGINI MRIGID
  110. MTYMAT = 'AMORTISS'
  111. * IFORIG = IFOMOD
  112. IFORIG = IFOUR
  113. ICHOLE = 0
  114. IMGEO1 = 0
  115. IMGEO2 = 0
  116. ISUPEQ = 0
  117. * termes croises STATIQUE et/ou MODAL
  118. nstat = 100
  119. kstat = 0
  120. nmoda = 100
  121. kmoda = 0
  122. segini modsta
  123. *
  124. *--------------------------------------------------------------------*
  125. *
  126. * BOUCLE SUR LES ZONES ELEMENTAIRES ( MEME TYPE D'EF )
  127. *
  128. *--------------------------------------------------------------------*
  129. *
  130. DO 500 ISOMO=1,NSOUS
  131.  
  132. IMODEL = KMODEL(ISOMO)
  133. SEGACT,IMODEL
  134. *
  135. IF (FORMOD(1).EQ.'LIAISON') GOTO 5990
  136. *
  137. * INITIALISATIONS
  138. *
  139. IPMINT = 0
  140. IPMIN1 = 0
  141.  
  142. MOMATR = 0
  143. MOCARA = 0
  144. MOTYPM = 0
  145. MOTYPC = 0
  146.  
  147. MODEPL = 0
  148. MOFORC = 0
  149. lsupde = .false.
  150. lsupfo = .false.
  151.  
  152. IDESCR = 0
  153.  
  154. C- Recuperation d'informations sur le maillage elementaire
  155. IPMAIL=IMAMOD
  156. CONM =CONMOD
  157.  
  158. IPT1 = IMAMOD
  159. SEGACT,IPT1
  160. NBNOE1 = IPT1.NUM(/1)
  161. NBELE1 = IPT1.NUM(/2)
  162.  
  163. C- Quelques informations sur le modele
  164.  
  165. IIPDPG = imodel.IPDPGE
  166.  
  167. CMATE = CMATEE
  168. MATE = IMATEE
  169. INAT = INATUU
  170.  
  171. dcmate = .false.
  172. dcmat2 = .false.
  173. do im = 1,matmod(/2)
  174. if (matmod(im).eq.'IMPEDANCE') then
  175. dcmate =.true.
  176. if(tymode(/2).gt.0)then
  177. if(tymode(1).eq.'LISTMOTS') dcmat2 = .true.
  178. endif
  179. endif
  180. enddo
  181.  
  182. IRTD = 1
  183. CALL IDENT(IPT1,CONM,IPCHE1,IPCHE2, INFOS,IRTD)
  184. IF (IRTD.EQ.0) GOTO 5991
  185. C
  186. C- Recuperation d'informations sur l'element fini
  187. MELE = NEFMOD
  188. C Cas particulier : POI1/SEG2 et IMPEDANCE
  189. IF (dcmate) THEN
  190. IF (ipt1.itypel.EQ.1) MELE = 45
  191. IF (ipt1.itypel.EQ.2) MELE = 2
  192. ENDIF
  193. c
  194. C COQUE INTEGREE OU PAS ?
  195. IF (INFMOD(/1).NE.0)THEN
  196. NPINT=INFMOD(1)
  197. ELSE
  198. NPINT=0
  199. ENDIF
  200.  
  201. if (infmod(/1).lt.2+inttyp) then
  202. CALL ELQUOI(MELE,0,INTTYP,IPINF,IMODEL)
  203. IF ( IERR.NE.0 ) GOTO 5991
  204. INFO = IPINF
  205. LHOOK = INFELL(10)
  206. NSTRS = INFELL(16)
  207. MFR = INFELL(13)
  208. LW = INFELL(7)
  209. LRE = INFELL(9)
  210. NDDL = INFELL(15)
  211. IELE = INFELL( 14)
  212. IPORE = INFELL(8)
  213. IPMINT= INFELL(11)
  214. IPMIN1= INFELL(12)
  215. NBPGAU= INFELL( 6)
  216. C* ICARA = INFELL( 5)
  217. segsup info
  218. ELSE
  219. LHOOK = INFELE(10)
  220. NSTRS = INFELE(16)
  221. MFR = INFELE(13)
  222. LW = INFELE(7)
  223. LRE = INFELE(9)
  224. NDDL = INFELE(15)
  225. IELE = INFELE( 14)
  226. IPORE = INFELE(8)
  227. IPMINT=INFMOD(2+INTTYP)
  228. C* IPMINT = INFELE(11)
  229. IPMIN1= INFMOD(8)
  230. NBPGAU= INFELE( 6)
  231. C* ICARA = INFELE( 5)
  232. ENDIF
  233. c* LHOO2 = LHOOK*LHOOK
  234.  
  235. CALL INFDPG(MFR,IFOUR, BDPGE,NDPGE)
  236. IF (BDPGE) THEN
  237. IF (IIPDPG.LE.0) THEN
  238. CALL ERREUR(925)
  239. GOTO 5991
  240. ENDIF
  241. ENDIF
  242.  
  243. IPPORE=0
  244. IF(MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) THEN
  245. IPPORE=NBNNE(NUMGEO(MELE))
  246. ENDIF
  247.  
  248. MINTE = IPMINT
  249. IF (IPMINT.NE.0) SEGACT,MINTE
  250. *
  251. C- RECHERCHE DES NOMS D'INCONNUES ET DES DUAUX
  252. *
  253. if (lnomid(1).ne.0) then
  254. modepl=lnomid(1)
  255. else
  256. lsupde=.true.
  257. CALL IDPRIM(IMODEL,MFR,MODEPL,NDEPL,NDUM)
  258. endif
  259. nomid=MODEPL
  260. segact nomid
  261. ndepl=lesobl(/2)
  262. c* ndum = lesfac(/1)
  263. *
  264. if (lnomid(2).ne.0) then
  265. moforc = lnomid(2)
  266. else
  267. lsupfo=.true.
  268. CALL IDDUAL(IMODEL,MFR,MOFORC,NFORC,NDUM)
  269. endif
  270. nomid=MOFORC
  271. segact nomid
  272. nforc=lesobl(/2)
  273. c* ndum = lesfac(/1)
  274. *
  275. IF (NDEPL.EQ.0.OR.NFORC.EQ.0.OR.NDEPL.NE.NFORC) THEN
  276. CALL ERREUR(5)
  277. GOTO 598
  278. ENDIF
  279. *
  280. * REMPLISSAGE DU SEGMENT DESCRIPTEUR
  281. *
  282. NCOMP = NDEPL
  283. NBNNS = NBNOE1
  284. NBNN = NBNOE1
  285. *PV idecap pas defini
  286. ** IF (MFR.EQ.33.OR.MFR.EQ.57.OR.MFR.EQ.59) THEN
  287. ** NCOMP = NDEPL-IDECAP
  288. ** ENDIF
  289. IF (BDPGE) THEN
  290. NCOMP = NDEPL - NDPGE
  291. NBNN = NBNOE1 + 1
  292. ENDIF
  293. IF (MFR.EQ.19.OR.MFR.EQ.21) THEN
  294. NBNNS = NBNN / 2
  295. ENDIF
  296. *
  297. NFAC = NBNNS
  298. IF (MELE.GE.108.AND.MELE.LE.110)
  299. & NFAC = MIN(NFAC,(3*NBNN-IPORE)/2)
  300. *
  301. NLIGRP = LRE
  302. NLIGRD = LRE
  303. * erreur dans les dimensions de DESCR
  304. * le mode de calcul n'est pas correct
  305. IF (NBNNS*NCOMP .GT. NLIGRD) THEN
  306. CALL ERREUR(717)
  307. GOTO 598
  308. ENDIF
  309.  
  310. SEGINI,DESCR
  311.  
  312. IDDL = 1
  313. DO 1004 INOEUD=1,NFAC
  314. DO 1005 ICOMP=1,NCOMP
  315. NOMID=MODEPL
  316. LISINC(IDDL)=LESOBL(ICOMP)
  317. if (dcmat2) then
  318. if (inoeud.eq.2) then
  319. LISINC(IDDL)=LESFAC(ICOMP)
  320. endif
  321. endif
  322. NOMID=MOFORC
  323. LISDUA(IDDL)=LESOBL(ICOMP)
  324. if (dcmat2) then
  325. if (inoeud.eq.2) then
  326. LISDUA(IDDL)=LESFAC(ICOMP)
  327. endif
  328. endif
  329. NOELEP(IDDL)=INOEUD
  330. NOELED(IDDL)=INOEUD
  331. IDDL=IDDL+1
  332. 1005 CONTINUE
  333. 1004 CONTINUE
  334. *
  335. * CAS DES ELEMENT RACCORD
  336. *
  337. IF (MFR.EQ.19.OR.MFR.EQ.21) THEN
  338. CALL IDPRIM(IMODEL,MFR+1000,MODPL,NDEPL,NDUM)
  339. CALL IDDUAL(IMODEL,MFR+1000,MOFRC,NFORC,NDUM)
  340. NOMID=MODPL
  341. SEGACT NOMID
  342. NOMID=MOFRC
  343. SEGACT NOMID
  344. DO 1106 INOEUD=NBNNS+1,NBNN
  345. DO 1107 ICOMP=1,NDEPL
  346. NOMID=MODPL
  347. LISINC(IDDL)=LESOBL(ICOMP)
  348. NOMID=MOFRC
  349. LISDUA(IDDL)=LESOBL(ICOMP)
  350. NOELEP(IDDL)=INOEUD
  351. NOELED(IDDL)=INOEUD
  352. IDDL=IDDL+1
  353. 1107 CONTINUE
  354. 1106 CONTINUE
  355. NOMID=MODPL
  356. SEGSUP,NOMID
  357. NOMID=MOFRC
  358. SEGSUP,NOMID
  359. ENDIF
  360. *
  361. SEGDES,DESCR
  362. IDESCR = DESCR
  363. 1999 continue
  364. *
  365. * TRAITEMENT DES CHAMPS EN ENTREE
  366. * -------------------------------
  367. *
  368. NBROBL = 0
  369. NBRFAC = 0
  370. NOMID = 0
  371. NOTYPE = 0
  372. *
  373. * >>> CHAMP DE MATERIAU
  374. *
  375. C* IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'ISOTROPE') THEN
  376. IF (FORMOD(1).EQ.'MECANIQUE'.AND.MATE.EQ.1.AND..NOT.dcmate) THEN
  377. IF (MFR.EQ.35) THEN
  378. NBROBL=2
  379. SEGINI NOMID
  380. LESOBL(1)='KS '
  381. LESOBL(2)='KN '
  382. ELSE IF(MFR.EQ.53) THEN
  383. NBROBL=1
  384. SEGINI,NOMID
  385. LESOBL(1)='KS '
  386. ELSE
  387. NBROBL=2
  388. SEGINI NOMID
  389. LESOBL(1)='VISQ'
  390. LESOBL(2)='NU '
  391. ENDIF
  392. NBTYPE=1
  393. SEGINI NOTYPE
  394. TYPE(1)='REAL*8'
  395. C* ELSE IF (FORMOD(1).EQ.'MECANIQUE'.AND.CMATE.EQ.'UNIDIREC') THEN
  396. ELSE IF (FORMOD(1).EQ.'MECANIQUE'.AND.MATE.EQ.4) THEN
  397. IF (MFR.EQ.1.AND.IDIM.EQ.3) THEN
  398. NBROBL=7
  399. SEGINI NOMID
  400. LESOBL(1)='VISQ'
  401. LESOBL(2)='V1X '
  402. LESOBL(3)='V1Y '
  403. LESOBL(4)='V1Z '
  404. LESOBL(5)='V2X '
  405. LESOBL(6)='V2Y '
  406. LESOBL(7)='V2Z '
  407. ELSE
  408. NBROBL=3
  409. SEGINI NOMID
  410. LESOBL(1)='VISQ'
  411. LESOBL(2)='V1X '
  412. LESOBL(3)='V1Y '
  413. ENDIF
  414. NBTYPE=1
  415. SEGINI NOTYPE
  416. TYPE(1)='REAL*8'
  417. *
  418. C* ELSE IF (INAT.EQ.67.AND.CMATE.EQ.'ORTHOTRO') THEN
  419. ELSEIF(INAT.EQ.67.AND. MATE.EQ.2) THEN
  420. NBROBL=6
  421. SEGINI NOMID
  422. LESOBL(1)='YG1 '
  423. LESOBL(2)='YG2 '
  424. LESOBL(3)='NU12'
  425. LESOBL(4)='G12 '
  426. LESOBL(5)='V1X '
  427. LESOBL(6)='V1Y '
  428. NBTYPE=1
  429. SEGINI NOTYPE
  430. TYPE(1)='REAL*8'
  431. *
  432. C* ELSEIF (CMATE.EQ.'SECTION') THEN
  433. ELSE IF (MATE.EQ.11) THEN
  434. C
  435. C MODELE ET MATERIAU DE LA SECTION DU MODELE A FIBRE
  436. C
  437. NBROBL=2
  438. SEGINI NOMID
  439. LESOBL(1)='MODS'
  440. LESOBL(2)='MATS'
  441. NBTYPE=2
  442. SEGINI NOTYPE
  443. TYPE(1)='POINTEURMMODEL'
  444. TYPE(2)='POINTEURMCHAML'
  445. C
  446. ELSEIF (CMATE.EQ.'MODAL') THEN
  447. NBROBL=3
  448. NBRFAC=1
  449. SEGINI NOMID
  450. LESOBL(1)='FREQ'
  451. LESOBL(2)='MASS'
  452. LESOBL(3)='DEFO'
  453. LESFAC(1) ='AMOR'
  454. NBTYPE=4
  455. SEGINI NOTYPE
  456. TYPE(1)='REAL*8'
  457. TYPE(2)='REAL*8'
  458. TYPE(3)='POINTEURCHPOINT'
  459. TYPE(4)='REAL*8'
  460.  
  461. ELSEIF (CMATE.EQ.'STATIQUE') THEN
  462. NBROBL=3
  463. NBRFAC=1
  464. SEGINI NOMID
  465. LESOBL(1)='DEFO'
  466. LESOBL(2)='RIDE'
  467. LESOBL(3)='MADE'
  468. LESFAC(1) ='AMOR'
  469. NBTYPE=4
  470. SEGINI NOTYPE
  471. TYPE(1)='POINTEURCHPOINT'
  472. TYPE(2)='POINTEURCHPOINT'
  473. TYPE(3)='POINTEURCHPOINT'
  474. TYPE(4)='REAL*8'
  475.  
  476. ELSE IF (dcmate) THEN
  477. IF (CMATE.EQ.'IMPCOMPL') THEN
  478. *
  479. * IMPEDANCE COMPLEXE
  480. *
  481. NBROBL=0
  482. NBRFAC=1
  483. SEGINI NOMID
  484. MOMATR=NOMID
  485. LESFAC(1)='VISC'
  486. *
  487. NBTYPE=1
  488. SEGINI NOTYPE
  489. MOTYPE=NOTYPE
  490. TYPE(1)='REAL*8'
  491.  
  492. ELSE
  493. NBROBL=0
  494. NBRFAC=2
  495. SEGINI NOMID
  496. MOMATR=NOMID
  497. LESFAC(1) ='AMOR'
  498. LESFAC(2) ='AROT'
  499. *
  500. NBTYPE=1
  501. SEGINI NOTYPE
  502. MOTYPE=NOTYPE
  503. TYPE(1)='REAL*8'
  504.  
  505. ENDIF
  506.  
  507. *
  508. ELSE
  509. C* CALL IDMATR(MFR,IMODEL,MOMATR,NBROBL,NBRFAC)
  510. C* NOMID = MOMATR
  511. C* NBTYPE=1
  512. C* SEGINI NOTYPE
  513. C* TYPE(1)='REAL*8'
  514. ENDIF
  515. *
  516. *
  517. MOMATR = NOMID
  518. MOTYPM = NOTYPE
  519. *
  520. NMATR = NBROBL
  521. NMATF = NBRFAC
  522. NMATT = NMATR+NMATF
  523. *
  524. * >>> CHAMPS DE CARACTERISTIQUES
  525. *
  526. NBROBL = 0
  527. NBRFAC = 0
  528. IVECT = 0
  529. NOMID = 0
  530. NOTYPE = 0
  531. *
  532. * EPAISSEUR DANS LE CAS MASSIF EN CONTRAINTES PLANES
  533. *
  534. IF ((MFR.EQ.1.OR.MFR.EQ.31.OR.
  535. + ((MELE.GE.79.AND.MELE.LE.83).OR.
  536. + (MELE.GE.173.AND.MELE.LE.182)))
  537. + .AND.IFOUR.EQ.-2)THEN
  538. NBRFAC=1
  539. SEGINI NOMID
  540. LESFAC(1)='DIM3'
  541. *
  542. NBTYPE=1
  543. SEGINI NOTYPE
  544. TYPE(1)='REAL*8'
  545. *
  546. * EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  547. *
  548. ELSEIF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  549. NBROBL=1
  550. IF(MFR.EQ.3.AND.IFOUR.EQ.-2) THEN
  551. NBRFAC=2
  552. ELSE
  553. NBRFAC=1
  554. ENDIF
  555. SEGINI NOMID
  556. LESOBL(1)='EPAI'
  557. LESFAC(1)='EXCE'
  558. IF(MFR.EQ.3.AND.IFOUR.EQ.-2) LESFAC(2)='DIM3'
  559. *
  560. NBTYPE=1
  561. SEGINI NOTYPE
  562. TYPE(1)='REAL*8'
  563. *
  564. * SECTION POUR LES BARRES ET LES CERCES
  565. *
  566. ELSE IF (MFR.EQ.27) THEN
  567. IF(.NOT.dcmate) THEN
  568. NBROBL=1
  569. SEGINI NOMID
  570. LESOBL(1)='SECT'
  571. *
  572. NBTYPE=1
  573. SEGINI NOTYPE
  574. TYPE(1)='REAL*8'
  575. ENDIF
  576. *
  577. * section, excentrements et orientation pour les barres excentrees
  578. *
  579. ELSE IF (MFR.EQ.49) THEN
  580. NBROBL=6
  581. SEGINI NOMID
  582. LESOBL(1)='SECT'
  583. LESOBL(2)='EXCZ'
  584. LESOBL(3)='EXCY'
  585. LESOBL(4)='VX '
  586. LESOBL(5)='VY '
  587. LESOBL(6)='VZ '
  588.  
  589. NBTYPE=1
  590. SEGINI NOTYPE
  591. TYPE(1)='REAL*8'
  592.  
  593. * CARACTERISTIQUES POUR LES POUTRES
  594. *
  595. ELSE IF (MFR.EQ.7 ) THEN
  596. if (dcmate) then
  597. NBROBL=0
  598. NBRFAC=1
  599. SEGINI NOMID
  600. MOCARA=NOMID
  601. LESFAC(1)='VECT'
  602. IVECT=1
  603. *
  604. NBTYPE=1
  605. SEGINI NOTYPE
  606. MOTYPE=NOTYPE
  607. TYPE(1)='POINTEURPOINT '
  608. else
  609. C MODELE A FIBRE
  610. C* IF (CMATE.EQ.'SECTION') THEN
  611. IF (MATE.EQ.11) THEN
  612. IF (ICAS.EQ.2) THEN
  613. NBRFAC=2
  614. SEGINI NOMID
  615. LESFAC(1)='OMEG'
  616. LESFAC(2)='VECT'
  617. IVECT=1
  618. NBTYPE=2
  619. SEGINI NOTYPE
  620. TYPE(1)='REAL*8'
  621. TYPE(2)='POINTEURPOINT '
  622. ELSE
  623. NBRFAC=1
  624. SEGINI NOMID
  625. LESFAC(1)='VECT'
  626. IVECT=1
  627. NBTYPE=1
  628. SEGINI NOTYPE
  629. TYPE(1)='POINTEURPOINT '
  630. ENDIF
  631. *
  632. * POUTRE STANDARD
  633. * CAS 2D
  634. *
  635. ELSE IF (IFOUR.EQ.-2.OR.IFOUR.EQ.-1.OR.IFOUR.EQ.-3) THEN
  636. NBROBL=2
  637. NBRFAC=1
  638. SEGINI NOMID
  639. LESOBL(1)= 'SECT'
  640. LESOBL(2)= 'INRZ'
  641. LESFAC(1)= 'SECY'
  642. *
  643. NBTYPE=1
  644. SEGINI NOTYPE
  645. TYPE(1)='REAL*8'
  646.  
  647. * CAS 3D
  648. *
  649. ELSE
  650. *
  651. * AMORTISSEMENT COROTATIF
  652. *
  653. IF (ICAS.EQ.2) THEN
  654. NBROBL=4
  655. NBRFAC=4
  656. SEGINI NOMID
  657. LESOBL(1)='TORS'
  658. LESOBL(2)='INRY'
  659. LESOBL(3)='INRZ'
  660. LESOBL(4)='SECT'
  661. LESFAC(1)='SECY'
  662. LESFAC(2)='SECZ'
  663. LESFAC(3)='OMEG'
  664. LESFAC(4)='VECT'
  665. IVECT=1
  666. *
  667. NBTYPE=8
  668. SEGINI NOTYPE
  669. TYPE(1)='REAL*8'
  670. TYPE(2)='REAL*8'
  671. TYPE(3)='REAL*8'
  672. TYPE(4)='REAL*8'
  673. TYPE(5)='REAL*8'
  674. TYPE(6)='REAL*8'
  675. TYPE(7)='REAL*8'
  676. TYPE(8)='POINTEURPOINT '
  677. ELSE
  678. *
  679. * AMORTISSEMENT STANDARD
  680. *
  681. NBROBL=4
  682. NBRFAC=3
  683. SEGINI NOMID
  684. LESOBL(1)='TORS'
  685. LESOBL(2)='INRY'
  686. LESOBL(3)='INRZ'
  687. LESOBL(4)='SECT'
  688. LESFAC(1)='SECY'
  689. LESFAC(2)='SECZ'
  690. LESFAC(3)='VECT'
  691. IVECT=1
  692. *
  693. NBTYPE=7
  694. SEGINI NOTYPE
  695. TYPE(1)='REAL*8'
  696. TYPE(2)='REAL*8'
  697. TYPE(3)='REAL*8'
  698. TYPE(4)='REAL*8'
  699. TYPE(5)='REAL*8'
  700. TYPE(6)='REAL*8'
  701. TYPE(7)='POINTEURPOINT '
  702. ENDIF
  703. ENDIF
  704. endif
  705. *
  706. * CARACTERISTIQUES POUR LES TUYAUX
  707. *
  708. ELSE IF (MFR.EQ.13) THEN
  709. IF (ICAS.EQ.2) THEN
  710. NBROBL=2
  711. NBRFAC=5
  712. SEGINI NOMID
  713. LESOBL(1)='EPAI'
  714. LESOBL(2)='RAYO'
  715. LESFAC(1)='RACO'
  716. LESFAC(2)='PRES'
  717. LESFAC(3)='CISA'
  718. LESFAC(4)='OMEG'
  719. LESFAC(5)='VECT'
  720. IVECT=1
  721. *
  722. NBTYPE=7
  723. SEGINI NOTYPE
  724. TYPE(1)='REAL*8'
  725. TYPE(2)='REAL*8'
  726. TYPE(3)='REAL*8'
  727. TYPE(4)='REAL*8'
  728. TYPE(5)='REAL*8'
  729. TYPE(6)='REAL*8'
  730. TYPE(7)='POINTEURPOINT '
  731. ELSE
  732. NBROBL=2
  733. NBRFAC=4
  734. SEGINI NOMID
  735. LESOBL(1)='EPAI'
  736. LESOBL(2)='RAYO'
  737. LESFAC(1)='RACO'
  738. LESFAC(2)='PRES'
  739. LESFAC(3)='CISA'
  740. LESFAC(4)='VECT'
  741. IVECT=1
  742. *
  743. NBTYPE=6
  744. SEGINI NOTYPE
  745. TYPE(1)='REAL*8'
  746. TYPE(2)='REAL*8'
  747. TYPE(3)='REAL*8'
  748. TYPE(4)='REAL*8'
  749. TYPE(5)='REAL*8'
  750. TYPE(6)='POINTEURPOINT '
  751. ENDIF
  752. *
  753. ELSE IF (MFR.EQ.39) THEN
  754. IF (ICAS.EQ.2) THEN
  755. NBROBL=2
  756. NBRFAC=4
  757. SEGINI NOMID
  758. LESOBL(1)='EPAI'
  759. LESOBL(2)='RAYO'
  760. LESFAC(1)='RACO'
  761. LESFAC(2)='PRES'
  762. LESFAC(3)='OMEG'
  763. LESFAC(4)='VECT'
  764. IVECT=1
  765.  
  766. NBTYPE=6
  767. SEGINI NOTYPE
  768. TYPE(1)='REAL*8'
  769. TYPE(2)='REAL*8'
  770. TYPE(3)='REAL*8'
  771. TYPE(4)='REAL*8'
  772. TYPE(5)='REAL*8'
  773. TYPE(6)='POINTEURPOINT '
  774.  
  775. ELSE
  776. NBROBL=2
  777. NBRFAC=3
  778. SEGINI NOMID
  779. LESOBL(1)='EPAI'
  780. LESOBL(2)='RAYO'
  781. LESFAC(1)='RACO'
  782. LESFAC(2)='PRES'
  783. LESFAC(3)='VECT'
  784. IVECT=1
  785.  
  786. NBTYPE=5
  787. SEGINI NOTYPE
  788. TYPE(1)='REAL*8'
  789. TYPE(2)='REAL*8'
  790. TYPE(3)='REAL*8'
  791. TYPE(4)='REAL*8'
  792. TYPE(5)='POINTEURPOINT '
  793. ENDIF
  794. ENDIF
  795.  
  796. * Rendement :
  797. * Notion non utilisee actuellement (mais conserver a titre historique !)
  798. IF (NOMID.LE.0) THEN
  799. NBROBL = 0
  800. NBRFAC = 0
  801. SEGINI,NOMID
  802. NBTYPE = 0
  803. SEGINI,NOTYPE
  804. ENDIF
  805. ncar1 = NBROBL + NBRFAC + 1
  806. ifac = NBRFAC
  807. NBRFAC = NBRFAC + 10
  808. SEGADJ,NOMID
  809. LESFAC(ifac + 1) = 'REND'
  810. LESFAC(ifac + 2) = 'W1X '
  811. LESFAC(ifac + 3) = 'W1Y '
  812. LESFAC(ifac + 4) = 'W1Z '
  813. LESFAC(ifac + 5) = 'W2X '
  814. LESFAC(ifac + 6) = 'W2Y '
  815. LESFAC(ifac + 7) = 'W2Z '
  816. LESFAC(ifac + 8) = 'REN1'
  817. LESFAC(ifac + 9) = 'REN2'
  818. LESFAC(ifac + 10) = 'REN3'
  819. NBTYPE = NBTYPE + 1
  820. SEGADJ,NOTYPE
  821. TYPE(NBTYPE) = 'REAL*8'
  822. *
  823. MOCARA = NOMID
  824. MOTYPC = NOTYPE
  825. NCARA = NBROBL
  826. NCARF = NBRFAC
  827. NCARR = NCARA+NCARF
  828.  
  829. C- Partionnement si necessaire de la matrice d'amortissement
  830. C- determinant ainsi le nombre d'objets elementaires de MRIGID
  831. LTRK = oooval(1,4)
  832. IF (LTRK.EQ.0) LTRK = oooval(1,1)
  833. * Ajout a la taille en mots de la matrice des infos du segment
  834. LSEG = LRE*LRE*NBELE1 + 16
  835. NBLPRT = (LSEG-1)/LTRK + 1
  836. NBLMAX = (NBELE1-1)/NBLPRT + 1
  837. NBLPRT = (NBELE1-1)/NBLMAX + 1
  838. * write(ioimp,*) ' amor1 : nblprt nblmax = ',nblprt,nblmax,nbele1
  839.  
  840. descr = IDESCR
  841. meleme = IPT1
  842. nbnn = NBNOE1
  843. nbelem = NBELE1
  844. nbsous = 0
  845. nbref = 0
  846. *
  847. ************************************************************************
  848. * P H A S E 2
  849. *
  850. * Boucle sur les PARTITIONS elementaires de la matrice
  851. *
  852. ************************************************************************
  853. isous = 0
  854. DO irige = 1, NBLPRT
  855.  
  856. IF (NBLPRT.GT.1) THEN
  857. C- Partitionnement du maillage support de la matrice elementaire
  858. C- (IPT1 peut etre desactive suite a l'appel a KOMCHA !)
  859. SEGACT,IPT1
  860. ielem = (irige-1)*NBLMAX
  861. nbelem = MIN(NBLMAX,NBELE1-ielem)
  862. * write(ioimp,*) ' creation segment ',nbnn,nbelem
  863. SEGINI,meleme
  864. itypel = IPT1.itypel
  865. DO ielt = 1, nbelem
  866. jelt = ielt + ielem
  867. DO inoe = 1, nbnn
  868. num(inoe,ielt) = IPT1.NUM(inoe,jelt)
  869. ENDDO
  870. icolor(ielt) = IPT1.ICOLOR(jelt)
  871. ENDDO
  872. C- Recopie du descripteur
  873. des1 = IDESCR
  874. SEGINI,descr=des1
  875. SEGDES,descr
  876. ENDIF
  877.  
  878. C- Cas particulier en DEFO PLAN GENE
  879. IF (BDPGE) THEN
  880. c* nbelem = NUM(/2)
  881. nbnn = NBNOE1 + 1
  882. SEGINI,ipt2
  883. ipt2.itypel = 28
  884. DO ielt = 1,nbelem
  885. DO inoe = 1,NBNOE1
  886. ipt2.num(inoe,ielt) = NUM(inoe,ielt)
  887. ENDDO
  888. ipt2.num(nbnn,ielt) = IIPDPG
  889. ipt2.icolor(ielt) = ICOLOR(jelt)
  890. ENDDO
  891. SEGDES,IPT2
  892. nbnn = NBNOE1
  893. ELSE
  894. ipt2 = meleme
  895. ENDIF
  896.  
  897. ipmail = meleme
  898. ipdesc = descr
  899. ipmadg = ipt2
  900.  
  901. C- Initialisation de la matrice de rigidite elementaire (xmatri)
  902. NELRIG = nbelem
  903. SEGINI,xmatri
  904. ipmatr = xmatri
  905.  
  906. C- Recuperation des valeurs des proprietes materiau et geometriques
  907. IVAMAT = 0
  908. IVACAR = 0
  909. brend = .FALSE.
  910. *
  911. CALL KOMCHA(IPCHE1,ipmail,CONM,MOMATR,MOTYPM,1,INFOS,3,IVAMAT)
  912. IF (IERR.NE.0) GOTO 597
  913. IF (ISUPM.EQ.1) THEN
  914. CALL VALCHE(IVAMAT,NMATT,IPMINT,IPPORE,MOMATR,MELE)
  915. IF (IERR.NE.0) THEN
  916. ISUPM = 0
  917. GOTO 597
  918. ENDIF
  919. ENDIF
  920.  
  921. if (cmate.eq.'STATIQUE'.or.cmate.eq.'MODAL') then
  922. mptval = ivamat
  923. segact mptval
  924. if (ival(/1).lt.3) call erreur(5)
  925. endif
  926. if (cmate.eq.'STATIQUE') then
  927. kstat = kstat + 1
  928. ivstat(kstat) = ivamat
  929. pistat(kstat) = imodel
  930. if (kstat.eq.nstat) then
  931. nstat = nstat + 100
  932. segadj modsta
  933. endif
  934. endif
  935. if (cmate.eq.'MODAL') then
  936. kmoda = kmoda + 1
  937. ivmoda(kmoda) = ivamat
  938. pimoda(kmoda) = imodel
  939. if (kmoda.eq.nmoda) then
  940. nmoda = nmoda + 100
  941. segadj modsta
  942. endif
  943. endif
  944. if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') then
  945. if (ival(4).eq.0) goto 519
  946. endif
  947.  
  948. MPTVAL = IVAMAT
  949. NBGMAT = 0
  950. NELMAT = 0
  951. DO i = 1,NMATT
  952. IF (IVAL(i).NE.0) THEN
  953. MELVAL = IVAL(i)
  954. C* IF (CMATE.EQ.'SECTION') THEN
  955. IF (MATE.EQ.11) THEN
  956. NBGMAT = MAX(NBGMAT,IELCHE(/1))
  957. NELMAT = MAX(NELMAT,IELCHE(/2))
  958. ELSE
  959. NBGMAT = MAX(NBGMAT,VELCHE(/1))
  960. NELMAT = MAX(NELMAT,VELCHE(/2))
  961. ENDIF
  962. ENDIF
  963. ENDDO
  964.  
  965. IF (MOCARA.NE.0) THEN
  966. CALL KOMCHA(IPCHE1,ipmail,CONM,MOCARA,MOTYPC,1,
  967. & INFOS,3,IVACAR)
  968. IF (IERR.NE.0) GOTO 597
  969. IF (ISUPC.EQ.1) THEN
  970. CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  971. IF (IERR.NE.0) THEN
  972. ISUPC = 0
  973. GOTO 597
  974. ENDIF
  975. ENDIF
  976. * Rendement :
  977. mptval = IVACAR
  978. IF (ival(/1).GE.ncar1+9) THEN
  979. brend = ival(ncar1+7).GT.0 .OR. ival(ncar1+8).GT.0 .OR.
  980. & ival(ncar1+9).GT.0
  981. ENDIF
  982. ENDIF
  983.  
  984. isous = isous + 1
  985. imod = imodel
  986. if (dcmate.and.mele.eq.2) goto 29
  987.  
  988. ************************************************************************
  989. * P H A S E 3
  990. *
  991. * CALCUL DES RIGIDITES ELEMENTAIRES
  992. *
  993. ************************************************************************
  994. *
  995. * NUMERO DES ETIQUETTES :
  996. * Les elements sont groupes comme suit :
  997. * - massif,liquide 'surface libre' poreux ----------------------> r
  998. * - coq3,dkt,coq4,coq8,coq2,dst --------------------------------> r
  999. * - poutre,tuyau,linespring,tuyau fissure,barre,homogeneise,jot3> r
  1000. * - joi4,joi2,poutre de timoschenko,joi3
  1001. *
  1002. * CABL SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 QUA8 QUA9
  1003. GOTO ( 99, 99, 99, 4, 99, 4, 99, 4, 99, 4, 99
  1004. * RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 LIA4 LIA6 LIA8 MULT
  1005. & , 99, 99, 4 , 4, 4, 4, 99, 99, 99, 99, 99
  1006. * TET4 TE10 PYR5 PY13 COQ3 DKT POUT LISP FAC3 FAC4 FAC6
  1007. & , 4, 4, 4, 4, 27, 27, 29, 29, 99, 99, 99
  1008. * FAC8 LTR3 LQU4 LCU8 LPR6 LTE4 LPY5 COQ8 TUYA TUFI COQ2
  1009. & , 99, 4, 4, 4, 4, 4, 4, 27, 29, 29, 27
  1010. * POI1 BARR RACO LSU2 COQ4 LISM COF3 RES2 LSU3 LSU4 LICO
  1011. & , 29, 29, 99, 4, 27, 99, 99, 99, 4, 4, 99
  1012. * COQ6 CVS2 CVS3 CVT3 CVT6 CVQ4 CVQ8 THP5 TH13 THP6 TH15
  1013. & , 27, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  1014. * THC8 TH20 ICT3 ICQ4 ICT6 ICQ8 ICC8 ICT4 ICP6 IC20 IC10
  1015. & , 99, 99, 4, 4, 4, 4, 99, 99, 99, 99, 99
  1016. * IC15 TRIP QUAP CUBP TETP PRIP TIMO JOI2 JOI3 JOT3 JOI4
  1017. & , 99, 99, 99, 99, 99, 99, 29, 29, 29, 29, 29
  1018. * JOI6 JOI8 LISC TRIH DST LIC4 CERC TUYO LSE2 LITU HYT3
  1019. & , 99, 99, 99, 29, 27, 99, 29, 29, 29, 29, 99
  1020. * HYQ4 HYT4 HYP6 HYC8 TRIS QUAS POIS FOR3 JOP3 JOP6 JOP8
  1021. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  1022. * POL3 POL4 POL5 POL6 POL7 POL8 POL9 PO10 PO11 PO12 PO13
  1023. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  1024. * PO14 BAR3 BAEX LIA2 QUAH CUBH ROT3 SEF2 TRF3 QUF4 CUF8
  1025. & , 99, 29, 29, 29, 99, 99, 99, 99, 99, 99, 99
  1026. * PRF6 TEF4 PYF5 MSE3 MTR6 MQU9 MC27 MP18 MT10 MP14 SEF3
  1027. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  1028. * TRF7 QUF9 CF27 PF21 TF15 PF19 SEG6 TR21 QU36 C216 P126
  1029. & , 99, 99, 99, 99, 99, 99, 99, 99, 99, 99, 99
  1030. * TE56 PY91 TRH6
  1031. & , 99, 99, 99),MELE
  1032. C
  1033. C CASE OF THE NEW JOINT ELEMENTS (JCT3 AND JCI4 IN 2D SHEAR)
  1034. C (JGI2 2D GENERALIZED)
  1035. C (JGT3 AND JGI4 GENERALIZED)
  1036. IF (MELE.GE.168.AND.MELE.LE.172)GOTO 29
  1037. IF (MELE.GE.173.OR.MELE.LE.184) GO TO 4
  1038. C
  1039. 99 CONTINUE
  1040. MOTERR(1:4) = NOMTP(MELE)
  1041. MOTERR(9:12)= 'AMOR1'
  1042. CALL ERREUR(86)
  1043. GOTO 510
  1044. C_______________________________________________________________________
  1045. C
  1046. C massif
  1047. C_______________________________________________________________________
  1048. C
  1049. 4 CONTINUE
  1050. IF (ICAS.EQ.2) GOTO 99
  1051. CALL AMOR2 (MATE,MELE,ipmail,IPMINT,NBPGAU,LRE,NSTRS,IVAMAT,
  1052. & IVACAR,CMATE,MFR,NBGMAT,NELMAT,1,LHOOK,NMATT,
  1053. & IPORE,NDDL,IPMATR,IIPDPG,ncar1)
  1054. GOTO 510
  1055. C_______________________________________________________________________
  1056. C
  1057. C coq3,dkt,coq4,coq8,coq2,dst
  1058. C_______________________________________________________________________
  1059. C
  1060. 27 CONTINUE
  1061. IF (ICAS.EQ.2) GOTO 99
  1062. CALL RIGI3(MATE,MELE,ipmail,IPMINT,IPMIN1,NBPGAU,LRE,NSTRS,
  1063. & IVAMAT,IVACAR,CMATE,MFR,NBGMAT,NELMAT,1,LHOOK,
  1064. & NMATT,LW,NPINT,IPMATR,IIPDPG)
  1065. GOTO 510
  1066. C_______________________________________________________________________
  1067. C
  1068. C poutre,tuyau,linespring,tuyau fissure,barre,joints 2-3D
  1069. C poutre de Timoschenko,point
  1070. C_______________________________________________________________________
  1071. C
  1072. 29 CONTINUE
  1073. n_z = ncar1 - 1
  1074. CALL AMOR4(MATE,MELE,ipmail,IPMINT,NBPGAU,LRE,NSTRS,
  1075. & IVAMAT,IVACAR,IVECT,CMATE,MFR,ICAS,NBGMAT,NELMAT,
  1076. & LHOOK,NMATT,n_z,ISOUS,LW,IPORE,IPMATR,IIPDPG,IMOD)
  1077. GOTO 510
  1078. *
  1079. ************************************************************************
  1080. * P H A S E 4
  1081. *
  1082. * DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE IA
  1083. *
  1084. ***********************************************************************
  1085. 510 CONTINUE
  1086. 597 CONTINUE
  1087. if (cmate.eq.'MODAL'.or.cmate.eq.'STATIQUE') goto 518
  1088. IF (ISUPM.EQ.1 .OR. nblprt.GT.1) THEN
  1089. CALL DTMVAL(IVAMAT,3)
  1090. ELSE
  1091. CALL DTMVAL(IVAMAT,1)
  1092. ENDIF
  1093. IF (ISUPC.EQ.1 .OR. nblprt.GT.1) THEN
  1094. CALL DTMVAL(IVACAR,3)
  1095. ELSE
  1096. CALL DTMVAL(IVACAR,1)
  1097. ENDIF
  1098. c* xmatri = ipmatr
  1099. 518 continue
  1100. SEGDES,xmatri
  1101. IF (NBLPRT.GT.1) THEN
  1102. meleme = ipmail
  1103. SEGDES,meleme
  1104. ENDIF
  1105.  
  1106. C- Sortie prematuree en cas d'erreur
  1107. IF (IERR.NE.0) GOTO 598
  1108. C Ajout de la matrice d'AMORTISSEMENT a la matrice globale
  1109. C ========================================================
  1110. NRIGE0 = IRIGEL(/2)
  1111. c NRIGEL = NRIGE0 + NBLPRT
  1112. NRIGEL = NRIGE0 + 1
  1113. SEGADJ,MRIGID
  1114.  
  1115. C- Stockage de la matrice
  1116. c jrige = NRIGE0 + isous
  1117. jrige = NRIGE0 + 1
  1118. COERIG(jrige) = 1.
  1119. IF (BDPGE) THEN
  1120. IRIGEL(1,jrige) = ipmadg
  1121. ELSE
  1122. IRIGEL(1,jrige)=IPMAIL
  1123. ENDIF
  1124. IRIGEL(2,jrige) = 0
  1125. IRIGEL(3,jrige) = ipdesc
  1126. IRIGEL(4,jrige) = ipmatr
  1127. IRIGEL(5,jrige) = NIFOUR
  1128. IRIGEL(6,jrige) = 0
  1129. IF (ICAS.EQ.2) THEN
  1130. IRIGEL(7,jrige) = 2
  1131. ELSE IF (MFR.EQ.57.OR.MFR.EQ.59) THEN
  1132. IRIGEL(7,jrige) = 2
  1133. ELSE IF (brend) THEN
  1134. IRIGEL(7,jrige) = 2
  1135. ELSE
  1136. IRIGEL(7,jrige) = 0
  1137. ENDIF
  1138. IRIGEL(8,jrige) = 0
  1139.  
  1140. ENDDO
  1141. C- Fin de la boucle sur les partitions
  1142. *
  1143. 519 continue
  1144. 598 CONTINUE
  1145. IF (MOMATR.NE.0) THEN
  1146. nomid = MOMATR
  1147. SEGSUP,nomid
  1148. notype = MOTYPM
  1149. SEGSUP,notype
  1150. ENDIF
  1151. IF (MOCARA.NE.0) THEN
  1152. nomid = MOCARA
  1153. SEGSUP,nomid
  1154. notype = MOTYPC
  1155. SEGSUP,notype
  1156. ENDIF
  1157. NOMID = MODEPL
  1158. SEGDES,NOMID
  1159. IF (lsupde) SEGSUP,NOMID
  1160. NOMID = MOFORC
  1161. SEGDES,NOMID
  1162. IF (lsupfo) SEGSUP,NOMID
  1163.  
  1164. *
  1165. * Fin de la boucle (5000) de PARTITIONNEMENT du segment XMATRI
  1166. 5000 CONTINUE
  1167.  
  1168. 5991 CONTINUE
  1169. IF (IPMINT.NE.0) SEGDES,MINTE
  1170. SEGDES,IPT1
  1171. 5990 CONTINUE
  1172. SEGDES,IMODEL
  1173.  
  1174. C EN CAS D'ERREUR
  1175. IF (IERR.NE.0) GOTO 999
  1176.  
  1177. 500 CONTINUE
  1178. C* Fin de la boucle sur les modeles elementaires
  1179. NRIGEL = jrige
  1180. segadj mrigid
  1181.  
  1182. *termes croises 'STATIQUE'/'MODAL'
  1183. nstat = kstat
  1184. nmoda = kmoda
  1185. segadj modsta
  1186. ir2 = 0
  1187. if (nstat.ne.0) then
  1188. if (nstat.gt.0) call ricroi(modsta, ir2,3)
  1189. if (nstat.gt.0) then
  1190. do kstat=1,nstat
  1191. mptval = ivstat(kstat)
  1192. segact mptval
  1193. IF (ISUPM.EQ.1) THEN
  1194. CALL DTMVAL(mptval,3)
  1195. ELSE
  1196. CALL DTMVAL(mptval,1)
  1197. ENDIF
  1198. enddo
  1199. endif
  1200. if (nmoda.gt.0) then
  1201. do kmoda=1,nmoda
  1202. mptval = ivmoda(kmoda)
  1203. segact mptval
  1204. IF (ISUPM.EQ.1) THEN
  1205. CALL DTMVAL(mptval,3)
  1206. ELSE
  1207. CALL DTMVAL(mptval,1)
  1208. ENDIF
  1209. enddo
  1210. endif
  1211. endif
  1212.  
  1213. if (ierr.eq.0.and.ir2.gt.0) then
  1214. ir1 = mrigid
  1215. call fusrig(ir1,ir2,ir3)
  1216. mrigid = ir3
  1217. endif
  1218. segsup modsta
  1219.  
  1220. 999 CONTINUE
  1221. IF (IERR.NE.0) THEN
  1222. SEGSUP,MRIGID
  1223. IPRIG = 0
  1224. ELSE
  1225. SEGDES,MRIGID
  1226. IPRIG = MRIGID
  1227. ENDIF
  1228.  
  1229. SEGDES,MMODEL
  1230.  
  1231. RETURN
  1232. END
  1233.  
  1234.  
  1235.  
  1236.  
  1237.  
  1238.  
  1239.  
  1240.  

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