Télécharger pjmode.eso

Retour à la liste

Numérotation des lignes :

  1. C PJMODE SOURCE CB215821 19/07/30 21:17:31 10273
  2. SUBROUTINE PJMODE(ipmode)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C=======================================================================
  6. C OPERATEUR PJBA :
  7. C PROJECTION D'UN CHPOINT, D'UN CHARGEMENT OU D'UNE RIGIDITE
  8. C SUR LES ELEMENTS D'UNE BASE MODALE B.
  9. C LE RESULTAT EST DU MEME TYPE.
  10. C
  11. C SYNTAXE :
  12. C * FN = PJBA B OBJET ; SI BASE ELEMENTAIRE
  13. C * FN = PJBA B STR1 (N) OBJET ; SI BASE COMPLEXE
  14. C
  15. C OBJET POUVANT ETRE UNE FORCE OU UN CHARGEMENT,
  16. C OU UNE RIGIDITE DANS LE PREMIER CAS.
  17. C=======================================================================
  18. ***********************************************************
  19. * PROJECTION D'UNE MATRICE SUR UNE BASE DE MODES *
  20. * _______________________________________________________ *
  21. * *
  22. * DATE : le 11 Avril 1995 *
  23. * AUTEUR : Nicolas BENECH *
  24. * _______________________________________________________ *
  25. * *
  26. * MODULE(S) APPELANT(S) : PJBA *
  27. * *
  28. * MODULE(S) APPELE(S) : ACCTAB, YTMX *
  29. * _______________________________________________________ *
  30. * *
  31. * EN ENTREE : *
  32. * MRIGID : Matrice a projeter *
  33. * MTAB1 : Base de modes, reels ou complexes *
  34. * 'REEL' : indique que l'on utilise le produit *
  35. * scalaire reel (pas de conjugaison) *
  36. * *
  37. * EN SORTIE : *
  38. * RI1 : Matrice projetee (partie reelle) *
  39. * RI2 : Matrice projetee (partie imaginaire) *
  40. * _______________________________________________________ *
  41. * *
  42. * REMARQUE : *
  43. * L'operation realisee est : *
  44. * (MTAB1)t . MRIGID. MTAB1 *
  45. * Dans le cas complexe, la transposition est accompagnee *
  46. * de la conjugaison (si REEL n'est pas mentionne). *
  47. *
  48. * voir aussi PROJTA
  49. ***********************************************************
  50. *
  51. -INC SMCHPOI
  52. -INC SMCHARG
  53. -INC SMLCHPO
  54. -INC PPARAM
  55. -INC CCOPTIO
  56. -INC CCGEOME
  57. -INC CCREEL
  58. -INC SMELEME
  59. -INC CCHAMP
  60. -INC SMCHAML
  61. -INC SMMODEL
  62. -INC SMRIGID
  63. -INC SMLMOTS
  64. -INC SMLENTI
  65.  
  66. C
  67. * Declarations
  68. *
  69. PARAMETER(ZERO=0.D0)
  70. REAL*8 XVAL, RMAX
  71. CHARACTER*8 LETYPE
  72. CHARACTER*8 TYPMOD,cmate
  73. LOGICAL MODCOM,dedans,dchpo,l3,lr2,lirl
  74. INTEGER I, J, NBMOD, POS, IREEL, IVALRE, IOBRE
  75. REAL*8 XVALRE
  76. LOGICAL LOGRE
  77. segment plcf
  78. integer lpref(ldepl),ldefo(ldepl),lmade(ldepl)
  79. real*8 prmas(ldepl)
  80. endsegment
  81. segment pmod
  82. integer kdefo(nbmod)
  83. endsegment
  84. segment prigmat
  85. integer lrigmat(nrigmat,2+9)
  86. endsegment
  87. segment pmapmo
  88. integer lmapmo(nmapmo),defpmo(nmapmo),dimpmo(nmapmo)
  89. character*4 compmo(nmapmo)
  90. real*8 coepmo(nmapmo)
  91. endsegment
  92. segment pcompo
  93. character*4 mcol
  94. real*8 valmod(nipmod)
  95. endsegment
  96. LOGICAL L0,L1,lcf
  97. PARAMETER (ncod=8)
  98. CHARACTER*4 IDDL,lcod(ncod),lcof(ncod),motinc
  99. CHARACTER*8 TYPRET,CHARRE
  100. data xlopre/1.d-11/
  101. DATA KZERO/0/
  102. data lcod/'UX','UY','UZ','RX','RY','RZ','UR','UT'/
  103. data lcof/'FX','FY','FZ','MX','MY','MZ','FR','FT'/
  104.  
  105. plcf = 0
  106. jgn = 4
  107. jgm = ncod
  108. segini mlmot5
  109. segini mlmot6
  110. do io = 1,ncod
  111. mlmot5.mots(io) = lcod(io)
  112. mlmot6.mots(io) = lcof(io)
  113. enddo
  114.  
  115. modcom = .false.
  116. dchpo = .false.
  117. iriout = 0
  118. iriout1 = 0
  119. iriout2 = 0
  120. mmodel = ipmode
  121. n1 = kmodel(/1)
  122. segini mmode1
  123. jn = 0
  124. do im = 1, n1
  125. imodel = kmodel(im)
  126. if (formod(1).eq.'MECANIQUE'.and.MATMOD(1).eq.'ELASTIQUE'
  127. &.and.(MATMOD(2).eq.'MODAL'.or.MATMOD(2).eq.'STATIQUE')) then
  128. jn = jn + 1
  129. mmode1.kmodel(jn) = imodel
  130. endif
  131. enddo
  132. if (jn.ne.0) then
  133. n1 = jn
  134. segadj mmode1
  135. ipmode = mmode1
  136. else
  137. segsup mmode1
  138. * cas de projection non pr�vue
  139. call erreur(5)
  140. return
  141. endif
  142.  
  143. call lirobj('MCHAML ',IPCAR1,1,iretou)
  144. call actobj('MCHAML ',IPCAR1,1)
  145. if (ierr.ne.0) return
  146.  
  147. ipchpo = 0
  148. iprigi = 0
  149. call lirobj('CHARGEME',IPCHAR,0,iretou)
  150. if (iretou.eq.0) then
  151. call lirobj('CHPOINT ',IPCHPO,0,iretou)
  152. if(iretou .EQ. 1)call actobj('CHPOINT ',IPCHPO,1)
  153. endif
  154. if (iretou.eq.0) call lirobj('RIGIDITE',IPRIGI,0,iretou)
  155.  
  156. if (iretou.eq.0) then
  157. * manque un op�rande
  158. call erreur(5)
  159. return
  160. endif
  161.  
  162. call reduaf (ipcar1,ipmode,IPCARA,1,iretr,kerre)
  163. if (ierr.ne.0) return
  164. if( iretr.ne.1) then
  165. call erreur (kerre)
  166. return
  167. endif
  168.  
  169. lcf = .false.
  170. mmodel = ipmode
  171. mchelm = ipcara
  172. if (ipchar.ne.0) goto 100
  173. if (iprigi.ne.0) goto 200
  174. if (ipchpo.ne.0) then
  175. n = 1
  176. segini mcharg
  177. ipchar = mcharg
  178. segini icharg
  179. kcharg(1) = icharg
  180. ichpo1 = ipchpo
  181. goto 100
  182. endif
  183.  
  184.  
  185. 100 continue
  186. MCHAR1=IPCHAR
  187. SEGINI,MCHARG=MCHAR1
  188. NBCHG=KCHARG(/1)
  189. DO 10 INCHA=1,NBCHG
  190. ICHAR1=KCHARG(INCHA)
  191. SEGINI,ICHARG=ICHAR1
  192. KCHARG(INCHA)=ICHARG
  193. IP1=ICHPO1
  194. c
  195. IRET = 0
  196. c
  197. c deplacement impose => idepi=1
  198. c force imposee => idepi=0
  199. c
  200. IDEPI = 0
  201. c idepi = -1
  202. KDEPI = 0
  203. MCHPOI = IP1
  204. IF (MTYPOI.EQ.'FLX ') IDEPI = 1
  205. c if (idepi.lt.0) then
  206. c moterr(1:8) = 'chpoint'
  207. c call erreur(302)
  208. c return
  209. c endif
  210. c
  211. NBNN = 1
  212. NBREF = 0
  213. NBSOUS = 0
  214. *
  215. LDEPL = kmodel(/1)
  216. if (.not.lcf) segini plcf
  217. c
  218. c
  219. c **** on initialise le chpoint
  220. c
  221. NSOUPO = 1
  222. NAT=1
  223. SEGINI,MCHPOI
  224. IRET = MCHPOI
  225. MTYPOI = ' '
  226. MOCHDE=' J''AI ETE FABRIQUE PAR L''OPERATEUR PJBA'
  227. IFOPOI = IFOUR
  228. * champ de force nodal: nature discrete
  229. JATTRI(1)=2
  230. NC = 1
  231. SEGINI,MSOUPO
  232. IPCHP(1) = MSOUPO
  233. NOHARM(1) = NIFOUR
  234. NOCOMP(1) = 'FALF'
  235.  
  236. do 101 inocomp=1,2
  237.  
  238. N = LDEPL
  239. SEGINI MPOVAL
  240. IPOVAL = MPOVAL
  241. *
  242. NBNN = 1
  243. NBELEM = LDEPL
  244. NBSOUS = 0
  245. NBREF = 0
  246. SEGINI MELEME
  247. IGEOC = MELEME
  248. ITYPEL = 1
  249.  
  250. knum = 0
  251. c
  252. c ****boucle sur les chpoints de depl
  253. c
  254. DO 11 IM = 1,kmodel(/1)
  255. imodel = kmodel(im)
  256. nomid = lnomid(2)
  257. if (.not.lcf) then
  258. ipt1 = imamod
  259. iptr = ipt1.num(1,1)
  260. lpref(im) = iptr
  261.  
  262. indc = 1
  263. 34 if (imache(indc).ne.imamod.or.conche(indc).ne.conmod) then
  264. indc = indc + 1
  265. if (indc.gt.imache(/1)) then
  266. * champ de caracteristiques incomplet
  267. goto 99
  268. endif
  269. goto 34
  270. endif
  271.  
  272. mchaml = ichaml(indc)
  273. do iij = 1, nomche(/2)
  274. if (nomche(iij).eq.'DEFO') then
  275. melval = ielval(iij)
  276. ipp1 = ielche(1,1)
  277. ldefo(im) = ipp1
  278. endif
  279. if (nomche(iij).eq.'MADE') then
  280. melval = ielval(iij)
  281. ipp2 = ielche(1,1)
  282. lmade(im) = ipp2
  283. endif
  284. if (nomche(iij).eq.'MASS') then
  285. melval = ielval(iij)
  286. ymass = velche(1,1)
  287. prmas(im) = ymass
  288. endif
  289. if(ldefo(im).gt.0.and.lmade(im).gt.0.and.
  290. &prmas(im).gt.0) goto 35
  291. enddo
  292. 35 continue
  293. if (ldefo(im).eq.0) goto 99
  294. if (prmas(im).le.0.and.cmatee(1:5).eq.'MODAL') goto 99
  295. if (lmade(im).eq.0.and.cmatee(1:8).eq.'STATIQUE') goto 99
  296.  
  297. endif
  298.  
  299. if (NOCOMP(1).ne.lesobl(1)(1:4)) goto 11
  300. knum = knum + 1
  301.  
  302. iptr = lpref(im)
  303. ipp1 = ldefo(im)
  304. NUM(1,knum) = IPTR
  305. ICOLOR(knum) = IDCOUL
  306. XRET = 0.D0
  307. call xty1(ipp1,ip1,mlmot5,mlmot6,xret)
  308. IF (IDEPI.NE.1) THEN
  309. ELSE
  310. * ??
  311. indn = 1
  312. 45 if (nomche(indn).ne.'FREQ') then
  313. indn = indn + 1
  314. if (indn.gt.nomche(/2)) then
  315. * pas la composante FREQ
  316. goto 99
  317. endif
  318. goto 45
  319. endif
  320.  
  321. melval = ielval(indn)
  322. x1 = velche(1,1)
  323. OM = X1
  324. OM = 2.D0 * XPI * OM
  325. OM = OM * OM
  326. XRET = -XRET / OM
  327. ENDIF
  328. IF (IFOUR .EQ. 1) THEN
  329. IF (NIFOUR .NE. 0) THEN
  330. XRET = XRET*XPI
  331. ELSE
  332. XRET = XRET*2.D0*XPI
  333. ENDIF
  334. ENDIF
  335. VPOCHA(knum,1) = XRET
  336. *
  337. if (cmatee(1:5).eq.'MODAL') then
  338. ymass = prmas(im)
  339. elseif (cmatee(1:8).eq.'STATIQUE') then
  340. ipp2 = lmade(im)
  341. call xty1(ipp1,ipp2,mlmot5,mlmot6,ymass)
  342. else
  343. endif
  344. if (lmade(im).gt.0.and.ABS(XRET).gt.(1.d-10*ymass).and.
  345. & ymass.gt.0.and.cmatee(1:5).eq.'MODAL') then
  346. * kich : on enleve la projection sur base modale - a creuser pour statique !
  347. CALL ADCHPO(IP1,IPP2,IP2,1.d0,(XRET/ymass*(-1.d0)))
  348. IP1 = IP2
  349. endif
  350. *
  351. 11 CONTINUE
  352. *
  353. lcf = .true.
  354. *
  355. *
  356. if (knum.eq.kmodel(/1)) goto 102
  357. if (inocomp.eq.1) then
  358. if (knum.eq.0) then
  359. NOCOMP(1) = 'FBET'
  360. else
  361. N = knum
  362. NBELEM = knum
  363. segadj MPOVAL,MELEME
  364. NSOUPO = 2
  365. segadj MCHPOI
  366. SEGINI,MSOUPO
  367. IPCHP(2) = MSOUPO
  368. NOCOMP(1) = 'FBET'
  369. endif
  370. endif
  371. 101 continue
  372.  
  373. 102 continue
  374. N = knum
  375. NBELEM = knum
  376. segadj MPOVAL,MELEME
  377.  
  378. IF(IERR.NE.0) RETURN
  379. ICHPO1=IRET
  380. SEGDES,ICHARG
  381. 10 CONTINUE
  382. segsup mlmot5,mlmot6,plcf
  383. if (ipchpo.gt.0) then
  384. segsup icharg,mcharg
  385. call actobj('CHPOINT ',iret,1)
  386. call ecrobj('CHPOINT ',iret)
  387. goto 999
  388. endif
  389. SEGDES,MCHARG
  390. CALL ECROBJ('CHARGEME',MCHARG)
  391.  
  392. goto 999
  393. 99 segsup mpoval,msoupo,mchpoi
  394. call erreur(26)
  395. return
  396.  
  397.  
  398. 200 continue
  399. ipri1 = iprigi
  400. call SEPA(ipri1,1)
  401. ipri2 = iprigi
  402. call SEPA(ipri2,2)
  403. *
  404. *
  405. *
  406. *
  407. nmapmo = 100
  408. kpmo = 0
  409. segini pmapmo
  410. do isous = 1,kmodel(/1)
  411. imodel = kmodel(isous)
  412. cmate = cmatee
  413. meleme = imamod
  414. if (itypel.ne.1) call erreur(5)
  415. if (num(/1).ne.1) call erreur(5)
  416. if (cmate.eq.'STATIQUE'.or.cmate.EQ.'MODAL') then
  417. do ilp = 1,num(/2)
  418. kpmo = kpmo + 1
  419. if (kpmo.gt.nmapmo) then
  420. nmapmo = nmapmo + 100
  421. segadj pmapmo
  422. endif
  423. lmapmo(kpmo) = num(1,ilp)
  424. if (cmate.eq.'STATIQUE') then
  425. compmo(kpmo) = 'BETA'
  426. elseif (cmate.eq.'MODAL') then
  427. compmo(kpmo) = 'ALFA'
  428. endif
  429. do im = 1 , imache(/1)
  430. if (imache(im).eq.imamod) then
  431. if (conche(im).eq.conmod) then
  432. mchaml = ichaml(im)
  433. do iv = 1,ielval(/1)
  434. if (nomche(iv).eq.'DEFO') then
  435. melval = ielval(iv)
  436. ibmn = min(ilp,ielche(/2))
  437. defpmo(kpmo) = ielche(1,ibmn)
  438. endif
  439. if (nomche(iv).eq.'IDEF') then
  440. melval = ielval(iv)
  441. ibmn = min(ilp,ielche(/2))
  442. dimpmo(kpmo) = ielche(1,ibmn)
  443. endif
  444. enddo
  445. endif
  446. endif
  447. enddo
  448.  
  449. enddo
  450. endif
  451. enddo
  452.  
  453. nmapmo = kpmo
  454. segadj pmapmo
  455. nbmod = nmapmo
  456. *
  457. N1 = NBMOD
  458. nbcod = 8
  459. segini pmod
  460. SEGINI, MLCHP1
  461. SEGINI, MLCHP2
  462. jgm = 1
  463. jgn = 4
  464. segini mlmot4
  465. *
  466. * Constitution du maillage support et du segment descriptif
  467. *
  468. NBNN = NBMOD
  469. NBELEM = 1
  470. NBSOUS = 0
  471. NBREF = 0
  472. SEGINI, MELEME
  473. ITYPEL = 1
  474. *
  475. NLIGRD=NBMOD
  476. NLIGRP=NBMOD
  477. SEGINI, DESCR
  478. *
  479. mrigid = ipri1
  480. segact mrigid
  481. nrigel = coerig(/1)
  482. if (nrigel.lt.1) goto 250
  483. typmod = ' '
  484. IREEL = -1
  485. C* POS ? IF (POS.EQ.1) IREEL = 1
  486. *
  487. LETYPE = ' '
  488. DO 210 IM=1,NBMOD
  489. IPT1 = 0
  490. *
  491. imodel = kmodel(im)
  492. ipt1 = imamod
  493. iptr = ipt1.num(1,1)
  494. * Cas reel ou cas complexe ?
  495. *
  496. if (dimpmo(im).gt.0) TYPMOD = 'MODE_COM'
  497.  
  498. IF (TYPMOD .EQ. 'MODE_COM') THEN
  499. MODCOM=.TRUE.
  500. mchpoi = defpmo(im)
  501. MLCHP1.ICHPOI(IM) = MCHPOI
  502. mchpoi = dimpmo(im)
  503. MLCHP2.ICHPOI(IM) = MCHPOI
  504. ELSE
  505. MODCOM = .FALSE.
  506. mchpoi = defpmo(im)
  507. MLCHP1.ICHPOI(IM) = MCHPOI
  508. ENDIF
  509. *
  510. ipt1 = iptr
  511. *
  512. MELEME.NUM(IM,1)=IPT1
  513. *
  514. if (cmatee.eq.'MODAL') then
  515. DESCR.LISINC(IM) = 'ALFA'
  516. DESCR.LISDUA(IM) = 'FALF'
  517. else if (cmatee.eq.'STATIQUE') then
  518. DESCR.LISINC(IM) = 'BETA'
  519. DESCR.LISDUA(IM) = 'FBET'
  520. endif
  521. DESCR.NOELEP(IM) = IM
  522. DESCR.NOELED(IM) = IM
  523. *
  524. 210 CONTINUE
  525. *
  526. * Constitution des segments XMATRI
  527. *
  528. NLIGRD=NBMOD
  529. NLIGRP=NBMOD
  530. nelrig=1
  531. *
  532. IF (LETYPE .EQ. 'ANNULE') THEN
  533. SEGINI, XMATR1
  534. IF (MODCOM) THEN
  535. SEGINI, XMATR2
  536. SEGDES, XMATR2
  537. ENDIF
  538. SEGDES, XMATR1
  539. GOTO 55
  540. ENDIF
  541. *
  542. * Cas reel
  543. *
  544. SEGINI, XMATR1
  545. DO 20, I=1, NBMOD
  546. MCHPO1 = MLCHP1.ICHPOI(I)
  547. DO 20, J=1, NBMOD
  548. MCHPO2 = MLCHP1.ICHPOI(J)
  549. CALL YTMX (MCHPO2, MCHPO1, MRIGID, XVAL)
  550. XMATR1.RE(I,J,1)=XVAL
  551. 20 CONTINUE
  552. SEGDES, XMATR1
  553. *
  554. * Cas complexe : calcul de termes complementaires
  555. *
  556. IF (MODCOM) THEN
  557. SEGACT, XMATR1*mod
  558. DO 30, I=1, NBMOD
  559. MCHPO1 = MLCHP2.ICHPOI(I)
  560. DO 30, J=1, NBMOD
  561. MCHPO2 = MLCHP2.ICHPOI(J)
  562. CALL YTMX (MCHPO1, MCHPO2, MRIGID, XVAL)
  563. XMATR1.RE(I,J,1)=XMATR1.RE(I,J,1)-IREEL*XVAL
  564. 30 CONTINUE
  565. SEGDES, XMATR1
  566. *
  567. SEGINI, XMATR2
  568. DO 40, I=1, NBMOD
  569. MCHPO1 = MLCHP1.ICHPOI(I)
  570. DO 40, J=1, NBMOD
  571. MCHPO2 = MLCHP2.ICHPOI(J)
  572. CALL YTMX (MCHPO1, MCHPO2, MRIGID, XVAL)
  573. XMATR2.RE(I,J,1)=XVAL
  574. 40 CONTINUE
  575. DO 50, I=1, NBMOD
  576. MCHPO1 = MLCHP2.ICHPOI(I)
  577. DO 50, J=1, NBMOD
  578. MCHPO2 = MLCHP1.ICHPOI(J)
  579. CALL YTMX (MCHPO1, MCHPO2, MRIGID, XVAL)
  580. XMATR2.RE(I,J,1)=XMATR2.RE(I,J,1)+IREEL*XVAL
  581. 50 CONTINUE
  582. SEGDES, XMATR2
  583. ENDIF
  584. *
  585. SEGACT, MRIGID
  586. LETYPE = MRIGID.MTYMAT
  587. SEGDES, MRIGID
  588. *
  589. * Creation des segments IMATRI
  590. *
  591. 55 NELRIG = 1
  592. * SEGINI, IMATR1
  593. * IMATR1.IMATTT(1) = XMATR1
  594. SEGDES, xMATR1
  595. IF (MODCOM) THEN
  596. * SEGINI, IMATR2
  597. * IMATR2.IMATTT(1) = XMATR2
  598. SEGDES, xMATR2
  599. ENDIF
  600. *
  601. * Creation des rigidites calculees
  602. *
  603. NRIGE=7
  604. NRIGEL=1
  605. SEGINI, RI1
  606. RI1.MTYMAT = LETYPE
  607. RI1.IFORIG = IFOMOD
  608. RI1.IMGEO1 = 0
  609. RI1.IMGEO2 = 0
  610. RI1.COERIG = 1.D0
  611. RI1.IRIGEL(1,1) = MELEME
  612. RI1.IRIGEL(2,1) = 0
  613. RI1.IRIGEL(3,1) = DESCR
  614. RI1.IRIGEL(4,1) = xMATR1
  615. RI1.IRIGEL(5,1) = NIFOUR
  616. RI1.IRIGEL(6,1) = 0
  617. RI1.IRIGEL(7,1) = 2
  618. segact xmatr1*mod
  619. xmatr1.symre=2
  620. segdes xmatr1
  621. SEGDES, RI1
  622. IF (MODCOM) THEN
  623. SEGINI, RI2 = RI1
  624. RI2.IRIGEL(4,1) = xMATR2
  625. SEGDES, RI2
  626. ELSE
  627. RI2 = 0
  628. SEGSUP, MLCHP2
  629. ENDIF
  630. *
  631. iriout1 = ri1
  632. iriout2 = ri2
  633.  
  634. 250 continue
  635. mrigid = ipri2
  636. segact mrigid
  637. nrigel = coerig(/1)
  638. if (nrigel.lt.1) goto 290
  639. typmod = ' '
  640.  
  641. nrigmat =100
  642. kgmat = 0
  643. segini prigmat
  644.  
  645. KRIGEL = 0
  646. nrigel = irigel(/2)
  647. nrige = irigel(/1)
  648. segini ri1
  649. ri1.mtymat = mtymat
  650. nrige0 = nrigel
  651.  
  652. kige = 0
  653. kige1 = 100
  654. nrigel = kige1
  655. segini ri2
  656. ri2.mtymat = mtymat
  657.  
  658. DO ire = 1,nrige0
  659. meleme = irigel (1,ire)
  660. segact meleme
  661. if (itypel.ne.22) then
  662. call erreur(977)
  663. return
  664. endif
  665. nbelem = num(/2)
  666. nbele0 = nbelem
  667. descr = irigel(3,ire)
  668. segact descr
  669. nligrp0 = noelep(/1)
  670. nligrd0 = noeled(/1)
  671. nligrp = nligrp0 + nmapmo
  672. nligrd = nligrd0 + nmapmo
  673.  
  674. nbnn = num(/1)
  675. nbsous = 0
  676. nbref = 0
  677. segini ipt2
  678. ipt2.itypel = itypel
  679. nbelem = 1
  680. nbnn = nligrd
  681. segini ipt1
  682. ipt1.itypel = itypel
  683. ri1.coerig(ire) = coerig(ire)
  684. kele = 0
  685.  
  686. xmatr1 = irigel(4,ire)
  687. segact xmatr1
  688. nelrig0 = xmatr1.re(/3)
  689. nelrig = nelrig0 + nmapmo
  690. segini xmatr2
  691. DO iele = 1,nbele0
  692. ie2 = min(iele,nelrig0)
  693. * xmatr1 = imatr1.imattt(ie2)
  694. * segact xmatr1
  695. nligrp = nligrp0 + nmapmo
  696. nligrd = nligrd0 + nmapmo
  697. nelrig=1
  698. segini des2,xmatri
  699. des2.lisinc(1) = 'LX'
  700. des2.lisdua(1) = 'FLX'
  701. des2.noelep(1) = 1
  702. des2.noeled(1) = 1
  703. * le premier point correspond aux multiplicateurs
  704. CALL CREPO1 (ZERO, ZERO, ZERO, IPTS)
  705. ipt1.num(1,1) = ipts
  706. kgrp = 1
  707. kirp = 1
  708. do ipmo = 1,nmapmo
  709. coepmo(ipmo) = 0.d0
  710. enddo
  711. do igrp = 2,nligrp0
  712. jno = noelep(igrp)
  713. motinc = lisinc(igrp)
  714. IP1 = num(jno,iele)
  715. * recherche association noeud physique - points support déformée
  716. do ilmat = 1,kgmat
  717. if(lrigmat(ilmat,1).eq.ip1) goto 315
  718. enddo
  719.  
  720. kgmat = kgmat+1
  721. ilmat = kgmat
  722. if (kgmat.gt.nrigmat) then
  723. nrigmat = nrigmat + 100
  724. segadj prigmat
  725. endif
  726. kpb = 0
  727. jg = 100
  728. segini mlent3
  729. lrigmat(kgmat,1) = ip1
  730. do ikmo = 1, nmapmo
  731. ichp1 = defpmo(ikmo)
  732. call ecrcha('NOMU')
  733. call ecrcha('MAIL')
  734. call ecrobj('CHPOINT ',ichp1)
  735. call extrai
  736. call ecrobj('POINT ',IP1)
  737. call DANS
  738. call lirlog(l3,1,iretou)
  739. if(l3) then
  740. kpb = kpb + 1
  741. if (kpb.gt.jg) then
  742. jg = jg + 100
  743. segadj mlent3
  744. endif
  745. mlent3.lect(kpb) = ikmo
  746. endif
  747. enddo
  748. jg = kpb
  749. segadj mlent3
  750. if (kpb.gt.0) then
  751. lrigmat(ilmat,2) = mlent3
  752. else
  753. lrigmat(ilmat,2) = 0
  754. segsup mlent3
  755. endif
  756.  
  757. 315 continue
  758. ilr3 = lrigmat(ilmat,2)
  759. if (ilr3.eq.0) goto 253
  760. mlent3 = ilr3
  761. segact mlent3
  762. * selection selon nom composante
  763. mlmat = 0
  764. do lmo = 1,9
  765. if (motinc.eq.lcod(lmo)) mlmat = lmo+2
  766. enddo
  767. if (mlmat.eq.0) then
  768. * WRITE(6,*) 'coefs pour cette composante non trouves'
  769. goto 253
  770. endif
  771. if (lrigmat(ilmat,mlmat).ne.0) then
  772. pcompo = lrigmat(ilmat,mlmat)
  773. segact pcompo
  774. nipmod = valmod(/1)
  775. do ilg = 1,nipmod
  776. lkmo = mlent3.lect(ilg)
  777. coepmo(lkmo) = (valmod(ilg)* xmatr1.re(1,igrp,ie2))
  778. & + coepmo(lkmo)
  779. enddo
  780. else
  781. jg = mlent3.lect(/1)
  782. nipmod = jg
  783. segini pcompo
  784. mcol = motinc
  785. do ilg = 1,nipmod
  786. lkmo = mlent3.lect(ilg)
  787. ichp1 = defpmo(lkmo)
  788. CALL EXTRA9(ICHP1,ip1,motinc,0,.false.,XFLOT,IRET)
  789. coepmo(lkmo) = (xflot * xmatr1.re(1,igrp,ie2))
  790. & + coepmo(lkmo)
  791. valmod(ilg) = xflot
  792. enddo
  793. lrigmat(ilmat,mlmat) = pcompo
  794. endif
  795.  
  796. 253 continue
  797. enddo
  798.  
  799. xmaut1 = 0.d0
  800. do kpmo = 1,nmapmo
  801. xmaut1 = max(xmaut1,ABS(coepmo(kpmo)))
  802. enddo
  803.  
  804. * synthèse
  805. do igrp = 2,nligrp0
  806. jno = noelep(igrp)
  807. motinc = lisinc(igrp)
  808. IP1 = num(jno,iele)
  809. lr2 = .false.
  810. do jgmat = 1,kgmat
  811. if(lrigmat(jgmat,1).eq.ip1) goto 325
  812. enddo
  813. c WRITE(6,*) 'bizarre, point dans l element non repertorie'
  814. call erreur(5)
  815. return
  816. 325 continue
  817. mlmat = 0
  818. do lmo = 1,9
  819. if (motinc.eq.lcod(lmo)) mlmat = lmo+2
  820. enddo
  821. if (mlmat.eq.0) lr2 = .true.
  822. if (lrigmat(jgmat,mlmat).eq.0) lr2 = .true.
  823. if(lr2) then
  824. jirp = 0
  825. do iirp = 1,kgrp
  826. if (ipt1.num(iirp,1).eq.ip1) jirp = iirp
  827. enddo
  828. c recopie
  829. kgrp = kgrp + 1
  830. if (jirp.ne.0) then
  831. des2.noelep(kgrp) = des2.noelep(jirp)
  832. des2.noeled(kgrp) = des2.noeled(jirp)
  833. else
  834. kirp = kirp + 1
  835. ipt1.num(kirp,1) = ip1
  836. des2.noelep(kgrp) = kirp
  837. des2.noeled(kgrp) = kirp
  838. endif
  839. des2.lisinc(kgrp) = lisinc(igrp)
  840. des2.lisdua(kgrp) = lisdua(igrp)
  841. re(1,kgrp,1) = xmatr1.re(1,igrp,ie2)
  842. re(kgrp,1,1) = re(1,kgrp,1)
  843. endif
  844. *
  845. enddo
  846.  
  847. do kpmo = 1,nmapmo
  848. if (ABS(coepmo(kpmo)).gt.xlopre*xmaut1) then
  849. kirp = kirp + 1
  850. kgrp = kgrp + 1
  851. ipt1.num(kirp,1) = lmapmo(kpmo)
  852. des2.noelep(kgrp) = kirp
  853. des2.noeled(kgrp) = kirp
  854. des2.lisinc(kgrp) = compmo(kpmo)
  855. if (compmo(kpmo).eq.'ALFA') des2.lisdua(kgrp) = 'FALF'
  856. if (compmo(kpmo).eq.'BETA') des2.lisdua(kgrp) = 'FBET'
  857. re(1,kgrp,1) = coepmo(kpmo)
  858. re(kgrp,1,1) = re(1,kgrp,1)
  859. endif
  860. enddo
  861. *
  862. lirl = .false.
  863. if (kirp.ne.num(/1)) then
  864. lirl = .true.
  865. else
  866. do io = 1,kirp
  867. if (num(io,iele).ne.ipt1.num(io,1)) lirl=.true.
  868. enddo
  869. endif
  870. c creation d'un irigel
  871. if (lirl) then
  872. kige = kige + 1
  873. if (kige.gt.kige1) then
  874. nrigel = kige1 + 100
  875. segadj ri2
  876. kige1 = nrigel
  877. endif
  878. nbelem = 1
  879. nbnn = kirp
  880. segini ipt3
  881. ipt3.itypel = itypel
  882. do io =1,nbnn
  883. ipt3.num(io,1) = ipt1.num(io,1)
  884. enddo
  885. nligrp = kgrp
  886. nligrd = kgrp
  887. nelrig=1
  888. segadj xmatri,des2
  889. * segini imatr3
  890. * imatr3.imattt(1) = xmatri
  891. segdes ipt3,des2,xmatri
  892. RI2.IRIGEL(1,kige) = IPT3
  893. RI2.IRIGEL(3,kige) = DES2
  894. RI2.IRIGEL(4,kige) = xmatri
  895. RI2.IRIGEL(2,kige) = 0
  896. RI2.IRIGEL(5,kige) = irigel(5,ire)
  897. RI2.IRIGEL(6,kige) = irigel(6,ire)
  898. ri2.coerig(kige) = coerig(ire)
  899. else
  900. * relation non modifiee pour cet element
  901. kele = kele + 1
  902. do ig = 1,nligrp0
  903. ipt2.num(ig,kele) = ipt1.num(ig,1)
  904. enddo
  905. * imatr2.imattt(kele) = xmatr1
  906. * kich : a tester
  907. do ju = 1,kgrp
  908. xmatr2.re(1,ju,kele) = re(1,ju,1)
  909. xmatr2.re(ju,1,kele) = re(ju,1,1)
  910. enddo
  911. segsup xmatri,des2
  912. endif
  913. ENDDO
  914.  
  915. nbelem = kele
  916. nelrig = kele
  917. nligrd=xmatr2.re(/1)
  918. nligrp=xmatr2.re(/2)
  919. if (nbelem.gt.0) then
  920. segadj ipt2
  921. segadj xmatr2
  922. krigel = krigel + 1
  923. RI1.IRIGEL(1,krigel) = IPT2
  924. RI1.IRIGEL(3,krigel) = irigel(3,ire)
  925. RI1.IRIGEL(4,krigel) = xmatr2
  926. RI1.IRIGEL(2,krigel) = 0
  927. RI1.IRIGEL(5,krigel) = irigel(5,ire)
  928. RI1.IRIGEL(6,krigel) = irigel(6,ire)
  929. segdes ipt2,xmatr2
  930. else
  931. segsup ipt2
  932. endif
  933. segsup ipt1
  934. ENDDO
  935.  
  936. iriout = 0
  937. nrigel = krigel
  938. segadj ri1
  939. nrigel = kige
  940. segadj ri2
  941. segdes mrigid,ri1,ri2
  942. if (kige.eq.0) segsup ri2
  943. if (krigel.eq.0) segsup ri1
  944. if (kige.gt.0.and.krigel.gt.0) then
  945. c WRITE(6,*) 'fus', ri1,ri2,kige,krigel
  946. call fusrig(ri1,ri2,iriout)
  947. segsup ri1, ri2
  948. return
  949. endif
  950. if (kige.gt.0) iriout = ri2
  951. if (krigel.gt.0) iriout = ri1
  952. if (iriout.eq.0) call erreur(-5)
  953. c WRITE(6,*) 'iriout', iriout
  954.  
  955. 290 continue
  956. if (iriout.ne.0) iriout3 = iriout
  957. if (iriout1.ne.0) iriout3 = iriout1
  958. if (iriout.ne.0.and.iriout1.ne.0) then
  959. call fusrig(iriout, iriout1,iriout3)
  960. ri1 = iriout
  961. ri2 = iriout1
  962. segsup ri1,ri2
  963. endif
  964.  
  965. call ecrobj('RIGIDITE',iriout3)
  966. if (modcom) call ecrobj('RIGIDITE',iriout2)
  967.  
  968. goto 999
  969.  
  970. 199 continue
  971. segsup descr,meleme,mlchp1,mlchp2
  972. call erreur(5)
  973. return
  974.  
  975. 999 continue
  976.  
  977. if (plcf.ne.0) segsup plcf
  978.  
  979. END
  980.  
  981.  
  982.  

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