Télécharger fuslre.eso

Retour à la liste

Numérotation des lignes :

  1. C FUSLRE SOURCE CHAT 05/01/13 00:12:44 5004
  2. SUBROUTINE FUSLRE (MLREE1,MLREE2, MLREE3)
  3. ************************************************************************
  4. *
  5. * F U S L R E
  6. * -----------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *
  11. * FUSION DE 2 "LISTREEL" ORDONNES STRICTEMENT CROISSANT, PAR
  12. * INSERTION, DANS LE 1ER, DES REELS N'APPARTENANT QU'AU 2IEME.
  13. *
  14. * MODULES UTILISES:
  15. * -----------------
  16. *
  17. IMPLICIT INTEGER(I-N)
  18. -INC SMLREEL
  19. -INC SMLENTI
  20. *
  21. * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN)
  22. * -----------
  23. *
  24. * MLREE1 (E) 1ER LISTREEL ORDONNE.
  25. * MLREE2 (E) 2EME LISTREEL ORDONNE.
  26. * MLREE3 (S) FUSION ORDONNEE STRICTEMENT CROISSANT DES 2 LISTREEL.
  27. *
  28. * CONSTANTES:
  29. * -----------
  30. *
  31. REAL*8 EPS,EPS9
  32. PARAMETER (EPS = 1.D-3)
  33. PARAMETER (EPS9 = 1.D0-EPS)
  34. *
  35. * VARIABLES:
  36. * ----------
  37. *
  38. * NEAR = RR TRES VOISIN D'UNE VALEUR DANS LA LISTE "MLREE1".
  39. * RR = VALEUR COURANTE DE LA LISTE "MLREE2".
  40. *
  41. REAL*8 RR,AR
  42. LOGICAL NEAR
  43. *
  44. * AUTEUR, DATE DE CREATION:
  45. * -------------------------
  46. *
  47. * PASCAL MANIGOT 9 SEPTEMBRE 1988
  48. *
  49. * LANGAGE:
  50. * --------
  51. *
  52. * ESOPE + FORTRAN77
  53. *
  54. ************************************************************************
  55. *
  56. SEGACT,MLREE1,MLREE2
  57. LDIM1 = MLREE1.PROG(/1)
  58. LDIM2 = MLREE2.PROG(/1)
  59. *
  60. JG = LDIM2
  61. SEGINI,MLENTI
  62. * CETTE TABLE, ASSOCIEE A "MLREE2", VA INDIQUER LA POSITION
  63. * D'INSERTION DE CHAQUE REEL (=0 S'IL NE FAUT PAS L'INSERER).
  64. *
  65. IR = 0
  66. NBINSE = 0
  67. *
  68. DO 100 IB=1,LDIM2
  69. *
  70. RR = MLREE2.PROG(IB)
  71. IDEB = MAX(1,IR)
  72. CALL PLACE3 (MLREE1.PROG,IDEB,LDIM1,RR, IR,AR)
  73. *
  74. IF (IR .EQ. 0) THEN
  75. NEAR = AR .LT. EPS
  76. ELSE IF (IR .EQ. LDIM1) THEN
  77. NEAR = AR .LT. EPS
  78. ELSE
  79. NEAR = AR.LT.EPS .OR. AR.GT.EPS9
  80. END IF
  81. *
  82. IF (NEAR) THEN
  83. LECT(IB) = 0
  84. ELSE
  85. LECT(IB) = IR + 1
  86. NBINSE = NBINSE + 1
  87. END IF
  88. *
  89. 100 CONTINUE
  90. * END DO
  91. *
  92. JG = LDIM1 + NBINSE
  93. SEGINI,MLREE3
  94. IDEB2 = 1
  95. I3 = 0
  96. *
  97. DO 200 IB=1,LDIM1
  98. *
  99. IF (NBINSE .GT. 0) THEN
  100. I2 = IDEB2
  101. DO 210 IB2=I2,JG
  102. IF (LECT(IB2) .GT. IB) THEN
  103. IDEB2 = IB2
  104. GOTO 212
  105. * EXIT
  106. END IF
  107. IF (LECT(IB2) .EQ. IB) THEN
  108. I3 = I3 + 1
  109. MLREE3.PROG(I3) = MLREE2.PROG(IB2)
  110. NBINSE = NBINSE - 1
  111. END IF
  112. 210 CONTINUE
  113. * END DO
  114. 212 CONTINUE
  115. END IF
  116. *
  117. I3 = I3 + 1
  118. MLREE3.PROG(I3) = MLREE1.PROG(IB)
  119. *
  120. 200 CONTINUE
  121. * END DO
  122. *
  123. IF (I3.LT.JG) THEN
  124. I4 = I3 + 1
  125. DO 220 IB = I4,JG
  126. DO 222 IB2 = 1,LDIM2
  127. IF (LECT(IB2).EQ.IB) THEN
  128. I3 = I3 + 1
  129. MLREE3.PROG(I3) = MLREE2.PROG(IB2)
  130. * EXIT
  131. GOTO 220
  132. ENDIF
  133. 222 CONTINUE
  134. * END DO
  135. 220 CONTINUE
  136. * END DO
  137. END IF
  138. *
  139. SEGSUP,MLENTI
  140. SEGDES,MLREE1,MLREE2
  141. SEGDES,MLREE3
  142. *
  143. END
  144.  
  145.  

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