Télécharger crech1.eso

Retour à la liste

Numérotation des lignes :

  1. C CRECH1 SOURCE CB215821 19/08/20 21:16:26 10287
  2. * preconditionnement des meleme cree par crechp
  3. subroutine crech1(meleme,idet)
  4. -INC CCPRECO
  5. -INC SMELEME
  6. if=nbemel
  7. ith=oothrd
  8.  
  9. C Activations par paquets
  10. CALL oooprl(1)
  11. segact meleme
  12. do i=1,nbemel
  13. ipt1=premel(i,ith)
  14. if (ipt1.eq.0) goto 1
  15. segact,ipt1
  16. enddo
  17. 1 CONTINUE
  18. CALL oooprl(0)
  19.  
  20. if (num(/1).ne.1.or.itypel.ne.1) return
  21. nbel=num(/2)
  22. if (nbel.eq.0) then
  23. ihash1=0
  24. ihash2=0
  25. elseif (nbel.eq.1) then
  26. ihash1=num(1,1)
  27. ihash2=num(1,1)
  28. else
  29. ihash1=num(1,1)+num(1,nbel)
  30. ihash2=num(1,1)-num(1,nbel)
  31. endif
  32. do 10 i=1,nbemel
  33. if (premel(i,ith).eq.0) goto 20
  34. ipt1=premel(i,ith)
  35. if (ipt1.eq.meleme) return
  36. if (nbso(i,ith) .ne.nbel) goto 10
  37. if (hash1(i,ith).ne.ihash1) goto 10
  38. if (hash2(i,ith).ne.ihash2) goto 10
  39. if (ipt1.num(/2).ne.nbel) goto 10
  40. do j=1,nbel
  41. if (num(1,j) .ne.ipt1.num(1,j)) goto 10
  42. if (icolor(j).ne.ipt1.icolor(j)) goto 10
  43. enddo
  44. * maillage identiques
  45. * write (6,*) ' crech1 ',meleme,' remplace par ',ipt1,
  46. * > 'position ',i, 'thread ',ith
  47. *** if (idet.eq.1) segsup meleme
  48. meleme=ipt1
  49. if = i
  50. goto 20
  51. return
  52. 10 continue
  53. 20 continue
  54. if (if.lt.nbemel/3) return
  55.  
  56. * on rajoute le maillage courant en tête
  57. do j=if,2,-1
  58. premel(j,ith)=premel(j-1,ith)
  59. nbso(j,ith)=nbso(j-1,ith)
  60. hash1(j,ith)=hash1(j-1,ith)
  61. hash2(j,ith)=hash2(j-1,ith)
  62. enddo
  63. premel(1,ith)=meleme
  64. nbso(1,ith) =nbel
  65. hash1(1,ith) =ihash1
  66. hash2(1,ith) =ihash2
  67. end
  68.  
  69.  
  70.  

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