Télécharger racpol.eso

Retour à la liste

Numérotation des lignes :

  1. C RACPOL SOURCE GF238795 18/02/05 21:15:46 9726
  2. SUBROUTINE RACPOL
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5.  
  6. -INC PPARAM
  7. -INC CCOPTIO
  8. -INC SMLREEL
  9. DIMENSION Q(4)
  10. CHARACTER*3 MOTI
  11. CHARACTER*4 MOT(3)
  12. data mot/'IMAG','BAIR','INTE'/
  13. MLREEI=0
  14. NROOT=0
  15. imeth=2
  16. ireel=1
  17. * write(6,*) ' entree dans racpol'
  18. 1 call lirmot ( mot ,3, iret, 0)
  19. if(iret.eq.1) then
  20. ireel=0
  21. elseif(iret.eq.2) then
  22. imeth=1
  23. elseif(iret.eq.3) then
  24. call lirree(xva1,1,iretou)
  25. if( ierr.ne.0) return
  26. call lirree(xva2,1,iretou)
  27. if( ierr.ne.0) return
  28. imeth=3
  29. endif
  30. if(iret.eq.0) go to 25
  31. go to 1
  32. 25 continue
  33. CALL LIRREE(U0,0,IRETOU)
  34. kerre=0
  35. if( iretou.eq.0) then
  36. call lirobj('LISTREEL',mlree1,1,iretou)
  37. if(ierr.ne.0) return
  38. segact mlree1
  39. * write(6,*)(mlree1.prog(iu),iu=1,mlree1.prog(/1))
  40. if(imeth.eq.2) then
  41. * write(6,*) ' appel de prlagu'
  42. call prlagu(mlree1,mlreel,mlreei,ireel,kerre)
  43. * write(6,*) ' sortie de prlagu'
  44. if(kerre.ne.0) then
  45. call erreur ( kerre)
  46. return
  47. endif
  48. elseif(imeth.eq.1) then
  49. * write(6,*) ' appel a bairst'
  50. call bairst(mlree1,mlreel,mlreei,ireel,kerre)
  51. if(kerre.ne.0) call erreur ( kerre)
  52. elseif(imeth.eq.3) then
  53. call cherac(mlree1,xraci,xva1,xva2)
  54. if(ierr.ne.0) return
  55. if( xraci.ne.-1234567.d0) then
  56. call ecrree(xraci)
  57. else
  58. call ecrcha('VIDE')
  59. endif
  60. return
  61. endif
  62. if(ierr.ne.0) return
  63. go to 100
  64. endif
  65. * write(6,*) ' passage ancienne methode'
  66. CALL LIRREE(U1,1,IRETOU)
  67. IF(IERR.NE.0) RETURN
  68. NDEG=1
  69. CALL LIRREE(U2,0,IRETOU)
  70. IF(IRETOU.EQ.0) GO TO 10
  71. NDEG=2
  72. CALL LIRREE(U3,0,IRETOU)
  73. IF(IRETOU.EQ.0) GO TO 20
  74. NDEG=3
  75. CALL LIRREE(U4,0,IRETOU)
  76. IF(IRETOU.EQ.0) GO TO 30
  77. NDEG=4
  78. C
  79. C cas du polynome du quatrieme degré
  80. C
  81. IF(U4.EQ.0.D0) GO TO 30
  82. * write(6,*) ' appel de quarti'
  83. CALL QUARTI(U4, U3, U2, U1,U0, Q(1), Q(2), Q(3), Q(4), NRoot)
  84. * write(6,*) ' sortie de quarti'
  85. GO TO 50
  86. C
  87. C cas du polynome du troisieme degré
  88. C
  89. 30 CONTINUE
  90. IF(U3.EQ.0.D0) GO TO 20
  91. CALL CUBIC(U3, U2, U1, U0, Q(1), Q(2), Q(3), NRoot)
  92. GO TO 50
  93. C
  94. C cas du polynome du deuxieme degré
  95. C
  96. 20 CONTINUE
  97. IF(U2.EQ.0.D0) GO TO 10
  98. CALL QUADRA(U2, U1, U0, Q(1), Q(2), NRoot)
  99. GO TO 50
  100. C
  101. C cas du polynome du premier degré
  102. C
  103. 10 CONTINUE
  104. IF(U1.EQ.0) THEN
  105. CALL ERREUR(21)
  106. RETURN
  107. ENDIF
  108. NROOT=1
  109. Q(1) = -U0 / U1
  110. 50 CONTINUE
  111. C
  112. C sortie des résultats
  113. C
  114. jg=nroot
  115. segini mlreel
  116. DO 52 I=1,NROOT
  117. prog(i)=Q(I)
  118. 52 CONTINUE
  119. 100 continue
  120. segact mlreel*mod
  121. mlree1=mlreei
  122. if(ireel.eq.0) segact mlree1*mod
  123. * write(6,*) 'avant ',( prog(io),io=1,prog(/1))
  124. * on commence par ordonnée en ordre croissant
  125. 101 continue
  126. ienc=0
  127. * write(6,*) ' prog(/1)' , prog(/1)
  128. do 102 i=1,prog(/1)-1
  129. * write(6,*) ' i ' ,i
  130. if( prog(i) . gt. prog (i+1) ) then
  131. a= prog(i)
  132. prog(i)= prog(i+1)
  133. prog(i+1)=a
  134. if(ireel.eq.0) then
  135. a = mlree1.prog(i)
  136. mlree1.prog(i)=mlree1.prog(i+1)
  137. mlree1.prog(i+1)=a
  138. endif
  139. ienc=1
  140. endif
  141. 102 continue
  142. if(ienc.eq.1) go to 101
  143. * write(6,*) 'apres ',( prog(io),io=1,prog(/1))
  144. if(ireel.eq.0) then
  145. call ecrobj ('LISTREEL',mlree1)
  146. segdes mlree1
  147. endif
  148. call ecrobj ('LISTREEL' , mlreel)
  149. segdes mlreel
  150. RETURN
  151. END
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  

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