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

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