F90: Programa de PA e PG

Este programa foi desenvolvido pelos alunos Alberto Rocha da Silva, Calos Alberto, Rafael Santos da Costa e Ruy Pereira durante a disciplina Processamento de Dados (UFBA 2008.2). Data da apresentação: 27/11/2008.

PROGRAM paepg 
  IMPLICIT NONE 
  CALL MenuPrincipal() 
CONTAINS 
  SUBROUTINE MenuPrincipal() 
    IMPLICIT NONE 
    INTEGER :: opcao, erro 
    Write (*,*) "1  Verificar se a serie e uma PA ou PG" 
    Write (*,*) "2  Calculo da razao da PA" 
    Write (*,*) "3  Calculo do ultimo termo da PA" 
    Write (*,*) "4  Calculo da quantidade de termos da PA" 
    Write (*,*) "5  Calculo da soma dos termos da PA" 
    Write (*,*) "6  Calculo da razao da PG"
    Write (*,*) "7  Calculo do termo qualquer da PG"
    Write (*,*) "8  Calculo do termo medio da PG"
    Write (*,*) "9  Calculo da soma da PG finita"
    Write (*,*) "10 Calculo da soma da pg infinita"
    Write (*,*) "11 Calculo do produto da PG finita"
    Write (*,*) "12  Sair"  
    DO 
      Read (*,*) opcao 
      IF (opcao>= 1 .AND. Opcao<=12) THEN 
        SELECT CASE (Opcao) 
          CASE (1)
            CALL Verificaraserie()
          CASE (2)
            CALL Calculararazao() 
          CASE (3)
            CALL Calcularultimotermo() 
          CASE (4)  
            CALL Calcularquantidadedetermos() 
          CASE (5) 
            CALL Calcularasomadostermos() 
          CASE (6)
            CALL Calcularrazaopg()
          CASE (7)
            CALL Calculartermoqualquerdapg()
          CASE (8)
            CALL Calculartermomediodapg()
          CASE (9)
            CALL Calcularsomapgfinita()
          CASE (10)
            CALL Calcularsomapginfinita()
          CASE (11)
            CALL Calcularprodutopgfinita()
          CASE (12)
            RETURN
        END SELECT 
        EXIT 
      END IF 
    END DO 
  END SUBROUTINE MenuPrincipal 
  SUBROUTINE Verificaraserie() 
    IMPLICIT NONE 
    REAL :: a,b,c,r 
    WRITE (*,*) "Digite o 1,2 e 3 termos de sua serie" 
    READ (*,*) a,b,c 
    IF (b-a==0 .AND. c-b==0) THEN 
      WRITE(*,*) "A serie e uma PA constante" 
    End IF 
    IF (b-a<0 .AND. b-a==c-b) THEN 
      WRITE(*,*) "A serie e uma PA decrescente" 
    END IF 
    IF (b-a>0 .AND. b-a==c-b) THEN 
      WRITE(*,*) "A serie é uma PA crescente" 
    END IF 
    IF (b/a==1 .AND. b/a==c/b) THEN 
      WRITE(*,*) "A serie e uma PG constante" 
    END IF 
    IF (b/a<0 .AND. b/a==c/b) THEN 
      WRITE(*,*) "A serie e uma PG oscilante" 
    END IF
    IF (b/a == c/b) THEN 
      r=(b/a)
    END IF 
    IF ((a>0 .AND. r>1) .OR. (a<0 .AND. r>0 .AND. r<1)) THEN 
      WRITE(*,*) "A serie e uma PG crescente" 
    END IF
    IF (b/a == c/b) THEN
      r= (b/a)
    END IF 
    IF ((a<0 .AND. r>1) .OR. (a>0 .AND. r>0 .AND. r<1)) THEN 
      WRITE(*,*) "A serie e uma PG decrescente" 
    END IF 
    IF (b-a/=c-b .AND. b/a /= c/b) THEN 
      WRITE(*,*) "A serie nao e PA e nao e PG" 
    END IF 
  END SUBROUTINE verificaraserie 
  SUBROUTINE Calculararazao() 
    IMPLICIT NONE 
    REAL :: a,b 
    WRITE (*,*) "Digite o 1 e o 2 termo da PA" 
    READ (*,*) a,b 
    WRITE (*,*) "A razao e:",b-a 
  END SUBROUTINE Calculararazao 
  SUBROUTINE Calcularultimotermo() 
    IMPLICIT NONE 
    REAL :: a,b 
    INTEGER :: n 
    WRITE (*,*) "Digite o 1 e o 2 termo da PA" 
    READ (*,*) a,b 
    WRITE (*,*) "Digite a quantidade de termos da PA" 
    READ (*,*) n 
    WRITE(*,*)  "O ultimo termo da PA e:",a+(n-1)*(b-a) 
  END SUBROUTINE Calcularultimotermo 
  SUBROUTINE Calcularquantidadedetermos() 
    IMPLICIT NONE 
    REAL :: a,b,c,Q
    WRITE (*,*) "Digite o 1 e o ultimo termo da PA" 
    READ (*,*) a,b 
    WRITE (*,*) "Digite a razao da PA" 
    READ (*,*) c
    Q = ((b-a)/c)+1
    IF (Q <= 0) THEN
      WRITE(*,*) "Os dados nao sao coerentes"
    ELSE
      WRITE (*,*) "A quantidade de termos da PA e:",Q
    END IF
  END SUBROUTINE calcularquantidadedetermos 
  SUBROUTINE Calcularasomadostermos()  
    IMPLICIT NONE 
    REAL :: a,b 
    INTEGER :: n 
    WRITE (*,*) "Digite o 1 e o ultimo termo da PA" 
    READ (*,*) a,b 
    WRITE (*,*) "Digite a quantidade de termos da PA" 
    READ (*,*) n 
    WRITE(*,*) "A soma dos termos da PA e:",(a+b)*n/2 
  END SUBROUTINE Calcularasomadostermos 
  SUBROUTINE Calcularrazaopg()
    implicit none
    real :: a1,an,q
    integer :: n, ERRO
    do
      write(*,*) "Digite o primeiro termo da P.G"
      read(*,*,IOstat=ERRO) a1
      write(*,*) "Digite um termo sucessor n do termo digitado"
      read(*,*,IOstat=ERRO) an
      if(a1==0 .or. an==0 .or. a1*an<=0) then
        write(*,*) "Numeros invalidos (a1 e an devem ser diferentes de zero e devem ter o mesmo sinal)"
      else
        exit
      end if
    end do
    do
      write(*,*) "Informe o quanto o termo n sucede o primeiro termo"
      read(*,*,IOstat=ERRO) n
      if(n<=0) THEN
        write(*,*) "Numero Invalido(n>0)"
      else
        exit
      end if
    end do
    q= ((an/a1)**(1/(n*1.0)))
    write(*,*) "A razao e",q
  END SUBROUTINE Calcularrazaopg
  SUBROUTINE Calculartermoqualquerdapg()
    real :: a1, an, q, n
    do
      write (*,*) "Digite o primeiro termo da P.G."
      read (*,*) a1
      if (a1 == 0) then
        write(*,*) "O numero e invalido"
      else
        exit
      end if
    end do
    do
      write (*,*) "Digite a razao"
      read (*,*) q
      if (q == 1 .or. q <= 0) then
        write (*,*) "O numero e invalido"
      else
        exit
      end if
    end do
    do
      write (*,*) "Digite o numero do termo desejado"
      read (*,*) n
      if (n <= 1) then
        write (*,*) "O numero e invalido"
      else
        exit
      end if
    end do
    an = a1*q**(n-1)
    write (*,*) "O termo e igual a",an
  END SUBROUTINE Calculartermoqualquerdapg
  SUBROUTINE Calculartermomediodapg()
    real:: a1, an, T
    do
      write(*,*) "digite o primeiro termo"
      read(*,*) a1
      write(*,*) "digite o ultimo termo"
      read(*,*) an
      if(a1==0 .or. an==0 .or. a1*an<=0) then
        write(*,*) "Numeros invalidos"
      else
        exit
      end if
    end do
    T=(a1*an)**(0.5)
    write(*,*) "O termo medio e",T
  END SUBROUTINE Calculartermomediodapg
  SUBROUTINE Calcularsomapgfinita()
    IMPLICIT NONE
    real:: Sn, a1, q
    integer :: n
    do
      write(*,*) "digite o termo inicial da P.G."
      read(*,*) a1
      if (a1==0) then
        write(*,*) "Numero invalido"
      else
        exit
      end if
    end do
    do
      write(*,*) "Digite a razao"
      read(*,*) q
      if(q<=0 .or. q==1) then
        write(*,*)"O numero e invalido"
      else
        exit
      end if
    end do
    do
      write(*,*) "Digite o numero de termos da P,G."
      read(*,*) n
      if(n<=1) then
        write(*,*) "Numero invalido"
      else
        exit
      end if
    end do
    Sn=(a1*(q**n-1))/(q-1)
    write(*,*) "A soma dos termos da P.G. e",Sn
  END SUBROUTINE Calcularsomapgfinita
  SUBROUTINE Calcularsomapginfinita()
    IMPLICIT NONE
    real :: a1, Sn, q
    do
      write(*,*) "digite o primeiro termo"
      read(*,*) a1
      if(a1==0) then
        write(*,*) "Numero invalido"
      else
        exit
      end if
    end do
    do
      write(*,*) "Digite a razao"
      read(*,*) q
      if(q<=0 .or. q>=1) then
        write(*,*) "Numero invalido, A razao deve estar entre ]0,1["
      else
        exit
      end if
    end do
    Sn=a1/(1-q)
    write(*,*) "A soma desta P.G. e",Sn
  END SUBROUTINE Calcularsomapginfinita
  SUBROUTINE Calcularprodutopgfinita()
    real:: a1, q, Pn
    integer:: n, ERRO
    do
      write(*,*) "Digite o primeiro termo da P.G."
      read(*,*) a1
      if(a1==0) then
        write(*,*) "Numero invalido"
      else
        exit
      end if
    end do
    do
      write(*,*) "Digite a razao"
      read(*,*) q
      if(q==1 .or. q<=0) then
        write(*,*) "Numero invalido"
      else
        exit
      end if
    end do
    do
      write(*,*) "Digite o numero de termos da P.G."
      read(*,*,IOstat=ERRO) n
      if(n<=0 .or. n==1) then
        write(*,*) "Numero invalido"
      else
        exit
      end if
    end do
    Pn=(a1**n)*(q**((n*(n-1))/2))
    write(*,*) "O produto dos", n,"termos da P.G. e",Pn
  END SUBROUTINE Calcularprodutopgfinita
END PROGRAM paepg