Télécharger raflre.eso

Retour à la liste

Numérotation des lignes :

  1. C RAFLRE SOURCE PASCAL 19/03/22 21:15:05 10170
  2. SUBROUTINE RAFLRE(ILRE1,KR1,ILRE2)
  3. C----------------------------------------------------------------------C
  4. C Sous-programme de raffinement d'un LISTREEL (Operateur RAFF) C
  5. C----------------------------------------------------------------------C
  6. C
  7. C Syntaxe : LRE2 = RAFF LRE1 ENT1 ;
  8. C
  9. C Entrees :
  10. C - ILRE1 : pointeur sur LISTREEL
  11. C - KR1 : ENTIER, nb de coupes de chaque intervalles
  12. C
  13. C Sortie :
  14. C - ILRE2 : pointeur sur LISTREEL resultat
  15. C
  16. C----------------------------------------------------------------------C
  17. IMPLICIT REAL*8(A-H,O-Z)
  18. IMPLICIT INTEGER(I-N)
  19. C
  20. -INC SMLREEL
  21. -INC CCREEL
  22. -INC CCOPTIO
  23. C
  24. MLREEL = ILRE1
  25. SEGACT,MLREEL
  26. NL1 = PROG(/1)
  27. C
  28. C---- CAS OU LE LISTREEL EST VIDE OU N'A QU'UNE SEULE VALEUR
  29. C => on le renvoie en sortie
  30. IF (NL1.LE.1) THEN
  31. ILRE2 = ILRE1
  32. RETURN
  33. ENDIF
  34. C
  35. C---- CAS OU LE NOMBRE DE COUPES EST EGAL A 1 OU -1
  36. C => on renvoie le LISTREEL en entree (identite)
  37. IF (ABS(KR1).EQ.1) THEN
  38. ILRE2 = ILRE1
  39. RETURN
  40. ENDIF
  41. C
  42. C---- CAS OU LE NOMBRE DE COUPES EST NUL
  43. C => erreur
  44. IF (KR1.EQ.0) THEN
  45. INTERR(1) = KR1
  46. CALL ERREUR(36)
  47. RETURN
  48. ENDIF
  49. C
  50. C---- CAS GENERAL
  51. C Initialisation du LISTREEL resultat
  52. JG = ABS(KR1)*(NL1-1)+1
  53. JG = 5*JG
  54. SEGINI,MLREE1
  55. ILRE2 = MLREE1
  56. C
  57. C Sous-decoupage des intervalles
  58. XKR1 = REAL(KR1)
  59. VAL1 = MLREEL.PROG(1)
  60. DVI1 = 0.D0
  61. ICP1 = 1
  62. MLREE1.PROG(ICP1) = VAL1
  63. DO 20 I=2,NL1
  64. VAL2 = MLREEL.PROG(I)
  65. DVI2 = VAL2 - VAL1
  66. C IF (I.EQ.2) DVI1 = DVI2
  67. VALM = MAX(VAL1,VAL2)
  68. TOL1 = MAX(XZPREC*VALM,XPETIT)
  69. IF (ABS(DVI2).GT.TOL1) THEN
  70. C write(6,*) 'Cas DVI2 non nul'
  71. DEN2 = 1.D0 / ABS(XKR1)
  72. IF(ABS(DVI1).GT.TOL1)THEN
  73. DEN1 = ABS(DVI1 / (XKR1 * DVI2))
  74. ELSE
  75. DEN1 = DEN2
  76. ENDIF
  77. C Appel a decoup
  78. C write(6,*) 'DEN1, DEN2',DEN1,DEN2
  79. C KR2 = MAX(KR1,0)
  80. KR2 = KR1
  81. CALL DECOUP(KR2,DEN1,DEN2,A1,NBE,DENI,DECA,DVI2)
  82. XVA1 = A1*DENI
  83. XVA1 = XVA1 + VAL1
  84. ICP1 = ICP1 + 1
  85. IF(ICP1 .GT. JG)THEN
  86. JG = ICP1*2 + 20
  87. SEGADJ,MLREE1
  88. ENDIF
  89. MLREE1.PROG(ICP1) = XVA1
  90. XXVA = XVA1
  91. DO 21 J=1,NBE-2
  92. XXVA = A1*(XXVA - VAL1) + XVA1
  93. ICP1 = ICP1 + 1
  94. IF(ICP1 .GT. JG)THEN
  95. JG = ICP1*2 + 20
  96. SEGADJ,MLREE1
  97. ENDIF
  98. MLREE1.PROG(ICP1) = XXVA
  99. 21 CONTINUE
  100. ICP1 = ICP1 + 1
  101. IF(ICP1 .GT. JG)THEN
  102. JG = ICP1*2 + 20
  103. SEGADJ,MLREE1
  104. ENDIF
  105. MLREE1.PROG(ICP1) = VAL2
  106. ELSE
  107. C write(6,*) 'Cas DVI2 nul'
  108. DO 22 J=1,ABS(KR1)
  109. ICP1 = ICP1 + 1
  110. IF(ICP1 .GT. JG)THEN
  111. JG = ICP1*2 + 20
  112. SEGADJ,MLREE1
  113. ENDIF
  114. MLREE1.PROG(ICP1) = MLREE1.PROG(ICP1-1)
  115. 22 CONTINUE
  116. ENDIF
  117. DVI1 = DVI2
  118. VAL1 = VAL2
  119. 20 CONTINUE
  120. JG = ICP1
  121. SEGADJ,MLREE1
  122.  
  123. SEGACT,MLREE1*NOMOD
  124. END
  125.  
  126.  
  127.  

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