Télécharger compac.eso

Retour à la liste

Numérotation des lignes :

compac
  1. C COMPAC SOURCE PV 22/04/15 17:10:49 11344
  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 (inc.eq.1.or.abs(val(inc)).gt.prec) then
  89. izro=0
  90. goto 26
  91. endif
  92. 25 continue
  93. izro=izro+1
  94. 26 continue
  95. if (izro.ge.izrosf) goto 30
  96. 20 continue
  97. incpos=iprel-1
  98. 30 continue
  99. incfin=min(iprel-1,incpos-izro)
  100. ** incfin=min(iprel-1,incpos-1)
  101. ilfin=ildeb+incfin-incdeb
  102. * write (6,*) ' incdeb incfin izro iprel',incdeb,incfin,izro,iprel
  103. ildeb=ilfin+1
  104. incdeb=incpos+1
  105. if (incdeb.le.iprel-1) goto 1
  106.  
  107. 200 continue
  108.  
  109. **
  110. * on a construit kivpo et kivlo il ne reste plus qu'a recopier les valeurs.
  111. * on a tout fait avant iprel. Il faut donc rajouter la partie triangulaire
  112. **
  113. nbpar=nbpar+1
  114. kivlo(nbpar)=ilfin+1
  115. kivpo(nbpar)=incdeb-incdebi+1
  116. nvall=kivlo(nbpar)-1
  117. nvallg=kivpo(nbpar)-1
  118. * write (6,*) ' compac na nbpar initial ',na,nbpar,nvall,incfin
  119.  
  120.  
  121. * puis recopier l'ensemble en completant le triangle
  122.  
  123. ippvv(1)=1
  124. do 100 il=2,na
  125. ippvv(il)=(il-1)*nbpar+1
  126. do 110 nbp=1,nbpar
  127. kivlo(nbp+(il-1)*nbpar)=kivlo(nbp+(il-2)*nbpar)+nvall+il-1
  128. kivpo(nbp+(il-1)*nbpar)=kivpo(nbp+(il-2)*nbpar)+nvallg+il-1
  129. 110 continue
  130.  
  131. 100 continue
  132. nbpar=nbpar*na
  133. nbpar=nbpar+1
  134. ippvv(na+1)=nbpar
  135. kivpo(nbpar)=kivpo(nbpar-1)+na
  136. kivlo(nbpar)=kivlo(nbpar-1)+na
  137. nvall=kivlo(nbpar)-1
  138.  
  139. * write (6,*) ' compac iprel na nbpar nvall ',iprel,na,nbpar,nvall
  140. * write (6,*) 'nouveau ippvv',(ippvv(i),i=1,na+1)
  141. * write (6,*) 'kivpo',(kivpo(i),i=1,nbpar)
  142. * write (6,*) 'kivlo',(kivlo(i),i=1,nbpar)
  143.  
  144. * deplacement des valeurs
  145. * fait maintenant dans le programme appelant pour eviter un double mouvement
  146. * do 300 nbp=1,nbpar-1
  147. * do 310 iv=kivlo(nbp),kivlo(nbp+1)-1
  148. * val(iv)=val(iv-kivlo(nbp)+kivpo(nbp))
  149. *310 continue
  150. *300 continue
  151.  
  152. return
  153. end
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  

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