! Compute square roots of input data values.
  program E18
    implicit none
    integer, parameter :: LIMIT = 10
    integer :: Loop
    real :: X
! start program E18
    open (unit = 1, file = "e18.txt", status = "old", action = "read", position = "rewind")
    do Loop = 1, LIMIT
      read (unit = 1, fmt = *) X
      if (X < 0) then
        cycle
      end if
      write (unit = *, fmt = *) " Square root of: ", X, " is: ", sqrt( X )
    end do
    stop
  end program E18

  program E19
    use E19M
    implicit none
! Start program E19
    open (unit = 1, file = "E18.txt", status = "old", action = "read", position = "rewind")
    read (unit = 1, fmt = *) List
    write (unit = *, fmt = *) " Please enter a search key."
    read (unit = *, fmt = *) Search_Key
    select case (Search( ))
    case ("FOUND")
      write (unit = *, fmt = *) " Update "
    case ("NOT FOUND")
      write (unit = *, fmt = *) " Insert "
    end select
    stop
  end program E19


! Program Example from "Essential Fortran 90 & 95" by Loren P. Meissner
! Copyright 1996. Copying for sale requires permission from the author.
! Otherwise, distribution is permitted if these three lines are included.

module E19M
  implicit none
  public :: Search
  integer, parameter, private :: List_Length = 10
  integer, public, dimension(List_Length) :: List
  integer, public :: Search_Key
contains
  function Search( ) result( Search_R )
    character (len = 9) :: Search_R
    integer :: I
! start function Search
    do I = 1, List_Length
      if (List(I) == Search_Key) then
        Search_R = "FOUND"
        return
      else if (List(I) > Search_Key) then
        Search_R = "NOT FOUND"  ! Or exit
        return
      else  ! Continue searching
      end if
    end do
    Search_R = "NOT FOUND"
    return
  end function Search
end module E19M


! Echo printing.
  program E20
    implicit none
    real :: Average, X, Y, Diameter
! start program E20
    open (unit = 11, file = "data.txt", status = "old", action = "read", position = "rewind")
    open (unit = 12, file = "e20.zzz", status = "new", action = "write")
    read (unit = 11, fmt = *) X, Y
    Average = (X + Y) / 2.0
    write (unit = 12, fmt = *) " The average of ", X, " and ", Y, " is ", Average
    read (unit = 11, fmt = *) Diameter
    write (unit = 12, fmt = *) " DIAMETER: ", Diameter
    write (unit = 12, fmt = *) " CIRCUMFERENCE: ", 3.1416 * Diameter
    stop
  end program E20


! Total weight and average weight of cats.
  program E21
    implicit none
    integer :: How_Many, EoF
    character (len = 1) :: Sex
    real :: Next_Weight, Total_Weight
! start program E21
    How_Many = 0
    Total_Weight = 0.0
    open (unit = 2, file = "myfile.txt", status = "old", action = "read", position = "rewind")
    do
      read (unit = 2, fmt = *, iostat = EoF) Sex, Next_Weight
      if (EoF < 0) then
        exit
      else if ((Sex /= "m") .and. (Sex /= "f") .and. (Sex /= "M") .and. (Sex /= "F")) then
        write (unit = *, fmt = *) " Sex data error. "
        stop
      end if
      How_Many = How_Many + 1
      Total_Weight = Total_Weight + Next_Weight
    end do
    write (unit = *, fmt = *) How_Many, Total_Weight
    if (How_Many > 0) then
      write (unit = *, fmt = *) " Average weight: ", Total_Weight / real( How_Many )
    else
      write (unit = *, fmt = *) " There are no cats in this sample. "
    end if
    stop
  end program E21

   program ex0511
     ! Determines the type of the triangle
     ! entered with the three side lengths.
     ! The subroutine that decides the type with the use
     ! of the given lengths, named "decision" is in the
     ! module named "decide".
     use decide            !Declaration of the module's name.
     real :: a, b, c       !Side lengts, as real.
     logical :: triangle, isosceles, equilat
                        !Three logical variables are defined.
     print *, "  This program decides the type of a triangle"
     print *, "         given with its side lengths"
     print *, " "                !The header of the program.
     print *, "         ( To finish enter 0, 0, 0 ) "
     do                   !For easy use a loop is introduced.
       print *, " "
       print *, "        Enter the side lengths : "
       print *, " "
       read *, a, b, c
       if ( a + b + c == 0.0 ) then
         exit                            !Exiting procedure.
       end if
       print *, " "
       if (a>0.0 .and. b>0.0 .and. c>0.0) then
         call decision ( a, b, c,triangle, & !The type identi-
                        isosceles, equilat ) !fier is called.
         if ( .not. triangle ) then
           print *, " The given side lengths "
           print *, " can't define a triangle. "
         else
           if ( isosceles ) then
             print *, " The triangle is an isosceles. "
           else if ( equilat ) then
             print *, " The triangle is an equilateral. "
         else
           print *, " The triangle is a scalene."
         end if         !The third possible type is the most
       end if           !general, the nonequal sides case.
       else
         print *, " One or more negative side length!"
       end if
     end do
   end program ex0511


    module decide       
      public :: decision
      contains
      subroutine decision (aa, bb, cc, triangle, &
                            isosceles, equilat )
        real, intent (in) :: aa, bb, cc
        logical, intent (out) :: triangle,  &
                         isosceles, equilat
        real :: a, b, c
        logical, parameter :: t= .true. , f= .false.
        a=max(aa,bb,cc)
        c=min(aa,bb,cc)
        if (( a==aa .and. c==cc ).or.  &
                         (a==cc .and. c==aa)) then
          b=bb
        else if (( a==aa .and. c==bb ).or.&
                         ( a==bb .and. c==aa )) then
          b=cc
        else
          b=aa
        end if
        if ( a < b+c ) then 
          triangle = t
          if ( a==b .and. b==c ) then
            equilat = t
            isosceles = f
          else
            equilat = f
            if ( a==b .or. b==c) then
              isosceles = t
            else
              isosceles = f
            end if
          end if
        else
          triangle = f
          isosceles = f
          equilat = f
        end if
      end subroutine decision
    end module decide         
      

