Télécharger racpol.eso

Retour à la liste

Numérotation des lignes :

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

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