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