Télécharger chole3.eso

Retour à la liste

Numérotation des lignes :

  1. C CHOLE3 SOURCE PV 20/02/21 21:15:06 10498
  2. SUBROUTINE CHOLE3(IPREL,IDERL,IPPVV,IPPR,IDDR,IVPO,
  3. # IPPVV1,VAL,VAL1,IVPO1,imasq,nbo,irondi,irondf,ivd)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6. -INC CCHOLE
  7. DIMENSION IPPVV(*),IVPO(*),IPPVV1(*),VAL(*),VAL1(*),IVPO1(*)
  8. DIMENSION imasq(*)
  9. real*8 pt(36)
  10.  
  11. * nombre max de lignes traitees simultanement
  12. nbl=6
  13.  
  14. C inconnues correspondant aux noeuds
  15.  
  16. ** write (6,*) ' chole3 irondi irondj ',irondi
  17.  
  18. C val1 en stockage compacte
  19. C val mis a jour et utilise imasq pour avoir les termes non nuls
  20. C nombres de groupes (incluant la diagonale)
  21. nbg1=ippvv1(2)-1
  22. nbg=1
  23. C nb ligne
  24. na=iderl-iprel+1
  25. na1=iddr-ippr+1
  26. C longueur de la premiere ligne incluant la diagonale
  27. lpl1=ivpo1(2*(nbg1+1))-ivpo1(2*1)
  28. C nb termes premiere ligne
  29. nval1=ivpo1(2*(nbg1+1)-1)-ivpo1(2*1-1)
  30. C longueur de la premiere ligne de val
  31. lpl=ippvv(2)-ippvv(1)
  32. C nb termes premiere ligne de val
  33. nval=lpl
  34. C position depart de val et val1
  35. idepv=iprel-nval+1
  36. idepv1=ippr-nval1+1
  37. imb=idepv1-idepv
  38. C write (6,*) 'chole3 idepv1 iml',idepv1,iml
  39. C les groupes (hors groupe diagonal)
  40. kidepg=ivpo(1)
  41. do 121 im=2,na
  42. kidepg=max(kidepg,ivpo(im))
  43. 121 continue
  44.  
  45. do 10 ig1=nbg1-1,1,-1
  46. C il position dans la ligne compressee
  47. C i position relative dans la ligne
  48. ildeb1=ivpo1(2*ig1)
  49. ilfin1=ivpo1(2*(ig1+1))-1
  50. ideb1=ivpo1(2*ig1-1)
  51. ifin1=ideb1+ilfin1-ildeb1
  52. ideb1n=max(1-imb,ideb1)
  53. long=ifin1-ideb1n+1
  54. lond=min(long,kidepg-imb-ideb1n+1)
  55. ifin1=lond+ideb1n-1
  56. ideb1n=max(irondi-imb,ideb1n)
  57. ifin1 =min(irondf-imb,ifin1 )
  58. lond=ifin1-ideb1n+1
  59. if (ifin1.lt.ivd-imb) then
  60. ** fin d'operation avant le premier terme significatif de la rondelle
  61. ** write (6,*) ' chole3 saut',ivd,irondi,irondf
  62. goto 999
  63. endif
  64. if (lond.le.0) goto 10
  65. C optimisation pour le cas na>1 na1>1
  66. C on decoupe les operations en groupes de 6x6 car au dela n'est pas programme
  67. if (na.gt.1.or.na1.gt.1) then
  68. do 301 ia=0,na-1,nbl
  69. iposrb=imb+ia*lpl+(ia*(ia-1))/2
  70. do 300 ia1=0,na1-1,nbl
  71. ilpos1b=-ideb1+ildeb1+ia1*lpl1+(ia1*(ia1-1))/2
  72. nboq=nbo
  73. ** write(6,*) 'appel mamupv ia na ia1 na1 ',ia,na,ia1,na1
  74. npa=min(nbl,na-ia)
  75. npa1=min(nbl,na1-ia1)
  76. call mamupv(ideb1n,ifin1,val(1),iposrb,lpl+ia,val1(1),
  77. > ilpos1b,lpl1+ia1,imasq(1),imb,pt,
  78. > npa,npa1,nbo)
  79. if (nbo.eq.nboq) then
  80. * rien a mettre a jour
  81. *** write (6,*) ' mamupv rien a mettre a jour '
  82. goto 10
  83. endif
  84. C mise a jour val
  85. do ic=1,npa
  86. ivad=ippr-idepv+ia1+(ia+ic-1)*lpl+
  87. > ((ia+ic-1)*(ia+ic-2))/2
  88. do il=1,npa1
  89. ivad = ivad+1
  90. if (ivad.ge.1) val(ivad)=val(ivad)-pt(il+(ic-1)*npa1)
  91. enddo
  92. enddo
  93. 300 continue
  94. 301 continue
  95. elseif (na.eq.1.and.na1.eq.1) then
  96. ideqb= ideb1n+imb
  97. im1=1
  98. idebzc=ideb1n-ideb1+ildeb1+(im1-1)*lpl1+((im1-2)*(im1-1))/2
  99. im=1
  100. ideq= ideqb+(im-1)*lpl+((im-2)*(im-1))/2
  101. nboq=nbo
  102. p=ddotpw(lond,val(ideq),val1(idebzc),imasq(1),ideqb,nbo)
  103. if (nbo.ne.nboq) then
  104. C mise a jour val
  105. ivad=ippr-idepv+im1+(im-1)*lpl+((im-2)*(im-1))/2
  106. if (ivad.ge.1) val(ivad)=val(ivad)-p
  107. endif
  108. endif
  109. 10 continue
  110. 999 continue
  111. if (irondi-imb.gt.nval1.or.irondf-imb.lt.nval1 ) return
  112.  
  113. C le groupe diagonal
  114. ig1=nbg1
  115. C les lignes de val1 on s'arrete avant le terme diagonal.
  116. ivadb=ippr-idepv+1
  117. C* > ippr,iblcd
  118. kidepb=ivpo(1)
  119. do 210 im=1,na
  120. kidep=ivpo(im)
  121. do 220 im1=1,na1
  122. p=0.d0
  123.  
  124. ildeb1=ivpo1(2*ig1)
  125. C* ilfin1=ildeb1+im1-2
  126. ideb1=ivpo1(2*ig1-1)
  127. ideb1n=max(1-imb,ideb1)
  128. ifin1=ideb1+im1-2
  129. ifin1=min(ifin1,kidep-imb)
  130. C le travail sur les colonnes de val
  131. ilpos1=ideb1n-ideb1+ildeb1 +(im1-1)*lpl1+((im1-2)*(im1-1))/2
  132. iposr=ideb1n+imb+(im-1)*lpl+((im-2)*(im-1))/2
  133. ideqb=ideb1n+imb
  134.  
  135. ** p=ddotpw(ifin1-ideb1n+1,val(iposr),val1(ilpos1),imasq(1),
  136. ** > ideqb,nbo)
  137.  
  138. * il y a trop peu de travail pour appeler ddotpw
  139. do 200 ipos=ideb1n,ifin1
  140. p=p+val(iposr)*val1(ilpos1)
  141. ilpos1=ilpos1+1
  142. iposr=iposr+1
  143. 200 continue
  144. if (ifin1-ideb1n.ge.0) nbo=nbo+ifin1-ideb1n+1
  145. C comparaison au terme diagonal
  146. dnorm = precc * abs(val1(im1*lpl1+(im1*(im1-1))/2))
  147. C mise a jour val
  148. ivad=ippr-idepv+im1+(im-1)*lpl+((im-2)*(im-1))/2
  149. if (ivad.lt.1) goto 220
  150. ivadb=ippr-idepv+im1
  151. if (ivadb.lt.1) goto 220
  152. val(ivad)=val(ivad)-p
  153. if (abs(val(ivad)).gt.dnorm) then
  154. imasq(ivad/masdim+1)=1
  155. if (ivadb.le.lpl) imasq(ivadb/masdim+1)=1
  156. C mise a jour imasq
  157. do imt=kidep/masdim+1+1,ivad/masdim+1-1
  158. imasq(imt)=-(ivad/masdim)*masdim+1
  159. enddo
  160. kidep=ivad
  161. C* if (im.eq.1) then
  162. C* kidepb=kidep
  163. C* endif
  164.  
  165. if (im.ne.1) then
  166. do imt=kidepb/masdim+1+1,ivadb/masdim+1-1
  167. imasq(imt)=-(ivadb/masdim)*masdim+1
  168. enddo
  169. endif
  170. kidepb=max(ivadb,kidepb)
  171. else
  172. C si on note que la valeur est nulle, il faut qu'elle le soit vraiment
  173. val(ivad)=0.d0
  174. C* write (6,*) ' chole3 ivad lpl ',ivad,lpl
  175. endif
  176. 220 continue
  177. ivpo(im)=kidep
  178. ivpo(1)=kidepb
  179. 210 continue
  180.  
  181. RETURN
  182. END
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  
  193.  
  194.  

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