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

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