Télécharger compac.eso

Retour à la liste

Numérotation des lignes :

  1. C COMPAC SOURCE PV 15/02/19 21:15:22 8406
  2. SUBROUTINE COMPAC(VAL,NBPAR,KIVPO,KIVLO,NVALL,IPPVV,
  3. > IZROSF,NA,PREC,imasq,iprel,iderl)
  4. ******
  5. * COMPACTE UNE LIGNE DE LA MATRICE. TOUTES SEQUENCES DE IZROFS VALEURS
  6. * INFERIEURES A PREC SONT ELIMINEES
  7. *
  8. * Modif janvier 2015 toutes les inconnues de la ligne ont le même ivpo
  9. * de plus, le premier terme de la ligne est forcement gardé
  10. *
  11. *
  12. ******
  13. IMPLICIT INTEGER(I-N)
  14. IMPLICIT REAL*8(A-H,O-Z)
  15. -INC CCHOLE
  16. DIMENSION VAL(*),KIVPO(*),KIVLO(*),IPPVV(*),imasq(*)
  17. * d'abord calcul des kivpo kivlo initiaux
  18. * on suppose que les lignes ont la meme colonne de depart. C'est la responsibilite de assem2
  19. * write (6,*) ' compac na izrosf ',na,izrosf
  20. * write (6,*) ' ippvv ',(ippvv(i),i=1,na+1)
  21. incdeb=iprel-ippvv(2)+1
  22. incdebi=incdeb
  23. incpos=incdeb
  24. incfin=incdeb-1
  25. ildeb=1
  26. ilfin=0
  27. nbpar=0
  28. * decalage colonne adresse dans la ligne
  29. idec=-incdebi+1
  30. * on balaye en colonne a partis de incdeb
  31. 1 continue
  32. * recherche nouveau debut
  33. * recherche acceleree en utilisant imasq
  34.  
  35. 1020 continue
  36. * recherche du saut pour chaque ligne
  37. * verif si premier masque nul
  38. incdeba=iprel+na
  39. do 1100 il=1,na
  40. ipr=(incdeb+ippvv(il)+idec)/masdim+1
  41. incbas=min(ipr*masdim,iprel+ippvv(il)+idec)
  42. do inc=incdeb+ippvv(il)+idec,incbas
  43. if (abs(val(inc)).gt.prec.or.inc.eq.1) goto 1954
  44. enddo
  45.  
  46. 1047 continue
  47. im=ipr
  48. do 1045 im=ipr,(iprel-1+ippvv(il)+idec)/masdim+1
  49. ** write (6,*) ' im imasq ',im,imasq(im),imasq(im+1)
  50. if (imasq(im+1).gt.0) goto 1046
  51. if (imasq(im+1).lt.0) then
  52. ipr=-(imasq(im+1)/masdim)+1
  53. ** write (6,*) 'compac acceleration im ipr',im,ipr
  54. goto 1047
  55. endif
  56. 1045 continue
  57. 1046 continue
  58. ** write (6,*) 'compac il incdeb indecba im',il,incdeb,
  59. ** > im*masdim-idec-ippvv(il),im
  60. incdeba=min(incdeba,im*masdim-idec-ippvv(il))
  61. 1100 continue
  62. ** if (incdeb.ne.incdeba)
  63. ** > write (6,*)'incdeb incdeba na',incdeb,incdeba,na,ipr,im,ippvv(2)
  64. incdeb=incdeba
  65. 1954 continue
  66. do 40 incpos=incdeb,iprel-1
  67. do 45 il=1,na
  68. inc=incpos-incdebi+ippvv(il)+1
  69. if (abs(val(inc)).lt.prec.and.inc.ne.1) goto 45
  70. goto 50
  71. 45 continue
  72. 40 continue
  73. * write (6,*) ' pas trouve debut '
  74. * pas trouve de debut
  75. incdeb=iprel
  76. goto 200
  77. 50 continue
  78. incdeb=incpos
  79. nbpar=nbpar+1
  80. kivlo(nbpar)=ildeb
  81. kivpo(nbpar)=incdeb-incdebi+1
  82. * recherche de la fin
  83. * acceleration en utilisant itmasq
  84. izro=0
  85. do 20 incpos=incdeb+1,iprel-1
  86. do 25 il=1,na
  87. inc=incpos-incdebi+ippvv(il)+1
  88. if (abs(val(inc)).lt.prec.and.inc.ne.1) then
  89. izro=izro+1
  90. else
  91. izro=0
  92. endif
  93. 25 continue
  94. if (izro.ge.izrosf*na) goto 30
  95. 20 continue
  96. incpos=iprel-1
  97. 30 continue
  98. incfin=min(iprel-1,incpos-izro/na)
  99. ** incfin=min(iprel-1,incpos-1)
  100. ilfin=ildeb+incfin-incdeb
  101. * write (6,*) ' incdeb incfin izro iprel',incdeb,incfin,izro,iprel
  102. ildeb=ilfin+1
  103. incdeb=incpos+1
  104. if (incdeb.le.iprel-1) goto 1
  105.  
  106. 200 continue
  107.  
  108. **
  109. * on a construit kivpo et kivlo il ne reste plus qu'a recopier les valeurs.
  110. * on a tout fait avant iprel. Il faut donc rajouter la partie triangulaire
  111. **
  112. nbpar=nbpar+1
  113. kivlo(nbpar)=ilfin+1
  114. kivpo(nbpar)=incdeb-incdebi+1
  115. nvall=kivlo(nbpar)-1
  116. nvallg=kivpo(nbpar)-1
  117. * write (6,*) ' compac na nbpar initial ',na,nbpar,nvall,incfin
  118.  
  119.  
  120. * puis recopier l'ensemble en completant le triangle
  121.  
  122. ippvv(1)=1
  123. do 100 il=2,na
  124. ippvv(il)=(il-1)*nbpar+1
  125. do 110 nbp=1,nbpar
  126. kivlo(nbp+(il-1)*nbpar)=kivlo(nbp+(il-2)*nbpar)+nvall+il-1
  127. kivpo(nbp+(il-1)*nbpar)=kivpo(nbp+(il-2)*nbpar)+nvallg+il-1
  128. 110 continue
  129.  
  130. 100 continue
  131. nbpar=nbpar*na
  132. nbpar=nbpar+1
  133. ippvv(na+1)=nbpar
  134. kivpo(nbpar)=kivpo(nbpar-1)+na
  135. kivlo(nbpar)=kivlo(nbpar-1)+na
  136. nvall=kivlo(nbpar)-1
  137.  
  138. * write (6,*) ' compac iprel na nbpar nvall ',iprel,na,nbpar,nvall
  139. * write (6,*) 'nouveau ippvv',(ippvv(i),i=1,na+1)
  140. * write (6,*) 'kivpo',(kivpo(i),i=1,nbpar)
  141. * write (6,*) 'kivlo',(kivlo(i),i=1,nbpar)
  142.  
  143. * deplacement des valeurs
  144.  
  145. do 300 nbp=1,nbpar-1
  146. do 310 iv=kivlo(nbp),kivlo(nbp+1)-1
  147. val(iv)=val(iv-kivlo(nbp)+kivpo(nbp))
  148. 310 continue
  149. 300 continue
  150.  
  151. return
  152. end
  153.  
  154.  
  155.  
  156.  

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