Télécharger amor1.eso

Retour à la liste

Numérotation des lignes :

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

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