Télécharger chole3.eso

Retour à la liste

Numérotation des lignes :

  1. C CHOLE3 SOURCE PV 20/01/16 21:15:06 10501
  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(6,6)
  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. call mamupv(ideb1n,ifin1,val(1),iposrb,lpl+ia,val1(1),
  75. > ilpos1b,lpl1+ia1,imasq(1),imb,pt,
  76. > min(nbl,na-ia),min(nbl,na1-ia1),nbo)
  77. if (nbo.eq.nboq) then
  78. * rien a mettre a jour
  79. *** write (6,*) ' mamupv rien a mettre a jour '
  80. goto 10
  81. endif
  82. C mise a jour val
  83. do ic=1,min(nbl,na-ia)
  84. ivad=ippr-idepv+ia1+(ia+ic-1)*lpl+
  85. > ((ia+ic-1)*(ia+ic-2))/2
  86. do il=1,min(nbl,na1-ia1)
  87. ivad = ivad+1
  88. if (ivad.ge.1) val(ivad)=val(ivad)-pt(il,ic)
  89. enddo
  90. enddo
  91. 300 continue
  92. 301 continue
  93. elseif (na.eq.1.and.na1.eq.1) then
  94. ideqb= ideb1n+imb
  95. im1=1
  96. idebzc=ideb1n-ideb1+ildeb1+(im1-1)*lpl1+((im1-2)*(im1-1))/2
  97. im=1
  98. ideq= ideqb+(im-1)*lpl+((im-2)*(im-1))/2
  99. nboq=nbo
  100. p=ddotpw(lond,val(ideq),val1(idebzc),imasq(1),ideqb,nbo)
  101. if (nbo.ne.nboq) then
  102. C mise a jour val
  103. ivad=ippr-idepv+im1+(im-1)*lpl+((im-2)*(im-1))/2
  104. if (ivad.ge.1) val(ivad)=val(ivad)-p
  105. endif
  106. endif
  107. 10 continue
  108. 999 continue
  109. if (irondi-imb.gt.nval1.or.irondf-imb.lt.nval1 ) return
  110.  
  111. C le groupe diagonal
  112. ig1=nbg1
  113. C les lignes de val1 on s'arrete avant le terme diagonal.
  114. ivadb=ippr-idepv+1
  115. C* > ippr,iblcd
  116. kidepb=ivpo(1)
  117. do 210 im=1,na
  118. kidep=ivpo(im)
  119. do 220 im1=1,na1
  120. p=0.d0
  121.  
  122. ildeb1=ivpo1(2*ig1)
  123. C* ilfin1=ildeb1+im1-2
  124. ideb1=ivpo1(2*ig1-1)
  125. ideb1n=max(1-imb,ideb1)
  126. ifin1=ideb1+im1-2
  127. ifin1=min(ifin1,kidep-imb)
  128. C le travail sur les colonnes de val
  129. ilpos1=ideb1n-ideb1+ildeb1 +(im1-1)*lpl1+((im1-2)*(im1-1))/2
  130. iposr=ideb1n+imb+(im-1)*lpl+((im-2)*(im-1))/2
  131. ideqb=ideb1n+imb
  132.  
  133. ** p=ddotpw(ifin1-ideb1n+1,val(iposr),val1(ilpos1),imasq(1),
  134. ** > ideqb,nbo)
  135.  
  136. * il y a trop peu de travail pour appeler ddotpw
  137. do 200 ipos=ideb1n,ifin1
  138. p=p+val(iposr)*val1(ilpos1)
  139. ilpos1=ilpos1+1
  140. iposr=iposr+1
  141. 200 continue
  142. if (ifin1-ideb1n.ge.0) nbo=nbo+ifin1-ideb1n+1
  143. C comparaison au terme diagonal
  144. dnorm = precc * abs(val1(im1*lpl1+(im1*(im1-1))/2))
  145. C mise a jour val
  146. ivad=ippr-idepv+im1+(im-1)*lpl+((im-2)*(im-1))/2
  147. if (ivad.lt.1) goto 220
  148. ivadb=ippr-idepv+im1
  149. if (ivadb.lt.1) goto 220
  150. val(ivad)=val(ivad)-p
  151. if (abs(val(ivad)).gt.dnorm) then
  152. imasq(ivad/masdim+1)=1
  153. if (ivadb.le.lpl) imasq(ivadb/masdim+1)=1
  154. C mise a jour imasq
  155. do imt=kidep/masdim+1+1,ivad/masdim+1-1
  156. imasq(imt)=-(ivad/masdim)*masdim+1
  157. enddo
  158. kidep=ivad
  159. C* if (im.eq.1) then
  160. C* kidepb=kidep
  161. C* endif
  162.  
  163. if (im.ne.1) then
  164. do imt=kidepb/masdim+1+1,ivadb/masdim+1-1
  165. imasq(imt)=-(ivadb/masdim)*masdim+1
  166. enddo
  167. endif
  168. kidepb=max(ivadb,kidepb)
  169. else
  170. C si on note que la valeur est nulle, il faut qu'elle le soit vraiment
  171. val(ivad)=0.d0
  172. C* write (6,*) ' chole3 ivad lpl ',ivad,lpl
  173. endif
  174. 220 continue
  175. ivpo(im)=kidep
  176. ivpo(1)=kidepb
  177. 210 continue
  178.  
  179. RETURN
  180. END
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  

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