Télécharger monde1.eso

Retour à la liste

Numérotation des lignes :

monde1
  1. C MONDE1 SOURCE PV 20/09/27 08:43:14 10725
  2. SUBROUTINE MONDE1 (IPPVV,VECTBB,VAL,IVPO,
  3. > NA,IPREL,MULRE,INC,dnorm)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6. DIMENSION VECTBB(*),VAL(*),IVPO(*),IPPVV(*)
  7. ** experimental: on annule les termes resultants exclusivement d'une erreur d'arrondi
  8. ** ca permet a certains cas test de passer
  9.  
  10. -INC CCREEL
  11.  
  12. * nombres de groupes (incluant la diagonale)
  13. nbg=ippvv(2)-1
  14. * longueur de la premiere ligne
  15. lpl=ivpo(2*(nbg+1))-ivpo(2*1)
  16. lpl1=lpl-1
  17. * nb termes premiere ligne
  18. nval=ivpo(2*(nbg+1)-1)-ivpo(2*1-1)
  19. * la partie triangulaire = le dernier groupe
  20. do 200 k=0,(mulre-1)*inc,inc
  21. ig=nbg
  22. iprelk =iprel+k
  23. iprelkm=iprelk-1
  24. iprelk1=iprelk+1
  25. iprelk2=iprelk+2
  26. iprelk3=iprelk+3
  27. iprelk4=iprelk+4
  28. iprelk5=iprelk+5
  29. iposb=-nval+iprelk
  30. do 120 ilm=na,1,-1
  31. ii=iprel-1+ilm
  32. vkon=vectbb(ii+k)
  33. if (abs(vkon).lt.dnorm) goto 120
  34. ildeb=ivpo(2*ig)
  35. ilfin=ildeb+ilm-1
  36. ideb=ivpo(2*ig-1)
  37. ifin=ideb+ilfin-ildeb
  38. * dans le groupe
  39. jdec=-ideb+ildeb+lpl*(ilm-1)+((ilm-1)*(ilm-2))/2
  40. do 130 j=ifin-1,ideb,-1
  41. * on force la nullite de vectbb si il n'est pas significatif
  42. vini=vectbb(iposb+j)
  43. vfin=vini-vkon*val(jdec+j)
  44. if(abs(vfin).le.abs(vini)*xzprec) vfin=0.d0
  45. vectbb(iposb+j)=vfin
  46. 130 continue
  47. 120 continue
  48. * les groupes (hors groupe diagonal)
  49. ** jdecb = lpl*na+((na)*(na-1))/2
  50. ilfin=ivpo(2*1)-1
  51. do 10 ig=1,nbg-1
  52. * ildeb=ivpo(2*ig)
  53. ildeb=ilfin+1
  54. ilfin=ivpo(2*(ig+1))-1
  55. ideb=ivpo(2*ig-1)
  56. ifin=ilfin+ideb-ildeb
  57. * les lignes
  58. * dans le groupe
  59. jdec = -(ideb-ildeb)
  60. do 30 j=ideb,ifin
  61. ipos=j-nval+iprel
  62. p1=vectbb(ipos+k)
  63. p1c=abs(p1*xzprec)
  64. jpos=j+jdec
  65. * unrolling a la main. En general na <=6
  66. p1=p1-vectbb(iprelk )*val(jpos)
  67. if (na.eq.1) goto 31
  68. jpos=jpos+lpl1+1
  69. p1=p1-vectbb(iprelk1)*val(jpos)
  70. if (na.eq.2) goto 31
  71. jpos=jpos+lpl1+2
  72. p1=p1-vectbb(iprelk2)*val(jpos)
  73. if (na.eq.3) goto 31
  74. jpos=jpos+lpl1+3
  75. p1=p1-vectbb(iprelk3)*val(jpos)
  76. if (na.eq.4) goto 31
  77. jpos=jpos+lpl1+4
  78. p1=p1-vectbb(iprelk4)*val(jpos)
  79. if (na.eq.5) goto 31
  80. jpos=jpos+lpl1+5
  81. p1=p1-vectbb(iprelk5)*val(jpos)
  82. if (na.eq.6) goto 31
  83. jpos=jpos+lpl1+6
  84. do 20 ilm=7,na
  85. ii=iprelkm+ilm
  86. p1=p1-vectbb(ii)*val(jpos)
  87. jpos=jpos+lpl1+ilm
  88. 20 continue
  89. 31 continue
  90. vectbb(ipos+k)=p1
  91. if(abs(p1).le.p1c) vectbb(ipos+k)=0.d0
  92. 30 continue
  93. 10 continue
  94. 200 continue
  95. return
  96. end
  97.  
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  

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