Iniciar sesiónCerrar
Correo:
Contraseña:
Entrar
Recordar sesión en este navegador
Iniciar sesiónIniciar sesiónCrear cuentaCrear cuenta
LWP » Código Fuente » Pascal/Turbo Pascal » Código de Pascal/Turbo Pascal - metodo de cardano para ecuciones cubicas , tercer grado

Código de Pascal/Turbo Pascal - metodo de cardano para ecuciones cubicas , tercer grado

Volver
Agregar Código Fuente
<<>>

Requerimientos

crt,math

free pascal
estrellaestrellaestrellaestrellaestrella(4)

Publicado el 12 de Abril del 2020gráfica de visualizaciones de la versión: free pascal
1.789 visualizaciones desde el 12 de Abril del 2020
estrellaestrellaestrellaestrellaestrella
estrellaestrellaestrellaestrella
estrellaestrellaestrella
estrellaestrella
estrella

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
program cardano;{ecuacion cubica con el metodo de cardano segun wikipedia}
uses crt,math;
var A,B,C,D,a1,b1,c1,p,q,dis,
    o,m,m1,ma,m2,u,ua,vf,v,
    x1,x1a,x21,x22,x31,x32,
    num,num1,num2,num3: real;
 
function racub(k:real) : real; {funcion para calcular la raiz cubica}
 var
  raiz : real;
 begin
   if k > 0 then
   begin
     racub:= exp((1/3)*ln(k));
   end;
   if k = 0 then
   begin
     racub:= 0;
   end;
   if k < 0 then
   begin
     racub:= -exp((1/3)*ln(-k));
   end;
 end;
 
begin
  clrscr;
  writeln('ecuacion cubica AX^3+BX^2+CX+D=0');
  writeln('Introduzca A');read(A);
  writeln('Introduzca B');read(B);
  writeln('Introduzca C');read(C);
  writeln('Introduzca D');read(D);
  a1:=B/A;
  b1:=C/A;
  c1:=D/A;
  p:= b1 - (power(a1,2)/3);
  q:= (2/27)*(power(a1,3)) - (1/3)*(a1*b1) + c1;
  dis:= power(q,2) + (4/27)*power(p,3);
  writeln('ecuacion reducida es : Z^3 + ',p:2:3,'Z + ',q:2:3);
  writeln('el discriminate es : ',dis:2:3);
  if dis > 0.1  then
  begin
    m := (1/2)*(-q + sqrt(dis));
    m1:= (-0.5)*(q + sqrt(dis));
    u:=  racub(m);
    v:=  racub(m1);
    writeln('el valor de u es : ',u:2:3);
    writeln('el valor de v es : ',v:2:3);
    x1:= u + v -(a1/3);
    x21:= (-1/2)*(u+v) -(a1/3);
    x22:= (1/2)*sqrt(3)*(u-v);
    x31:= x21;
    x32:= -x22;
    writeln(' la ecuacion tiene 1 raiz real 2 raices complejas');
    writeln(' la solucion real       es : ',x1:2:3);
    writeln(' la solucion compleja 1 es : ',x21:2:3,' + ',abs(x22):2:3,'i');
    writeln(' la solucion compleja 2 es : ',x31:2:3,' - ',abs(x32):2:3,'i');
  end;
  if ((dis < 0.1) and (dis > -0.1)) and ((p < 0.1) and (p > -0.1)) then
  begin
    writeln('la ecuacion tiene solucion unica');
    writeln('la solucion es :',-(a1/3):2:3);
  end;
  if ((dis < 0.1) and (dis  > - 0.1)) and ((p >= 0.1) or (p <= -0.1)) then
  begin
    m := (1/2)*(-q);
    u:=  racub(m);
    x1:= 2*u -(a1/3);
    x21:= -u -(a1/3);
    writeln('la ecuacion tiene soluciones multiples');
    writeln('la primera solucion es :',x1:2:3);
    writeln('la solucion repetida es :',x21:2:3);
  end;
  if dis < -0.1 then
  begin
    if round(q) <> 0 then
    begin
      num:= (-q/2)*sqrt((-27)/(p*p*p));
      num1:= (1/3)*ArcTan(sqrt(1-(num*num))/num);
    end
    else
    begin
      num1:= 1.5707/3;
    end;
    num2 := 2.094;
    num3 := 2*sqrt(-p/3);
    x1:= num3*cos(num1) -(a1/3);
    x21:= num3*cos(num1 +num2) -(a1/3);
    x31:= num3*cos(num1 +2*num2) -(a1/3);
    writeln('la ecuacion tiene raices distintas');
    writeln('la solucion 1 es ',x1:2:2);
    writeln('la solucion 2 es ',x21:2:2);
    writeln('la solucion 3 es ',x31:2:2);
  end;
  readkey;