! Pascal's triangle (binomial coefficients).
  program F24
    implicit none
    integer, parameter :: M = 20
    integer :: N, R
    integer, dimension(0: M) :: Pascal
! start program F24
    do N = 0, M
      Pascal(0) = 1
      Pascal(N) = 1
      do R = N - 1, 1, -1
        Pascal(R) = Pascal(R) + Pascal(R - 1)
      end do
      write (unit = *, fmt = *) Pascal(0: N)
    end do
    stop
  end program F24


! Matrix input by rows.
  program F11
    implicit none
    integer, parameter :: N_ROWS = 5, N_COLS = 8
    integer :: Row
    real, dimension(N_ROWS, N_COLS) :: Vector
! start program F11
    open (unit = 1, file = "f11.txt", status = "old", action = "read", position = "rewind")
    do Row = 1, N_ROWS
      read (unit = 1, fmt = *) Vector(Row, 1: N_COLS)
    end do
    do Row = 1, N_ROWS
      write (unit = *, fmt = *) " Row: ", Row
      write (unit = *, fmt = *) Vector(Row, 1: N_COLS)
    end do
    stop
  end program F11
    

! Arithmetic and relational operations on whole arrays.
  program F08
    implicit none
    real, dimension(5, 7) :: A, B, C
    logical, dimension(5, 7) :: T
    real, dimension(20) :: V, V_Squared
! start program F08
    open (unit = 7, file = "myinput.txt", status = "old", action = "read", position = "rewind")
    open (unit = 2,  file = "f08.zzz", status = "new", action = "write")
    read (unit = 7, fmt = *) B, C, V
    A = B + C
    T = B > C
    C = A * B
    V_Squared = V * V
    write (unit = 2, fmt = *) T
    write (unit = 2, fmt = *) C
    write (unit = 2, fmt = *) V
    write (unit = 2, fmt = *) V_Squared
    stop
  end program F08
! Encapsulated Polar data type.
  program H10
    use H10M
    implicit none
    real, parameter :: DEG = 180.0 / PI
    real :: A1, F1, A2, F2
    type (Polar) :: P1, P2, P3
! start program H10
    do
      write (unit = *, fmt = *) " Please enter Amplitude and Phase (degrees) of"
      write (unit = *, fmt = *) " two polar numbers. To stop, enter 0,0,0,0 "
      read (unit = *, fmt = *)  A1, F1, A2, F2
      if (A1 == 0) then
        exit
      end if
      P1 = Make_Polar( A1, F1 / DEG )
      write (unit = *, fmt = *) " Polar: ", Amplitude( P1 ), Phase( P1 )
      P2 = Make_Polar( A2, F2 / DEG )
      write (unit = *, fmt = *) " Polar: ", Amplitude( P2 ), Phase( P2 )
      P3  = P1 + P2
      write (unit = *, fmt = *) " Sum: ", Amplitude( P3 ), Phase( P3 )* DEG
      P3 = P1 - P2
      write (unit = *, fmt = *) " Difference: ", Amplitude( P3 ), Phase( P3 ) * DEG
      P3 = P1 * P2
      write (unit = *, fmt = *) " Product: ", Amplitude( P3 ), Phase( P3 )* DEG
      P3 = P1 / P2
      write (unit = *, fmt = *) " Quotient: ", Amplitude( P3 ), Phase( P3 )* DEG
      P3 = P1 ** 3.0
      write (unit = *, fmt = *) " Cube: ", Amplitude( P3 ), Phase( P3 )* DEG
    end do
    stop
  end program H10

