Télécharger rima.eso

Retour à la liste

Numérotation des lignes :

  1. C RIMA SOURCE PV 17/09/29 21:15:55 9578
  2. subroutine rima
  3.  
  4. ********************************************
  5. * traduction objet rigi en matrik
  6. * ou matrik en rigi
  7. *
  8. *******************************************
  9.  
  10. IMPLICIT INTEGER(I-N)
  11. IMPLICIT REAL*8 (A-H,O-Z)
  12.  
  13. -INC CCOPTIO
  14. -INC SMLENTI
  15. POINTEUR NOFSET.MLENTI
  16. -INC SMELEME
  17. POINTEUR MELPRI.MELEME,MELDUA.MELEME
  18. POINTEUR SMLPRI.MELEME,SMLDUA.MELEME
  19. -INC SMRIGID
  20. -INC SMLMOTS
  21. *INC SMMATRIK
  22.  
  23. CHARACTER*8 MOTCLE(1)
  24. DATA MOTCLE /'NSYM'/
  25.  
  26. SEGMENT MATRIK
  27. REAL*8 COEMTK(NMATRI)
  28. INTEGER jRIGEL(NRIGE,NMATRI)
  29. INTEGER KSYM,KMINC,KMINCP,KMINCD,KIZM
  30. INTEGER KISPGT,KISPGP,KISPGD
  31. INTEGER KNTTT,KNTTP,KNTTD
  32. INTEGER KIDMAT(NKID)
  33. INTEGER KKMMT(NKMT)
  34. ENDSEGMENT
  35.  
  36. SEGMENT jMATRI
  37. CHARACTER*8 LISPRj(NBME),LISDUb(NBME)
  38. INTEGER LIZAFM(NBSOUS,NBME)
  39. INTEGER KSPGP,KSPGD
  40. ENDSEGMENT
  41.  
  42. C Stokage matrices elementaires non assemblees (valeurs)
  43. SEGMENT IZAFM
  44. REAL*8 AM(NBEL,NP,MP)
  45. ENDSEGMENT
  46. POINTEUR IPM1.IZAFM,IPM2.IZAFM,IPM3.IZAFM,IPM4.IZAFM
  47. POINTEUR IPM5.IZAFM,IPM6.IZAFM,IPM7.IZAFM,IPM8.IZAFM
  48. POINTEUR IPM9.IZAFM
  49.  
  50. C Reperage des inconnues
  51. SEGMENT MINC
  52. CHARACTER*8 LISjNC(NBI)
  53. INTEGER NPOS(NPT+1)
  54. INTEGER MPOS(NPT,NBI+1)
  55. ENDSEGMENT
  56. POINTEUR MINCP.MINC,MINCD.MINC
  57.  
  58. SEGMENT PMORS
  59. INTEGER IA (NTT+1)
  60. INTEGER JA (NJA)
  61. ENDSEGMENT
  62. POINTEUR PMS1.PMORS,PMS2.PMORS
  63.  
  64. C Segment de stokage
  65. SEGMENT IZA
  66. REAL*8 A(NBVA)
  67. ENDSEGMENT
  68. POINTEUR IZA1.IZA,IZA2.IZA,IZAU.IZA,IZAL.IZA,ISA.IZA
  69.  
  70. SEGMENT IDMAT
  71. INTEGER KZA(NTT),NUIA(NTT,2)
  72. INTEGER NUAN(NPT),NUNA(NPT)
  73. INTEGER IDIAG
  74. INTEGER IDESCL(NBLK)
  75. INTEGER IDESCU(NBLK)
  76. INTEGER NLDBLK(NBLK+1)
  77. ENDSEGMENT
  78.  
  79. C*******************************************************************
  80. C
  81. C REPERAGE ET STOKAGE DES MATRICES ELEMENTAIRES puis assemblees
  82. C (description par sous-zone associees a un operateur)
  83. C
  84. C IRIGEL(1,I) : POINTEUR SUR L'OBJET GEOMETRIE (Inconnues primales)
  85. C IRIGEL(2,I) : POINTEUR SUR L'OBJET GEOMETRIE (Inconnues duales)
  86. C IRIGEL(3,I) : Non utilise (POINTEUR SUR LE SEGMENT DESCRIPTIF D'UNE
  87. C MATRICE ELEMENTAIRE.(SEGMENT DESCR)
  88. C IRIGEL(4,I) : POINTEUR SUR LE SEGMENT CONTENANT LES POINTEURS
  89. C DES MATRICES DE MRIGIDITE DE CHAQUE ELEMENTS.
  90. C (SEGMENT IMATRI)
  91. C IRIGEL(5,I) : Non utilise
  92. C IRIGEL(6,I) : Non utilise
  93. C IRIGEL(7,1) : 0 LA MATRICE EST SYMETRIQUE
  94. C : 1 LA MATRICE EST ANTISYMETRIQUE
  95. C : 2 LA MATRICE EST NON SYMETRIQUE
  96. C : 3 LA MATRICE EST RECTANGULAIRE avec SPGP # SPGD
  97. C : 4 LA MATRICE EST type 3 et CCt (on ne stoke que C)
  98. C : 5 LA MATRICE EST diagonale
  99. C : 6 LA MATRICE EST deja assemblee en morse
  100.  
  101. C KSIM =0 matrice symetrique =2 matrice non symetrique
  102. C KMINC , KMINCP , KMINCD : pointeur sur MINC repartition des inconnues
  103. C totales primales et duales PROFKS PKINC
  104. C KIZM : pointeur sur les connectivites globales
  105. C KISPGT KISPGP KISPGD ; SPG assemble pour inc totales,prim et dua
  106. C KNTTT KNTTP KNTTD ; nb d'inconnues total
  107.  
  108.  
  109. C KIDMAT: pointeur sur stokage bloc IDMAT (Cholevski) TRIAKS
  110. C KS2B : pointeur sur second membre(IZA)cree ds PROFKS calcule ds KASMBR
  111. C KMORS : pointeur sur profil Morse(PMORS) ASSMT (KALMOR)
  112. C KISA : pointeur sur stokage Morse(IZA) ASSMT (KALMOR)
  113. C KMRST : pointeur sur profil Morse(PMORS)de AAt PROFKS(KALMOR)
  114. C KIST : pointeur sur stokage Morse(IZA) de AAt PROFKS(KALMOR)
  115. C KCLIM : pointeur sur stokage C lim (CHPT)
  116. C KTRING: 0 pas triangulée 1 triangulée
  117.  
  118. C nkid=9 : IDMATP,IDMATD,KS2B,KMORS,KISA,KMRST,KIST,KCLIM,KTRING
  119.  
  120. C LIZAFM(NBSOUS,.) description par sous-objet geometrique -> IZAFM
  121. C KSPGP , KSPGD : SPG pour les inconnues primales et duales
  122. C nkmt=7 : KMMT,MATRIU,MATRIP,IZDU,IZDP,IZFU,IZFP
  123. C (IZA)(IZA)(IZA)(IZA)
  124. * NPT nb de noeud NBI nb de composantes total NTT nb total de DDL
  125. * MPOS(NPT,NBI+1) = 0 si l'inconnue j n est pas defini au noeud i
  126. * sinon = k rang de cette inconnue pour le noeud i
  127. * MPOS(i,NBI+1) nb d'inconnues au noeud i
  128. * NPOS(NPT) Position de la 1ere inconnue du noeud i
  129. * NPOS et MPOS sont donnes ds la numerotation optimisee
  130. * KZA(NTT) Longueur de chaque ligne de la matrice (diag comprise)
  131. * NUIA(NTT,2) 1/ numero du bloc dans lequel se trouve la ligne i de la
  132. * matrice
  133. * 2/ position du debut de la ligne dans le segment IZA - 1
  134.  
  135. C*******************************************************************
  136.  
  137. segment iztra
  138. character*4 lisp(l1)
  139. integer itab(l1,l2),ltab(l1)
  140. endsegment
  141. segment jztra
  142. character*4 lisd(l3)
  143. integer jtab(l3,l2),ktab(l3)
  144. endsegment
  145.  
  146.  
  147. character*8 type,typp
  148. character*4 nomi
  149. * WRITE(IOIMP,*) ' entree dans rima'
  150. impj = 1
  151. * impj = 0
  152. impr=0
  153.  
  154. call quetyp(typp,0,iret)
  155. * WRITE(IOIMP,*)' typp ',typp
  156.  
  157. if(typp.eq.'MATRIK')then
  158. type = typp
  159. CALL LIROBJ(TYPE,MATRIK,1,IRET)
  160. * WRITE(IOIMP,*)' iret ',iret,' ierr ',ierr
  161. CALL LIRMOT(MOTCLE,1,IVAL,0)
  162. * WRITE(IOIMP,*)' IVAL ',IVAL
  163. type ='MATRIK'
  164. segact matrik
  165. nmatri = jrigel(/2)
  166. if(impj.eq.0)then
  167. WRITE(IOIMP,*)' MATRIK '
  168. WRITE(IOIMP,*)' nmatri ',nmatri
  169. nrigel = jrigel(/1)
  170. do ik=1,nmatri
  171. WRITE(IOIMP,*) ik
  172. WRITE(IOIMP,*)(jrigel(il,ik),il=1,nrigel)
  173. WRITE(IOIMP,*)' '
  174. meleme= jrigel(1,ik)
  175. segact meleme
  176. nbs=lisous(/1)
  177. WRITE(IOIMP,*)' nbre ssobjt mail p',nbs
  178. if(nbs.eq.0) then
  179. nbnn=num(/1)
  180. nbl= num(/2)
  181. do iel=1,nbl
  182. WRITE(IOIMP,*)iel,' ',(num(io,iel),io=1,nbnn)
  183. enddo
  184. endif
  185. if(nbs.ge.1)then
  186. WRITE(IOIMP,*)' ssobjet maill',(lisous(io),io=1,nbs)
  187. do iss=1,nbs
  188. ipt1=lisous(iss)
  189. segact ipt1
  190. nbnn=ipt1.num(/1)
  191. nbl =ipt1.num(/2)
  192. WRITE(IOIMP,*)' nbl ',nbl,' nbnn ',nbnn
  193. do il = 1,nbl
  194. WRITE(IOIMP,*)il,' ',(ipt1.num(iop,il),iop=1
  195. $ ,nbnn)
  196. enddo
  197. segdes ipt1
  198. enddo
  199. endif
  200. segdes meleme
  201. meleme= jrigel(2,ik)
  202. segact meleme
  203. nbs=lisous(/1)
  204. WRITE(IOIMP,*)' nbre ssobjt mail d',nbs
  205. if(nbs.eq.0) then
  206. nbnn=num(/1)
  207. nbl= num(/2)
  208. do iel=1,nbl
  209. WRITE(IOIMP,*)iel,' ',(num(io,iel),io=1,nbnn)
  210. enddo
  211. endif
  212. if(nbs.ge.1)then
  213. WRITE(IOIMP,*)' ssobjet maill',(lisous(io),io=1,nbs)
  214. do iss=1,nbs
  215. ipt1=lisous(iss)
  216. segact ipt1
  217. nbnn=ipt1.num(/1)
  218. nbl =ipt1.num(/2)
  219. WRITE(IOIMP,*)' nbl ',nbl,' nbnn ',nbnn
  220. do il = 1,nbl
  221. WRITE(IOIMP,*)il,' ',(ipt1.num(iop,il),iop=1
  222. $ ,nbnn)
  223. enddo
  224. segdes ipt1
  225. enddo
  226. endif
  227. segdes meleme
  228. enddo
  229. WRITE(IOIMP,*)'ksym kminc kmincd kizm'
  230. WRITE(IOIMP,*) ksym,kminc,kmincd,kizm
  231. WRITE(IOIMP,*)'kispgt kispgp kispgd knttt knttp knttd'
  232. WRITE(IOIMP,*) kispgt,kispgp,kispgd,knttt,knttp,knttd
  233. nkid=kidmat(/1)
  234. WRITE(IOIMP,*)' kidmat '
  235. WRITE(IOIMP,*)(kidmat(il),il=1,nkid)
  236. nkmt=kkmmt(/1)
  237. WRITE(IOIMP,*)' kkmmt '
  238. WRITE(IOIMP,*)(kkmmt(il),il=1,nkmt)
  239. do ik=1,nmatri
  240. WRITE(IOIMP,*)' ik ',ik
  241. jmatri = jrigel(4,ik)
  242. segact jmatri
  243. nbme = lisprj(/2)
  244. nbsous = lizafm(/1)
  245. WRITE(IOIMP,*)' nbme nbsous kspgp kspgd '
  246. WRITE(IOIMP,*) nbme,nbsous,kspgp,kspgd
  247. WRITE(IOIMP,*)' lisprj '
  248. WRITE(IOIMP,*)(lisprj(il),il=1,nbme)
  249. WRITE(IOIMP,*)' lisdub '
  250. WRITE(IOIMP,*)(lisdub(il),il=1,nbme)
  251. do im=1,nbme
  252. WRITE(IOIMP,*)' im ',im
  253. do is=1,nbsous
  254. WRITE(IOIMP,*)' is ',is
  255. izafm = lizafm(is,im)
  256. segact izafm
  257. nbel=am(/1)
  258. np=am(/2)
  259. mp=am(/3)
  260. WRITE(IOIMP,*)' nbel np mp'
  261. WRITE(IOIMP,*) nbel,np,mp
  262. do ie=1,nbel
  263. WRITE(IOIMP,*)' iel ',ie
  264. do ip =1,np
  265. WRITE(IOIMP,*)ip,(am(ie,ip,kp),kp=1,mp)
  266. enddo
  267. enddo
  268. segdes izafm
  269. enddo
  270. enddo
  271. segdes jmatri
  272. enddo
  273. endif
  274.  
  275. * Ligne suivante inutile cf include SMRIGID
  276. * nrige = 8
  277. nrigel = 0
  278. do ir=1,nmatri
  279. ir7=jrigel(7,ir)
  280. ncmul=1
  281. if (ir7.EQ.4) ncmul=2
  282. jmatri=jrigel(4,ir)
  283. segact jmatri
  284. nbs=lizafm(/1)
  285. nbe=lizafm(/2)
  286. nrigel=nrigel+nbs*nbe*ncmul
  287. enddo
  288.  
  289. segini mrigid
  290. jr=0
  291. do ir=1,nmatri
  292. ir7=jrigel(7,ir)
  293. ncmul=1
  294. if (ir7.EQ.4) ncmul=2
  295. mtymat='MATRIK '
  296. jmatri=jrigel(4,ir)
  297. nbs=lizafm(/1)
  298. nbe=lizafm(/2)
  299. melpri =jrigel(1,ir)
  300. meldua =jrigel(2,ir)
  301. jg=nbs
  302. segini nofset
  303. if (melpri.eq.meldua) then
  304. * Write(ioimp,*) 'Cas melpri=meldua'
  305. meleme=melpri
  306. else
  307. * Write(ioimp,*) 'Cas melpri.ne.meldua'
  308. * On s'arrange pour que les deux maillages aient le même nombre de
  309. * sous-maillages
  310. call fixmel(melpri,meldua,melpr2,meldu2,impr,iret)
  311. if (iret.ne.0) goto 9999
  312. melpri=melpr2
  313. meldua=meldu2
  314. segact melpri,meldua
  315. nbsou1=melpri.lisous(/1)
  316. nbsou2=meldua.lisous(/1)
  317. * write(ioimp,*) 'nbsou1=',nbsou1
  318. * write(ioimp,*) 'nbsou2=',nbsou2
  319. * write(ioimp,*) 'nbs=',nbs
  320. if (nbsou1.ne.nbsou2) goto 9999
  321. if (max(1,nbsou1).ne.nbs) goto 9999
  322. if (nbsou1.eq.0) then
  323. nbnn1=melpri.num(/1)
  324. nbnn2=meldua.num(/1)
  325. nbel1=melpri.num(/2)
  326. nbel2=meldua.num(/2)
  327. if (nbel1.ne.nbel2) goto 9999
  328. nofset.lect(1)=nbnn1
  329. nbnn=nbnn1+nbnn2
  330. nbelem=nbel1
  331. nbref=0
  332. nbsous=0
  333. segini meleme
  334. do ibelem=1,nbelem
  335. do ibnn1=1,nbnn1
  336. num(ibnn1,ibelem)=melpri.num(ibnn1,ibelem)
  337. enddo
  338. do ibnn2=1,nbnn2
  339. num(ibnn2+nbnn1,ibelem)=meldua.num(ibnn2,ibelem)
  340. enddo
  341. enddo
  342. segdes meleme
  343. segdes melpri,meldua
  344. else
  345. nbsous=nbs
  346. nbref=0
  347. nbnn=0
  348. nbelem=0
  349. segini meleme
  350. do isous=1,nbs
  351. smlpri=melpri.lisous(isous)
  352. smldua=meldua.lisous(isous)
  353. segact smlpri,smldua
  354. nbnn1=smlpri.num(/1)
  355. nbnn2=smldua.num(/1)
  356. nbel1=smlpri.num(/2)
  357. nbel2=smldua.num(/2)
  358. if (nbel1.ne.nbel2) goto 9999
  359. nofset.lect(isous)=nbnn1
  360. nbnn=nbnn1+nbnn2
  361. nbelem=nbel1
  362. nbref=0
  363. nbsous=0
  364. segini ipt1
  365. do ibelem=1,nbelem
  366. do ibnn1=1,nbnn1
  367. ipt1.num(ibnn1,ibelem)=smlpri.num(ibnn1
  368. $ ,ibelem)
  369. enddo
  370. do ibnn2=1,nbnn2
  371. ipt1.num(ibnn2+nbnn1,ibelem)=smldua.num(ibnn2
  372. $ ,ibelem)
  373. enddo
  374. enddo
  375. segdes ipt1
  376. segdes smlpri,smldua
  377. lisous(isous)=ipt1
  378. enddo
  379. segdes meleme
  380. endif
  381. endif
  382. * WRITE(IOIMP,*)' meleme ',meleme
  383. * call ecmail(meleme,1)
  384. segact meleme
  385. nbs2 = lisous(/1)
  386. if(nbs2 .eq.0) then
  387. nbs2 = 1
  388. endif
  389. if (nbs.ne.nbs2) then
  390. write(ioimp,*) 'lizafm non compatible avec meleme'
  391. goto 9999
  392. endif
  393. * WRITE(IOIMP,*)' aa '
  394. do icmul=1,ncmul
  395. do is=1,nbs
  396. do in=1,nbe
  397. jr =jr+1
  398. * WRITE(IOIMP,*)' jr ',jr,ir,is,in
  399. coerig(jr)=1.d0
  400. if(nbs.eq.1) then
  401. irigel(1,jr)=meleme
  402. else
  403. irigel(1,jr)=lisous(is)
  404. endif
  405. * WRITE(IOIMP,*)' bb '
  406. irigel(2,jr)=0
  407. irigel(5,jr)=0
  408. irigel(6,jr)=0
  409. ii = jrigel(7,ir)
  410. if(ii.le.2) then
  411. irigel(7,jr)=ii
  412.  
  413. if(IVAL.EQ.1.AND.ii.EQ.0)then
  414. irigel(7,jr)=2
  415. endif
  416.  
  417. elseif(ii.eq.3)then
  418. * WRITE(IOIMP,*)' support primal dual differents '
  419. * WRITE(IOIMP,*)' on ne fait rien'
  420. * segsup mrigid
  421. * return
  422. irigel(7,jr)=2
  423. elseif(ii.eq.4)then
  424. irigel(7,jr)=2
  425. icc = 1
  426. elseif(ii.eq.5)then
  427. irigel(7,jr)=2
  428. elseif(ii.eq.6)then
  429. WRITE(IOIMP,*
  430. $ )' matrice de type morse on ne fait rien'
  431. goto 9999
  432. * segsup mrigid
  433. * return
  434. endif
  435. irigel(7,jr)=jrigel(7,ir)
  436.  
  437. if(IVAL.EQ.1.AND.jrigel(7,ir).EQ.0)then
  438. irigel(7,jr)=2
  439. endif
  440.  
  441. irigel(8,jr)=0
  442. iforig=-1
  443. jmatri = jrigel(4,ir)
  444. izafm=lizafm(is,in)
  445. segact izafm
  446. nbel=am(/1)
  447. nelrig=nbel
  448. if (icmul.eq.1) then
  449. * recopier les matrices élémentaires
  450. nligrp=am(/2)
  451. nligrd=am(/3)
  452. segini descr,xmatri
  453. irigel(3,jr)=descr
  454. irigel(4,jr)=Xmatri
  455. xmatri.symre=irigel(7,jr)
  456. do il=1,nligrp
  457. lisinc(il)=lisprj(in)(1:4)
  458. noelep(il)=il
  459. enddo
  460. do il=1,nligrd
  461. lisdua(il)=lisdub(in)(1:4)
  462. noeled(il)=il+nofset.lect(is)
  463. enddo
  464. do ip=1,nbel
  465. do iu=1,nligrp
  466. do ju=1,nligrd
  467. re(ju,iu,ip)=am(ip,iu,ju)
  468. enddo
  469. enddo
  470. enddo
  471. segdes xmatri,descr
  472. else
  473. * recopier les transposées des matrices élémentaires
  474. nligrd=am(/2)
  475. nligrp=am(/3)
  476. segini descr,xmatri
  477. irigel(3,jr)=descr
  478. irigel(4,jr)=Xmatri
  479. xmatri.symre=irigel(7,jr)
  480. do il=1,nligrp
  481. lisinc(il)=lisdub(in)(1:4)
  482. noelep(il)=il+nofset.lect(is)
  483. enddo
  484. do il=1,nligrd
  485. lisdua(il)=lisprj(in)(1:4)
  486. noeled(il)=il
  487. enddo
  488. do ip=1,nbel
  489. do iu=1,nligrp
  490. do ju=1,nligrd
  491. re(ju,iu,ip)=am(ip,ju,iu)
  492. enddo
  493. enddo
  494. enddo
  495. segdes xmatri,descr
  496. endif
  497. segdes izafm
  498. enddo
  499. enddo
  500. enddo
  501.  
  502. segdes meleme
  503. segdes jmatri
  504. segsup nofset
  505. enddo
  506. segdes mrigid
  507. segdes matrik
  508. CALL ECRobj('RIGIDITE',mrigid)
  509. return
  510. elseif(typp.eq.'RIGIDITE') then
  511. type='RIGIDITE'
  512. call lirobj(type,mrigid,1,iret)
  513. * WRITE(IOIMP,*)' rigidite '
  514.  
  515. * On regarde si il y a un autre argument.
  516. * Si ce n'est pas le cas on appele RIMB
  517. * qui termine le travail.
  518. * Modif GBM
  519.  
  520. call quetyp(typp,0,iret)
  521. if(typp.ne.'MAILLAGE') then
  522. call RIMB(mrigid)
  523. return
  524. endif
  525.  
  526. * fin de modif GBM 18/12/02
  527.  
  528. type='MAILLAGE'
  529. call lirobj(type,mele ,1,iret)
  530. * WRITE(IOIMP,*)' mele ',mele,iret
  531. *
  532. * eventuellemnt liste nom composante
  533. *
  534. ico = 0
  535. jmo=0
  536. lmo=0
  537. call quetyp(typp,ico,iret)
  538. if(typp.eq.'LISTMOTS') then
  539. call lirobj(typp,mlmots,0,iret)
  540. segact mlmots
  541. jmo = mots(/1)
  542. lmo = mots(/2)
  543. endif
  544. segact mrigid
  545. nrigel=irigel(/2)
  546. nrige =irigel(/1)
  547.  
  548. if(impj.eq.0) then
  549. WRITE(IOIMP,*)' nrigel',nrigel,' nrige ',nrige
  550. WRITE(IOIMP,*)' mtymat ',mtymat
  551. do ir =1,nrigel
  552. WRITE(IOIMP,*)' ir ',ir
  553. WRITE(IOIMP,*)(irigel(ik,ir),ik=1,nrige)
  554. WRITE(IOIMP,*)' '
  555. meleme=irigel(1,ir)
  556. segact meleme
  557. nbs=lisous(/1)
  558. WRITE(IOIMP,*)' nbre ssobjt mail ',nbs
  559. if(nbs.eq.0) then
  560. nbnn=num(/1)
  561. nbl=num(/2)
  562. do iel=1,nbl
  563. WRITE(IOIMP,*)iel,' ',(num(io,iel),io=1,nbnn)
  564. enddo
  565. endif
  566. if(nbs.ge.1)then
  567. WRITE(IOIMP,*)' ssobjet maill',(lisous(io),io=1,nbs)
  568. do iss=1,nbs
  569. ipt1=lisous(iss)
  570. segact ipt1
  571. nbnn=ipt1.num(/1)
  572. nbl =ipt1.num(/2)
  573. WRITE(IOIMP,*)' nbl ',nbl,' nbnn ',nbnn
  574. do il = 1,nbl
  575. WRITE(IOIMP,*)il,' ',(ipt1.num(iop,il),iop=1
  576. $ ,nbnn)
  577. enddo
  578. segdes ipt1
  579. enddo
  580. endif
  581. segdes meleme
  582. enddo
  583. WRITE(IOIMP,*)' coerig '
  584. WRITE(IOIMP,*)(coerig(ik),ik=1,nrigel)
  585. WRITE(IOIMP,*)' ichole imgeo1 imgeo2 iforig '
  586. WRITE(IOIMP,*) ichole,imgeo1,imgeo2,iforig
  587. WRITE(IOIMP,*)' isupeq jrcond jrdepp jrdepd '
  588. WRITE(IOIMP,*) isupeq,jrcond,jrdepp,jrdepd
  589. WRITE(IOIMP,*)' jrelim jrgard jrtot '
  590. WRITE(IOIMP,*) jrelim,jrgard,jrtot
  591. do ir=1,nrigel
  592. xmatri = irigel(4,ir)
  593. descr = irigel(3,ir)
  594. segact xmatri,descr
  595. nelrig = re(/3)
  596. nligrp = noelep(/1)
  597. nligrd = noeled(/1)
  598. WRITE(IOIMP,*)' nelrig nligrp nligrd '
  599. WRITE(IOIMP,*) nelrig,nligrp,nligrd
  600. WRITE(IOIMP,*)' lisinc '
  601. WRITE(IOIMP,*)(lisinc(io),io=1,nligrp)
  602. WRITE(IOIMP,*)' lisdua '
  603. WRITE(IOIMP,*)(lisdua(io),io=1,nligrd)
  604. WRITE(IOIMP,*)' noelep '
  605. WRITE(IOIMP,*)(noelep(io),io=1,nligrp)
  606. WRITE(IOIMP,*)' noeled '
  607. WRITE(IOIMP,*)(noeled(io),io=1,nligrd)
  608. do ie=1, nelrig
  609. * xmatri = imattt(ie)
  610. * segact xmatri
  611. WRITE(IOIMP,*)' iel ',ie
  612. do ij =1,nligrd
  613. WRITE(IOIMP,*)ij,(re(ij,kj,ie),kj=1,nligrp)
  614. enddo
  615. * segdes xmatri
  616. enddo
  617. segdes xmatri,descr
  618. enddo
  619. endif
  620.  
  621. nmatri = nrigel
  622. nrige = 7
  623. nrig = irigel(/1)
  624. nkid=9
  625. nkmt=7
  626. segini matrik
  627. * WRITE(IOIMP,*)' creation matrik',matrik
  628. do in=1,nrigel
  629. jrigel(1,in)=irigel(1,in)
  630. jrigel(2,in)=irigel(1,in)
  631. meleme = irigel(1,in)
  632. segact meleme
  633. jrigel(7,in)=0
  634. if(nrig.gt.6) then
  635. jrigel(7,in)=irigel(7,in)
  636. endif
  637. * WRITE(IOIMP,*)' in ',in,irigel(7,in)
  638. * WRITE(IOIMP,*)' in ',in,irigel(6,in)
  639. if(irigel(6,in).ne.0)then
  640. segsup matrik
  641. WRITE(IOIMP,*)' matrice definie par une inegalite'
  642. return
  643. endif
  644. if(irigel(5,in).ne.0) then
  645. segsup matrik
  646. WRITE(IOIMP,*)' harmonique de fourier non nulle'
  647. return
  648. endif
  649. coef = coerig(in)
  650. descr=irigel(3,in)
  651. segact descr
  652. xmatri = irigel(4,in)
  653. segact xmatri
  654. nbp = noelep(/1)
  655. nbd = noeled(/1)
  656. np = num(/1)
  657. nbme = nbp/np*nbd/np
  658. nbel = num(/2)
  659. mp =np
  660. nbsous=1
  661. segini jmatri
  662. jrigel(4,in)=jmatri
  663. * WRITE(IOIMP,*)' jmatri ',jmatri
  664.  
  665. * WRITE(IOIMP,*)' jrigel ',(jrigel(iop,in),iop=1,7)
  666.  
  667.  
  668.  
  669. l1=nbp/np
  670. l2=np
  671. segini iztra
  672. * WRITE(IOIMP,*)' iztra ',iztra,l1,l2
  673. k0 = 1
  674. lisp(1)=lisinc(1)
  675. do io=1,np
  676. itab(1,io)=io
  677. enddo
  678. ltab(1)=1
  679. do j=2,nbp
  680. nomi=lisinc(j)
  681. do l=1,k0
  682. if(nomi.eq.lisp(l))then
  683. k=ltab(l)+1
  684. itab(l,k)=j
  685. ltab(l)=k
  686. go to 30
  687. endif
  688. enddo
  689. k0=k0+1
  690. lisp(k0)=nomi
  691. ltab(k0)=1
  692. itab(k0,1)=j
  693. 30 continue
  694. enddo
  695. l3=nbd/np
  696. l2=np
  697. segini jztra
  698. k0 = 1
  699. lisd(1)=lisdua(1)
  700. do io=1,np
  701. jtab(1,io)=io
  702. enddo
  703. ktab(1)=1
  704. do j=2,nbd
  705. nomi=lisdua(j)
  706. do l=1,k0
  707. if(nomi.eq.lisd(l))then
  708. k=ktab(l)+1
  709. jtab(l,k)=j
  710. ktab(l)=k
  711. go to 31
  712. endif
  713. enddo
  714. k0=k0+1
  715. lisd(k0)=nomi
  716. ktab(k0)=1
  717. jtab(k0,1)=j
  718. 31 continue
  719. enddo
  720. k=0
  721. do lp=1,l1
  722. do ld=1,l3
  723. k=k+1
  724. lisprj(k)=lisp(lp)
  725. * lisdub(k)=lisd(ld)
  726. lisdub(k)=lisp(ld)
  727. if(lmo.ne.0.and.lmo.ge.lp)then
  728. lisprj(k)= mots(lp)
  729. lisdub(k)= mots(ld)
  730. endif
  731. segini izafm
  732. lizafm(1,k)=izafm
  733. kspgp = mele
  734. kspgd = mele
  735. * WRITE(IOIMP,*)' kspgp ',kspgp
  736. do ip =1,nbel
  737. * xmatri = imattt(ip)
  738. * segact xmatri
  739. ll=0
  740. do ki=1,np
  741. do kj=1,np
  742. il= noelep(ki)
  743. jl= noeled(kj)
  744. ii=itab(lp,ki)
  745. jj=jtab(ld,kj)
  746. * am(ip,il,jl)=coef * re(jj,ii)
  747. ll=ll+1
  748. il=noelep(ii)
  749. jl=noelep(jj)
  750. if(ip.eq.1)then
  751. * WRITE(IOIMP,*)' lp ',lp,' ki ',ki,' nop ',il,' ii ',ii,' ip ',ip
  752. * WRITE(IOIMP,*)' ld ',ld,' kj ',kj,' nod ',jl,' jj ',jj
  753. endif
  754. am(ip,il,jl)=coef * re(jj,ii,ip)
  755. ***** am(ip,ki,kj)=coef * re(ii,jj)
  756. enddo
  757. enddo
  758. * segdes xmatri
  759. enddo
  760. * WRITE(IOIMP,*)' finfin '
  761. segdes izafm
  762. enddo
  763. enddo
  764. * WRITE(IOIMP,*)' fin 1 '
  765. segsup iztra,jztra
  766. segdes descr,xmatri
  767. segdes jmatri
  768. * WRITE(IOIMP,*)' segdes 1 '
  769. enddo
  770. segdes mrigid
  771. * WRITE(IOIMP,*)' jrigel ',(jrigel(iop,1 ),iop=1,7)
  772. * WRITE(IOIMP,*)' jrigel ',(jrigel(iop,2 ),iop=1,7)
  773. segdes matrik
  774. * WRITE(IOIMP,*)' segdes 2 '
  775. CALL ECRobj('MATRIK',matrik)
  776. return
  777. else
  778. WRITE(IOIMP,*)' erreur'
  779. return
  780. endif
  781. *
  782. * Error handling
  783. *
  784. 9999 CONTINUE
  785. WRITE(IOIMP,*) 'An error was detected in subroutine rima'
  786. CALL ERREUR(5)
  787. RETURN
  788. end
  789.  
  790.  
  791.  
  792.  
  793.  
  794.  
  795.  
  796.  
  797.  
  798.  
  799.  
  800.  
  801.  
  802.  
  803.  
  804.  
  805.  
  806.  
  807.  

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