end.



Comentarios sobre la versión: free pascal (4)

Roberto
13 de Abril del 2020
estrellaestrellaestrellaestrellaestrella
He ignorado que se debe considerar 3 casos para round(q)


if round(q) > 0 then
begin
num:= (-q/2)*sqrt((-27)/p*p*p);
num1:= (1/3)*(3.1416 + ArcTan(sqrt(1-(num*num))/num));
end;
if round(q) = 0 then
begin
num1:= 1.5707/3;
end;
if round(q) < 0 then
begin
num:= (-q/2)*sqrt((-27)/(p*p*p));
num1:= (1/3)*(ArcTan(sqrt(1-(num*num))/num));
end;
Responder
Roberto
13 de Abril del 2020
estrellaestrellaestrellaestrellaestrella
En este link de Wikipedia te explican el método
https://es.wikipedia.org/wiki/Método_de_Cardano
Responder
Roberto
13 de Abril del 2020
estrellaestrellaestrellaestrellaestrella
num:= (-q/2)*sqrt((-27)/p*p*p); en esta linea faltaron 2 paréntesis quedando así num:= (-q/2)*sqrt((-27)/(p*p*p)); Esto generaba un error después de introducir los datos

if round(q) > 0 then
begin
num:= (-q/2)*sqrt((-27)/(p*p*p));
num1:= (1/3)*(3.1416 + ArcTan(sqrt(1-(num*num))/num));
end;
if round(q) = 0 then
begin
num1:= 1.5707/3;
end;
if round(q) < 0 then
begin
num:= (-q/2)*sqrt((-27)/(p*p*p));
num1:= (1/3)*(ArcTan(sqrt(1-(num*num))/num));
end;
Responder
Roberto
15 de Abril del 2020
estrellaestrellaestrellaestrellaestrella
He incorporado la funcion arcocoseno

program cardano;{ecuacion cubica con el metodo de cardano segun wikipedia}
uses crt;

var A,B,C,D,a1,b1,c1,
p,q,dis,u,v,
x1,x2,x3,
pi,t: real;

function racub(k:real) : real; {funcion para calcular la raiz cubica}
begin
if k > 0 then
begin
racub:= exp((1/3)*ln(k));
end;
if k = 0 then
begin
racub:= 0;
end;
if k < 0 then
begin
racub:= -exp((1/3)*ln(abs(k)));
end;
end;

function arcs(i:real) : real; {funcion arcocoseno}
begin
if i> 0 then
begin
arcs:= (ArcTan(sqrt(1-(i*i))/abs(i)));
end;
if i=0 then
begin
arcs:= 2*(4*ArcTan(1/5) - ArcTan(1/239));{ se obtiene pi/2 = 1.5707}
end;
if i < 0 then
begin
arcs:= 4*(4*ArcTan(1/5) - ArcTan(1/239)) - (ArcTan(sqrt(1-(i*i))/abs(i)));
end;
end;