! Encapsulated Polar data type.
  module H10M
    implicit none
    public :: Make_Polar, Amplitude, Phase, &
      operator( + ), operator( - ), operator( * ), operator( / ), operator( ** )
    private :: Add_Polar, Sub_Polar, Mult_Polar, Div_Polar, Exp_Polar, &
      Polar_To_Complex, Complex_To_Polar
    type, public :: Polar
      private
      real :: R
      real :: Theta
    end type Polar
    interface operator( + )
      module procedure Add_Polar
    end interface
    interface operator( - )
      module procedure Sub_Polar
    end interface
    interface operator( * )
      module procedure Mult_Polar
    end interface
    interface operator( / )
      module procedure Div_Polar
    end interface
    interface operator( ** )  ! Note: Second operand is real.
      module procedure Exp_Polar
    end interface
    real, parameter, public :: PI = 3.14159265
  contains
    function Make_Polar( Amplitude, Phase ) result ( Make_Polar_R )
      real, intent (in) :: Amplitude, Phase
      type (Polar) :: Make_Polar_R
  ! start function Make_Polar
      Make_Polar_R = Polar( Amplitude, Phase )
      return
    end function Make_Polar
    function Amplitude( P ) result( Amplitude_R )
      type (Polar), intent (in) :: P
      real :: Amplitude_R
  ! start function Amplitude
      Amplitude_R = P % R
      return
    end function Amplitude
    function Phase( P ) result( Phase_R )
      type (Polar), intent (in) :: P
      real :: Phase_R
  ! start function Phase
      Phase_R = P % Theta
      return
    end function Phase
! The remaining module procedures are private.
    function Add_Polar( P1, P2 ) result( Add_Polar_R )
      type (Polar), intent (in) :: P1, P2
      type (Polar) :: Add_Polar_R
  ! start function Add_Polar
  ! Convert to complex, add, and convert back.
      Add_Polar_R = Complex_To_Polar( Polar_To_Complex( P1 ) + Polar_To_Complex( P2 ) )
      return
    end function Add_Polar
    function Sub_Polar( P1, P2 ) result( Sub_Polar_R )
      type (Polar), intent (in) :: P1, P2
      type (Polar) :: Sub_Polar_R
  ! start function Sub_Polar
  ! Add P1 to -1 times P2.
      Sub_Polar_R = Add_Polar( P1, Mult_Polar( Polar( 1.0, PI ), P2 ) )
      return
    end function Sub_Polar
    function Mult_Polar( P1, P2 ) result( Mult_Polar_R )
      type (Polar), intent (in) :: P1, P2
      type (Polar) :: Mult_Polar_R
  ! start function Mult_Polar
  ! Multiply amplitudes and add phases.
      Mult_Polar_R = Polar( P1 % R * P2 % R, P1 % Theta + P2 % Theta )
      return
    end function Mult_Polar
    function Div_Polar( P1, P2 ) result( Div_Polar_R )
      type (Polar), intent (in) :: P1, P2
      type (Polar) :: Div_Polar_R
  ! start function Div_Polar
  ! Divide amplitudes and subtract phases.
      if (P2 % R /= 0.0) then
        Div_Polar_R = Polar( P1 % R / P2 % R, P1 % Theta - P2 % Theta )
      else
        Div_Polar_R = Polar( huge( 1.0 ), P1 % Theta - P2 % Theta )
      end if
      return
    end function Div_Polar
    function Exp_Polar( P1, R2 ) result( Exp_Polar_R )
      type (Polar), intent (in) :: P1
      real, intent (in) :: R2  ! Note: Second argument is real.
      type (Polar) :: Exp_Polar_R
  ! start function Exp_Polar
  ! Exponentiate amplitude and multiply phase.
      Exp_Polar_R = Polar( (P1 % R) ** R2, (P1 % Theta) * R2 )
      return
    end function Exp_Polar
    function Polar_To_Complex( P ) result( PTC_R )
  ! Convert polar to complex.
      type (Polar), intent (in) :: P
      complex :: PTC_R
  ! start function Polar_To_Complex
      PTC_R = cmplx( P % R * cos( P % Theta ), P % R * sin( P % Theta ) )
      return
    end function Polar_To_Complex
    function Complex_To_Polar( Z ) result( CTP_R )
  ! Convert complex to polar.
      complex, intent (in) :: Z
      type (Polar) :: CTP_R
  ! start function Complex_To_Polar
      CTP_R = Polar( abs (Z), atan2 (aimag( Z ), real( Z ) ) )
      return
    end function Complex_To_Polar
  end module H10M