F90: Programa matemático (derivada, trigonometria, área, volume e raizes de polinômio)
From AdonaiMedrado.Pro.Br
Este programa foi desenvolvido pelos alunos Jeidsan Pereira, Juliana Fonseca Julio Cesar e Raimundo Junior durante a disciplina Processamento de Dados (UFBA 2008.2). Data da apresentação: 27/11/2008.
PROGRAM matematica IMPLICIT NONE REAL,PARAMETER::pi=3.1415926535897932384626433832795 INTEGER:: ERRO CALL MenuPrincipal CONTAINS !Subrotinas SUBROUTINE MenuPrincipal IMPLICIT NONE INTEGER::OPCAO WRITE(*,*) "Escolha uma das opcoes abaixo." WRITE(*,*) " "!Por motivos de organização do menu na tela. WRITE(*,*) "1 - Derivada polinomial" WRITE(*,*) "2 - Divisores de numeros inteiros" WRITE(*,*) "3 - A hipotenusa de um triangulo" WRITE(*,*) "4 - Area de uma figura geometrica" WRITE(*,*) "5 - Volume de um solido" WRITE(*,*) "6 - Raizes de um polinomio" WRITE(*,*) "7 - Trigonometria circular com multiplos arcos" WRITE(*,*) "8 - Trigonometria hiperbolica com multiplos arcos" WRITE(*,*) "9 - Sair" DO READ(*,*,IOSTAT=ERRO) opcao IF(ERRO>0.OR.OPCAO<1.OR.OPCAO>9)THEN WRITE(*,*)"Esta não e uma opcao valida. Por favor digite outra." ELSE EXIT END IF END DO SELECT CASE (OPCAO) CASE(1) CALL derivada CASE(2) CALL divisores CASE(3) CALL pitagoras CASE(4) CALL area CASE(5) CALL volume CASE(6) CALL polinomio CASE(7) CALL trigonometriacircular CASE(8) CALL trigonometriahiperbolica CASE(9) PAUSE "Obrigado por utilizar esse programa. Pressione ENTER para sair." STOP END SELECT END SUBROUTINE SUBROUTINE derivada IMPLICIT NONE INTEGER::grau,i,aux INTEGER,DIMENSION(:),ALLOCATABLE::V WRITE(*,*)"Digite o grau do polinomio que deseja derivar." READ(*,*) grau ALLOCATE(V(0:grau)) WRITE(*,*) "Digite os coeficientes inteiros do polinomio que deseja derivar em ordem de grau decrescente." DO i=1,grau+1 DO READ(*,*,IOSTAT=ERRO) V(i) IF(ERRO<=0)THEN EXIT ELSE IF(ERRO>0)THEN WRITE(*,*)"Valor invalido, digite outro." END IF END DO END DO IF(grau==0)THEN WRITE(*,*) "A derivada de seu polinomio e 0" END IF aux=grau+1 WRITE(*,*)"Seu polinomio e:" WRITE(*,*) (V(i),"x^",grau+1-i,"+",i=1,grau), v(aux) WRITE(*,*) "A expressao da derivada de seu polinomio é:" WRITE(*,*) ((aux-i)*v(i),"x^",grau-i,"+",i=1,grau-1), v(grau) DEALLOCATE(V) CALL VoltarParaMenu END SUBROUTINE SUBROUTINE divisores IMPLICIT NONE INTEGER::num, i INTEGER, DIMENSION(:), ALLOCATABLE::V WRITE(*,*)"Digite seu numero" READ(*,*) num ALLOCATE(V(1:ABS(num))) DO i=1,ABS(num) IF(MOD(num,i)==0)THEN V(i)=i ELSE V(i)=0 END IF END DO WRITE(*,*) "Os divisores de",num," sao" WRITE(*,*) " " DO i=1,ABS(num) IF(V(i)==0)CYCLE WRITE(*,*) V(i) WRITE(*,*) -V(i) END DO DEALLOCATE(V) CALL VoltarParaMenu END SUBROUTINE SUBROUTINE pitagoras IMPLICIT NONE REAL:: Cateto1, Cateto2, Hipotenusa WRITE(*,*) "Digite a medida do primeiro cateto." DO READ(*,*,IOSTAT=ERRO) Cateto1 IF(ERRO>0.OR.Cateto1<0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "Digite a medida do segundo cateto." DO READ(*,*,IOSTAT=ERRO) Cateto2 IF(ERRO>0.OR.Cateto1<0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO Hipotenusa=sqrt((Cateto1**2)+(Cateto2**2)) WRITE(*,*) "A hipotenusa do seu triangulo e ",Hipotenusa,"." CALL VoltarParaMenu END SUBROUTINE SUBROUTINE area IMPLICIT NONE INTEGER:: OPCAO WRITE(*,*)"Escolha uma das opcoes" WRITE(*,*) " " WRITE(*,*)"1 - Area do triangulo sabendo a altura" WRITE(*,*)"2 - Area do triangulo sabendo o angulo entre dois lados" WRITE(*,*)"3 - Area do triangulo circunscrito" WRITE(*,*)"4 - Area do triangulo inscrito" WRITE(*,*)"5 - Area do triangulo so com as medidas dos lados" WRITE(*,*)"6 - Area do triangulo equilatero" WRITE(*,*)"7 - Area do paralelogramo" WRITE(*,*)"8 - Area do trapezio" WRITE(*,*)"9 - Area do losango" WRITE(*,*)"10 - Area do quadrado" WRITE(*,*)"11 - Area do quadrado sabendo sua diagonal" WRITE(*,*)"12 - Area do circulo" WRITE(*,*)"13 - Area da coroa circular" DO READ(*,*,IOSTAT=ERRO) opcao IF(ERRO>0.OR.OPCAO<1.OR.OPCAO>13)THEN WRITE(*,*)"Esta nao e uma opcao valida. Por favor digite outra." ELSE EXIT END IF END DO SELECT CASE (OPCAO) CASE(1) CALL triangulocomaltura CASE(2) CALL triangulocomangulo CASE(3) CALL triangulocircunscrito CASE(4) CALL trianguloinscrito CASE(5) CALL triangulosocomasmedidasdoslados CASE(6) CALL trianguloequilatero CASE(7) CALL paralelogramo CASE(8) CALL trapezio CASE(9) CALL losango CASE(10) CALL quadrado CASE(11) CALL quadradosabendosuadiagonal CASE(12) CALL circulo CASE(13) CALL coroacircular END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE triangulocomaltura IMPLICIT NONE REAL ::a,h WRITE(*,*)"Digite a medida da base do triangulo" DO READ(*,*,IOSTAT=ERRO) a IF(ERRO>0.OR.a<0)THEN WRITE(*,*)"Valor invalido. Digite outra vez." ELSE EXIT END IF END DO WRITE(*,*)"Digite a medida da altura" DO READ(*,*,IOSTAT=ERRO) h IF(ERRO>0.OR.h<0)THEN WRITE(*,*)"Valor invalido. Digite outra vez." ELSE EXIT END IF END DO WRITE(*,*) calcularareadotriangulo(a,h) END SUBROUTINE triangulocomaltura SUBROUTINE triangulocomangulo IMPLICIT NONE REAL ::a,b,l WRITE(*,*)"Digite o primeiro lado" DO READ(*,*,IOSTAT=ERRO) a IF(ERRO>0.OR.a<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"digite o lado adjascente" DO READ(*,*,IOSTAT=ERRO) b IF(ERRO>0.OR.b<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO l=areadotriangulocomangulo(a,b) WRITE(*,*) l END SUBROUTINE triangulocomangulo SUBROUTINE triangulocircunscrito IMPLICIT NONE REAL ::a,b,c,R WRITE(*,*)"Digite o primeiro lado" DO READ(*,*,IOSTAT=ERRO) a IF(ERRO>0.OR.a<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite o segundo lado" DO READ(*,*,IOSTAT=ERRO) b IF(ERRO>0.OR.b<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite o terceiro lado" DO READ(*,*,IOSTAT=ERRO) c IF(ERRO>0.OR.c<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite o raio" DO READ(*,*,IOSTAT=ERRO) R IF(ERRO>0.OR.R<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*) areatriangulocircunscrito(a,b,c,R) END SUBROUTINE SUBROUTINE trianguloinscrito IMPLICIT NONE REAL ::a,b,c,r WRITE(*,*)"Digite o primeiro lado" DO READ(*,*,IOSTAT=ERRO) a IF(ERRO>0.OR.a<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite o segundo lado" DO READ(*,*,IOSTAT=ERRO) b IF(ERRO>0.OR.b<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite o terceiro lado" DO READ(*,*,IOSTAT=ERRO) c IF(ERRO>0.OR.c<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite o raio" DO READ(*,*,IOSTAT=ERRO) r IF(ERRO>0.OR.r<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*) areatrianguloinscrito(a,b,c,r) END SUBROUTINE trianguloinscrito SUBROUTINE triangulosocomasmedidasdoslados IMPLICIT NONE REAL ::a,b,c WRITE(*,*)"Digite o primeiro lado" DO READ(*,*,IOSTAT=ERRO) a IF(ERRO>0.OR.a<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite o segundo lado" DO READ(*,*,IOSTAT=ERRO) b IF(ERRO>0.OR.b<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite o terceiro lado" DO READ(*,*,IOSTAT=ERRO) c IF(ERRO>0.OR.c<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*) areatriangulosocomasmedidasdoslados(a,b,c) END SUBROUTINE triangulosocomasmedidasdoslados SUBROUTINE trianguloequilatero IMPLICIT NONE REAL ::l WRITE(*,*)"Digite o lado do triangulo equilatero" DO READ(*,*,IOSTAT=ERRO) l IF(ERRO>0.OR.l<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*) areatrianguloequilatero(l) END SUBROUTINE trianguloequilatero SUBROUTINE paralelogramo IMPLICIT NONE REAL ::a,b WRITE(*,*)"Digite a base" DO READ(*,*,IOSTAT=ERRO) a IF(ERRO>0.OR.a<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite a altura" DO READ(*,*,IOSTAT=ERRO) b IF(ERRO>0.OR.b<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*) arearetangulo(a,b) END SUBROUTINE paralelogramo SUBROUTINE trapezio IMPLICIT NONE REAL ::a,b,h WRITE(*,*)"Digite a medida da base maior" DO READ(*,*,IOSTAT=ERRO) a IF(ERRO>0.OR.a<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite a medida da base menor" DO READ(*,*,IOSTAT=ERRO)b IF(ERRO>0.OR.b<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite a altura do trapezio" DO READ(*,*,IOSTAT=ERRO)h IF(ERRO>0.OR.h<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*) areatrapezio(a,b,h) END SUBROUTINE trapezio SUBROUTINE losango IMPLICIT NONE REAL ::d1,d WRITE(*,*)"Digite a medida da diagonal maior" DO READ(*,*,IOSTAT=ERRO) d1 IF(ERRO>0.OR.d1<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite a medida da diagonal menor" DO READ(*,*,IOSTAT=ERRO) d IF(ERRO>0.OR.d<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*) arealosango(d1,d) END SUBROUTINE losango SUBROUTINE quadrado IMPLICIT NONE REAL ::l WRITE(*,*)"Digite o lado do quadrado" DO READ(*,*,IOSTAT=ERRO)l IF(ERRO>0.OR.l<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*) areaquadrado(l) END SUBROUTINE quadrado SUBROUTINE quadradosabendosuadiagonal IMPLICIT NONE REAL ::d WRITE(*,*)"Digite a diagonal" DO READ(*,*,IOSTAT=ERRO)d IF(ERRO>0.OR.d<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*) areaquadradosabendosuadiagonal(d) END SUBROUTINE quadradosabendosuadiagonal SUBROUTINE circulo IMPLICIT NONE REAL ::r WRITE(*,*)"Digite o raio." DO READ(*,*,IOSTAT=ERRO) r IF(ERRO>0.OR.r<0)THEN WRITE(*,*) "Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*) areacirculo(r) END SUBROUTINE circulo SUBROUTINE coroacircular IMPLICIT NONE REAL ::r1,r2 WRITE(*,*)"Digite a medida do raio maior." DO READ(*,*,IOSTAT=ERRO) r1 IF(ERRO>0.OR.r1<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*) "Digite a medida do raio menor." DO READ(*,*,IOSTAT=ERRO) r2 IF(ERRO>0.OR.r2<0.OR.r2>r1)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*) areacoroacircular(r1,r2) END SUBROUTINE coroacircular SUBROUTINE volume INTEGER ::ERRO,OPCAO WRITE(*,*)"Escolha uma das opcoes abaixo." WRITE(*,*)" " WRITE(*,*)"1 - Volume do paralelepipedo" WRITE(*,*)"2 - Cubo com aresta" WRITE(*,*)"3 - Volume do cilindro reto" WRITE(*,*)"4 - Volume do cilindro oco" WRITE(*,*)"5 - Volume do cilindro com secsão obliqua" WRITE(*,*)"6 - Volume da esfera cheia" WRITE(*,*)"7 - Volume da esfera oca" WRITE(*,*)"8 - Volume do cone reto" WRITE(*,*)"9 - Volume do tronco de cone" WRITE(*,*)"10 - Volume do prisma reto" WRITE(*,*)"11 - Volume do obelisco" DO READ(*,*,IOSTAT=ERRO) opcao IF(ERRO>0.OR.OPCAO<1.OR.OPCAO>11)THEN WRITE(*,*)"Esta nao e uma opcao valida. Por favor digite outra." ELSE EXIT END IF END DO SELECT CASE (OPCAO) CASE(1) CALL paralelepipedo CASE(2) CALL cubocomaresta CASE(3) CALL cilindroreto CASE(4) CALL cilindrooco CASE(5) CALL cilindrocomseccaoobliqua CASE(6) CALL esferacheia CASE(7) CALL esferaoca CASE(8) CALL conereto CASE(9) CALL troncodecone CASE(10) CALL prismareto CASE(11) CALL obelisco END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE paralelepipedo IMPLICIT NONE REAL ::a,b,h,l WRITE(*,*)"Digite a medida do comprimento da base" DO READ(*,*,IOSTAT=ERRO) a IF(ERRO>0.OR.a<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite a medida da largura da base" DO READ(*,*,IOSTAT=ERRO) b IF(ERRO>0.OR.b<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite a medida da altura" DO READ(*,*,IOSTAT=ERRO) h IF(ERRO>0.OR.h<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO l=arearetangulo(a,b) WRITE(*,*)(l*h) END SUBROUTINE paralelepipedo SUBROUTINE cubocomaresta IMPLICIT NONE REAL::aresta WRITE(*,*) "Digite o comprimento da aresta de seu cubo." DO READ(*,*,IOSTAT=ERRO) aresta IF(ERRO>0.OR.aresta<0)THEN WRITE(*,*) "Valor inválido, digite o comprimento da aresta de seu cubo." ELSE EXIT END IF END DO WRITE(*,*) "O volume do cubo de aresta",aresta," e ", aresta**3,"." END SUBROUTINE SUBROUTINE cilindroreto IMPLICIT NONE REAL ::r,h,l WRITE(*,*)"Digite a medida do raio da base" DO READ(*,*,IOSTAT=ERRO) r IF(ERRO>0.OR.r<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite a medida da altura" DO READ(*,*,IOSTAT=ERRO) h IF(ERRO>0.OR.h<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO l=areacirculo(r) WRITE(*,*)(l*h) END SUBROUTINE cilindroreto SUBROUTINE cilindrooco IMPLICIT NONE REAL ::r1,r2,h,l WRITE(*,*)"Digite o maior raio da coroa circular da base" DO READ(*,*,IOSTAT=ERRO)r1 IF(ERRO<0.OR.r1<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite o menor raio da coroa circular da base" DO READ(*,*,IOSTAT=ERRO)r2 IF(ERRO<0.OR.r2<0.OR.r1<r2)THEN WRITE(*,*)"Voce digitou um raio negativo ou MENOR que o SEGUNDO" ELSE EXIT END IF END DO WRITE(*,*)"Digite a medida da altura" DO READ(*,*,IOSTAT=ERRO)h IF(ERRO<0.OR.h<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO l=areacoroacircular(r1,r2) WRITE(*,*)(l*h) END SUBROUTINE cilindrooco SUBROUTINE cilindrocomseccaoobliqua IMPLICIT NONE REAL ::r,h1,h2,l WRITE(*,*)"Digite o raio da base" DO READ(*,*,IOSTAT=ERRO)r IF(ERRO<0.OR.r<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite a medida da altura menor" DO READ(*,*,IOSTAT=ERRO)h1 IF(ERRO<0.OR.h1<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite a altura maior" DO READ(*,*,IOSTAT=ERRO)h2 IF(ERRO<0.OR.h2<0.OR.h1>h2)THEN WRITE(*,*)"Voce digitou uma altura negativa ou MENOR que a primeira" ELSE EXIT END IF END DO l=areacirculo(r) WRITE(*,*)l*((h1+h2)/2) END SUBROUTINE cilindrocomseccaoobliqua SUBROUTINE esferacheia IMPLICIT NONE REAL ::r,l WRITE(*,*)"Digite a medida do raio" DO READ(*,*,IOSTAT=ERRO)r IF(ERRO<0.OR.r<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO l=areacirculo(r) WRITE(*,*) "O volume da esfera de raio ",r," e ", (4*l*r)/3 END SUBROUTINE esferacheia SUBROUTINE esferaoca IMPLICIT NONE REAL ::r1,r2,l WRITE(*,*)"Digite o raio maior" DO READ(*,*,IOSTAT=ERRO)r1 IF(ERRO<0.OR.r1<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite o raio menor" DO READ(*,*,IOSTAT=ERRO)r2 IF(ERRO<0.OR.r2<0.OR.r1<r2)THEN WRITE(*,*)"Voce digitou um raio negativo ou maior que o primeiro" ELSE EXIT END IF END DO l=areacoroacircular(r1,r2) WRITE(*,*)"O volume de sua esfera oca e ",4*l END SUBROUTINE esferaoca SUBROUTINE conereto IMPLICIT NONE REAL ::r,h,l WRITE(*,*) "Digite o raio da base de seu cone." DO READ(*,*,IOSTAT=ERRO) r IF(ERRO>0.OR.r<0)THEN WRITE(*,*) "Valor invalido. Digite o raio do circulo da base de seu cone." ELSE EXIT END IF END DO WRITE(*,*) "Digite a altura do seu cone." DO READ(*,*,IOSTAT=ERRO) h IF(ERRO>0.OR.h<0)THEN WRITE(*,*) "Valor invalido. Digite a altura de seu cone." ELSE EXIT END IF END DO l=areacirculo(r) WRITE(*,*) "O volume do cone de altura",h," e raio da base",r," e ", (l*h)/3 END SUBROUTINE conereto SUBROUTINE troncodecone IMPLICIT NONE REAL ::r1,r2,h,l,j WRITE(*,*)"Digite o raio do circulo da base" DO READ(*,*,IOSTAT=ERRO)r1 IF(ERRO<0.OR.r1<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO WRITE(*,*)"Digite o raio da circunferencia menor" DO READ(*,*,IOSTAT=ERRO)r2 IF(ERRO<0.OR.r2<0.OR.r1<r2)THEN WRITE(*,*)"Voce digitou um raio negativo ou maior que o primeiro" ELSE EXIT END IF END DO WRITE(*,*) "Digite a altura do seu cone." DO READ(*,*,IOSTAT=ERRO) h IF(ERRO>0.OR.h<0)THEN WRITE(*,*) "Valor invalido. Digite a altura de seu cone." ELSE EXIT END IF END DO l=areacirculo(r1) j=areacirculo(r2) WRITE(*,*) ((h*l)+(h*j)+(r1*r2*h*pi))/3 END SUBROUTINE troncodecone SUBROUTINE prismareto IMPLICIT NONE REAL::areadabase, altura WRITE(*,*) "Digite a area da base." DO READ(*,*,IOSTAT=ERRO) areadabase IF(ERRO>0.OR.areadabase<0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "Digite a altura." DO READ(*,*,IOSTAT=ERRO)altura IF(ERRO>0.OR.altura<0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*)"O volume do prisma cuja area da base e",areadabase,"e a altura e",altura,"e",areadabase*altura END SUBROUTINE prismareto SUBROUTINE obelisco IMPLICIT NONE REAL ::h,b1,b2,a1,a2 WRITE(*,*)"Digite o comprimento da base menor" DO READ(*,*,IOSTAT=ERRO) a1 IF(ERRO>0.OR.a1<0)THEN WRITE(*,*) "Valor invalido. Digite a altura de seu cone." ELSE EXIT END IF END DO WRITE(*,*)"Digite a largura da base maior" DO READ(*,*,IOSTAT=ERRO)b1 IF(ERRO>0.OR.b1<0)THEN WRITE(*,*) "Valor invalido. Digite a altura de seu cone." ELSE EXIT END IF END DO WRITE(*,*)"Digite o comprimento da base menor" DO READ(*,*,IOSTAT=ERRO) a2 IF(ERRO>0.OR.a2<0)THEN WRITE(*,*) "Valor invalido. Digite a altura de seu cone." ELSE EXIT END IF END DO WRITE(*,*)"Digite a largura da base menor" DO READ(*,*,IOSTAT=ERRO)b2 IF(ERRO>0.OR.b2<0)THEN WRITE(*,*) "Valor invalido. Digite a altura de seu cone." ELSE EXIT END IF END DO WRITE(*,*)"Digite a altura de seu obelisco" DO READ(*,*,IOSTAT=ERRO) h IF(ERRO>0.OR.h<0)THEN WRITE(*,*) "Valor invalido. Digite a altura de seu cone." ELSE EXIT END IF END DO WRITE(*,*)(h/6)*(((2*a1+a2)*b1)+((2*a2+a1)*b2)) END SUBROUTINE obelisco SUBROUTINE polinomio IMPLICIT NONE INTEGER::grau, j, i, k REAL:: auxiliar1, auxiliar2 INTEGER,DIMENSION(:),ALLOCATABLE:: Coeficientes, Divmaiorgrau, Divindependente REAL,DIMENSION(:,:),ALLOCATABLE:: PossiveisRaizes WRITE(*,*) "Digite o grau do seu polinomio." DO READ(*,*,IOSTAT=ERRO) grau IF(ERRO>0.OR.grau<0)THEN WRITE(*,*) "Valor invalido. Digite o grau de seu polinomio, maior que zero." ELSE EXIT END IF END DO ALLOCATE(Coeficientes(0:grau)) WRITE(*,*) "Digito os coeficientes de seu polinomio ordenadamente." DO i=1,grau+1 DO READ(*,*,IOSTAT=ERRO) Coeficientes(grau+1-i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido. Digite um numero inteiro." ELSE EXIT END IF END DO END DO IF(Coeficientes(grau)==0.OR.Coeficientes(0)==0)THEN WRITE(*,*) "Nao e possivel encontrar raizes em seu polinomio." STOP END IF ALLOCATE(Divmaiorgrau(1:ABS(Coeficientes(grau)))) ALLOCATE(Divindependente(1:ABS(Coeficientes(0)))) DO i=1,ABS(Coeficientes(grau)) IF(MOD(Coeficientes(grau),i)==0)THEN Divmaiorgrau(i)=i ELSE Divmaiorgrau(i)=1 END IF END DO DO i=1,ABS(Coeficientes(0)) IF(MOD(Coeficientes(0),i)==0)THEN Divindependente(i)=i ELSE Divindependente(i)=1 END IF END DO ALLOCATE(Possiveisraizes(1:ABS(Coeficientes(grau)),1:ABS(Coeficientes(0)))) DO i=1,ABS(Coeficientes(grau)) DO j=1,ABS(Coeficientes(0)) Possiveisraizes(i,j)=Divindependente(j)/(1.0*Divmaiorgrau(i)) END DO END DO WRITE(*,*) "Os divisores do termo",Coeficientes(grau),"sao:" WRITE(*,*) (Divmaiorgrau(i),i=1,ABS(Coeficientes(grau))) WRITE(*,*) "Os divisores do termo",Coeficientes(0),"sao:" WRITE(*,*) (Divindependente(i),i=1,ABS(Coeficientes(0))) WRITE(*,*) "As Possiveis raizes de seu polinomio sao:" DO i=1,Coeficientes(grau) DO j=1,Coeficientes(0) WRITE(*,*) Possiveisraizes(i,j) WRITE(*,*) -Possiveisraizes(i,j) END DO END DO WRITE(*,*) "Concluimos que:" DO i=1,ABS(Coeficientes(grau)) DO j=1,ABS(Coeficientes(0)) auxiliar1=0 auxiliar2=0 DO k=1,grau+1 IF(MOD(grau,2)==0)THEN auxiliar1=auxiliar1+(Coeficientes(grau+1-k)*((PossiveisRaizes(i,j))**(grau+1-k))) auxiliar2=auxiliar2+(Coeficientes(grau+1-k)*((-PossiveisRaizes(i,j))**(grau+1-k))) ELSE auxiliar1=auxiliar1+(Coeficientes(grau+1-k)*(PossiveisRaizes(i,j))**(grau+1-k)) auxiliar2=auxiliar2+(Coeficientes(grau+1-k)*(-PossiveisRaizes(i,j))**(grau+1-k)) END IF END DO IF(auxiliar1==0)THEN WRITE(*,*) PossiveisRaizes(i,j)," e uma raiz." END IF IF(auxiliar2==0)THEN WRITE(*,*) -PossiveisRaizes(i,j)," e uma raiz." END IF END DO END DO CALL VoltarParaMenu END SUBROUTINE SUBROUTINE trigonometriacircular IMPLICIT NONE INTEGER:: OPCAO2 WRITE(*,*) "Por favor, escolha uma das opcoes abaixo." WRITE(*,*) " " WRITE(*,*) "1 - Seno" WRITE(*,*) "2 - Cosseno" WRITE(*,*) "3 - Tangente" WRITE(*,*) "4 - Cotangente" WRITE(*,*) "5 - Secante" WRITE(*,*) "6 - Cossecante" DO READ(*,*,IOSTAT=ERRO) OPCAO2 IF(ERRO>0.OR.OPCAO2<1.OR.OPCAO2>6)THEN WRITE(*,*) "Opcao invalida, por favor digite uma opcao valida." ELSE EXIT END IF END DO SELECT CASE(OPCAO2) CASE(1) CALL SenoCircular CASE(2) CALL CossenoCircular CASE(3) CALL TangenteCircular CASE(4) CALL CotangenteCircular CASE(5) CALL SecanteCircular CASE(6) CALL CossecanteCircular END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE SenoCircular IMPLICIT NONE INTEGER::OPCAO3,i,quantidade REAL:: argumento,doisarcos(2),arco, auxiliar REAL,DIMENSION(:),ALLOCATABLE::arcos WRITE(*,*) "Selecione uma das opcoes abaixo" WRITE(*,*) " " WRITE(*,*) "1 - Seno da soma de arcos" WRITE(*,*) "2 - Seno da diferença entre dois arcos" WRITE(*,*) "3 - Seno do arco metade" WRITE(*,*) "4 - Seno do arco duplo" DO READ(*,*,IOSTAT=ERRO) OPCAO3 IF(ERRO>0.OR.OPCAO3<1.OR.OPCAO3>4)THEN WRITE(*,*) "Opcao invalida, por favor digite outra." ELSE EXIT END IF END DO SELECT CASE(OPCAO3) CASE(1) WRITE(*,*) "Quantos arcos voce deseja calcular?" DO READ(*,*,IOSTAT=ERRO) quantidade IF(ERRO>0.OR.OPCAO3<0.OR.quantidade>25)THEN WRITE(*,*) "Valor invalido, digite um valor inteiro entre 0 e 25." ELSE EXIT END IF END DO ALLOCATE(arcos(1:quantidade)) WRITE(*,*) "Digite seus arcos." DO i=1,quantidade DO READ(*,*,IOSTAT=ERRO) arcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite um numero real." ELSE EXIT END IF END DO END DO auxiliar=0 DO i=1,quantidade auxiliar=auxiliar+arcos(i) END DO WRITE(*,*) "O seno da soma dos termos",(arcos(i), i=1,quantidade)," e ",sin(auxiliar),"." CASE(2) WRITE(*,*) "Digite seus dois arcos." DO i=1,2 DO READ(*,*,IOSTAT=ERRO) doisarcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite outro valor." ELSE EXIT END IF END DO END DO WRITE(*,*) "O seno da diferença entre",doisarcos(1)," e",doisarcos(2)," e",sin((doisarcos(1)-doisarcos(2))),"." CASE(3) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "O seno da metade do arco",arco," e,",sin((arco/2)),"." CASE(4) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "O seno do arco duplo",arco," e,",sin((2*arco)),"." END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE CossenoCircular IMPLICIT NONE INTEGER::OPCAO3,i,quantidade REAL:: argumento,doisarcos(2),arco, auxiliar REAL,DIMENSION(:),ALLOCATABLE::arcos WRITE(*,*) "Selecione uma das opcoes abaixo" WRITE(*,*) " " WRITE(*,*) "1 - Cosseno da soma de arcos" WRITE(*,*) "2 - Cosseno da diferença entre dois arcos" WRITE(*,*) "3 - Cosseno do arco metade" WRITE(*,*) "4 - Cosseno do arco duplo" DO READ(*,*,IOSTAT=ERRO) OPCAO3 IF(ERRO>0.OR.OPCAO3<1.OR.OPCAO3>4)THEN WRITE(*,*) "Opcao invalida, por favor digite outra." ELSE EXIT END IF END DO SELECT CASE(OPCAO3) CASE(1) WRITE(*,*) "Quantos arcos voce deseja calcular?" DO READ(*,*,IOSTAT=ERRO) quantidade IF(ERRO>0.OR.OPCAO3<0.OR.quantidade>25)THEN WRITE(*,*) "Valor invalido, digite um valor inteiro entre 0 e 25." ELSE EXIT END IF END DO ALLOCATE(arcos(1:quantidade)) WRITE(*,*) "Digite seus arcos." DO i=1,quantidade DO READ(*,*,IOSTAT=ERRO) arcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite um numero real." ELSE EXIT END IF END DO END DO auxiliar=0 DO i=1,quantidade auxiliar=auxiliar+arcos(i) END DO WRITE(*,*) "O cosseno da soma dos termos",(arcos(i), i=1,quantidade)," e ",cos(auxiliar),"." CASE(2) WRITE(*,*) "Digite seus dois arcos." DO i=1,2 DO READ(*,*,IOSTAT=ERRO) doisarcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite outro valor." ELSE EXIT END IF END DO END DO WRITE(*,*) "O cosseno da diferença entre",doisarcos(1)," e",doisarcos(2)," e",cos((doisarcos(1)-doisarcos(2))),"." CASE(3) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "O cosseno da metade do arco",arco," e,",cos((arco/2)),"." CASE(4) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "O cosseno do arco duplo",arco," e,",cos((2*arco)),"." END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE TangenteCircular IMPLICIT NONE INTEGER::OPCAO3,i,quantidade REAL:: argumento,doisarcos(2),arco, auxiliar REAL,DIMENSION(:),ALLOCATABLE::arcos WRITE(*,*) "Selecione uma das opcoes abaixo" WRITE(*,*) " " WRITE(*,*) "1 - Tangente da soma de arcos" WRITE(*,*) "2 - Tangente da diferença entre dois arcos" WRITE(*,*) "3 - Tangente do arco metade" WRITE(*,*) "4 - Tangente do arco duplo" DO READ(*,*,IOSTAT=ERRO) OPCAO3 IF(ERRO>0.OR.OPCAO3<1.OR.OPCAO3>4)THEN WRITE(*,*) "Opcao invalida, por favor digite outra." ELSE EXIT END IF END DO SELECT CASE(OPCAO3) CASE(1) WRITE(*,*) "Quantos arcos voce deseja calcular?" DO READ(*,*,IOSTAT=ERRO) quantidade IF(ERRO>0.OR.OPCAO3<0.OR.quantidade>25)THEN WRITE(*,*) "Valor invalido, digite um valor inteiro entre 0 e 25." ELSE EXIT END IF END DO ALLOCATE(arcos(1:quantidade)) WRITE(*,*) "Digite seus arcos." DO i=1,quantidade DO READ(*,*,IOSTAT=ERRO) arcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite um numero real." ELSE EXIT END IF END DO END DO auxiliar=0 DO i=1,quantidade auxiliar=auxiliar+arcos(i) END DO WRITE(*,*) "A tangente da soma dos termos",(arcos(i), i=1,quantidade)," e ",tan(auxiliar),"." CASE(2) WRITE(*,*) "Digite seus dois arcos." DO i=1,2 DO READ(*,*,IOSTAT=ERRO) doisarcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite outro valor." ELSE EXIT END IF END DO END DO WRITE(*,*) "A tangente da diferença entre",doisarcos(1)," e",doisarcos(2)," e",tan((doisarcos(1)-doisarcos(2))),"." CASE(3) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A tangente da metade do arco",arco," e,",tan((arco/2)),"." CASE(4) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A tangente do arco duplo",arco," e,",tan((2*arco)),"." END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE CotangenteCircular IMPLICIT NONE INTEGER::OPCAO3,i,quantidade REAL:: argumento,doisarcos(2),arco, auxiliar REAL,DIMENSION(:),ALLOCATABLE::arcos WRITE(*,*) "Selecione uma das opcoes abaixo" WRITE(*,*) " " WRITE(*,*) "1 - Cotangente da soma de arcos" WRITE(*,*) "2 - Cotangente da diferença entre dois arcos" WRITE(*,*) "3 - Cotangente do arco metade" WRITE(*,*) "4 - Cotangente do arco duplo" DO READ(*,*,IOSTAT=ERRO) OPCAO3 IF(ERRO>0.OR.OPCAO3<1.OR.OPCAO3>4)THEN WRITE(*,*) "Opcao invalida, por favor digite outra." ELSE EXIT END IF END DO SELECT CASE(OPCAO3) CASE(1) WRITE(*,*) "Quantos arcos voce deseja calcular?" DO READ(*,*,IOSTAT=ERRO) quantidade IF(ERRO>0.OR.OPCAO3<0.OR.quantidade>25)THEN WRITE(*,*) "Valor invalido, digite um valor inteiro entre 0 e 25." ELSE EXIT END IF END DO ALLOCATE(arcos(1:quantidade)) WRITE(*,*) "Digite seus arcos." DO i=1,quantidade DO READ(*,*,IOSTAT=ERRO) arcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite um numero real." ELSE EXIT END IF END DO END DO auxiliar=0 DO i=1,quantidade auxiliar=auxiliar+arcos(i) END DO WRITE(*,*) "A cotangente da soma dos termos",(arcos(i), i=1,quantidade)," e ",(1.0)/(tan(auxiliar)),"." CASE(2) WRITE(*,*) "Digite seus dois arcos." DO i=1,2 DO READ(*,*,IOSTAT=ERRO) doisarcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite outro valor." ELSE EXIT END IF END DO END DO WRITE(*,*) "A cotangente da diferença entre",doisarcos(1)," e",doisarcos(2)," e",(1.0)/(tan((doisarcos(1)-doisarcos(2)))),"." CASE(3) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A cotangente da metade do arco",arco," e,",(1.0)/(tan((arco/2))),"." CASE(4) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A cotangente do arco duplo",arco," e,",(1.0)/(tan((2*arco))),"." END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE SecanteCircular IMPLICIT NONE INTEGER::OPCAO3,i,quantidade REAL:: argumento,doisarcos(2),arco, auxiliar REAL,DIMENSION(:),ALLOCATABLE::arcos WRITE(*,*) "Selecione uma das opcoes abaixo" WRITE(*,*) " " WRITE(*,*) "1 - Secante da soma de arcos" WRITE(*,*) "2 - Secante da diferença entre dois arcos" WRITE(*,*) "3 - Secante do arco metade" WRITE(*,*) "4 - Secante do arco duplo" DO READ(*,*,IOSTAT=ERRO) OPCAO3 IF(ERRO>0.OR.OPCAO3<1.OR.OPCAO3>4)THEN WRITE(*,*) "Opcao invalida, por favor digite outra." ELSE EXIT END IF END DO SELECT CASE(OPCAO3) CASE(1) WRITE(*,*) "Quantos arcos voce deseja calcular?" DO READ(*,*,IOSTAT=ERRO) quantidade IF(ERRO>0.OR.OPCAO3<0.OR.quantidade>25)THEN WRITE(*,*) "Valor invalido, digite um valor inteiro entre 0 e 25." ELSE EXIT END IF END DO ALLOCATE(arcos(1:quantidade)) WRITE(*,*) "Digite seus arcos." DO i=1,quantidade DO READ(*,*,IOSTAT=ERRO) arcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite um numero real." ELSE EXIT END IF END DO END DO auxiliar=0 DO i=1,quantidade auxiliar=auxiliar+arcos(i) END DO WRITE(*,*) "A secante da soma dos termos",(arcos(i), i=1,quantidade)," e ",(1.0)/(cos(auxiliar)),"." CASE(2) WRITE(*,*) "Digite seus dois arcos." DO i=1,2 DO READ(*,*,IOSTAT=ERRO) doisarcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite outro valor." ELSE EXIT END IF END DO END DO WRITE(*,*) "A secante da diferença entre",doisarcos(1)," e",doisarcos(2)," e",(1.0)/(cos((doisarcos(1)-doisarcos(2)))),"." CASE(3) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A secante da metade do arco",arco," e,",(1.0)/(cos((arco/2))),"." CASE(4) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A secante do arco duplo",arco," e,",(1.0)/(cos((2*arco))),"." END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE CossecanteCircular IMPLICIT NONE INTEGER::OPCAO3,i,quantidade REAL:: argumento,doisarcos(2),arco, auxiliar REAL,DIMENSION(:),ALLOCATABLE::arcos WRITE(*,*) "Selecione uma das opcoes abaixo" WRITE(*,*) " " WRITE(*,*) "1 - Secante da soma de arcos" WRITE(*,*) "2 - Secante da diferença entre dois arcos" WRITE(*,*) "3 - Secante do arco metade" WRITE(*,*) "4 - Secante do arco duplo" DO READ(*,*,IOSTAT=ERRO) OPCAO3 IF(ERRO>0.OR.OPCAO3<1.OR.OPCAO3>4)THEN WRITE(*,*) "Opcao invalida, por favor digite outra." ELSE EXIT END IF END DO SELECT CASE(OPCAO3) CASE(1) WRITE(*,*) "Quantos arcos voce deseja calcular?" DO READ(*,*,IOSTAT=ERRO) quantidade IF(ERRO>0.OR.OPCAO3<0.OR.quantidade>25)THEN WRITE(*,*) "Valor invalido, digite um valor inteiro entre 0 e 25." ELSE EXIT END IF END DO ALLOCATE(arcos(1:quantidade)) WRITE(*,*) "Digite seus arcos." DO i=1,quantidade DO READ(*,*,IOSTAT=ERRO) arcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite um numero real." ELSE EXIT END IF END DO END DO auxiliar=0 DO i=1,quantidade auxiliar=auxiliar+arcos(i) END DO WRITE(*,*) "A cossecante da soma dos termos",(arcos(i), i=1,quantidade)," e ",(1.0)/(sin(auxiliar)),"." CASE(2) WRITE(*,*) "Digite seus dois arcos." DO i=1,2 DO READ(*,*,IOSTAT=ERRO) doisarcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite outro valor." ELSE EXIT END IF END DO END DO WRITE(*,*) "A cossecante da diferença entre",doisarcos(1)," e",doisarcos(2)," e",(1.0)/(sin((doisarcos(1)-doisarcos(2)))),"." CASE(3) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A cossecante da metade do arco",arco," e,",(1.0)/(sin((arco/2))),"." CASE(4) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A cossecante do arco duplo",arco," e,",(1.0)/(sin((2*arco))),"." END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE trigonometriaHiperbolica IMPLICIT NONE INTEGER:: OPCAO2 WRITE(*,*) "Por favor, escolha uma das opcoes abaixo." WRITE(*,*) " " WRITE(*,*) "1 - Seno" WRITE(*,*) "2 - Cosseno" WRITE(*,*) "3 - Tangente" WRITE(*,*) "4 - Cotangente" WRITE(*,*) "5 - Secante" WRITE(*,*) "6 - Cossecante" DO READ(*,*,IOSTAT=ERRO) OPCAO2 IF(ERRO>0.OR.OPCAO2<1.OR.OPCAO2>6)THEN WRITE(*,*) "Opcao invalida, por favor digite uma opcao valida." ELSE EXIT END IF END DO SELECT CASE(OPCAO2) CASE(1) CALL SenoHiperbolico CASE(2) CALL CossenoHiperbolico CASE(3) CALL TangenteHiperbolica CASE(4) CALL CotangenteHiperbolica CASE(5) CALL SecanteHiperbolica CASE(6) CALL CossecanteHiperbolica END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE SenoHiperbolico IMPLICIT NONE INTEGER::OPCAO3,i,quantidade REAL:: argumento,doisarcos(2),arco, auxiliar REAL,DIMENSION(:),ALLOCATABLE::arcos WRITE(*,*) "Selecione uma das opcoes abaixo" WRITE(*,*) " " WRITE(*,*) "1 - Seno hiperbolico da soma de arcos" WRITE(*,*) "2 - Seno hiperbolico da diferença entre dois arcos" WRITE(*,*) "3 - Seno hiperbolico do arco metade" WRITE(*,*) "4 - Seno hiperbolico do arco duplo" DO READ(*,*,IOSTAT=ERRO) OPCAO3 IF(ERRO>0.OR.OPCAO3<1.OR.OPCAO3>4)THEN WRITE(*,*) "Opcao invalida, por favor digite outra." ELSE EXIT END IF END DO SELECT CASE(OPCAO3) CASE(1) WRITE(*,*) "Quantos arcos voce deseja calcular?" DO READ(*,*,IOSTAT=ERRO) quantidade IF(ERRO>0.OR.OPCAO3<0.OR.quantidade>25)THEN WRITE(*,*) "Valor invalido, digite um valor inteiro entre 0 e 25." ELSE EXIT END IF END DO ALLOCATE(arcos(1:quantidade)) WRITE(*,*) "Digite seus arcos." DO i=1,quantidade DO READ(*,*,IOSTAT=ERRO) arcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite um numero real." ELSE EXIT END IF END DO END DO auxiliar=0 DO i=1,quantidade auxiliar=auxiliar+arcos(i) END DO WRITE(*,*) "O seno hiperbolico da soma dos termos",(arcos(i), i=1,quantidade)," e ",sinh(auxiliar),"." CASE(2) WRITE(*,*) "Digite seus dois arcos." DO i=1,2 DO READ(*,*,IOSTAT=ERRO) doisarcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite outro valor." ELSE EXIT END IF END DO END DO WRITE(*,*) "O seno hiperbolico da diferença entre",doisarcos(1)," e",doisarcos(2)," e",sinh((doisarcos(1)-doisarcos(2))),"." CASE(3) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "O seno hiperbolico da metade do arco",arco," e,",sinh((arco/2)),"." CASE(4) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "O seno hiperbolico do arco duplo",arco," e,",sinh((2*arco)),"." END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE CossenoHiperbolico IMPLICIT NONE INTEGER::OPCAO3,i,quantidade REAL:: argumento,doisarcos(2),arco, auxiliar REAL,DIMENSION(:),ALLOCATABLE::arcos WRITE(*,*) "Selecione uma das opcoes abaixo" WRITE(*,*) " " WRITE(*,*) "1 - Cosseno hiperbolico da soma de arcos" WRITE(*,*) "2 - Cosseno hiperbolico da diferença entre dois arcos" WRITE(*,*) "3 - Cosseno hiperbolico do arco metade" WRITE(*,*) "4 - Cosseno hiperbolico do arco duplo" DO READ(*,*,IOSTAT=ERRO) OPCAO3 IF(ERRO>0.OR.OPCAO3<1.OR.OPCAO3>4)THEN WRITE(*,*) "Opcao invalida, por favor digite outra." ELSE EXIT END IF END DO SELECT CASE(OPCAO3) CASE(1) WRITE(*,*) "Quantos arcos voce deseja calcular?" DO READ(*,*,IOSTAT=ERRO) quantidade IF(ERRO>0.OR.OPCAO3<0.OR.quantidade>25)THEN WRITE(*,*) "Valor invalido, digite um valor inteiro entre 0 e 25." ELSE EXIT END IF END DO ALLOCATE(arcos(1:quantidade)) WRITE(*,*) "Digite seus arcos." DO i=1,quantidade DO READ(*,*,IOSTAT=ERRO) arcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite um numero real." ELSE EXIT END IF END DO END DO auxiliar=0 DO i=1,quantidade auxiliar=auxiliar+arcos(i) END DO WRITE(*,*) "O cosseno hiperbolico da soma dos termos",(arcos(i), i=1,quantidade)," e ",cosh(auxiliar),"." CASE(2) WRITE(*,*) "Digite seus dois arcos." DO i=1,2 DO READ(*,*,IOSTAT=ERRO) doisarcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite outro valor." ELSE EXIT END IF END DO END DO WRITE(*,*) "O cosseno hiperbolico da diferença entre",doisarcos(1)," e",doisarcos(2)," e",cosh((doisarcos(1)-doisarcos(2))),"." CASE(3) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "O cosseno hiperbolico da metade do arco",arco," e,",cosh((arco/2)),"." CASE(4) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "O cosseno hiperbolico do arco duplo",arco," e,",cosh((2*arco)),"." END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE TangenteHiperbolica IMPLICIT NONE INTEGER::OPCAO3,i,quantidade REAL:: argumento,doisarcos(2),arco, auxiliar REAL,DIMENSION(:),ALLOCATABLE::arcos WRITE(*,*) "Selecione uma das opcoes abaixo" WRITE(*,*) " " WRITE(*,*) "1 - Tangente hiperbolico da soma de arcos" WRITE(*,*) "2 - Tangente hiperbolico da diferença entre dois arcos" WRITE(*,*) "3 - Tangente hiperbolico do arco metade" WRITE(*,*) "4 - Tangente hiperbolico do arco duplo" DO READ(*,*,IOSTAT=ERRO) OPCAO3 IF(ERRO>0.OR.OPCAO3<1.OR.OPCAO3>4)THEN WRITE(*,*) "Opcao invalida, por favor digite outra." ELSE EXIT END IF END DO SELECT CASE(OPCAO3) CASE(1) WRITE(*,*) "Quantos arcos voce deseja calcular?" DO READ(*,*,IOSTAT=ERRO) quantidade IF(ERRO>0.OR.OPCAO3<0.OR.quantidade>25)THEN WRITE(*,*) "Valor invalido, digite um valor inteiro entre 0 e 25." ELSE EXIT END IF END DO ALLOCATE(arcos(1:quantidade)) WRITE(*,*) "Digite seus arcos." DO i=1,quantidade DO READ(*,*,IOSTAT=ERRO) arcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite um numero real." ELSE EXIT END IF END DO END DO auxiliar=0 DO i=1,quantidade auxiliar=auxiliar+arcos(i) END DO WRITE(*,*) "A tangente hiperbolico da soma dos termos",(arcos(i), i=1,quantidade)," e ",tanh(auxiliar),"." CASE(2) WRITE(*,*) "Digite seus dois arcos." DO i=1,2 DO READ(*,*,IOSTAT=ERRO) doisarcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite outro valor." ELSE EXIT END IF END DO END DO WRITE(*,*) "A tangente hiperbolico da diferença entre",doisarcos(1)," e",doisarcos(2)," e",tanh((doisarcos(1)-doisarcos(2))),"." CASE(3) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A tangente hiperbolico da metade do arco",arco," e,",tanh((arco/2)),"." CASE(4) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A tangente hiperbolico do arco duplo",arco," e,",tanh((2*arco)),"." END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE CotangenteHiperbolica IMPLICIT NONE INTEGER::OPCAO3,i,quantidade REAL:: argumento,doisarcos(2),arco, auxiliar REAL,DIMENSION(:),ALLOCATABLE::arcos WRITE(*,*) "Selecione uma das opcoes abaixo" WRITE(*,*) " " WRITE(*,*) "1 - Cotangente hiperbolico da soma de arcos" WRITE(*,*) "2 - Cotangente hiperbolico da diferença entre dois arcos" WRITE(*,*) "3 - Cotangente hiperbolico do arco metade" WRITE(*,*) "4 - Cotangente hiperbolico do arco duplo" DO READ(*,*,IOSTAT=ERRO) OPCAO3 IF(ERRO>0.OR.OPCAO3<1.OR.OPCAO3>4)THEN WRITE(*,*) "Opcao invalida, por favor digite outra." ELSE EXIT END IF END DO SELECT CASE(OPCAO3) CASE(1) WRITE(*,*) "Quantos arcos voce deseja calcular?" DO READ(*,*,IOSTAT=ERRO) quantidade IF(ERRO>0.OR.OPCAO3<0.OR.quantidade>25)THEN WRITE(*,*) "Valor invalido, digite um valor inteiro entre 0 e 25." ELSE EXIT END IF END DO ALLOCATE(arcos(1:quantidade)) WRITE(*,*) "Digite seus arcos." DO i=1,quantidade DO READ(*,*,IOSTAT=ERRO) arcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite um numero real." ELSE EXIT END IF END DO END DO auxiliar=0 DO i=1,quantidade auxiliar=auxiliar+arcos(i) END DO WRITE(*,*) "A cotangente hiperbolico da soma dos termos",(arcos(i), i=1,quantidade)," e ",(1.0)/(tanh(auxiliar)),"." CASE(2) WRITE(*,*) "Digite seus dois arcos." DO i=1,2 DO READ(*,*,IOSTAT=ERRO) doisarcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite outro valor." ELSE EXIT END IF END DO END DO WRITE(*,*) "A cotangente hiperbolico da diferença entre",doisarcos(1), & " e ",doisarcos(2)," e ",(1.0)/tanh(doisarcos(1)-doisarcos(2)),"." CASE(3) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A cotangente hiperbolico da metade do arco",arco," e,",(1.0)/(tanh((arco/2))),"." CASE(4) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A cotangente hiperbolico do arco duplo",arco," e,",(1.0)/(tanh((2*arco))),"." END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE SecanteHiperbolica IMPLICIT NONE INTEGER::OPCAO3,i,quantidade REAL:: argumento,doisarcos(2),arco, auxiliar REAL,DIMENSION(:),ALLOCATABLE::arcos WRITE(*,*) "Selecione uma das opcoes abaixo" WRITE(*,*) " " WRITE(*,*) "1 - Secante hiperbolico da soma de arcos" WRITE(*,*) "2 - Secante hiperbolico da diferença entre dois arcos" WRITE(*,*) "3 - Secante hiperbolico do arco metade" WRITE(*,*) "4 - Secante hiperbolico do arco duplo" DO READ(*,*,IOSTAT=ERRO) OPCAO3 IF(ERRO>0.OR.OPCAO3<1.OR.OPCAO3>4)THEN WRITE(*,*) "Opcao invalida, por favor digite outra." ELSE EXIT END IF END DO SELECT CASE(OPCAO3) CASE(1) WRITE(*,*) "Quantos arcos voce deseja calcular?" DO READ(*,*,IOSTAT=ERRO) quantidade IF(ERRO>0.OR.OPCAO3<0.OR.quantidade>25)THEN WRITE(*,*) "Valor invalido, digite um valor inteiro entre 0 e 25." ELSE EXIT END IF END DO ALLOCATE(arcos(1:quantidade)) WRITE(*,*) "Digite seus arcos." DO i=1,quantidade DO READ(*,*,IOSTAT=ERRO) arcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite um numero real." ELSE EXIT END IF END DO END DO auxiliar=0 DO i=1,quantidade auxiliar=auxiliar+arcos(i) END DO WRITE(*,*) "A secante hiperbolico da soma dos termos",(arcos(i), i=1,quantidade)," e ",(1.0)/(cosh(auxiliar)),"." CASE(2) WRITE(*,*) "Digite seus dois arcos." DO i=1,2 DO READ(*,*,IOSTAT=ERRO) doisarcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite outro valor." ELSE EXIT END IF END DO END DO WRITE(*,*) "A secante hiperbolico da diferença entre",doisarcos(1), & " e ",doisarcos(2)," e",(1.0)/cosh(doisarcos(1)-doisarcos(2)),"." CASE(3) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A secante hiperbolico da metade do arco",arco," e,",(1.0)/(cosh((arco/2))),"." CASE(4) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A secante hiperbolico do arco duplo",arco," e,",(1.0)/(cosh((2*arco))),"." END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE CossecanteHiperbolica IMPLICIT NONE INTEGER::OPCAO3,i,quantidade REAL:: argumento,doisarcos(2),arco, auxiliar REAL,DIMENSION(:),ALLOCATABLE::arcos WRITE(*,*) "Selecione uma das opcoes abaixo" WRITE(*,*) " " WRITE(*,*) "1 - Cossecante hiperbolico da soma de arcos" WRITE(*,*) "2 - Cossecante hiperbolico da diferença entre dois arcos" WRITE(*,*) "3 - Cossecante hiperbolico do arco metade" WRITE(*,*) "4 - Cossecante hiperbolico do arco duplo" DO READ(*,*,IOSTAT=ERRO) OPCAO3 IF(ERRO>0.OR.OPCAO3<1.OR.OPCAO3>4)THEN WRITE(*,*) "Opcao invalida, por favor digite outra." ELSE EXIT END IF END DO SELECT CASE(OPCAO3) CASE(1) WRITE(*,*) "Quantos arcos voce deseja calcular?" DO READ(*,*,IOSTAT=ERRO) quantidade IF(ERRO>0.OR.OPCAO3<0.OR.quantidade>25)THEN WRITE(*,*) "Valor invalido, digite um valor inteiro entre 0 e 25." ELSE EXIT END IF END DO ALLOCATE(arcos(1:quantidade)) WRITE(*,*) "Digite seus arcos." DO i=1,quantidade DO READ(*,*,IOSTAT=ERRO) arcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite um numero real." ELSE EXIT END IF END DO END DO auxiliar=0 DO i=1,quantidade auxiliar=auxiliar+arcos(i) END DO WRITE(*,*) "A cossecante hiperbolico da soma dos termos",(arcos(i), i=1,quantidade)," e ",(1.0)/(sinh(auxiliar)),"." CASE(2) WRITE(*,*) "Digite seus dois arcos." DO i=1,2 DO READ(*,*,IOSTAT=ERRO) doisarcos(i) IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, por favor digite outro valor." ELSE EXIT END IF END DO END DO WRITE(*,*) "A cossecante hiperbolico da diferença entre",doisarcos(1), & " e ",doisarcos(2)," e ",(1.0)/sinh(doisarcos(1)-doisarcos(2)),"." CASE(3) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A cossecante hiperbolico da metade do arco",arco," e,",(1.0)/(sinh((arco/2))),"." CASE(4) WRITE(*,*) "Digite o seu arco." DO READ(*,*,IOSTAT=ERRO) arco IF(ERRO>0)THEN WRITE(*,*) "Valor invalido, digite outro." ELSE EXIT END IF END DO WRITE(*,*) "A cossecante hiperbolico do arco duplo",arco," e,",(1.0)/(sinh((2*arco))),"." END SELECT CALL VoltarParaMenu END SUBROUTINE SUBROUTINE VoltarParaMenu IMPLICIT NONE CHARACTER(LEN=3):: Voltar WRITE(*,*) "Voce deseja voltar ao menu principal? Digite ""SIM"" ou ""NAO""." DO READ(*,*) Voltar SELECT CASE (Voltar) CASE ("sim") CALL MenuPrincipal EXIT CASE ("nao") PAUSE "Obrigado por utilizar esse programa. Pressione ENTER para sair." STOP CASE DEFAULT WRITE(*,*)"Sua opçao nao foi reconhecida. Digite SIM ou NAO." END SELECT END DO END SUBROUTINE !Funções REAL FUNCTION calcularareadotriangulo(base,altura) REAL,INTENT(in) ::base,altura calcularareadotriangulo= (base*altura)/2 END FUNCTION calcularareadotriangulo REAL FUNCTION areadotriangulocomangulo(lado,adjascente) REAL,INTENT(in) ::lado,adjascente REAL ::angulo,angulo_r WRITE(*,*)"Digite o angulo." DO READ(*,*,IOSTAT=ERRO) angulo IF(ERRO>0.OR.angulo<0)THEN WRITE(*,*)"Valor invalido. Digite outro." ELSE EXIT END IF END DO angulo_r=(angulo*pi)/180 areadotriangulocomangulo=(lado*adjascente*sin(angulo_r))/2 END FUNCTION areadotriangulocomangulo REAL FUNCTION areatriangulocircunscrito(lado1,lado2,lado3,raio) REAL,INTENT(in) ::lado1,lado2,lado3,raio areatriangulocircunscrito=(lado1*lado2*lado3)/(4*raio) END FUNCTION areatriangulocircunscrito REAL FUNCTION areatrianguloinscrito(lado1,lado2,lado3,raio) REAL,INTENT(in) ::lado1,lado2,lado3,raio areatrianguloinscrito=((lado1+lado2+lado3)*raio) END FUNCTION areatrianguloinscrito REAL FUNCTION areatriangulosocomasmedidasdoslados(lado1,lado2,lado3) REAL,INTENT(in) ::lado1,lado2,lado3 REAL::P P=(lado1+lado2+lado3) areatriangulosocomasmedidasdoslados=sqrt(P*(P-lado1)*(P-lado2)*(P-lado3)) END FUNCTION areatriangulosocomasmedidasdoslados REAL FUNCTION areatrianguloequilatero(lado) REAL,INTENT(in) ::lado areatrianguloequilatero=((lado**2)*(1.732050808))/4 END FUNCTION areatrianguloequilatero REAL FUNCTION arearetangulo(base,altura) REAL,INTENT(in) ::base,altura arearetangulo=base*altura END FUNCTION arearetangulo REAL FUNCTION areatrapezio(basemaior,basemenor,altura) REAL,INTENT(in) ::basemaior,basemenor,altura areatrapezio=((basemaior+basemenor)*altura)/2 END FUNCTION areatrapezio REAL FUNCTION arealosango(diagonalmaior,diagonalmenor) REAL,INTENT(in) ::diagonalmaior,diagonalmenor arealosango=(diagonalmaior*diagonalmenor)/2 END FUNCTION arealosango REAL FUNCTION areaquadrado(lado) REAL,INTENT(in) ::lado areaquadrado=(lado**2) END FUNCTION areaquadrado REAL FUNCTION areaquadradosabendosuadiagonal(diagonal) REAL,INTENT(in) ::diagonal areaquadradosabendosuadiagonal=(diagonal**2)/2 END FUNCTION areaquadradosabendosuadiagonal REAL FUNCTION areacirculo(raio) REAL,INTENT(in) ::raio areacirculo=(pi*(raio**2)) END FUNCTION REAL FUNCTION areacoroacircular(raio1,raio2) REAL,INTENT(in) ::raio1,raio2 areacoroacircular=(pi*((raio1**2)-(raio2**2))) END FUNCTION areacoroacircular END PROGRAM matematica
