Télécharger rima.eso

Retour à la liste

Numérotation des lignes :

  1. C RIMA SOURCE MAGN 17/02/24 21:15:24 9323
  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. do il=1,nligrp
  456. lisinc(il)=lisprj(in)(1:4)
  457. noelep(il)=il
  458. enddo
  459. do il=1,nligrd
  460. lisdua(il)=lisdub(in)(1:4)
  461. noeled(il)=il+nofset.lect(is)
  462. enddo
  463. do ip=1,nbel
  464. do iu=1,nligrp
  465. do ju=1,nligrd
  466. re(ju,iu,ip)=am(ip,iu,ju)
  467. enddo
  468. enddo
  469. enddo
  470. segdes xmatri,descr
  471. else
  472. * recopier les transposées des matrices élémentaires
  473. nligrd=am(/2)
  474. nligrp=am(/3)
  475. segini descr,xmatri
  476. irigel(3,jr)=descr
  477. irigel(4,jr)=Xmatri
  478. do il=1,nligrp
  479. lisinc(il)=lisdub(in)(1:4)
  480. noelep(il)=il+nofset.lect(is)
  481. enddo
  482. do il=1,nligrd
  483. lisdua(il)=lisprj(in)(1:4)
  484. noeled(il)=il
  485. enddo
  486. do ip=1,nbel
  487. do iu=1,nligrp
  488. do ju=1,nligrd
  489. re(ju,iu,ip)=am(ip,ju,iu)
  490. enddo
  491. enddo
  492. enddo
  493. segdes xmatri,descr
  494. endif
  495. segdes izafm
  496. enddo
  497. enddo
  498. enddo
  499.  
  500. segdes meleme
  501. segdes jmatri
  502. segsup nofset
  503. enddo
  504. segdes mrigid
  505. segdes matrik
  506. CALL ECRobj('RIGIDITE',mrigid)
  507. return
  508. elseif(typp.eq.'RIGIDITE') then
  509. type='RIGIDITE'
  510. call lirobj(type,mrigid,1,iret)
  511. * WRITE(IOIMP,*)' rigidite '
  512.  
  513. * On regarde si il y a un autre argument.
  514. * Si ce n'est pas le cas on appele RIMB
  515. * qui termine le travail.
  516. * Modif GBM
  517.  
  518. call quetyp(typp,0,iret)
  519. if(typp.ne.'MAILLAGE') then
  520. call RIMB(mrigid)
  521. return
  522. endif
  523.  
  524. * fin de modif GBM 18/12/02
  525.  
  526. type='MAILLAGE'
  527. call lirobj(type,mele ,1,iret)
  528. * WRITE(IOIMP,*)' mele ',mele,iret
  529. *
  530. * eventuellemnt liste nom composante
  531. *
  532. ico = 0
  533. jmo=0
  534. lmo=0
  535. call quetyp(typp,ico,iret)
  536. if(typp.eq.'LISTMOTS') then
  537. call lirobj(typp,mlmots,0,iret)
  538. segact mlmots
  539. jmo = mots(/1)
  540. lmo = mots(/2)
  541. endif
  542. segact mrigid
  543. nrigel=irigel(/2)
  544. nrige =irigel(/1)
  545.  
  546. if(impj.eq.0) then
  547. WRITE(IOIMP,*)' nrigel',nrigel,' nrige ',nrige
  548. WRITE(IOIMP,*)' mtymat ',mtymat
  549. do ir =1,nrigel
  550. WRITE(IOIMP,*)' ir ',ir
  551. WRITE(IOIMP,*)(irigel(ik,ir),ik=1,nrige)
  552. WRITE(IOIMP,*)' '
  553. meleme=irigel(1,ir)
  554. segact meleme
  555. nbs=lisous(/1)
  556. WRITE(IOIMP,*)' nbre ssobjt mail ',nbs
  557. if(nbs.eq.0) then
  558. nbnn=num(/1)
  559. nbl=num(/2)
  560. do iel=1,nbl
  561. WRITE(IOIMP,*)iel,' ',(num(io,iel),io=1,nbnn)
  562. enddo
  563. endif
  564. if(nbs.ge.1)then
  565. WRITE(IOIMP,*)' ssobjet maill',(lisous(io),io=1,nbs)
  566. do iss=1,nbs
  567. ipt1=lisous(iss)
  568. segact ipt1
  569. nbnn=ipt1.num(/1)
  570. nbl =ipt1.num(/2)
  571. WRITE(IOIMP,*)' nbl ',nbl,' nbnn ',nbnn
  572. do il = 1,nbl
  573. WRITE(IOIMP,*)il,' ',(ipt1.num(iop,il),iop=1
  574. $ ,nbnn)
  575. enddo
  576. segdes ipt1
  577. enddo
  578. endif
  579. segdes meleme
  580. enddo
  581. WRITE(IOIMP,*)' coerig '
  582. WRITE(IOIMP,*)(coerig(ik),ik=1,nrigel)
  583. WRITE(IOIMP,*)' ichole imgeo1 imgeo2 iforig '
  584. WRITE(IOIMP,*) ichole,imgeo1,imgeo2,iforig
  585. WRITE(IOIMP,*)' isupeq jrcond jrdepp jrdepd '
  586. WRITE(IOIMP,*) isupeq,jrcond,jrdepp,jrdepd
  587. WRITE(IOIMP,*)' jrelim jrgard jrtot '
  588. WRITE(IOIMP,*) jrelim,jrgard,jrtot
  589. do ir=1,nrigel
  590. xmatri = irigel(4,ir)
  591. descr = irigel(3,ir)
  592. segact xmatri,descr
  593. nelrig = re(/3)
  594. nligrp = noelep(/1)
  595. nligrd = noeled(/1)
  596. WRITE(IOIMP,*)' nelrig nligrp nligrd '
  597. WRITE(IOIMP,*) nelrig,nligrp,nligrd
  598. WRITE(IOIMP,*)' lisinc '
  599. WRITE(IOIMP,*)(lisinc(io),io=1,nligrp)
  600. WRITE(IOIMP,*)' lisdua '
  601. WRITE(IOIMP,*)(lisdua(io),io=1,nligrd)
  602. WRITE(IOIMP,*)' noelep '
  603. WRITE(IOIMP,*)(noelep(io),io=1,nligrp)
  604. WRITE(IOIMP,*)' noeled '
  605. WRITE(IOIMP,*)(noeled(io),io=1,nligrd)
  606. do ie=1, nelrig
  607. * xmatri = imattt(ie)
  608. * segact xmatri
  609. WRITE(IOIMP,*)' iel ',ie
  610. do ij =1,nligrd
  611. WRITE(IOIMP,*)ij,(re(ij,kj,ie),kj=1,nligrp)
  612. enddo
  613. * segdes xmatri
  614. enddo
  615. segdes xmatri,descr
  616. enddo
  617. endif
  618.  
  619. nmatri = nrigel
  620. nrige = 7
  621. nrig = irigel(/1)
  622. nkid=9
  623. nkmt=7
  624. segini matrik
  625. * WRITE(IOIMP,*)' creation matrik',matrik
  626. do in=1,nrigel
  627. jrigel(1,in)=irigel(1,in)
  628. jrigel(2,in)=irigel(1,in)
  629. meleme = irigel(1,in)
  630. segact meleme
  631. jrigel(7,in)=0
  632. if(nrig.gt.6) then
  633. jrigel(7,in)=irigel(7,in)
  634. endif
  635. * WRITE(IOIMP,*)' in ',in,irigel(7,in)
  636. * WRITE(IOIMP,*)' in ',in,irigel(6,in)
  637. if(irigel(6,in).ne.0)then
  638. segsup matrik
  639. WRITE(IOIMP,*)' matrice definie par une inegalite'
  640. return
  641. endif
  642. if(irigel(5,in).ne.0) then
  643. segsup matrik
  644. WRITE(IOIMP,*)' harmonique de fourier non nulle'
  645. return
  646. endif
  647. coef = coerig(in)
  648. descr=irigel(3,in)
  649. segact descr
  650. xmatri = irigel(4,in)
  651. segact xmatri
  652. nbp = noelep(/1)
  653. nbd = noeled(/1)
  654. np = num(/1)
  655. nbme = nbp/np*nbd/np
  656. nbel = num(/2)
  657. mp =np
  658. nbsous=1
  659. segini jmatri
  660. jrigel(4,in)=jmatri
  661. * WRITE(IOIMP,*)' jmatri ',jmatri
  662.  
  663. * WRITE(IOIMP,*)' jrigel ',(jrigel(iop,in),iop=1,7)
  664.  
  665.  
  666.  
  667. l1=nbp/np
  668. l2=np
  669. segini iztra
  670. * WRITE(IOIMP,*)' iztra ',iztra,l1,l2
  671. k0 = 1
  672. lisp(1)=lisinc(1)
  673. do io=1,np
  674. itab(1,io)=io
  675. enddo
  676. ltab(1)=1
  677. do j=2,nbp
  678. nomi=lisinc(j)
  679. do l=1,k0
  680. if(nomi.eq.lisp(l))then
  681. k=ltab(l)+1
  682. itab(l,k)=j
  683. ltab(l)=k
  684. go to 30
  685. endif
  686. enddo
  687. k0=k0+1
  688. lisp(k0)=nomi
  689. ltab(k0)=1
  690. itab(k0,1)=j
  691. 30 continue
  692. enddo
  693. l3=nbd/np
  694. l2=np
  695. segini jztra
  696. k0 = 1
  697. lisd(1)=lisdua(1)
  698. do io=1,np
  699. jtab(1,io)=io
  700. enddo
  701. ktab(1)=1
  702. do j=2,nbd
  703. nomi=lisdua(j)
  704. do l=1,k0
  705. if(nomi.eq.lisd(l))then
  706. k=ktab(l)+1
  707. jtab(l,k)=j
  708. ktab(l)=k
  709. go to 31
  710. endif
  711. enddo
  712. k0=k0+1
  713. lisd(k0)=nomi
  714. ktab(k0)=1
  715. jtab(k0,1)=j
  716. 31 continue
  717. enddo
  718. k=0
  719. do lp=1,l1
  720. do ld=1,l3
  721. k=k+1
  722. lisprj(k)=lisp(lp)
  723. * lisdub(k)=lisd(ld)
  724. lisdub(k)=lisp(ld)
  725. if(lmo.ne.0.and.lmo.ge.lp)then
  726. lisprj(k)= mots(lp)
  727. lisdub(k)= mots(ld)
  728. endif
  729. segini izafm
  730. lizafm(1,k)=izafm
  731. kspgp = mele
  732. kspgd = mele
  733. * WRITE(IOIMP,*)' kspgp ',kspgp
  734. do ip =1,nbel
  735. * xmatri = imattt(ip)
  736. * segact xmatri
  737. ll=0
  738. do ki=1,np
  739. do kj=1,np
  740. il= noelep(ki)
  741. jl= noeled(kj)
  742. ii=itab(lp,ki)
  743. jj=jtab(ld,kj)
  744. * am(ip,il,jl)=coef * re(jj,ii)
  745. ll=ll+1
  746. il=noelep(ii)
  747. jl=noelep(jj)
  748. if(ip.eq.1)then
  749. * WRITE(IOIMP,*)' lp ',lp,' ki ',ki,' nop ',il,' ii ',ii,' ip ',ip
  750. * WRITE(IOIMP,*)' ld ',ld,' kj ',kj,' nod ',jl,' jj ',jj
  751. endif
  752. am(ip,il,jl)=coef * re(jj,ii,ip)
  753. ***** am(ip,ki,kj)=coef * re(ii,jj)
  754. enddo
  755. enddo
  756. * segdes xmatri
  757. enddo
  758. * WRITE(IOIMP,*)' finfin '
  759. segdes izafm
  760. enddo
  761. enddo
  762. * WRITE(IOIMP,*)' fin 1 '
  763. segsup iztra,jztra
  764. segdes descr,xmatri
  765. segdes jmatri
  766. * WRITE(IOIMP,*)' segdes 1 '
  767. enddo
  768. segdes mrigid
  769. * WRITE(IOIMP,*)' jrigel ',(jrigel(iop,1 ),iop=1,7)
  770. * WRITE(IOIMP,*)' jrigel ',(jrigel(iop,2 ),iop=1,7)
  771. segdes matrik
  772. * WRITE(IOIMP,*)' segdes 2 '
  773. CALL ECRobj('MATRIK',matrik)
  774. return
  775. else
  776. WRITE(IOIMP,*)' erreur'
  777. return
  778. endif
  779. *
  780. * Error handling
  781. *
  782. 9999 CONTINUE
  783. WRITE(IOIMP,*) 'An error was detected in subroutine rima'
  784. CALL ERREUR(5)
  785. RETURN
  786. end
  787.  
  788.  
  789.  
  790.  
  791.  
  792.  
  793.  
  794.  
  795.  
  796.  
  797.  
  798.  
  799.  
  800.  
  801.  
  802.  
  803.  
  804.  

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