begin
clrscr;
writeln('ecuacion cubica AX^3+BX^2+CX+D=0');
write('Introduzca A ');read(A);
write('Introduzca B ');read(B);
write('Introduzca C ');read(C);
write('Introduzca D ');read(D);
If A= 0 then
begin write('A no puede ser igual a 0');readkey;exit;end;

pi:= 4*(4*ArcTan(1/5) - ArcTan(1/239));
t:= 0.0000000001;
a1:=B/A;
b1:=C/A;
c1:=D/A;
p:= b1 - ((a1*a1)/3);
q:= (2/27)*(a1*a1*a1) - (1/3)*(a1*b1) + c1;
dis:= (q*q) + (4/27)*(p*p*p); {discriminante}

writeln('ecuacion reducida es : Z^3 + ',p:2:3,'Z + ',q:2:3);
writeln('el discriminate es : ',dis:2:3);

if dis > t then { caso discriminate > 0}
begin
u:= racub((1/2)*(-q + sqrt(dis)));
v:= racub((-0.5)*(q + sqrt(dis)));
x1:= u + v -(a1/3);
x2:= (-1/2)*(u+v) -(a1/3);
x3:= (1/2)*sqrt(3)*(u-v);
writeln(' la ecuacion tiene 1 raiz real 2 raices complejas');
writeln(' la solucion real es : ',x1:2:3);
writeln(' la solucion compleja 1 es : ',x2:2:3,' + ',abs(x3):2:3,'i');
writeln(' la solucion compleja 2 es : ',x2:2:3,' - ',abs(x3):2:3,'i');
end;

if ((dis < t) and (dis > -t)) and ((p < t) and (p > -t)) then
{caso discriminante = 0 y p= 0}
begin
writeln('la ecuacion tiene solucion unica');
writeln('la solucion es :',-(a1/3):2:3);
end;

if ((dis < t) and (dis > - t)) and ((p >= t) or (p <= -t)) then
{caso discriminate = 0 y p<> 0}
begin
u:= racub((1/2)*(-q));
x1:= 2*u -(a1/3);
x2:= -u -(a1/3);
writeln('la ecuacion tiene soluciones multiples');
writeln('la primera solucion es :',x1:2:3);
writeln('la solucion repetida es :',x2:2:3);
end;

if dis < -t then { caso discriminante < 0}
begin
x1:= (2*sqrt(-p/3))*cos((1/3)*arcs((-q/2)*sqrt(-27/(p*p*p)))) -(a1/3);
x2:= (2*sqrt(-p/3))*cos((1/3)*arcs((-q/2)*sqrt((-27)/(p*p*p))) +(2*pi/3)) -(a1/3);
x3:= (2*sqrt(-p/3))*cos((1/3)*arcs((-q/2)*sqrt((-27)/(p*p*p))) +2*(2*pi/3)) -(a1/3);
writeln('la ecuacion tiene raices distintas');
writeln('la solucion 1 es ',x1:2:3);
writeln('la solucion 2 es ',x2:2:3);
writeln('la solucion 3 es ',x3:2:3);
end;

readkey;
end.
Responder

Comentar la versión: free pascal

Nombre
Correo (no se visualiza en la web)
Valoración
Comentarios...
CerrarCerrar
CerrarCerrar
Cerrar

Tienes que ser un usuario registrado para poder insertar imágenes, archivos y/o videos.

Puedes registrarte o validarte desde aquí.

Codigo
Negrita
Subrayado
Tachado
Cursiva
Insertar enlace
Imagen externa
Emoticon
Tabular
Centrar
Titulo
Linea
Disminuir
Aumentar
Vista preliminar
sonreir
dientes
lengua
guiño
enfadado
confundido
llorar
avergonzado
sorprendido
triste
sol
estrella
jarra
camara
taza de cafe
email
beso
bombilla
amor
mal
bien
Es necesario revisar y aceptar las políticas de privacidad
Acepto las políticas de privacidad

http://lwp-l.com/s6112