Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/tools/prp.src

Text File | 1988-05-03 | 621.2 KB | 20,333 lines

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--TYPES
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Package TYPES is
--
-- TYPES Package of PROP_LINK Version 1.0,  February 16, 1985.
--
-- This TYPES Package declares several types which are used in the
-- CONSTANTS package and throughout PROPLINK.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
--
-- TYPES:
      Type NODE_TYPES is (NOTDEFINED, FIXED, MOVING, SATELLITE);
      type NODE_ARRAY is array(1..100) of NODE_TYPES;
      Type BAND_TYPES is (UNDEFINED,HARD_WIRED,ELF,VLF,LF,MF,HF,VHF,
                          UHF,SHF,EHF);
      type BAND_ARRAY is array(1..100) of BAND_TYPES;
      Type COMMAND is (READ,WRITE,PRINT,VIEW,STOP,GO,ADD,DEL,MODIFY);
      Type ENTITY is  (RECEIVER,TRANSMITTER,NODE,ENTITY_ERROR);
      type I_ARRAY is array (integer range <>) of integer;
      type L_ARRAY is array (integer range <>) of long_integer;
      type F_ARRAY is array (integer range <>) of float;
      type IARRAY_TYPE is array (integer range 1..80) of integer;
      type SND1 is array (integer range 1..6,
                             integer range 1..100) of float;
      type SND2 is array (integer range 1..4,
                             integer range 1..10,
                             integer range 1..100) of float;
      type SND3 is array (integer range 1..2,
                             integer range 1..15,
                             integer range 1..100) of long_integer;
end TYPES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--CONSTANT3
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With TYPES; use TYPES;
Package CONSTANT3 is
--
-- CONSTANT3 Package of PROP_LINK Version 1.0,  February 16, 1985.
--
-- This Package declares two arrays which were to large to include in
-- the CONSTANTS package.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
IRCSND:SND3;   -- Receiver integerized names and classes at each node.
IXTSND:SND3;   -- Transmitter integerized names and class at each node.
end CONSTANT3;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--CONSTANT2
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With TYPES; use TYPES;
Package CONSTANT2 is
--
-- CONSTANT2 Package of PROP_LINK Version 1.0,  February 16, 1985.
--
-- This Package declares two arrays which were to large to include in
-- the CONSTANTS package.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
XPSSND:SND2;    -- Location data for each node.
EPHSND:SND1;    -- Ephemeride data for each node.
end CONSTANT2;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--CONSTANTS
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With TYPES; use TYPES;
With Text_io; Use Text_io;
Package CONSTANTS is
--
-- CONSTANTS Package of PROP_LINK Version 1.0,  February 16, 1985.
--
-- This CONSTANTS Package sets up variables and constants for the
-- entire PROPLINK program.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
--
-- VARIABLES:
--
      MAXNOD: constant integer:=100; -- Size of all arrays for nodes
      MAXRNT: constant integer:=99;  -- Size of all arrays for transmitters
                                     --    and receivers
--NODE VARIABLES:
      NUMNOD: integer;               -- Number of nodes
      NAMNOD: L_ARRAY(1..MAXNOD);    -- Node name array
      ITYSND: NODE_ARRAY;            -- Node types
      NLSND:  I_ARRAY(1..MAXNOD);    -- Number of locations (moving nodes)
      NRSND:  I_ARRAY(1..MAXNOD);    -- Number of receivers at node
      NXSND:  I_ARRAY(1..MAXNOD);    -- Number of transmitters at node
      IPTNOD: I_ARRAY(1..MAXNOD);    -- Pointers into the data structure
--
--RECEIVER VARIABLES:
      NUMREC: integer;               -- Number of receiver classes
      NAMREC: L_ARRAY(1..MAXRNT);    -- Integerized names
      ITPREC: BAND_ARRAY;            -- Band type
      IATREC: I_ARRAY(1..MAXRNT);    -- Antenna type
      FREREC: F_ARRAY(1..MAXRNT);    -- Frequency
      GTREC:  F_ARRAY(1..MAXRNT);    -- Gain/Temp
      BWREC:  F_ARRAY(1..MAXRNT);    -- Band Width
      RLLREC: F_ARRAY(1..MAXRNT);    -- Line Loss
      ANTGNR: F_ARRAY(1..MAXRNT);    -- Antenna Gain
      ANTHTR: F_ARRAY(1..MAXRNT);    -- Antenna Height
      ANTLNR: F_ARRAY(1..MAXRNT);    -- Antenna Length
      ANTTAR: F_ARRAY(1..MAXRNT);    -- Antenna Tilt Angle
--
   --TRANSMITTER VARIABLES:
      NUMXMT: integer;               -- Number of Transmitter classes
      NAMXMT: L_ARRAY(1..MAXRNT);    -- Integerized names
      ITPXMT: BAND_ARRAY;            -- Band type
      BWXMT:  F_ARRAY(1..MAXRNT);    -- Band Width
      TRPXMT: F_ARRAY(1..MAXRNT);    -- Radiated Power
      FREXMT: F_ARRAY(1..MAXRNT);    -- Frequency
      IATXMT: I_ARRAY(1..MAXRNT);    -- Antenna type
      ANTGNX: F_ARRAY(1..MAXRNT);    -- Antenna Gain
      ANTHTX: F_ARRAY(1..MAXRNT);    -- Antenna Height
      ANTLNX: F_ARRAY(1..MAXRNT);    -- Antenna Length
      ANTTAX: F_ARRAY(1..MAXRNT);    -- Antenna Tilt Angle
--
--      PI: constant float := 3.141592654; -- used math lib Pi instead
      TWOPI: constant float := 6.283185308;
      HALFPI: constant float := 1.570796327;
      PI3: constant float := 1.047197551;
      PI4: constant float := 0.7853981635;
      PI6: constant float := 0.5235987757;
      PI9: constant float := 0.3490658504;
      PI12: constant float := 0.2617993878;
      PI20: constant float := 0.1570796327;
      PI29: constant float := 0.6981317009;
      PI43: constant float := 4.188790207;
      PI2365: constant float := 1.7214206E-2;
      PI4365: constant float := 3.4428412E-2;
      RADIANS_PER_DEGREE: constant float := 1.7453292E-2;
      DEGREES_PER_RADIAN: constant float := 57.29577951;
      RADIUS_OF_EARTH_IN_KM: constant float := 6364.0;

-- GEOMAGNETIC/GEOGRAPHIC CONVERSION CONSTANTS FOLLOW:
      SINPOL: constant float := 0.9803;
      COSPOL: constant float := 0.1977;
      WMERID: constant float := 1.218;
      DIPOLE: constant float := 0.31;
--
--GENERAL PURPOSE VARIABLES:
      CURRENT_COMMAND: COMMAND;
      CURRENT_ENTITY: ENTITY;
      CURRENT_NOISE_SEASON: integer := 0;
      DATABASE_HAS_BEEN_MODIFIED: boolean := FALSE;
      DATA_HAS_NOT_YET_BEEN_WRITTEN: boolean := TRUE;
      CURRENT_NODE_INDEX: integer := 0;
      ENTITY_BUFFER: string (1..80);
      NUMBER_OF_RECEIVERS: integer := 0;
      NUMBER_OF_NODES: integer := 0;
      NUMBER_OF_TRANSMITTERS: integer := 0;
      PRINT_LEVEL: integer := 0;
      CURRENT_TIME: float := 0.0;
      REFERENCE_TIME: float := 0.0;
      MONTH: integer := 10;
      NSEAS: integer;
      AVERAGE_SUN_SPOT_NUMBER: integer := 70;
      NUMBER_OF_VARIABLES_TO_EXTRACT: integer;
      NUMBER_OF_VARIABLES_EXTRACTED: integer;
      FILE_NAME, OPTION: string(1..80);
      PRINTER_OUTPUT_FILE: file_type;
      MAX: integer range 0..80;
      XARRAY: array (integer range 1..80) of float;
      IARRAY: L_ARRAY(1..MAXNOD);
      INPUT_BUFFER: string (1..80);
      ARGUMENT_BUFFER: string (1..80);
      TITLE: string (1..80);
end CONSTANTS;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--HELPS
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Text_io;
Package HELPS is
      Function HELP_CHECK(BUFFER:string) return boolean;
      Function BLANK_CHECK(BUFFER:string) return boolean;
      Procedure SHIFT_LEFT(BUFFER: in out string) ;
      End HELPS;
Package body HELPS is
Use Text_io;
      Function HELP_CHECK(BUFFER:string) return boolean is
--
--PURPOSE: HELP_CHECK determines if the help command has been requested.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Data Checking.
--
--PARAMETER DESCRIPTIONS:
--IN        BUFFER = The buffer that is examined.
--
--OUT       HELP_CHECK  = True if H, h, HELP or help is found, otherwise false.
--
--CALLED BY:
--          ANTENNA_CHECK
--          ENTITY_DATA
--          EVENT_ADD
--          EVENT_DATA
--          COMMAND_LINE_PROCESSOR
--          INTERPRET_ENTITY,
--          LOCATION_DATA
--          MESSAGE_DATA
--          NODE_ADD
--          NODE_DATA
--          NODE_FETCH
--          RECEIVER_ADD
--          RECEIVER_DATA
--          TRANSMITTER_ADD
--          TRANSMITTER_DATA
--
--CALLS TO:
--          SHIFT_LEFT
--
--TECHNICAL DESCRIPTION:
--          HELP_CHECK examines the character buffer BUFFER and determines if
--          the next non-blank character string is "H", or "h"
--          in which case the function is true.  If anything
--          else is found then the value is false.  A simple left shift
--          and compare technique is used.
--
      SCRATCH: string(1..80);
      Begin
--
--SET UP WORKING ARRAY AND FIND FIRST NON-BLANK CHARACTER.
      SCRATCH(1..BUFFER'LENGTH) := BUFFER;
      For I in BUFFER'RANGE Loop
         If SCRATCH(1) = ' ' then
            SHIFT_LEFT(SCRATCH);
         elsif
            SCRATCH(1) = 'h' or SCRATCH(1) = 'H' then
               if I=BUFFER'LENGTH or SCRATCH(1..4)="help" or
                  SCRATCH(1..4)="HELP" then
                  return TRUE;
               else
                  return FALSE;
               end if;
         else
            return FALSE;
         End If;
      End Loop;
      Return FALSE;
--
      End HELP_CHECK;
--
      Procedure SHIFT_LEFT(BUFFER: in out string) is
--
--PURPOSE: SHIFT_LEFT shifts the data in the array BUFFER one place to the left.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Shift
--
--PARAMETER DESCRIPTIONS:
--IO        BUFFER  = The array that is to be shifted
--
--CALLED BY:
--          CONVERT_ALPHA_TO_NUMERIC
--          COMMAND_LINE_PROCESSOR
--          INTERPRET_ENTITY
--          HELP_CHECK
--          LIKE
--          PARSE
--
--CALLS TO:
--          'NONE'
--
--TECHNICAL DESCRIPTION:
--         SHIFT_LEFT shifts the data in BUFFER one place to the left,
--         throwing out the value in BUFFER(1) and putting a blank
--         in BUFFER(BUFFER'LENGTH).
--
      I: integer;
--
      Begin
      For I in 1..(BUFFER'LENGTH-1) Loop
         BUFFER(I) := BUFFER(I+1);
      End Loop;
      BUFFER(BUFFER'LENGTH) := ' ';
--
      End SHIFT_LEFT;
--
      Function BLANK_CHECK(BUFFER:string) return boolean is
--
--PURPOSE: BLANK_CHECK determines if the array is empty.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Array Test
--
--PARAMETER DESCRIPTIONS:
--IN        BUFFER = The 80 element buffer containing alpha
--                   information.
--OUT       BLANK_CHECK = True if the buffer is all alpha blanks,
--                   otherwise BLANK_CHECK is false
--
--CALLED BY:
--          ANTENNA_CHECK
--          ENTITY_DATA
--          INTERPRET_ENTITY
--          LOCATION_DATA
--          NODE_ADD
--          NODE_DATA
--          NODE_HANDLER
--          PARSE
--          RECEIVER_ADD
--          RECEIVER_DATA
--          RECEIVER_FETCH
--          RECEIVER_HANDLER
--          TRANSMITTER_ADD
--          TRANSMITTER_DATA
--          TRANSMITTER_FETCH
--          TRANSMITTER_HANDLER
--
--CALLS TO:
--          'NONE'
--
--TECHNICAL DESCRIPTION:
--          BLANK_CHECK searches the input buffer specified as BUFFER
--          looking for non-blank characters.  If the array
--          is blank the value of BLANK_CHECK is set to true,
--          and vice versa.
--
      I: integer;
--
      Begin
      For I in BUFFER'RANGE Loop
         If BUFFER(I) /= ' ' Then
            Return FALSE;
         End If;
      End Loop;
      Return TRUE;
--
      End BLANK_CHECK;
End HELPS;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--MATHLIB
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with TEXT_IO;
package MATHLIB is

package FLOATING_CHARACTERISTICS is

    IBETA : INTEGER;
    IT : INTEGER;
    IRND : INTEGER;
    NGRD : INTEGER;
    MACHEP : INTEGER;
    NEGEP : INTEGER;
    IEXP : INTEGER;
    MINEXP : INTEGER;
    MAXEXP : INTEGER;
    EPS : FLOAT;
    EPSNEG : FLOAT;
    XMIN : FLOAT;
    XMAX : FLOAT;

  subtype EXPONENT_TYPE is INTEGER;    --  should be derived  ##########
  subtype MANTISSA_TYPE is FLOAT;     --   range -1.0..1.0;
  MANTISSA_DIVISOR_2 : constant FLOAT := 2.0;
  MANTISSA_DIVISOR_3 : constant FLOAT := 3.0;
  MANTISSA_HALF : constant MANTISSA_TYPE := 0.5;


  procedure DEFLOAT(X : in FLOAT;
                    N : out EXPONENT_TYPE; F : out MANTISSA_TYPE);
  procedure REFLOAT(N : in EXPONENT_TYPE; F : in MANTISSA_TYPE;
                                                   X : out FLOAT);
  function CONVERT_TO_FLOAT(K : INTEGER) return FLOAT;
  function CONVERT_TO_FLOAT(F : MANTISSA_TYPE) return FLOAT;
end FLOATING_CHARACTERISTICS;


package NUMERIC_IO is
  use TEXT_IO;

  procedure GET(FILE : in FILE_TYPE; ITEM : out INTEGER);
  procedure GET(ITEM : out INTEGER);
  procedure GET(FILE : in FILE_TYPE; ITEM : out FLOAT);
  procedure GET(ITEM : out FLOAT);
  procedure PUT(FILE : in FILE_TYPE; ITEM : in INTEGER);
  procedure PUT(ITEM : in INTEGER; WIDTH : in FIELD);
  procedure PUT(ITEM : in INTEGER);
  procedure PUT(FILE : in FILE_TYPE; ITEM : in FLOAT);
  procedure PUT(ITEM : in FLOAT);
end NUMERIC_IO;



use FLOATING_CHARACTERISTICS;
package NUMERIC_PRIMITIVES is

  ZERO  : FLOAT;
  ONE   : FLOAT;
  TWO   : FLOAT;
  THREE : FLOAT;
  HALF  : FLOAT;

  PI            : FLOAT;
  ONE_OVER_PI   : FLOAT;
  TWO_OVER_PI   : FLOAT;
  PI_OVER_TWO   : FLOAT;
  PI_OVER_THREE : FLOAT;
  PI_OVER_FOUR  : FLOAT;
  PI_OVER_SIX   : FLOAT;


  function SIGN(X, Y : FLOAT) return FLOAT;
    --  Returns the value of X with the sign of Y
  function AMAX1(X, Y :  FLOAT) return FLOAT;
    --  Returns the algebraicly larger of X and Y
  function AMIN1(X, Y :  FLOAT) return FLOAT;
    --  Returns the algebraicly smaller of X and Y
  function MAX(X, Y :  INTEGER) return INTEGER;
    --  Returns the algebraicly larger of X and Y
  function MIN(X, Y :  INTEGER) return INTEGER;
    --  Returns the algebraicly smaller of X and Y
  function TRUNCATE(X : FLOAT) return FLOAT;
    --  Returns the floating value of the integer no larger than X
    --  AINT(X)
  function ROUND(X : FLOAT) return FLOAT;
    --  Returns the floating value nearest X
    --  AINTRND(X)
  function RAN return FLOAT;
  function AMOD(X, Y : FLOAT) return FLOAT;
    --  Returns the remainder of X/Y
end NUMERIC_PRIMITIVES;


use FLOATING_CHARACTERISTICS;
package CORE_FUNCTIONS is

  EXP_LARGE : FLOAT;
  EXP_SMALL : FLOAT;

  function SQRT(X : FLOAT) return FLOAT;
  function CBRT(X : FLOAT) return FLOAT;
  function LOG(X : FLOAT) return FLOAT;
  function LOG10(X : FLOAT) return FLOAT;
  function EXP(X : FLOAT) return FLOAT;
  function "**"(X, Y : FLOAT) return FLOAT;

end CORE_FUNCTIONS;



package TRIG_FUNCTIONS is
  function SIN(X : FLOAT) return FLOAT;
  function COS(X : FLOAT) return FLOAT;
  function TAN(X : FLOAT) return FLOAT;
  function COT(X : FLOAT) return FLOAT;
  function ASIN(X : FLOAT) return FLOAT;
  function ACOS(X : FLOAT) return FLOAT;
  function ATAN(X : FLOAT) return FLOAT;
  function ATAN2(V, U : FLOAT) return FLOAT;
  function SINH(X : FLOAT) return FLOAT;
  function COSH(X : FLOAT) return FLOAT;
  function TANH(X : FLOAT) return FLOAT;
end TRIG_FUNCTIONS;
end MATHLIB;




with TEXT_IO; use TEXT_IO;
package body MATHLIB is

package body FLOATING_CHARACTERISTICS is

    A, B, Y, Z : FLOAT;
    I, K, MX, IZ : INTEGER;
    BETA, BETAM1, BETAIN : FLOAT;
    ONE : FLOAT := 1.0;
    ZERO : FLOAT := 0.0;

  procedure DEFLOAT(X : in FLOAT;
                    N : out EXPONENT_TYPE; F : out MANTISSA_TYPE) is
    EXPONENT_LENGTH : INTEGER := IEXP;
    M : EXPONENT_TYPE;
    W, Y, Z : FLOAT;
  begin
    N := 0;
    F := 0.0;
    Y := ABS(X);
    if Y = 0.0  then
      return;
    elsif Y < 0.5  then
      for J in reverse 0..(EXPONENT_LENGTH - 2)  loop
        M := EXPONENT_TYPE(2 ** J);
        Z := 1.0 / (2.0**M);
        W := Y / Z;
        if W < 1.0  then
          Y := W;
          N := N - M;
        end if;
      end loop;
    else
      for J in reverse 0..(EXPONENT_LENGTH - 2)  loop
        M := EXPONENT_TYPE(2 ** J);
        Z := 2.0**M;
        W := Y / Z;
        if W >= 0.5  then
          Y := W;
          N := N + M;
        end if;
      end loop;
    end if;
    while Y < 0.5  loop
      Y := Y * 2.0;
      N := N - 1;
    end loop;
    while Y >= 1.0  loop
      Y := Y / 2.0;
      N := N + 1;
    end loop;
    F := MANTISSA_TYPE(Y);
    if X < 0.0  then
      F := -F;
    end if;
    return;
  exception
  when others =>
    N := 0;
    F := 0.0;
    return;
  end DEFLOAT;


  procedure REFLOAT(N : in EXPONENT_TYPE; F : in MANTISSA_TYPE;
                                                   X : out FLOAT) is
    M : INTEGER;
    Y : FLOAT;
  begin
    if F = 0.0  then
      X := ZERO;
      return;
    end if;
    M := INTEGER(N);
    Y := ABS(FLOAT(F));
    while Y < 0.5  loop
      M := M - 1;
      if M < MINEXP  then
        X := ZERO;
      end if;
      Y := Y + Y;
      exit when M <= MINEXP;
    end loop;
    if M = MAXEXP  then
      M := M - 1;
      X := Y * 2.0**M;
      X := X * 2.0;
    elsif M <= MINEXP + 2  then
      M := M + 3;
      X := Y * 2.0**M;
      X := ((X / 2.0) / 2.0) / 2.0;
    else
      X := Y * 2.0**M;
    end if;
    if F < 0.0  then
      X := -X;
    end if;
    return;
  end REFLOAT;

  function CONVERT_TO_FLOAT(K : INTEGER) return FLOAT is
  begin
    return FLOAT(K);
  end CONVERT_TO_FLOAT;

  function CONVERT_TO_FLOAT(N : EXPONENT_TYPE) return FLOAT is
  begin
    return FLOAT(N);
  end CONVERT_TO_FLOAT;

  function CONVERT_TO_FLOAT(F : MANTISSA_TYPE) return FLOAT is
  begin
    return FLOAT(F);
  end CONVERT_TO_FLOAT;


begin --  Initialization for the VAX with values derived by MACHAR

    IBETA :=    2;
    IT :=    24;
    IRND :=    1;
    NEGEP :=    -24;
    EPSNEG :=    5.9604644E-008;
    MACHEP :=    -24;
    EPS :=    5.9604644E-008;
    NGRD :=    0;
    XMIN := 5.9E-39;
    MINEXP :=    -126;
    IEXP :=    8;
    MAXEXP :=    127;
    XMAX :=    8.5E37 * 2.0;
end FLOATING_CHARACTERISTICS;




package body NUMERIC_IO is
use INTEGER_IO; use FLOAT_IO;

  procedure GET(FILE : in FILE_TYPE; ITEM : out INTEGER) is
  begin
INTEGER_IO.GET(FILE, ITEM);
  end GET;

  procedure GET(ITEM : out INTEGER) is
  begin
INTEGER_IO.GET(ITEM);
  end GET;

  procedure GET(FILE : in FILE_TYPE; ITEM : out FLOAT) is
  begin
FLOAT_IO.GET(FILE, ITEM);
  end GET;

  procedure GET(ITEM : out FLOAT) is
  begin
FLOAT_IO.GET(ITEM);
  end GET;

  procedure PUT(FILE : in FILE_TYPE; ITEM : in INTEGER) is
  begin
INTEGER_IO.PUT(FILE, ITEM);
  end PUT;

  procedure PUT(ITEM : in INTEGER; WIDTH : in FIELD) is
    J, K, M : INTEGER := 0;
  begin
    if WIDTH = 1  then
      case ITEM is
        when 0  => TEXT_IO.PUT('0');
        when 1  => TEXT_IO.PUT('1');
        when 2  => TEXT_IO.PUT('2');
        when 3  => TEXT_IO.PUT('3');
        when 4  => TEXT_IO.PUT('4');
        when 5  => TEXT_IO.PUT('5');
        when 6  => TEXT_IO.PUT('6');
        when 7  => TEXT_IO.PUT('7');
        when 8  => TEXT_IO.PUT('8');
        when 9  => TEXT_IO.PUT('9');
        when others  => TEXT_IO.PUT('*');
      end case;
    else
      if ITEM < 0  then
        TEXT_IO.PUT('-');
        J := -ITEM;
      else
        TEXT_IO.PUT(' ');
        J := ITEM;
      end if;
      for I in 1..WIDTH-1  loop
        M := 10**(WIDTH - 1 - I);
        K := J / M;
        J := J - K*M;
        NUMERIC_IO.PUT(K, 1);
      end loop;
    end if;
  end PUT;

  procedure PUT(ITEM : in INTEGER) is
  begin
INTEGER_IO.PUT(ITEM);
  end PUT;

  procedure PUT(FILE : in FILE_TYPE; ITEM : in FLOAT) is
  begin
FLOAT_IO.PUT(FILE, ITEM);
  end PUT;

  procedure PUT(ITEM : in FLOAT) is
  begin
FLOAT_IO.PUT(ITEM);
  end PUT;

end NUMERIC_IO;
use FLOATING_CHARACTERISTICS;
package body NUMERIC_PRIMITIVES is


  function SIGN(X, Y : FLOAT) return FLOAT is
    --  Returns the value of X with the sign of Y
  begin
    if Y >= 0.0  then
      return X;
    else
      return -X;
    end if;
  end SIGN;

  function AMAX1(X, Y : FLOAT) return FLOAT is
  begin
    if X >= Y  then
      return X;
    else
      return Y;
    end if;
  end AMAX1;

  function AMIN1(X, Y : FLOAT) return FLOAT is
  begin
    if X < Y  then
      return X;
    else
      return Y;
    end if;
  end AMIN1;

  function MAX(X, Y : INTEGER) return INTEGER is
  begin
    if X >= Y  then
      return X;
    else
      return Y;
    end if;
  end MAX;

  function MIN(X, Y : INTEGER) return INTEGER is
  begin
    if X < Y  then
      return X;
    else
      return Y;
    end if;
  end MIN;

  function TRUNCATE(X : FLOAT) return FLOAT is
  --  Optimum code depends on how the system rounds at exact halves
  begin
    if FLOAT(INTEGER(X)) = X  then
      return X;
    end if;
    if X > ZERO  then
      return FLOAT(INTEGER(X - HALF));
    elsif X = ZERO  then
      return ZERO;
    else
      return FLOAT(INTEGER(X + HALF));
    end if;
  end TRUNCATE;

  function ROUND(X : FLOAT) return FLOAT is
  begin
    return FLOAT(INTEGER(X));
  end ROUND;


  package KEY is
    X : INTEGER := 10_001;
    Y : INTEGER := 20_001;
    Z : INTEGER := 30_001;
  end KEY;

  function RAN return FLOAT is
    W : FLOAT;
  begin

    KEY.X := 171 * (KEY.X mod 177 - 177) -  2 * (KEY.X / 177);
    if KEY.X < 0  then
      KEY.X := KEY.X + 30269;
    end if;

    KEY.Y := 172 * (KEY.Y mod 176 - 176) - 35 * (KEY.Y / 176);
    if KEY.Y < 0  then
      KEY.Y := KEY.Y + 30307;
    end if;

    KEY.Z := 170 * (KEY.Z mod 178 - 178) - 63 * (KEY.Z / 178);
    if KEY.Z < 0  then
      KEY.Z := KEY.Z + 30323;
    end if;

    W :=     CONVERT_TO_FLOAT(KEY.X)/30269.0
           + CONVERT_TO_FLOAT(KEY.Y)/30307.0
           + CONVERT_TO_FLOAT(KEY.Z)/30323.0;

    return  W - CONVERT_TO_FLOAT(INTEGER(W - 0.5));

  end RAN;

  function AMOD (X,Y : FLOAT) return FLOAT is
  -- returns remainder of X/Y
  begin
     return X-Y * TRUNCATE(X/Y);
  end AMOD;


begin

  ZERO  := CONVERT_TO_FLOAT(INTEGER(0));
  ONE   := CONVERT_TO_FLOAT(INTEGER(1));
  TWO   := ONE + ONE;
  THREE := ONE + ONE + ONE;
  HALF  := ONE / TWO;

  PI            := CONVERT_TO_FLOAT(INTEGER(3)) +
                   CONVERT_TO_FLOAT(MANTISSA_TYPE(0.14159_26535_89793_23846));
  ONE_OVER_PI   := CONVERT_TO_FLOAT(MANTISSA_TYPE(0.31830_98861_83790_67154));
  TWO_OVER_PI   := CONVERT_TO_FLOAT(MANTISSA_TYPE(0.63661_97723_67581_34308));
  PI_OVER_TWO   := CONVERT_TO_FLOAT(INTEGER(1)) +
                   CONVERT_TO_FLOAT(MANTISSA_TYPE(0.57079_63267_94896_61923));
  PI_OVER_THREE := CONVERT_TO_FLOAT(INTEGER(1)) +
                   CONVERT_TO_FLOAT(MANTISSA_TYPE(0.04719_75511_96597_74615));
  PI_OVER_FOUR  := CONVERT_TO_FLOAT(MANTISSA_TYPE(0.78539_81633_97448_30962));
  PI_OVER_SIX   := CONVERT_TO_FLOAT(MANTISSA_TYPE(0.52359_87755_98298_87308));

end NUMERIC_PRIMITIVES;

package body CORE_FUNCTIONS is
  use TEXT_IO;
  use FLOATING_CHARACTERISTICS;
  use NUMERIC_IO;
  use NUMERIC_PRIMITIVES;


  function SQRT(X : FLOAT) return FLOAT is
    M, N : EXPONENT_TYPE;
    F, Y : MANTISSA_TYPE;
    RESULT : FLOAT;

    subtype INDEX is INTEGER range 0..100;    --  #########################
    SQRT_L1 : INDEX := 3;
    --  Could get away with SQRT_L1 := 2 for 28 bits
    --  Using the better Cody-Waite coeficients overflows MANTISSA_TYPE
    SQRT_C1 : MANTISSA_TYPE := 8#0.3317777777#;
    SQRT_C2 : MANTISSA_TYPE := 8#0.4460000000#;
    SQRT_C3 : MANTISSA_TYPE := 8#0.55202_36314_77747_36311_0#;

  begin
    if X = ZERO  then
      RESULT := ZERO;
      return RESULT;
    elsif X = ONE  then            --  To get exact SQRT(1.0)
      RESULT := ONE;
      return RESULT;
    elsif X < ZERO  then
      NEW_LINE;
      PUT("CALLED SQRT FOR NEGATIVE ARGUMENT   ");
      PUT(X);
      PUT("   USED ABSOLUTE VALUE");
      NEW_LINE;
      RESULT := SQRT(ABS(X));
      return RESULT;
    else
      DEFLOAT(X, N, F);
      Y := SQRT_C1 + MANTISSA_TYPE(SQRT_C2 * F);
      for J in 1..SQRT_L1  loop
        Y := Y/MANTISSA_DIVISOR_2 + MANTISSA_TYPE((F/MANTISSA_DIVISOR_2)/Y);
      end loop;
      if (N mod 2) /= 0  then
        Y := MANTISSA_TYPE(SQRT_C3 * Y);
        N := N + 1;
      end if;
      M := N/2;
      REFLOAT(M,Y,RESULT);
      return RESULT;
    end if;
  exception
  when others =>
    NEW_LINE; PUT(" EXCEPTION IN SQRT, X = "); PUT(X);
    PUT("  RETURNED 1.0"); NEW_LINE;
    return ONE;
  end SQRT;


  function CBRT(X : FLOAT) return FLOAT is
    M, N : EXPONENT_TYPE;
    F, Y : MANTISSA_TYPE;
    RESULT : FLOAT;

    subtype INDEX is INTEGER range 0..100;
    CBRT_L1 : INDEX := 3;
    CBRT_C1 : MANTISSA_TYPE := 0.5874009;
    CBRT_C2 : MANTISSA_TYPE := 0.4125990;
    CBRT_C3 : MANTISSA_TYPE := 0.62996_05249;
    CBRT_C4 : MANTISSA_TYPE := 0.79370_05260;

  begin
    if X = ZERO then
      RESULT := ZERO;
      return RESULT;
    else
      DEFLOAT(X, N, F);
      F := ABS(F);
      Y := CBRT_C1 + MANTISSA_TYPE(CBRT_C2 * F);
      for J in 1 .. CBRT_L1 loop
        Y :=     Y
            - (  Y/MANTISSA_DIVISOR_3
               - MANTISSA_TYPE((F/MANTISSA_DIVISOR_3) / MANTISSA_TYPE(Y*Y)) );
      end loop;
      case (N mod 3) is
        when 0 =>
          null;
        when 1 =>
          Y := MANTISSA_TYPE(CBRT_C3 * Y);
          N := N + 2;
        when 2 =>
          Y := MANTISSA_TYPE(CBRT_C4 * Y);
          N := N + 1;
        when others =>
          null;
      end case;
      M := N/3;
      if X < ZERO  then
        Y := -Y;
      end if;
      REFLOAT(M, Y, RESULT);
      return RESULT;
    end if;
  exception
    when others =>
      RESULT := ONE;
      if X < ZERO then
      RESULT := - ONE;
      end if;
      NEW_LINE; PUT("EXCEPTION IN CBRT, X = "); PUT(X);
      PUT("  RETURNED  "); PUT(RESULT); NEW_LINE;
      return RESULT;
  end CBRT;

    function LOG(X : FLOAT) return FLOAT is

    RESULT : FLOAT;
    N : EXPONENT_TYPE;
    XN : FLOAT;
    Y : FLOAT;
    F : MANTISSA_TYPE;
    Z, ZDEN, ZNUM : MANTISSA_TYPE;

    C0 : constant MANTISSA_TYPE := 0.20710_67811_86547_52440;
                                               --  SQRT(0.5) - 0.5
    C1 : constant FLOAT := 8#0.543#;
    C2 : constant FLOAT :=-2.12194_44005_46905_82767_9E-4;

    function R(Z : MANTISSA_TYPE) return MANTISSA_TYPE is
      A0 : constant MANTISSA_TYPE := 0.04862_85276_587;
      B0 : constant MANTISSA_TYPE := 0.69735_92187_803;
      B1 : constant MANTISSA_TYPE :=-0.125;
      C  : constant MANTISSA_TYPE := 0.01360_09546_862;
    begin
      return Z + MANTISSA_TYPE(Z *
          MANTISSA_TYPE(MANTISSA_TYPE(Z * Z) * (C +
          MANTISSA_TYPE(A0/(B0 + MANTISSA_TYPE(B1 * MANTISSA_TYPE(Z * Z)))))));
    end R;

  begin

    if X < ZERO      then
      NEW_LINE;
      PUT("CALLED LOG FOR NEGATIVE ");
      PUT(X);
      PUT("   USE ABS => ");
      RESULT := LOG(ABS(X));
      PUT(RESULT);
      NEW_LINE;
    elsif X = ZERO  then
      NEW_LINE;
      PUT("CALLED LOG FOR ZERO ARGUMENT, RETURNED ");
      RESULT := -XMAX;      --  SUPPOSED TO BE -LARGE
      PUT(RESULT);
      NEW_LINE;
    else
      DEFLOAT(X,N,F);
      ZNUM := F - MANTISSA_HALF;
      Y := CONVERT_TO_FLOAT(ZNUM);
      ZDEN := ZNUM / MANTISSA_DIVISOR_2 + MANTISSA_HALF;
      if ZNUM > C0  then
        Y := Y - MANTISSA_HALF;
        ZNUM := ZNUM - MANTISSA_HALF;
        ZDEN := ZDEN + MANTISSA_HALF/MANTISSA_DIVISOR_2;
      else
        N := N -1;
      end if;
      Z    := MANTISSA_TYPE(ZNUM / ZDEN);
      RESULT := CONVERT_TO_FLOAT(R(Z));
      if N /= 0  then
        XN := CONVERT_TO_FLOAT(N);
        RESULT := (XN * C2 + RESULT) + XN * C1;
      end if;
    end if;
    return RESULT;

  exception
  when others =>
    NEW_LINE; PUT(" EXCEPTION IN LOG, X = "); PUT(X);
    PUT("  RETURNED 0.0"); NEW_LINE;
    return ZERO;
  end LOG;


  function LOG10(X : FLOAT) return FLOAT is
    LOG_10_OF_2 : constant FLOAT :=
             CONVERT_TO_FLOAT(MANTISSA_TYPE(8#0.33626_75425_11562_41615#));
  begin
    return LOG(X) * LOG_10_OF_2;
  end LOG10;

  function EXP(X : FLOAT) return FLOAT is

    RESULT : FLOAT;
    N : EXPONENT_TYPE;
    XG, XN, X1, X2 : FLOAT;
    F, G : MANTISSA_TYPE;

    BIGX : FLOAT := EXP_LARGE;
    SMALLX : FLOAT := EXP_SMALL;

    ONE_OVER_LOG_2 : constant FLOAT :=  1.4426_95040_88896_34074;
    C1 : constant FLOAT :=  0.69335_9375;
    C2 : constant FLOAT := -2.1219_44400_54690_58277E-4;

    function R(G : MANTISSA_TYPE) return MANTISSA_TYPE is
      Z , GP, Q : MANTISSA_TYPE;

      P0 : constant MANTISSA_TYPE :=  0.24999_99999_9992;
      P1 : constant MANTISSA_TYPE :=  0.00595_04254_9776;
      Q0 : constant MANTISSA_TYPE :=  0.5;
      Q1 : constant MANTISSA_TYPE :=  0.05356_75176_4522;
      Q2 : constant MANTISSA_TYPE :=  0.00029_72936_3682;
    begin
      Z  := MANTISSA_TYPE(G * G);
      GP := MANTISSA_TYPE( (MANTISSA_TYPE(P1 * Z) + P0) * G );
      Q  := MANTISSA_TYPE( (MANTISSA_TYPE(Q2 * Z) + Q1) * Z ) + Q0;
      return MANTISSA_HALF + MANTISSA_TYPE( GP /(Q - GP) );
    end R;


  begin

    if X > BIGX  then
      NEW_LINE;
      PUT("  EXP CALLED WITH TOO BIG A POSITIVE ARGUMENT, ");
          PUT(X); PUT("   RETURNED XMAX");
      NEW_LINE;
      RESULT := XMAX;
    elsif X < SMALLX  then
      NEW_LINE;
      PUT("  EXP CALLED WITH TOO BIG A NEGATIVE ARGUMENT,  ");
          PUT(X); PUT("    RETURNED ZERO");
      NEW_LINE;
      RESULT := ZERO;
    elsif ABS(X) < EPS  then
      RESULT := ONE;
    else
      N  := EXPONENT_TYPE(X * ONE_OVER_LOG_2);
      XN := CONVERT_TO_FLOAT(N);
      X1 := ROUND(X);
      X2 := X - X1;
      XG := ( (X1 - XN * C1) + X2 ) - XN * C2;
      G  := MANTISSA_TYPE(XG);
      N  := N + 1;
      F := R(G);
      REFLOAT(N, F, RESULT);
    end if;
    return RESULT;

  exception
  when others =>
    NEW_LINE; PUT(" EXCEPTION IN EXP, X = "); PUT(X);
    PUT("  RETURNED 1.0"); NEW_LINE;
    return ONE;
  end EXP;

function "**" (X, Y : FLOAT) return FLOAT is
  M, N : EXPONENT_TYPE;
  G : MANTISSA_TYPE;
  P, TEMP, IW1, I : INTEGER;
  RESULT, Z, V, R, U1, U2, W, W1, W2, W3, Y1, Y2 : FLOAT;

  K : constant FLOAT := 0.44269_50408_88963_40736;
  IBIGX : constant INTEGER := INTEGER(TRUNCATE(16.0 * LOG(XMAX) - 1.0));
  ISMALLX : constant INTEGER := INTEGER(TRUNCATE(16.0 * LOG(XMIN) + 1.0));

  P1 : constant FLOAT := 0.83333_32862_45E-1;
  P2 : constant FLOAT := 0.12506_48500_52E-1;

  Q1 : constant FLOAT := 0.69314_71805_56341;
  Q2 : constant FLOAT := 0.24022_65061_44710;
  Q3 : constant FLOAT := 0.55504_04881_30765E-1;
  Q4 : constant FLOAT := 0.96162_06595_83789E-2;
  Q5 : constant FLOAT := 0.13052_55159_42810E-2;

  A1 : array (1 .. 17) of FLOAT:=
     (  8#1.00000_0000#,
        8#0.75222_5750#,
        8#0.72540_3067#,
        8#0.70146_3367#,
        8#0.65642_3746#,
        8#0.63422_2140#,
        8#0.61263_4520#,
        8#0.57204_2434#,
        8#0.55202_3631#,
        8#0.53254_0767#,
        8#0.51377_3265#,
        8#0.47572_4623#,
        8#0.46033_7602#,
        8#0.44341_7233#,
        8#0.42712_7017#,
        8#0.41325_3033#,
        8#0.40000_0000#  );

  A2 : array (1 .. 8) of FLOAT :=
     (  8#0.00000_00005_22220_66302_61734_72062#,
        8#0.00000_00003_02522_47021_04062_61124#,
        8#0.00000_00005_21760_44016_17421_53016#,
        8#0.00000_00007_65401_41553_72504_02177#,
        8#0.00000_00002_44124_12254_31114_01243#,
        8#0.00000_00000_11064_10432_66404_42174#,
        8#0.00000_00004_72542_16063_30176_55544#,
        8#0.00000_00001_74611_03661_23056_22556#  );


  function REDUCE (V : FLOAT) return FLOAT is
  begin
    return FLOAT(INTEGER(16.0 * V)) * 0.0625;
  end REDUCE;

  begin
    if X <= ZERO then
      if X < ZERO then
        RESULT := (ABS(X))**Y;
--        NEW_LINE;
--        PUT("X**Y CALLED WITH X = "); PUT(X); PUT("  Y= "); PUT(Y); NEW_LINE;
--        PUT("USED ABS, RETURNED "); PUT(RESULT); NEW_LINE;
      else
        if Y <= ZERO then
          if Y = ZERO then
            RESULT := ZERO;
          else
            RESULT := XMAX;
          end if;
          NEW_LINE;
          PUT("X**Y CALLED WITH X = 0, Y = "); PUT(Y); NEW_LINE;
          PUT("RETURNED "); PUT(RESULT); NEW_LINE;
        else
          RESULT := ZERO;
        end if;
      end if;
    else
      DEFLOAT(X, M, G);
      P := 1;
      if G <= A1(9) then
        P := 9;
      end if;
      if G <= A1(P+4) then
        P := P + 4;
      end if;
      if G <= A1(P+2) then
        P := P + 2;
      end if;
      Z := ((G - A1(P+1)) - A2((P+1)/2))/(G + A1(P+1));
      Z := Z + Z;
      V := Z * Z;
      R := (P2 * V + P1) * V * Z;
      R := R + K * R;
      U2 := (R + Z * K) + Z;
      U1 := FLOAT(INTEGER(M) * 16 - P) * 0.0625;
      Y1 := REDUCE(Y);
      Y2 := Y - Y1;
      W := U2 * Y + U1 * Y2;
      W1 := REDUCE(W);
      W2 := W - W1;
      W := W1 + U1 * Y1;
      W1 := REDUCE(W);
      W2 := W2 + (W - W1);
      W3 := REDUCE(W2);
      IW1 := INTEGER(TRUNCATE(16.0 * (W1 + W3)));
      W2 := W2 - W3;
      if W > FLOAT(IBIGX) then
        RESULT := XMAX;
        PUT("X**Y CALLED  X ="); PUT(X); PUT("   Y ="); PUT(Y);
        PUT("   TOO LARGE  RETURNED "); PUT(RESULT); NEW_LINE;
      elsif W < FLOAT(ISMALLX) then
        RESULT := ZERO;
        PUT("X**Y CALLED  X ="); PUT(X); PUT("   Y ="); PUT(Y);
        PUT("   TOO SMALL  RETURNED "); PUT(RESULT); NEW_LINE;
      else
        if W2 > ZERO then
          W2 := W2 - 0.0625;
          IW1 := IW1 + 1;
        end if;
        if IW1 < INTEGER(ZERO) then
          I := 0;
        else
          I := 1;
        end if;
        M := EXPONENT_TYPE(I + IW1/16);
        P := 16 * INTEGER(M) - IW1;
        Z := ((((Q5 * W2 + Q4) * W2 + Q3) * W2 + Q2) * W2 + Q1) * W2;
        Z := A1(P+1) + (A1(P+1) * Z);

        REFLOAT(M, Z, RESULT);
      end if;
    end if;
    return RESULT;
  end "**";

begin
  EXP_LARGE := LOG(XMAX) * (ONE - EPS);
  EXP_SMALL := LOG(XMIN) * (ONE - EPS);
end CORE_FUNCTIONS;

package body TRIG_FUNCTIONS is
  use TEXT_IO;
  use FLOATING_CHARACTERISTICS;
  use NUMERIC_IO;
  use NUMERIC_PRIMITIVES;
  use CORE_FUNCTIONS;



  function SIN(X : FLOAT) return FLOAT is
    SGN, Y : FLOAT;
    N : INTEGER;
    XN : FLOAT;
    F, G, X1, X2 : FLOAT;
    RESULT : FLOAT;

    YMAX : FLOAT := FLOAT(INTEGER(PI * TWO**(IT/2)));
    BETA : FLOAT := CONVERT_TO_FLOAT(IBETA);
    EPSILON : FLOAT := BETA ** (-IT/2);

    C1 : constant FLOAT :=  3.140625;
    C2 : constant FLOAT :=  9.6765_35897_93E-4;

    function R(G : FLOAT) return FLOAT is
      R1 : constant FLOAT := -0.16666_66660_883;
      R2 : constant FLOAT :=  0.83333_30720_556E-2;
      R3 : constant FLOAT := -0.19840_83282_313E-3;
      R4 : constant FLOAT :=  0.27523_97106_775E-5;
      R5 : constant FLOAT := -0.23868_34640_601E-7;
    begin
      return ((((R5*G + R4)*G + R3)*G + R2)*G + R1)*G;
    end R;

  begin
    if X < ZERO  then
      SGN := -ONE;
      Y := -X;
    else
      SGN := ONE;
      Y := X;
    end if;

    if Y > YMAX  then
      NEW_LINE;
      PUT(" SIN CALLED WITH ARGUMENT TOO LARGE FOR ACCURACY ");
      PUT(X); NEW_LINE;
    end if;

    N := INTEGER(Y * ONE_OVER_PI);
    XN := CONVERT_TO_FLOAT(N);
    if N mod 2 /= 0  then
      SGN := -SGN;
    end if;
    X1 := TRUNCATE(ABS(X));
    X2 := ABS(X) - X1;
    F := ((X1 - XN*C1) + X2) - XN*C2;
    if ABS(F) < EPSILON  then
      RESULT := F;
    else
      G := F * F;
      RESULT := F + F*R(G);
    end if;
    return (SGN * RESULT);
  end SIN;


  function COS(X : FLOAT) return FLOAT is
    SGN, Y : FLOAT;
    N : INTEGER;
    XN : FLOAT;
    F, G, X1, X2 : FLOAT;
    RESULT : FLOAT;

    YMAX : FLOAT := FLOAT(INTEGER(PI * TWO**(IT/2)));
    BETA : FLOAT := CONVERT_TO_FLOAT(IBETA);
    EPSILON : FLOAT := BETA ** (-IT/2);

    C1 : constant FLOAT :=  3.140625;
    C2 : constant FLOAT :=  9.6765_35897_93E-4;

    function R(G : FLOAT) return FLOAT is
      R1 : constant FLOAT := -0.16666_66660_883;
      R2 : constant FLOAT :=  0.83333_30720_556E-2;
      R3 : constant FLOAT := -0.19840_83282_313E-3;
      R4 : constant FLOAT :=  0.27523_97106_775E-5;
      R5 : constant FLOAT := -0.23868_34640_601E-7;
    begin
      return ((((R5*G + R4)*G + R3)*G + R2)*G + R1)*G;
    end R;

  begin
    SGN := 1.0;
    Y := ABS(X) + PI_OVER_TWO;

    if Y > YMAX  then
      NEW_LINE;
      PUT(" COS CALLED WITH ARGUMENT TOO LARGE FOR ACCURACY ");
      PUT(X); NEW_LINE;
    end if;

    N := INTEGER(Y * ONE_OVER_PI);
    XN := CONVERT_TO_FLOAT(N);
    if N mod 2 /= 0  then
      SGN := -SGN;
    end if;
    XN := XN - 0.5;          -- TO FORM COS INSTEAD OF SIN
    X1 := TRUNCATE(ABS(X));
    X2 := ABS(X) - X1;
    F := ((X1 - XN*C1) + X2) - XN*C2;
    if ABS(F) < EPSILON  then
      RESULT := F;
    else
      G := F * F;
      RESULT := F + F*R(G);
    end if;
    return (SGN * RESULT);
  end COS;


  function TAN(X : FLOAT) return FLOAT is
    SGN, Y : FLOAT;
    N : INTEGER;
    XN : FLOAT;
    F, G, X1, X2 : FLOAT;
    RESULT : FLOAT;

    YMAX : FLOAT := FLOAT(INTEGER(PI * TWO**(IT/2))) /2.0;
    BETA : FLOAT := CONVERT_TO_FLOAT(IBETA);
    EPSILON : FLOAT := BETA ** (-IT/2);

    C1 : constant FLOAT :=  8#1.444#;
    C2 : constant FLOAT :=  4.8382_67948_97E-4;

    function R(G : FLOAT) return FLOAT is
      P0 : constant FLOAT :=  1.0;
      P1 : constant FLOAT := -0.11136_14403_566;
      P2 : constant FLOAT :=  0.10751_54738_488E-2;
      Q0 : constant FLOAT :=  1.0;
      Q1 : constant FLOAT := -0.44469_47720_281;
      Q2 : constant FLOAT :=  0.15973_39213_300E-1;
    begin
      return ((P2*G + P1)*G*F + F) / (((Q2*G + Q1)*G +0.5) + 0.5);
    end R;

  begin
    Y := ABS(X);
    if Y > YMAX  then
      NEW_LINE;
      PUT(" TAN CALLED WITH ARGUMENT TOO LARGE FOR ACCURACY ");
      PUT(X); NEW_LINE;
    end if;

    N := INTEGER(X * TWO_OVER_PI);
    XN := CONVERT_TO_FLOAT(N);
    X1 := TRUNCATE(X);
    X2 := X - X1;
    F := ((X1 - XN*C1) + X2) - XN*C2;
    if ABS(F) < EPSILON  then
      RESULT := F;
    else
      G := F * F;
      RESULT := R(G);
    end if;
    if N mod 2 = 0  then
      return RESULT;
    else
      return -1.0/RESULT;
    end if;
  end TAN;

  function COT(X : FLOAT) return FLOAT is
    SGN, Y : FLOAT;
    N : INTEGER;
    XN : FLOAT;
    F, G, X1, X2 : FLOAT;
    RESULT : FLOAT;


    YMAX : FLOAT := FLOAT(INTEGER(PI * TWO**(IT/2))) /2.0;
    BETA : FLOAT := CONVERT_TO_FLOAT(IBETA);
    EPSILON : FLOAT := BETA ** (-IT/2);
    EPSILON1 : FLOAT :=  1.0/XMAX;

    C1 : constant FLOAT :=  8#1.444#;
    C2 : constant FLOAT :=  4.8382_67948_97E-4;

    function R(G : FLOAT) return FLOAT is
      P0 : constant FLOAT :=  1.0;
      P1 : constant FLOAT := -0.11136_14403_566;
      P2 : constant FLOAT :=  0.10751_54738_488E-2;
      Q0 : constant FLOAT :=  1.0;
      Q1 : constant FLOAT := -0.44469_47720_281;
      Q2 : constant FLOAT :=  0.15973_39213_300E-1;
    begin
      return ((P2*G + P1)*G*F + F) / (((Q2*G + Q1)*G +0.5) + 0.5);
    end R;

  begin
    Y := ABS(X);
    if Y < EPSILON1  then
      NEW_LINE;
      PUT(" COT CALLED WITH ARGUMENT TOO NEAR ZERO ");
      PUT(X); NEW_LINE;
      if X < 0.0  then
        return -XMAX;
      else
        return XMAX;
      end if;
    end if;
    if Y > YMAX  then
      NEW_LINE;
      PUT(" COT CALLED WITH ARGUMENT TOO LARGE FOR ACCURACY ");
      PUT(X); NEW_LINE;
    end if;

    N := INTEGER(X * TWO_OVER_PI);
    XN := CONVERT_TO_FLOAT(N);
    X1 := TRUNCATE(X);
    X2 := X - X1;
    F := ((X1 - XN*C1) + X2) - XN*C2;
    if ABS(F) < EPSILON  then
      RESULT := F;
    else
      G := F * F;
      RESULT := R(G);
    end if;
    if N mod 2 /= 0  then
      return -RESULT;
    else
      return 1.0/RESULT;
    end if;
  end COT;


  function ASIN(X : FLOAT) return FLOAT is
    G, Y : FLOAT;
    RESULT : FLOAT;
    BETA : FLOAT := CONVERT_TO_FLOAT(IBETA);
    EPSILON : FLOAT := BETA ** (-IT/2);

    function R(G : FLOAT) return FLOAT is
    P1 : constant FLOAT := -0.27516_55529_0596E1;
    P2 : constant FLOAT :=  0.29058_76237_4859E1;
    P3 : constant FLOAT := -0.59450_14419_3246;
    Q0 : constant FLOAT := -0.16509_93320_2424E2;
    Q1 : constant FLOAT :=  0.24864_72896_9164E2;
    Q2 : constant FLOAT := -0.10333_86707_2113E2;
    Q3 : constant FLOAT :=  1.0;
    begin
      return (((P3*G + P2)*G + P1)*G) / (((G + Q2)*G + Q1)*G + Q0);
    end R;

  begin
    Y := ABS(X);

    if Y > HALF  then
      if Y > 1.0  then
        NEW_LINE; PUT(" ASIN CALLED FOR "); PUT(X);
            PUT(" (> 1)  TRUNCATED TO 1, CONTINUED"); NEW_LINE;
        Y := 1.0;
      end if;
      G := ((0.5 - Y) + 0.5) / 2.0;
      Y := -2.0 * SQRT(G);
      RESULT := Y + Y * R(G);
      RESULT := (PI_OVER_FOUR + RESULT) + PI_OVER_FOUR;
    else
      if Y < EPSILON  then
        RESULT := Y;
      else
        G := Y * Y;
        RESULT := Y + Y * R(G);
      end if;
    end if;
    if X < 0.0  then
      RESULT := -RESULT;
    end if;

    return RESULT;
  end ASIN;

  function ACOS(X : FLOAT) return FLOAT is
    G, Y : FLOAT;
    RESULT : FLOAT;
    BETA : FLOAT := CONVERT_TO_FLOAT(IBETA);
    EPSILON : FLOAT := BETA ** (-IT/2);

    function R(G : FLOAT) return FLOAT is
    P1 : constant FLOAT := -0.27516_55529_0596E1;
    P2 : constant FLOAT :=  0.29058_76237_4859E1;
    P3 : constant FLOAT := -0.59450_14419_3246;
    Q0 : constant FLOAT := -0.16509_93320_2424E2;
    Q1 : constant FLOAT :=  0.24864_72896_9164E2;
    Q2 : constant FLOAT := -0.10333_86707_2113E2;
    Q3 : constant FLOAT :=  1.0;
    begin
      return (((P3*G + P2)*G + P1)*G) / (((G + Q2)*G + Q1)*G + Q0);
    end R;

  begin
    Y := ABS(X);

    if Y > HALF  then
      if Y > 1.0  then
        NEW_LINE; PUT(" ACOS CALLED FOR "); PUT(X);
            PUT(" (> 1)  TRUNCATED TO 1, CONTINUED"); NEW_LINE;
        Y := 1.0;
      end if;
      G := ((0.5 - Y) + 0.5) / 2.0;
      Y := -2.0 * SQRT(G);
      RESULT := Y + Y * R(G);
      if X < 0.0  then
        RESULT := (PI_OVER_TWO + RESULT) + PI_OVER_TWO;
      else
        RESULT := -RESULT;
      end if;

    else
      if Y < EPSILON  then
        RESULT := Y;
      else
        G := Y * Y;
        RESULT := Y + Y * R(G);
      end if;
      if X < 0.0  then
        RESULT := (PI_OVER_FOUR + RESULT) + PI_OVER_FOUR;
      else
        RESULT := (PI_OVER_FOUR - RESULT) + PI_OVER_FOUR;
      end if;
    end if;

    return RESULT;
  end ACOS;


  function ATAN(X : FLOAT) return FLOAT is
    F, G : FLOAT;
    subtype REGION is INTEGER range 0..3;    --  ##########
    N : REGION;
    RESULT : FLOAT;

    BETA : FLOAT := CONVERT_TO_FLOAT(IBETA);

    EPSILON : FLOAT := BETA ** (-IT/2);

    SQRT_3           : constant FLOAT :=  1.73205_08075_68877_29353;
    SQRT_3_MINUS_1   : constant FLOAT :=  0.73205_08075_68877_29353;
    TWO_MINUS_SQRT_3 : constant FLOAT :=  0.26794_91924_31122_70647;

    function R(G : FLOAT) return FLOAT is
      P0 : constant FLOAT := -0.14400_83448_74E1;
      P1 : constant FLOAT := -0.72002_68488_98;
      Q0 : constant FLOAT :=  0.43202_50389_19E1;
      Q1 : constant FLOAT :=  0.47522_25845_99E1;
      Q2 : constant FLOAT :=  1.0;
    begin
      return ((P1*G + P0)*G) / ((G + Q1)*G + Q0);
    end R;

  begin
    F := ABS(X);

    if F > 1.0  then
      F := 1.0 / F;
      N := 2;
    else
      N := 0;
    end if;

    if F > TWO_MINUS_SQRT_3  then
      F := (((SQRT_3_MINUS_1 * F - 0.5) - 0.5) + F) / (SQRT_3 + F);
      N := N + 1;
    end if;

    if ABS(F) < EPSILON  then
      RESULT := F;
    else
      G := F * F;
      RESULT := F + F * R(G);
    end if;

    if N > 1  then
      RESULT := - RESULT;
    end if;

    case N is
    when 0  =>
      RESULT := RESULT;
    when 1  =>
      RESULT := PI_OVER_SIX + RESULT;
    when 2  =>
      RESULT := PI_OVER_TWO + RESULT;
    when 3  =>
      RESULT := PI_OVER_THREE + RESULT;
    end case;

    if X < 0.0  then
      RESULT := - RESULT;
    end if;

    return RESULT;

  end ATAN;



  function ATAN2(V, U : FLOAT) return FLOAT is
    X, RESULT : FLOAT;

  begin

    if U = 0.0  then
      if V = 0.0  then
        RESULT := 0.0;
        NEW_LINE;
        PUT(" ATAN2 CALLED WITH 0/0   RETURNED "); PUT(RESULT);
        NEW_LINE;
      elsif V > 0.0  then
        RESULT := PI_OVER_TWO;
      else
        RESULT := - PI_OVER_TWO;
      end if;

    else
      X := ABS(V/U);
      --  If underflow or overflow is detected, go to the exception
      RESULT := ATAN(X);
      if U < 0.0  then
        RESULT := PI - RESULT;
      end if;
      if V < 0.0  then
        RESULT := - RESULT;
      end if;
    end if;
    return RESULT;
  exception
  when NUMERIC_ERROR  =>
    if ABS(V) > ABS(U)  then
      RESULT := PI_OVER_TWO;
      if V < 0.0  then
        RESULT := - RESULT;
      end if;
    else
      RESULT := 0.0;
      if U < 0.0  then
        RESULT := PI - RESULT;
      end if;
    end if;
    return RESULT;
  end ATAN2;


  function SINH(X : FLOAT) return FLOAT is
    G, W, Y, Z : FLOAT;
    RESULT : FLOAT;
    BETA : FLOAT := CONVERT_TO_FLOAT(IBETA);
    EPSILON : FLOAT := BETA ** (-IT/2);

    YBAR : FLOAT := EXP_LARGE;
    LN_V : FLOAT := 8#0.542714#;
    V_OVER_2_MINUS_1 : FLOAT :=  0.13830_27787_96019_02638E-4;
    WMAX : FLOAT := YBAR - LN_V + 0.69;

    function R(G : FLOAT) return FLOAT is
    P0 : constant FLOAT :=  0.10622_28883_7151E4;
    P1 : constant FLOAT :=  0.31359_75645_6058E2;
    P2 : constant FLOAT :=  0.34364_14035_8506;
    Q0 : constant FLOAT :=  0.63733_73302_1822E4;
    Q1 : constant FLOAT := -0.13051_01250_9199E3;
    Q2 : constant FLOAT :=  1.0;
    begin
      return (((P2*G + P1)*G + P0)*G) / ((G + Q1)*G + Q0);
    end R;

  begin
    Y := ABS(X);

    if Y <= 1.0  then
      if Y < EPSILON  then
        RESULT := X;
      else
        G := X * X;
        RESULT := X + X * R(G);
      end if;

    else
      if Y <= YBAR  then
        Z := EXP(Y);
        RESULT := (Z - 1.0/Z) / 2.0;
      else
        W := Y - LN_V;
        if W > WMAX  then
          NEW_LINE;
          PUT(" SINH CALLED WITH TOO LARGE ARGUMENT  "); PUT(X);
          PUT(" RETURN BIG"); NEW_LINE;
          W := WMAX;
        end if;
        Z := EXP(W);
        RESULT := Z + V_OVER_2_MINUS_1 * Z;
      end if;
      if X < 0.0  then
        RESULT := -RESULT;
      end if;

    end if;
    return RESULT;
  end SINH;


  function COSH(X : FLOAT) return FLOAT is
    G, W, Y, Z : FLOAT;
    RESULT : FLOAT;
    BETA : FLOAT := CONVERT_TO_FLOAT(IBETA);
    EPSILON : FLOAT := BETA ** (-IT/2);

    YBAR : FLOAT := EXP_LARGE;
    LN_V : FLOAT := 8#0.542714#;
    V_OVER_2_MINUS_1 : FLOAT :=  0.13830_27787_96019_02638E-4;
    WMAX : FLOAT := YBAR - LN_V + 0.69;

    function R(G : FLOAT) return FLOAT is
    P0 : constant FLOAT :=  0.10622_28883_7151E4;
    P1 : constant FLOAT :=  0.31359_75645_6058E2;
    P2 : constant FLOAT :=  0.34364_14035_8506;
    Q0 : constant FLOAT :=  0.63733_73302_1822E4;
    Q1 : constant FLOAT := -0.13051_01250_9199E3;
    Q2 : constant FLOAT :=  1.0;
    begin
      return (((P2*G + P1)*G + P0)*G) / ((G + Q1)*G + Q0);
    end R;

  begin
    Y := ABS(X);

    if Y <= YBAR  then
      Z := EXP(Y);
      RESULT := (Z + 1.0/Z) / 2.0;
    else
      W := Y - LN_V;
      if W > WMAX  then
        NEW_LINE;
        PUT(" COSH CALLED WITH TOO LARGE ARGUMENT  "); PUT(X);
        PUT(" RETURN BIG"); NEW_LINE;
        W := WMAX;
      end if;
      Z := EXP(W);
      RESULT := Z + V_OVER_2_MINUS_1 * Z;
    end if;

    return RESULT;
  end COSH;


  function TANH(X : FLOAT) return FLOAT is
    G, W, Y, Z : FLOAT;
    RESULT : FLOAT;
    BETA : FLOAT := CONVERT_TO_FLOAT(IBETA);
    EPSILON : FLOAT := BETA ** (-IT/2);

    XBIG : FLOAT := (LOG(2.0) + CONVERT_TO_FLOAT(IT + 1) * LOG(BETA))/2.0;
    LN_3_OVER_2 : FLOAT :=  0.54930_61443_34054_84570;

    function R(G : FLOAT) return FLOAT is
    P0 : constant FLOAT := -0.21063_95800_0245E2;
    P1 : constant FLOAT := -0.93363_47565_2401;
    Q0 : constant FLOAT :=  0.63191_87401_5582E2;
    Q1 : constant FLOAT :=  0.28077_65347_0471E2;
    Q2 : constant FLOAT :=  1.0;
    begin
      return ((P1*G + P0)*G) / ((G + Q1)*G + Q0);
    end R;

  begin
    Y := ABS(X);

    if Y > XBIG  then
      RESULT := 1.0;
    else
      if Y > LN_3_OVER_2  then
        RESULT := 0.5 - 1.0 / (EXP(Y + Y) + 1.0);
        RESULT := RESULT + RESULT;
      else
        if Y < EPSILON  then
          RESULT := Y;
        else
          G := Y * Y;
          RESULT := Y + Y * R(G);
        end if;
      end if;
    end if;
    if X < 0.0  then
      RESULT := - RESULT;
    end if;

    return RESULT;
  end TANH;


begin
  null;
end TRIG_FUNCTIONS;

end MATHLIB;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--ENTITYUTI
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Debugger; Use Debugger;
With Text_IO; use Text_io,float_io,integer_io;
With Mathlib; use Mathlib,core_functions;
With Types; Use Types;
With Constants; Use Constants;
With HELPS; use HELPS;
Package ENTITYUTI is
--
      Procedure ALPHA_TO_INTEGER(BUFFER: in string;
                                 NUMERIC_VALUE: out float);
      Procedure ALPHA_TO_INTEGERIZED_ALPHA(BUFFER: in out string;
                                         INTEGERIZED_ALPHA: out long_integer);
      Procedure ALPHA_TO_NUMERIC(BUFFER: in out string;
                                 NREP: out integer;
                                 NUMERIC_VALUE: out float);
      Procedure ANTENNA_CHECK(IATYP: in integer;
                              NFREQ: in BAND_TYPES;
                              GAIN: in out float;
                              HEIGHT: in out float;
                              ALNGTH: in out float;
                              TLTANG: in out float;
                              IERR: out integer);
      Function DIGIT_CHECK(MCHAR: character) return boolean;
      Procedure INTEGER_TO_ALPHA(INTEGERIZED_ALPHA: in long_integer;
                                 BUFFER: out string);
      Procedure NEW_TITLE_CHECK;
      Procedure PARSE(BUFFER: in out string);
--
End ENTITYUTI;
--
Package body ENTITYUTI is
--
-- ENTITYUTI Package of PROP_LINK Version 1.0, February 5, 1985
--
-- This ENTITY_UTILITIES Package contains all general purpose utilities
-- that support the subject of entity (e.g., Nodes, Transmitters and
-- Receivers) handling.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
--
-- CONSTANTS:
      CHAR_UPPER: string(1..38) := " ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789*";
      CHAR_LOWER: string(1..27) := " abcdefghijklmnopqrstuvwxyz";
--
-- TYPES:
--
-- VARIABLES:
      BUFFER: array (integer range 1..6) of character;
      INTEGERIZED_ALPHA: long_integer;
      HEIGHT:float;
--
--
Procedure ALPHA_TO_INTEGER(BUFFER: in string;
                           NUMERIC_VALUE: out float) is
--
--PURPOSE: ALPHA_TO_INTEGER converts the string of digits in the input
--         string to an integer number with a positive sign.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Digit Manipulation
--
--PARAMETER DESCRIPTIONS:
--IN       BUFFER  = The string containing the sequential digits to be
--                  converted
--OUT      NUMERIC_VALUE    = The resultant float number
--
--CALLED BY:
--         ALPHA_TO_NUMERIC
--
--CALLS TO:
--         'NONE'
--
--TECHNICAL DESCRIPTION:
--         ALPHA_TO_INTEGER converts the string of digits in the input
--         string to a float number with a positive sign.  The technique
--         used raises the base of the number 10 to the individual
--         value of each digit as input and sums the results.
--
      J: integer;
      LIM: integer;
      IEXP: integer;
--
      Begin
--
      NUMERIC_VALUE := 0.0;
      LIM := 1;
      IEXP := -1;
--
--COUNT THE DIGITS.
      For J in 1..81 Loop
         If J = 81 Then
            Return;
         End If;
         LIM := J;
         If BUFFER(J) = ' ' Then
            Exit;
          End If;
      End Loop;
--
      Loop
         LIM := LIM - 1;
         IEXP := IEXP + 1;
         If LIM = 0 Then
            Exit;
         End If;
         For J in 28..38 Loop
            If J = 38 Then
               New_line;
               Put("WARNING...Improper number field.");
               Return;
            End If;
            If BUFFER(LIM) = CHAR_UPPER(J) Then
               NUMERIC_VALUE := NUMERIC_VALUE + FLOAT((J-28)) * 10.0**IEXP;
               Exit;
            End If;
         End Loop;
      End Loop;
      Return;
--
      End ALPHA_TO_INTEGER;
--
--
Procedure ALPHA_TO_INTEGERIZED_ALPHA (BUFFER: in out string;
                            INTEGERIZED_ALPHA: out long_integer) is
--
--PURPOSE: ALPHA_TO_INTEGERIZED_ALPHA converts an alphanumeric input of up to six
--         characters to a unique integer representation.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Conversion Module
--
--PARAMETER DESCRIPTIONS:
--IO        BUFFER = The six element string containing the alphanumeric
--                   data to be converted.
--OUT       INTEGERIZED_ALPHA = The integer representation of the input data.
--
--CALLED BY:
--          PARSE
--
--CALLS TO:
--         'NONE'
--
--TECHNICAL DESCRIPTION:
--         This procedure accepts up to six alphanumeric characters, the
--         first of which must be alpha, and converts them to an
--         unique integer representation for internal use.  Allowable
--         characters are A-Z, 0-9.  The result is left justified and
--         blank filled to six characters.  An integer base of 37 is
--         used which results in integer values between 71270178 and
--         1943557016.  Lower case letters are first converted to
--         upper case.
--
      I,J: integer;
--
      Begin
--
      INTEGERIZED_ALPHA := 0;
--
      For I in 1..6 Loop
--
      --CONVERT ANY LOWER CASE TO UPPER CASE.
         For J in CHAR_LOWER'RANGE Loop
            If BUFFER(I) = CHAR_LOWER(J) Then
               BUFFER(I) := CHAR_UPPER(J);
               Exit;
            End If;
         End Loop;
--
      --CONVERT ALPHANUMERIC TO INTEGER.
         For J in CHAR_UPPER'RANGE Loop
            If J = 38 Then
               New_line;
               Put("WARNING...Improper alphanumeric field.");
               Return;
            End If;
            If BUFFER(I) = CHAR_UPPER(J) Then
               INTEGERIZED_ALPHA := INTEGERIZED_ALPHA + (long_integer(J) *
                                    long_integer (37)**(6-I));
               Exit;
            End If;
         End Loop;
--
      End Loop;
--
      Return;
      End ALPHA_TO_INTEGERIZED_ALPHA;
--
Procedure ALPHA_TO_NUMERIC (BUFFER: in out string;
                            NREP: out integer;
                            NUMERIC_VALUE: out float) is
--
--PURPOSE: ALPHA_TO_NUMERIC converts the alphanumeric digits and data
--         to the proper number for arithmetic use.  It can handle
--         integer, float, and exponential type notations as well as
--         negative numbers.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Conversion Module
--
--PARAMETER DESCRIPTIONS:
--IO       BUFFER        = The 80 element string containing the alphanumeric
--                         data to be converted.
--OUT      NREP          = The number of repetitions
--OUT      NUMERIC_VALUE = The numeric representation of the number
--
--CALLED BY:
--         PARSE
--
--CALLS TO:
--         DIGIT_CHECK
--         ALPHA_TO_INTEGER
--         SHIFT_LEFT
--
--TECHNICAL DESCRIPTION:
--         ALPHA_TO_NUMERIC converts the alphanumeric digits and data to the
--         proper number for arithmetic use.  It can handle integer, float,
--         and exponential type notations as well as negative numbers.
--         ALPHA_TO_NUMERIC can also handle * as an input symbol.
--         The technique employed is one of shifting and examining the
--         characters as input, one at a time, and then making the
--         appropriate conversion.
--
      KTEMP: string(1..80);
      VAL2: float;
      IFL22: integer;
      ISIGN: integer;
      J,M: integer;
--
      Begin
--
--INITIALIZATION.
      IFL22 := 0;
      ISIGN := 1;
      NUMERIC_VALUE := 0.0;
      NREP := 1;
<<THE_BEGINNING>>
--
--BLANK OUT THE KTEMP ARRAY.
      For J in KTEMP'RANGE Loop
         KTEMP(J) :=  ' ';
      End Loop;
--
--SHIFT LEFT UNTIL NON-BLANK CHARACTER FOUND.
      For J in 1..81 Loop
         If J = 81 Then
            Return;
         End If;
         If BUFFER(1) /= ' ' Then
            Exit;
         End If;
         SHIFT_LEFT(BUFFER);
      End Loop;
--
--PICK UP THE SIGN OF THE NUMBER.
      If BUFFER(1) = '-' Then
         ISIGN := -1;
         SHIFT_LEFT(BUFFER);
      End If;
      M := 0;
      If BUFFER(1) = '+' Then
         SHIFT_LEFT(BUFFER);
      End If;
--
--PICK OFF INTEGER PORTION.
      If BUFFER(1) = '.' Then
         Goto PERIOD_CHECK;
      End If;
      For J in 1..81 Loop
         If J = 81 Then
            Return;
         End If;
         If BUFFER(1) = '.'  or  BUFFER(1) = ' '  or
            BUFFER(1) = 'E'  or  BUFFER(1) = '+'  or
            BUFFER(1) = 'e'  or  BUFFER(1) = 'D'  or
            BUFFER(1) = 'd'  or  BUFFER(1) = '-'  or
            BUFFER(1) = '*'  or  BUFFER(1) = ','  or
            BUFFER(1) = '/'  or BUFFER(1) = '$' Then
            Exit;
         End If;
         M := M + 1;
         KTEMP(M) := BUFFER(1);
         SHIFT_LEFT(BUFFER);
      End Loop;
      ALPHA_TO_INTEGER(KTEMP,NUMERIC_VALUE);
--
--PROCESS REPETITION FACTOR.
      If BUFFER(1) = '*' Then
         NREP := INTEGER(NUMERIC_VALUE);
         SHIFT_LEFT(BUFFER);
         Goto THE_BEGINNING;
      End If;
--
--SKIP PAST ANY PERIOD.
      If BUFFER(1) /= '.' Then
         Goto ADD_SIGN;
      End If;
<<PERIOD_CHECK>>
      SHIFT_LEFT(BUFFER);
      If BUFFER(1) = ' ' Then
         Goto ADD_SIGN;
      End If;
--
--PICK UP DIGITS UNTIL THE NEXT SPECIAL CHARACTER.
      For J in KTEMP'RANGE Loop
         KTEMP(J) := ' ';
      End Loop;
      M := 0;
      For J in 1..81 Loop
         If J = 81 Then
            Return;
         End If;
         IFL22 := 0;
         If BUFFER(1) = ' '  or  BUFFER(1) = ','  or
            BUFFER(1) = '/'  or  BUFFER(1) = '$' Then
            Exit;
         End If;
         IFL22 := 1;
         If BUFFER(1) = '+' or BUFFER(1) = '-' or
            BUFFER(1) = 'E' or BUFFER(1) = 'e' or
            BUFFER(1) = 'D' or BUFFER(1) = 'd' Then
            Exit;
         End If;
         M := M + 1;
         KTEMP(M) := BUFFER(1);
         SHIFT_LEFT(BUFFER);
      End Loop;
      ALPHA_TO_INTEGER(KTEMP,VAL2);
      NUMERIC_VALUE := NUMERIC_VALUE + VAL2 / 10.0**M;
<<ADD_SIGN>>
      NUMERIC_VALUE := NUMERIC_VALUE * FLOAT(ISIGN);
      If IFL22 /= 1 and
         BUFFER(1) /= 'E' and BUFFER(1) /= '+' and
         BUFFER(1) /= 'e' and BUFFER(1) /= '-' and
         BUFFER(1) /= 'D' and BUFFER(1) /= 'd' Then
         Return;
      End If;
      If BUFFER(1) = 'E' or BUFFER(1) = 'e' or
         BUFFER(1) = 'D' or BUFFER(1) = 'd' Then
         SHIFT_LEFT(BUFFER);
      End If;
      ISIGN := 1;
      If BUFFER(1) = '-' Then
         ISIGN := -1;
      End If;
      IF (not DIGIT_CHECK(BUFFER(1))) Then
         SHIFT_LEFT(BUFFER);
      End If;
      ALPHA_TO_INTEGER(BUFFER,VAL2);
      If ISIGN = 1 Then
         NUMERIC_VALUE := NUMERIC_VALUE * (10.0**VAL2);
      Else
         NUMERIC_VALUE := NUMERIC_VALUE * (10.0**(-VAL2));
      End If;
      Return;
--
      End ALPHA_TO_NUMERIC;
--
--
Procedure ANTENNA_CHECK(IATYP: in integer;
                        NFREQ: in BAND_TYPES;
                        GAIN: in out float;
                        HEIGHT: in out float;
                        ALNGTH: in out float;
                        TLTANG: in out float;
                        IERR: out integer) is
--
--PURPOSE: ANTENNA_CHECK verifies that the antenna type input is appropriate
--         to the frequency class.
--
--AUTHOR:  B. Perry and J. Conrad
--
--PARAMETER DESCRIPTIONS:
--IN       IATYPE =  antenna type
--         NFREQ  =  frequency class
--IO       GAIN   =  antenna gain
--         HEIGHT =  antenna height
--         TLTANG =  antenna tilt angle
--         INPUT_BUFFER, IARRAY, XARRAY  = tempory strings used for input
--                                         (Declared in EXECUTIVE Package)
--OUT      IERR = returns 0 if all O.K.
--                returns 1 IF A = was encountered
--                returns 2 if IATYP not valid
--
--CALLED BY:
--         RECEIVER_DATA
--         TRANSMITTER_DATA
--
--CALLS TO:
--         BLANK_CHECK
--         HELP_CHECK
--         PARSE
--
--TECHNICAL DESCRIPTION:
--         ANTENNA_CHECK first tests the input frequency class to insure
--         that it is within the bounds between LF(4) and EHF(10).
--         A branch is then taken based on the frequency class and the
--         appropriate antenna data for that frequency class is echoed
--         for acceptance/modification.
--
      Procedure ANTDATA (S: string; D: in out FLOAT) is
      begin
         loop
            New_line;
            Put("Antenna "); Put(S); Put(": "); Put(D); New_line;
            Get_line(INPUT_BUFFER, MAX);
            If INPUT_BUFFER(1) = '=' Then
               IERR := 1;
               Return;
            End If;
            If not HELP_CHECK(INPUT_BUFFER(1..MAX)) Then exit; end if;
            New_line;
            Put("Enter the antenna "); Put(S); Put(".");
         End loop;
         If BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
            Return;
         End If;
         NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
         PARSE (INPUT_BUFFER(1..MAX));
         If NUMBER_OF_VARIABLES_TO_EXTRACT =
                   NUMBER_OF_VARIABLES_EXTRACTED Then
            NEW_TITLE_CHECK;
            D:= XARRAY(1);
         End If;
      end ANTDATA;
--
      Begin
--
      IERR := 0;
      Case NFREQ is
--
    --CHECK ANTENNA TYPE FOR LF.
         When LF =>
            New_line;
            If not (IATYP = 1 or IATYP = 2) Then
               Put("Expected antenna type 1 or 2, not ");
               Put(IATYP);
               IERR := 2;
            End If;
    --CHECK ANTENNA TYPE FOR MF,HF.
         When MF|HF => New_line;
            Case IATYP is
               When 5 =>
                  ANTDATA("gain in dB", GAIN);
               When 6 =>
                  ANTDATA("tilt angle in degrees",TLTANG);
                  If IERR=1 then return; end if;
                  ANTDATA("height in meters",HEIGHT);
                  If IERR=1 then return; end if;
                  ANTDATA("length in meters", ALNGTH);
               When 7 =>
                  ANTDATA("length in meters", ALNGTH);
               When 8 =>
                  ANTDATA("height in meters",HEIGHT);
               When others =>
                  Put("Expected antenna type 5, 6, 7 or 8, not ");
                  Put(IATYP);
                  IERR := 2;
            End Case;
    --CHECK ANTENNA TYPE FOR VHF,UHF,SHF,EHF.
         When VHF..EHF => New_line;
            If not (IATYP = 3 or IATYP = 4) Then
               Put("Expected antenna type 3 or 4, not ");
               Put(IATYP);
               IERR := 2;
            End If;
         When Others => Null;
      End Case;
--
      End ANTENNA_CHECK;
--
--
Function DIGIT_CHECK(MCHAR: character) return boolean is
--
--PURPOSE: DIGIT_CHECK determines if the input character is a numerical
--         digit (i.e. 0 - 9).
--
--AUTHOR:  J. Conrad
--
--TYPE:    Digit Test
--
--PARAMETER DESCRIPTIONS:
--IN       MCHAR        = The input character to be tested
--OUT      DIGIT_CHECK  = True if the input character is a digit,
--                        otherwise it will be false.
--
--CALLED BY:
--           ALPHA_TO_NUMERIC
--
--CALLS TO:
--         'NONE'
--
--TECHNICAL DESCRIPTION:
--         DIGIT_CHECK determines if the input character is a numerical
--         digit (i.e. 0 - 9).  If it is, DIGIT_CHECK will be true.
--         If the character is blank or alphabetic or a special
--         character, the value of DIGIT_CHECK will be false.
--         A simple Loop and comparison with all possible digits
--         is employed.
--
      I: integer;
--
      Begin
--
      For I in 28..37 Loop
         If MCHAR = CHAR_UPPER(I) Then
            Return TRUE;
         End If;
      End Loop;
--
      Return FALSE;
--
      End DIGIT_CHECK;
--
--
Procedure INTEGER_TO_ALPHA(INTEGERIZED_ALPHA: in long_integer;
                           BUFFER: out string) is
--
--PURPOSE: INTEGER_TO_ALPHA converts alphanumeric data from an internal
--         integer format to a six character alphanumeric string format.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Conversion Module
--
--PARAMETER DESCRIPTIONS:
--IN       INTERGERIZED_ALPHA = The internal integer representation of
--                              alphanumeric data
--OUT      BUFFER             = The six character string containing the
--                              converted alphanumeric data
--
--CALLED BY:
--         ENTITY_DATA
--         NODE_DATA
--         NODE_DISPLAY
--         NODE_FIND
--         NODE_HANDLER
--         RECEIVER_ADD
--         RECEIVER_DISPLAY
--         RECEIVER_FETCH
--         RECEIVER_HANDLER
--         RECEIVER_REMOVE
--         TRANSMITTER_ADD
--         TRANSMITTER_DISPLAY
--         TRANSMITTER_FETCH
--         TRANSMITTER_HANDLER
--         TRANSMITTER_REMOVE
--
--CALLS TO:
--         'NONE'
--
--TECHNICAL DESCRIPTION:
--         Alphanumeric data that has been converted by Procedure
--         ALPHA_TO_INTEGERIZED_ALPHA to an integer value between 71270178 and
--         1943557016 is converted back to alphanumeric string format.
--         If input is zero, a string of blanks is returned.
--
--
      ITEST: array (integer range 1..5) of long_integer;
      INPUT: long_integer;
      I,II: integer;
--
      Begin
--
      ITEST(1):=1926221;
      ITEST(2):=52060;
      ITEST(3):=1407;
      ITEST(4):=38;
      ITEST(5):=1;
      INPUT := INTEGERIZED_ALPHA;
      IF INPUT = 0 Then
         For I in BUFFER'RANGE Loop
            BUFFER(I) := CHAR_UPPER(1);
         End Loop;
         Return;
      End If;
      For I in 1..5 Loop
         II := integer(INPUT / (long_integer(37)**(6-I)));
         BUFFER(I) := CHAR_UPPER(II);
         INPUT := INPUT - (long_integer(II)*(long_integer(37)**(6-I)));
         If INPUT < ITEST(I) Then
            II := II - 1;
            BUFFER(I) := CHAR_UPPER(II);
            INPUT := INPUT + long_integer(37)**(6-I);
         End If;
      End Loop;
      BUFFER(6) := CHAR_UPPER(integer(INPUT));
      Return;
--
      End INTEGER_TO_ALPHA;
--
--
Procedure NEW_TITLE_CHECK is
--
--PURPOSE: NEW_TITLE_CHECK gets a new case title.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Input
--
--PARAMETER DESCRIPTIONS:
--IO       DATABASE_HAS_BEEN_MODIFIED is assumed to be visible from EXECUTIVE
--IO       TITLE is assumed to be visible from EXECUTIVE
--IO       INPUT_BUFFER is assumed to be visible from EXECUTIVE
--
--CALLED BY:
--         ANTENNA_CHECK
--         ENTITY_DATA
--         LOCATION_DATA
--         NODE_ADD
--         NODE_REMOVE
--         RECEIVER_ADD
--         RECEIVER_DATA
--         RECEIVER_REMOVE
--         TRANSMITTER_ADD
--         TRANSMITTER_DATA
--         TRANSMITTER_REMOVE
--
--CALLS TO:
--         'NONE'
--
--TECHNICAL DESCRIPTION:
--         NEW_TITLE_CHECK gets a new case title.
--
      Begin
--
      If DATABASE_HAS_BEEN_MODIFIED = TRUE Then
         Return;
      End If;
      New_line;
      Put("Old case name was:");
      New_line;
      Put(TITLE);
      New_line;
      Put("Enter new case name or empty <CR> to keep old name:");
      New_line;
      For I in 1..80 loop
         INPUT_BUFFER(I):=' ';
      end loop;
      Get_Line(INPUT_BUFFER, MAX);
      If BLANK_CHECK(INPUT_BUFFER(1..MAX)) = FALSE Then
         TITLE := INPUT_BUFFER;
      End If;
      DATABASE_HAS_BEEN_MODIFIED := TRUE;
      Return;
--
      End NEW_TITLE_CHECK;
--
--
Procedure PARSE(BUFFER: in out string) is
--
--PURPOSE: PARSE changes the specified number of alphnumeric
--         elements in the input buffer to the corresponding
--         numeric values.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Conversion
--
--PARAMETER DESCRIPTIONS:
--IN        BUFFER = The input buffer containing alphnumeric information
--
--   Note that all of the following parameters are assumed globally visible.
--
--IN        NUMBER_OF_VARIABLES_TO_EXTRACT
--OUT       NUMBER_OF_VARIABLES_EXTRACTED
--OUT       XARRAY = The array into which the converted values are placed
--
--CALLED BY:
--         ANTENNA_CHECK
--         ENTITY_DATA
--         LOCATION_DATA
--         NODE_FETCH
--         NODE_HANDLER
--         RECEIVER_DATA
--         RECEIVER_FETCH
--         RECEIVER_HANDLER
--         TRANSMITTER_ADD
--         TRANSMITTER_DATA
--         TRANSMITTER_FETCH
--         TRANSMITTER_HANDLER
--
--CALLS TO:
--         ALPHA_TO_INTEGERIZED_ALPHA
--         ALPHA_TO_NUMERIC
--         BLANK_CHECK
--         SHIFT_LEFT
--
--TECHNICAL DESCRIPTION:
--         PARSE changes the specified number of alphabetic
--         elements in the input buffer to the corresponding
--         numeric values.  Valid delimeters between elements
--         are spaces, commas, $, or slashes.
--
      I: integer;
      MN: integer;
      MAXFND: integer;
      BUFFER2: string(1..80);
      NREP: integer;
--
      Begin
--
--INITIALIZE.
      NUMBER_OF_VARIABLES_EXTRACTED := 0;
      MAXFND := ABS(NUMBER_OF_VARIABLES_TO_EXTRACT);
      For I in 1..MAXFND Loop
         XARRAY(I) := 0.0;
         IARRAY(I) := 71270178;
      End Loop;
--
      Loop
--
--SKIP OVER BLANKS.
         If BLANK_CHECK (BUFFER) Then
            Return;
         End If;
         For I in 1..81 Loop
            If I = 81 Then
               Return;
            End If;
            If BUFFER (1) /= ' ' and BUFFER (1) /= ',' and
               BUFFER (1) /= '$' and BUFFER (1) /= '/' Then
               Exit;
            End If;
            SHIFT_LEFT (BUFFER);
         End Loop;
--
         MN := 0;
         For I in BUFFER2'RANGE Loop
             BUFFER2(I) := ' ';
         End Loop;
--
--LOAD AND SHIFT BUFFER2.
         For I in BUFFER'RANGE Loop
            If BUFFER (1) = ' ' or BUFFER (1) = ',' or
               BUFFER (1) = '$' or BUFFER (1) = '/' Then
               Exit;
            End If;
            MN := MN + 1;
            BUFFER2(MN) := BUFFER(1);
            SHIFT_LEFT (BUFFER);
         End Loop;
--
--TEST FOR ALPHA OR NUMERIC TYPE OF DATA.
         NUMBER_OF_VARIABLES_EXTRACTED := NUMBER_OF_VARIABLES_EXTRACTED + 1;
         If BUFFER2(1) in 'A'..'Z' or BUFFER2(1) in 'a'..'z' Then
  --CONVERT ALPHA DATA.
            ALPHA_TO_INTEGERIZED_ALPHA(BUFFER2,
                                       IARRAY(NUMBER_OF_VARIABLES_EXTRACTED));
         Else  --CONVERT NUMERIC DATA.
            ALPHA_TO_NUMERIC(BUFFER2, NREP,
                             XARRAY(NUMBER_OF_VARIABLES_EXTRACTED));
            If NREP > 1 Then
               For I in 2..NREP Loop
                  NUMBER_OF_VARIABLES_EXTRACTED :=
                     NUMBER_OF_VARIABLES_EXTRACTED + 1;
                  XARRAY(NUMBER_OF_VARIABLES_EXTRACTED) :=
                     XARRAY(NUMBER_OF_VARIABLES_EXTRACTED - 1);
               End Loop;
            End If;
         End If;
--
         If NUMBER_OF_VARIABLES_EXTRACTED >= MAXFND Then
            Return;
         End If;
--
      End Loop;
--
      End PARSE;
--
--
End ENTITYUTI;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--PROPCNSTS
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Types;
Package PROPAGATION_CONSTANTS is
--
-- PROPAGATION_CONSTANTS Package of PROP_LINK Version 1.0
--
-- This Package declares many variables and constants used in
-- the propagation packages package.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
--TYPES:
      Type DAY_OR_NIGHT is (DAY, NIGHT);

--VARIABLES:
      IDNT, IDNR: DAY_OR_NIGHT;
      BRNG1, BRNG2, DPATH: float;
      DISDAY, DISNIT, TERLAT, TERLON, DISTOT, TRBRNG, RTBRNG: float;
      TERP, FREQ, GNX, HTX, LNX, TAX, BW, GOT, RLL, GNR, HTR, LNR, TAR: float;
      TLAT, TLON, TALT, RLAT, RLON, RALT: float;
      TIMSEC, FREQKC, FREQMC: float;
      IATYPT, IATYPR: integer;
      NLTYP: TYPES.BAND_TYPES;
      SIGNAL, SIGNOS: float;

--RF PROPAGATION SPECIFIC CONSTANTS:
--
      --DATA TO SET COEFFICIENTS FOR PROCEDURE GRWAVE:
--
      G: array (integer range 1..48) of float
      :=(-0.99877100, -0.99353017, -0.98412458, -0.97059159, -0.95298770,
         -0.93138669, -0.90587913, -0.87657202, -0.84358826, -0.80706620,
         -0.76715903, -0.72403413, -0.67787237, -0.62886739, -0.57722472,
         -0.52316097, -0.46690290, -0.40868648, -0.34875588, -0.28736248,
         -0.22476379, -0.16122235, -0.09700469, -0.03238017,  0.03238017,
          0.09700469,  0.16122235,  0.22476379,  0.28736248,  0.34875588,
          0.40868648,  0.46690290,  0.52316097,  0.57722472,  0.62886739,
          0.67787237,  0.72403413,  0.76715903,  0.80706620,  0.84358826,
          0.87657202,  0.90587913,  0.93138669,  0.95298770,  0.97059159,
          0.98412458,  0.99353017,  0.99877100);
      W: array (integer range 1..48) of float
      :=( 0.00315334,  0.00732755,  0.01147723,  0.01557931,  0.01961616,
          0.02357076,  0.02742650,  0.03116722,  0.03477722,  0.03824135,
          0.04154508,  0.04467456,  0.04761665,  0.05035903,  0.05289018,
          0.05519950,  0.05727729,  0.05911483,  0.06070443,  0.06203942,
          0.06311419,  0.06392423,  0.06446616,  0.06473769,  0.06473769,
          0.06446616,  0.06392423,  0.06311419,  0.06203942,  0.06070443,
          0.05911483,  0.05727729,  0.05519950,  0.05289018,  0.05035903,
          0.04761665,  0.04467456,  0.04154508,  0.03824135,  0.03477722,
          0.03116722,  0.02742650,  0.02357076,  0.01961616,  0.01557931,
          0.01147723,  0.00732755,  0.00315334);
--
      --THIS SETS THE IONOSPHERIC HEIGHTS FOR REFLECTION CALCULATIONS:
      HP: array (integer range 1..20) of float
      :=(5.0,  10.0, 15.0, 20.0, 25.0, 30.0, 35.0, 40.0, 45.0, 50.0,
         55.0, 60.0, 65.0, 70.0, 75.0, 80.0, 85.0, 90.0, 95.0, 100.0);
      PTS: array (integer range 1..5) of float
      :=(0.5, 0.125, 0.3, 0.7, 0.875);
      NHOP: integer :=5;
--
      --THESE VARIABLES APPEAR IN SEVERAL OF THE RF PROCEDURES:
--
      NYEAR: integer := 1977;
      NDAY: integer := 1;
      NSEC: integer := 0;
      T90: float := 183.0;
      T0: float := 300.0;
      ISD: integer := 0;
--
      --THESE VARIABLES ARE USED IN MF/HF PROPAGATION:
           --THE 1ST COLUMN OF IHFMD IS THE  #E HOPS.
           --THE 2ND COLUMN OF IHMFD IS THE  #F HOPS.
--
      IHFMD: array (integer range 1..20, integer range 1..9) of integer
      :=((1,0,0,0,0,0,0,0,0), (2,0,0,0,0,0,0,0,0),
         (3,0,0,0,0,0,0,0,0), (4,0,0,0,0,0,0,0,0),
         (5,0,0,0,0,0,0,0,0), (0,1,0,0,0,0,0,0,0),
         (0,2,0,0,0,0,0,0,0), (0,3,0,0,0,0,0,0,0),
         (0,4,0,0,0,0,0,0,0), (0,5,0,0,0,0,0,0,0),
         (1,1,0,0,0,0,0,0,0), (2,1,0,0,0,0,0,0,0),
         (3,1,0,0,0,0,0,0,0), (4,1,0,0,0,0,0,0,0),
         (1,2,0,0,0,0,0,0,0), (2,2,0,0,0,0,0,0,0),
         (3,2,0,0,0,0,0,0,0), (1,3,0,0,0,0,0,0,0),
         (2,3,0,0,0,0,0,0,0), (1,4,0,0,0,0,0,0,0));
--
          -- IJTMD DETERMINES THE MODE NUMBER FROM I+1, J+1.
          -- E.G. FOR 1E/0F, LOCATION 2,1 SAYS THE MODE NUMBER
          -- IS 1.  FOR 2E/3F, LOCATION 3,4 SAYS THE MODE
          -- NUMBER IS 19.
--
      IJTMD: array (integer range 1..6, integer range 1..6) of integer
      :=((0,  6,  7,  8,  9, 10),
         (1, 11, 15, 18, 20,  0),
         (2, 12, 16, 19,  0,  0),
         (3, 13, 17,  0,  0,  0),
         (4, 14,  0,  0,  0,  0),
         (5, 0,  0,  0,  0,  0));
--
--
end PROPAGATION_CONSTANTS;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--COMPLEX
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with MATHLIB; use MATHLIB, NUMERIC_PRIMITIVES, TRIG_FUNCTIONS, CORE_FUNCTIONS;
package COMPLEX_NUMBERS is

   type COMPLEX is private;
   function "+"(X,Y: COMPLEX) return COMPLEX;
   function "+"(X: float; Y: COMPLEX) return COMPLEX;
   function "+"(X: COMPLEX; Y: float) return COMPLEX;
   function "-"(X,Y: COMPLEX) return COMPLEX;
   function "-"(X: float; Y: COMPLEX) return COMPLEX;
   function "-"(X: COMPLEX; Y: float) return COMPLEX;
   function "-"(X: COMPLEX) return COMPLEX;
   function "*"(X,Y: COMPLEX) return COMPLEX;
   function "*"(X: float; Y: COMPLEX) return COMPLEX;
   function "*"(X: COMPLEX; Y: float) return COMPLEX;
   function "/"(X,Y: COMPLEX) return COMPLEX;
   function "/"(X: float; Y: COMPLEX) return COMPLEX;
   function "/"(X: COMPLEX; Y: Float) return COMPLEX;
   function CMPLX(X: Float; Y: Float) return COMPLEX;
   function AREAL(C: COMPLEX) return FLOAT;
   function AIMAG(C: COMPLEX) return FLOAT;
   function CEXP (C: COMPLEX) return COMPLEX;
   function CLOG (C: COMPLEX) return COMPLEX;
   function CSQRT(C: COMPLEX) return COMPLEX;
   function CABS (C: COMPLEX) return float;
   function "**" (C: COMPLEX; N: integer) return COMPLEX;
   function "**" (C: COMPLEX; W: float) return COMPLEX;
   function CONJG(C: COMPLEX) return COMPLEX;
private
   type COMPLEX is
      record
         RL, IM: float:=0.0;
      end record;
   I: constant COMPLEX:= (0.0,1.0);
   R, THETA: float;
   procedure CONVERT (X,Y: in float; R,THETA: out float);
end COMPLEX_NUMBERS;

package body COMPLEX_NUMBERS is
--
-- COMPLEX_NUMBERS package of PROPLINK Version 1.0, September 19, 1985.
--
-- This COMPLEX_NUMBERS package contains many complex number functions,
-- the operators for complex numbers as well as facilities
-- for creating and separating complex numbers.  A private type
-- is used to control access to the real and imaginary components of the
-- numbers outside the package.  CEXP, CSQRT, CABS, "**", and CLOG
-- were based on "Collected Algorithms of the CACM" (algorithms 46, 312,
-- 312, 106, and 243 respectively) and tested against
-- their FORTRAN 77 counterparts.
--
-- The package was written by Bruce Perry of IWG Corp.,
-- 975 Hornblend St., Suite C, San Diego, CA 92126.
-- Proplink has been developed for the Department
-- of Defense under contract N66001-85-C-0042 by IWG Corp.
--
--
   function "+"(X,Y: COMPLEX) return COMPLEX is
   begin
      return (X.RL+Y.RL, X.IM+Y.IM);
   end "+";

   function "+"(X: float; Y: COMPLEX) return COMPLEX is
   begin
      return (X+Y.RL, Y.IM);
   end "+";

   function "+"(X: COMPLEX; Y: float) return COMPLEX is
   begin
      return (X.RL+Y, X.IM);
   end "+";

   function "-"(X,Y: COMPLEX) return COMPLEX is
   begin
      return (X.RL-Y.RL,X.IM-Y.IM);
   end "-";

   function "-"(X: float; Y: COMPLEX) return COMPLEX is
   begin
      return (X-Y.RL,-Y.IM);
   end "-";

   function "-"(X: COMPLEX; Y:float) return COMPLEX is
   begin
      return (X.RL-Y,X.IM);
   end "-";

   function "-"(X: COMPLEX) return COMPLEX is
   begin
      return (-X.RL,-X.IM);
   end "-";

   function "*"(X,Y: COMPLEX) return COMPLEX is
   begin
      return (X.RL*Y.RL-X.IM*Y.IM,X.RL*Y.IM+X.IM*Y.RL);
   end "*";

   function "*"(X: float; Y:COMPLEX) return COMPLEX is
   begin
      return (X*Y.RL,X*Y.IM);
   end "*";

   function "*"(X: COMPLEX; Y:float) return COMPLEX is
   begin
      return (X.RL*Y,X.IM*Y);
   end "*";

   function "/"(X,Y: COMPLEX) return COMPLEX is
      D:float:=Y.RL**2+Y.IM**2;
      trl, tim: float;
   begin
      trl:=(X.RL*Y.RL+X.IM*Y.IM)/D;
      tim:=(X.IM*Y.RL-X.RL*Y.IM)/D;
      return (trl,tim);
   end "/";

   function "/"(X: float; Y:COMPLEX) return COMPLEX is
      D:float:=Y.RL**2+Y.IM**2;
      trl, tim: float;
   begin
      trl:=(X*Y.RL)/D;
      tim:=(-X*Y.IM)/D;
      return (trl,tim);
   end "/";

   function "/"(X:COMPLEX; Y:float) return COMPLEX is
   begin
      return (X.RL/Y, X.IM/Y);
   end "/";

   function CMPLX(X,Y: Float) return COMPLEX is
   begin
      return (X,Y);
   end CMPLX;

   function AREAL(C: COMPLEX) return FLOAT is
   begin
      return (C.RL);
   end AREAL;

   function AIMAG(C:COMPLEX) return FLOAT is
   begin
      return (C.IM);
   end AIMAG;

   function CEXP(C:COMPLEX) return COMPLEX is
      R: float;
   begin
      R := exp(C.RL);
      return (R*cos(C.IM),R*sin(C.IM));
   end CEXP;

   procedure CONVERT (X,Y: in float; R,THETA: out float) is
   begin
      THETA:=ATAN(Y/X);
      R:=SQRT(X**2+Y**2);
   end CONVERT;

   function CLOG(C:COMPLEX) return COMPLEX is
      E, F, G, H, S: float;
   begin
      E := 0.5*C.RL;
      F := 0.5*C.IM;
      if ABS(E)<0.5 and ABS(F)<0.5 then
         G := ABS(2.0*C.RL)+ABS(2.0*C.IM);
         H := 8.0*(C.RL/G)*C.RL+8.0*(C.IM/G)*C.IM;
         G := 0.5*(LOG(G)+LOG(H))-1.03972077084;
      else
         G := ABS(0.5*E)+ABS(0.5*F);
         H := 0.5*(E/G)*E+0.5*(F/G)*F;
         G := 0.5*(LOG(G)+LOG(H))+1.03972077084;
      end if;
      if C.RL /= 0.0 and ABS(e)>=ABS(F) then
         if C.RL >= 0.0 then
            S := 0.0;
         elsif C.IM >= 0.0 then
            S := 3.14159265359;
         else
            S := -3.14159265359;
         end if;
         H := ATAN(C.IM/C.RL)+S;
      else
         H := -ATAN(C.RL/C.IM)+1.57079632679*SIGN(1.0,C.IM);
      end if;
      return (G, H);
   end CLOG;

   function CSQRT(C: COMPLEX) return COMPLEX is
     A, B, X, Y: float;
   begin
      X := C.RL; Y := C.IM;
      if X=0.0 and Y=0.0 then
         A := 0.0 ; B := 0.0;
      else
         A := SQRT ((ABS(X)+CABS(C))*0.5);
         if X>=0.0 then
            B := Y/(A+A);
         else
            if Y<0.0 then
               B := -A;
            else
               B := A;
            end if;
            A := Y/(B+B);
         end if;
      end if;
      return (A,B);
   end CSQRT;

   function CABS(C:COMPLEX) return float is
      X, Y, R: float;
   begin
      X := ABS(C.RL); Y := ABS(C.IM);
      if X = 0.0 then
         R := Y;
      elsif Y = 0.0 then
         R := X;
      else
         if X > Y then
            R := X*SQRT(1.0+(Y/X)**2);
         else
            R := Y*SQRT(1.0+(X/Y)**2);
         end if;
      end if;
      return R;
   end;

   function "**" (C: COMPLEX; N: integer) return COMPLEX is
      X, Y, W, A, B, PHI, THETA: float;
   begin
      X := C.RL; Y := C.IM; W := float(N);
      A := 0.0; B := 0.0;
      if not (X=0.0 and Y=0.0) then
         if X>0.0 then
            PHI := ATAN(Y/X);
         elsif X<0.0 then
            if Y>=0.0 then
               THETA := 3.1415927;
            else
               THETA := -3.1415927;
            end if;
            PHI := ATAN(Y/X)+THETA;
         else
            if Y>0.0 then
               PHI := 1.5707963;
            else
               PHI := -1.5707963;
            end if;
         end if;
         R := SQRT(X*X+Y*Y);
         R := EXP(W*LOG(R));
         A := R * COS(W*PHI);
         B := R * SIN(W*PHI);
      end if;
      return (A,B);
   end "**";

   function "**" (C: COMPLEX; W: float) return COMPLEX is
      X, Y, A, B, PHI, THETA: float;
   begin
      X := C.RL; Y := C.IM;
      A := 0.0; B := 0.0;
      if not (X=0.0 and Y=0.0) then
         if X>0.0 then
            PHI := ATAN(Y/X);
         elsif X<0.0 then
            if Y>=0.0 then
               THETA := 3.1415927;
            else
               THETA := -3.1415927;
            end if;
            PHI := ATAN(Y/X)+THETA;
         else
            if Y>0.0 then
               PHI := 1.5707963;
            else
               PHI := -1.5707963;
            end if;
         end if;
         R := SQRT(X*X+Y*Y);
         R := EXP(W*LOG(R));
         A := R * COS(W*PHI);
         B := R * SIN(W*PHI);
      end if;
      return (A,B);
   end "**";

   function CONJG(C: COMPLEX) return COMPLEX is
   begin
   return (C.RL,-C.IM);
   end CONJG;

end COMPLEX_NUMBERS;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--NODELOC
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Types; use Types;
With Constants; use Constants;
With Constant2; use Constant2;
With Constant3; use Constant3;
With Mathlib; use Mathlib, numeric_primitives,
                           core_functions, trig_functions;
Package NODELOC is
--
--
      Procedure LOCEAN (TSP: in Float;
                        RATIO: in Float;
                        ECCEN: in Float;
                        IERR: out integer;
                        EANOM: out float);
      Procedure LOCGRB (XLA1: in float;
                        XLO1: in float;
                        XLA2: in float;
                        XLO2: in float;
                        BRNG1: out float;
                        BRNG2: out float;
                        DISTANCE: out float);
      Procedure LOCNEW (STALA: in float;
                        STALO: in float;
                        BRNGD: in float;
                        DR: in float;
                        XLA: out float;
                        XLO: out float);
      Procedure LOCSAT (EPH: in F_ARRAY;
                        SATLAT: out float;
                        SATLON: out float;
                        SATALT: out float);
      Procedure LOCTAN (ECCEN: in float;
                        EANOM: in float;
                        TANOM: out float);
      Procedure LOCUPD (NUM: in integer;
                        YLAT: out float;
                        YLON: out float;
                        YALT: out float);
--
--
End NODELOC;
--
Package body NODELOC is
--
-- NODELOC Package of PROP_LINK Version 1.0,  February 18, 1985.
--
-- This NODELOC Package contains all of the procedures that
-- are used to compute node locations.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
--
--
      Procedure LOCEAN (TSP: in float;
                        RATIO: in float;
                        ECCEN: in float;
                        IERR: out integer;
                        EANOM: out float) is
--
--#PURPOSE: LOCEAN calculates the eccentric anomaly of an orbit and
--          determines whether of not it converges.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Orbit Calculation.
--
--#PARAMETER DESCRIPTIONS:
--IN        TSP    = time since perigee (mins).
--IN        RATIO  = period of orbit (mins) divided by 2*PI.
--IN        ECCEN  = eccentricity of orbit ellipse.
--OUT       IERR   = index for convergence of eccentric anomaly
--                    = 0, converges,
--                    = 1, does not converge.
--          EANOM  = eccentric anomaly (radians).
--
--#CALLED BY:
--          LOCSAT
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          This routine first computes the ratio, in modulo two PI,
--          of the time since perigee (TSP) to the period of orbit
--          (divided by two PI).  If this ratio is 0 or two PI, then
--          the eccentricity anomaly converges and EANOM is returned as
--          the ratio in modulo two PI.  Otherwise, a convergence test
--          is set up.
--
      DELTAE: float;
      AANOM: float;
      I: integer;
--
      Begin
--
--COMPUTE MEAN ANOMALY.
      IERR := 0;
      AANOM := TSP/RATIO;
      AANOM := AMOD (AANOM, TWOPI);
--
--ITERATE TO COMPUTE TRUE ANOMALY.
      EANOM := AANOM;
      If SIN(EANOM) = 0.0 Then
         Return;
      End If;
      For I in 1..100 Loop
         DELTAE := (AANOM - EANOM + ECCEN*SIN(EANOM)) /
                   (1.0 - ECCEN*COS(EANOM));
         EANOM := EANOM + DELTAE;
         If DELTAE/EANOM < 1.0E-8 Then
            Return;
         End If;
      End Loop;
--
--NO CONVERGENCE.
      IERR := 1;
      Return;
--
      End LOCEAN;
--
--
      Procedure LOCGRB (XLA1: in float;
                        XLO1: in float;
                        XLA2: in float;
                        XLO2: in float;
                        BRNG1: out float;
                        BRNG2: out float;
                        DISTANCE: out float) is
--
--#PURPOSE: Given the latitude and longitude of two points, LOCGRB
--          determines the ground range between them and the bearing
--          from each point to the other.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Spherical Trigonometry.
--
--#PARAMETER DESCRIPTIONS:
--IN        XLA1   = latitude (degs) of point 1 (+north).
--IN        XLO1   = longitude (degs) of point 1 (+east).
--IN        XLA2   = latitude (degs) of point 2 (+north).
--IN        XLO2   = longitude (degs) of point 2 (+east).
--OUT       BRNG1  = bearing (degs) of point 2 from point 1
--                   (clockwise from north).
--OUT       BRNG2  = bearing (degs) of point 1 from point 2
--                   (clockwise from north).
--OUT       DISTANCE  = ground range (km) between points 1 and 2.
--
--#CALLED BY:
--          ALDAY
--          ALNITE
--          IONCAL
--          LOCUPD
--          NOISY
--          RF_PROPAGATION_HANDLER
--          SIGLNK
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--
--     LOCGRB computes the great circle range and bearings between two
--     points that are specified in terms of their latitude and longitude
--     coordinates. The procedure employed is one of spherical trigo-
--     nometry using two basic formulae:
--
--     DISTANCE = R*ACOS( SIN(LAT1)*SIN(LAT2) + COS(LAT1)*COS(LAT2)*COS(D))
--
--     Where:
--            DISTANCE  = Great circle distance between points in kilometers
--            R      = Radius of the earth := 6364.0 kilometers
--            LAT1   = Latitude of point 1 in radians
--            LAT2   = Latitude of point 2 in radians
--            D      = Difference in longitude between points in radians
--
--     And,
--            BRNG   = ACOS((SIN(LAT2 - SIN(LAT1)*COS(PHI)) /
--                     COS(LAT1)*SIN(PHI))
--
--     Where:
--            BRNG   = Bearing of point 2 from point 1 in radians
--            PHI    = Central earth angle in radians = DISTANCE/R
--
--     ***** IT SHOULD BE NOTED THAT ALL BEARINGS BECOME COUNTER
--           CLOCKWISE IF LONGITUDES ARE IN DEGREES + WEST        *****
--
--
      YLO1, YLO2, DIF1, DIF2, DL: float;
      KK: integer;
      A, B, AB, BA, AA, BB, YY, A1, B1: float;
      CSA, SNA, CSB, SNB, X, Y, XAR, YAR: float;
      DEL: constant float := 3.490659E-2;
      EPS: constant float := 8.726646E-3;
--
      Begin
--
      YLO1 := XLO1*RADIANS_PER_DEGREE;
      If XLO1 < 0.0 Then
         YLO1 := TWOPI + YLO1;
      End If;
      YLO2 := XLO2*RADIANS_PER_DEGREE;
      If  XLO2 < 0.0 Then
         YLO2 := TWOPI + YLO2;
      End If;
--
      DIF1 := YLO2 - YLO1;
      DIF2 := -DIF1;
      If DIF1 > 0.0 Then
         If DIF1 > PI Then
            DL := TWOPI - DIF1;
            KK := 0;
         Else
            DL := DIF1;
            KK := 1;
         End If;
      Else
         If DIF2 < PI Then
            DL := DIF2;
            KK := 0;
         Else
            DL := TWOPI - DIF2;
            KK := 1;
         End If;
      End If;
--
      B := HALFPI - XLA1*RADIANS_PER_DEGREE;
      A := HALFPI - XLA2*RADIANS_PER_DEGREE;
      If ABS(A - HALFPI) <= EPS and ABS(B - HALFPI) <= EPS Then
         DISTANCE := DL;
         AA := HALFPI;
         BB := HALFPI;
         Goto ADJUST_UNITS;
      End If;
      AB := A - B;
      BA := B - A;
      If DL <= EPS  Then
         If BA < 0.0 and AB > DEL Then
            BB := 0.0;
            AA := PI;
            DISTANCE := AB;
            Goto ADJUST_UNITS;
         End If;
         If BA > DEL Then
            BB := PI;
            AA := 0.0;
            DISTANCE := BA;
            Goto ADJUST_UNITS;
         End If;
      Else
         If B <= EPS and A <= EPS Then
            DISTANCE := AMAX1( (A*A + B*B - 2.0*A*B*COS(DL)), 0.0);
            DISTANCE := SQRT(DISTANCE);
            YY    := A/DISTANCE*SIN(DL);
            If ABS(YY) > RADIANS_PER_DEGREE Then
               AA := HALFPI;
               BB := HALFPI - DL;
               Goto ADJUST_UNITS;
            End If;
            A1 := B*B + DISTANCE*DISTANCE - A*A;
            If A1 > 0.0 Then
               AA := PI - ASIN(YY);
            Else
               AA := ASIN(YY);
            End If;
            BB := PI - AA + DL;
            Goto ADJUST_UNITS;
         End If;
      End If;
--
      CSA := COS(A);
      SNA := SIN(A);
      CSB := COS(B);
      SNB := SIN(B);
      X := CSA*CSB + SNA*SNB*COS(DL);
      X := SIGN (AMIN1 (ABS(X), 1.0), X);
      A1 := CSA - X*CSB;
      B1 := CSB - X*CSA;
      DISTANCE := ACOS(X);
      If ABS(DISTANCE - PI) <= EPS Then
         AA := 0.001*RADIANS_PER_DEGREE;
         BB := AA;
         Goto ADJUST_UNITS;
      End If;
      Y := 0.0;
      If DISTANCE /= 0.0 Then
         Y := SIN(DL)/SIN(DISTANCE);
      End If;
--
      XAR := Y*SNA;
      If ABS(XAR) >= 0.9999 Then
         AA := HALFPI;
      Else
         AA := ASIN(Y*SNA);
         If A1 <= 0.0 Then
            AA := PI - AA;
         End If;
      End If;
--
      YAR := Y*SNB;
      If ABS(YAR) >= 0.9999 Then
         BB := HALFPI;
      Else
         BB := ASIN(Y*SNB);
         If B1 <= 0.0 Then
            BB := PI - BB;
         End If;
      End If;
--
<<ADJUST_UNITS>>
      If KK <= 0 Then
         BRNG1 := TWOPI - AA;
         BRNG2 := BB;
      Else
         BRNG2 := TWOPI - BB;
         BRNG1 := AA;
      End If;
--
      DISTANCE := DISTANCE*RADIUS_OF_EARTH_IN_KM;
      BRNG1 := BRNG1*DEGREES_PER_RADIAN;
      BRNG2 := BRNG2*DEGREES_PER_RADIAN;
--
      Return;
--
      End LOCGRB;
--
--
      Procedure LOCNEW (STALA: in float;
                        STALO: in float;
                        BRNGD: in float;
                        DR: in float;
                        XLA: out float;
                        XLO: out float) is
--
--#PURPOSE: LOCNEW calculates a new position (latitude and longitude)
--          given a starting position, a bearing and a ground range.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Spherical Trigonometry.
--
--#PARAMETER DESCRIPTIONS:
--IN        STALA  = latitude of starting point (degs, + north).
--IN        STALO  = longitude of starting point (degs, + east).
--IN        BRNGD  = bearing of starting point (degs, measured
--                   clockwise from north to the point).
--IN        DR     = ground range between points (km).
--OUT       XLA    = latitude of new point (degs, + north).
--OUT       XLO    = longitude of new point (degs, + east).
--
--#CALLED BY:
--          ALDAY
--          ALNITE
--          DNTR
--          ELF
--          HFNACP
--          HFNORM
--          HIGHTF
--          IONDAT
--          LFPROP
--          LOCUPD
--          MMMUF
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--     LOCNEW computes the the latitude and longitude of a point given
--     the latitude and longitude of an initial point as well as the
--     bearing of the second point from the first using spherical trigo-
--     nometric formulae.
--
--     ***** IT SHOULD BE NOTED THAT THE BEARING IS COUNTER
--           CLOCKWISE IF THE LONGITUDES ARE IN DEGREES + WEST *****
--
      XLA1, XLA2, XLO1, XLO2, BRNG: float;
      BASE, THETA1, A1, A2: float;
      TERM1, TERM2, TERM3, TERM4, TERM5: float;
      TEST, RATIO, DLON: float;
      KK: integer;
--
      Begin
--
      XLA1 := STALA*RADIANS_PER_DEGREE;
      XLO1 := STALO*RADIANS_PER_DEGREE;
      BRNG := BRNGD*RADIANS_PER_DEGREE;
      If XLO1 < 0.0 Then
         XLO1 := XLO1 + TWOPI;
      End If;
      KK := 1;
      If BRNG <= PI Then
         KK := 0;
      End If;
--
      BASE := DR/RADIUS_OF_EARTH_IN_KM;
      THETA1 := AMIN1 (BRNG, TWOPI - BRNG);
      A1 := HALFPI - XLA1;
--
      TERM1 := COS(A1);
      TERM2 := COS(BASE);
      TERM3 := SIN(A1);
      TERM4 := SIN(BASE);
      TERM5 := COS(THETA1);
      A2 := ACOS (TERM1*TERM2 + TERM3*TERM4*TERM5);
--
      XLA2 := HALFPI - A2;
      TEST := COS(BASE) - COS(A1)*COS(A2);
      RATIO := 0.0;
      If A2 /= 0.0 Then
         RATIO := TERM4*SIN(THETA1)/SIN(A2);
      End If;
      DLON := ASIN( SIGN( AMIN1( ABS(RATIO), 1.0), RATIO));
      If TEST <= 0.0 Then
         DLON := PI - DLON;
      End If;
--
      XLO2 := AMOD (XLO1 + TWOPI - DLON, TWOPI);
      If KK = 0 Then
         XLO2 := AMOD (XLO1 + DLON, TWOPI);
      End If;
      XLO := XLO2*DEGREES_PER_RADIAN;
      If XLO2 > PI Then
         XLO := (XLO2 - TWOPI)*DEGREES_PER_RADIAN;
      End If;
      XLA := XLA2*DEGREES_PER_RADIAN;
--
      Return;
--
      End LOCNEW;
--
--
      Procedure LOCSAT (EPH: in F_ARRAY;
                        SATLAT: out float;
                        SATLON: out float;
                        SATALT: out float) is
--
--#PURPOSE: LOCSAT computes a satellite's position based on the ephemeris data.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Orbit Calculation.
--
--#PARAMETER DESCRIPTIONS:
--IN        EPH    = 6-element input ephemerous data array, where
--                   1,  semi-major axis of the ellipse (km),
--                   2,  eccentricity of the ellipse,
--                   3,  inclination angle (deg),
--                   4,  argument of perigee (deg),
--                   5,  longitude of the ascending node (deg),
--                   6,  time since perigee (min).
--OUT       SATLAT = satellite latitude (deg north),
--OUT       SATLON = satellite longitude (deg east),
--OUT       SATALT = satellite altitude (km).
--
--#CALLED BY:
--          LOCUPD
--
--#CALLS TO:
--          LOCEAN
--          LOCTAN
--
--#TECHNICAL DESCRIPTION:
--          LOCSAT computes a satellite's position based on
--          the ephemeris data.  Standard formulae based on Kepler
--          orbit state vectors are employed in the computation.
--
      XMU: constant float:= 0.0055674;
      OMEGAE: constant float:= 4.375269E-3;
      SMAJAX, ECCEN, ANGINC, ARGPER, ANLONG, TP: float;
      RATIO, SANGIN, CANGIN, TSP: float;
      RTOSAT, CENTRL, SCENT, CCENT, DSLON: float;
      EANOM, TANOM: float;
      IERR: integer;
--
      Begin
--
--CONVERT INPUT EPHEMERIDES TO STATE VECTOR FORMAT.
      SMAJAX := EPH(1)/RADIUS_OF_EARTH_IN_KM;
      ECCEN  := EPH(2);
      ANGINC := EPH(3)*RADIANS_PER_DEGREE;
      ARGPER := EPH(4)*RADIANS_PER_DEGREE;
      ANLONG := EPH(5)*RADIANS_PER_DEGREE;
      TP     := EPH(6);
--
      RATIO  := SMAJAX*SQRT(SMAJAX/XMU);
      SANGIN := SIN(ANGINC);
      CANGIN := COS(ANGINC);
--
--TIME SINCE PERIGEE.
      TSP := TP + CURRENT_TIME;
--
--CALCULATE ECCENTRIC ANOMALY.
      LOCEAN (TSP, RATIO, ECCEN, IERR, EANOM);
--
--ALTITUDE OF SATELLITE.
      RTOSAT := SMAJAX*(1.0 - ECCEN*COS(EANOM));
      SATALT := RADIUS_OF_EARTH_IN_KM*(RTOSAT - 1.0);
--
--TRUE ANOMALY.
      LOCTAN (ECCEN, EANOM, TANOM);
--
--ANGLE TO SATELLITE FROM ASCENDING NODE.
      CENTRL := ARGPER + TANOM;
      CENTRL := AMOD (CENTRL, TWOPI);
--
--DETERMINE GEOCENTRIC LATITUDE OF SATELLITE.
      SCENT := SIN(CENTRL);
      CCENT := COS(CENTRL);
      SATLAT := ASIN (SANGIN*SCENT)*DEGREES_PER_RADIAN;
--
--DIFFERENCE IN LONGITUDE FROM ASCENDING NODE.
      DSLON := ATAN2 (SCENT*CANGIN, CCENT);
--
--DETERMINE LONGITUDE OF SATELLITE.
      SATLON := ANLONG + DSLON - OMEGAE*CURRENT_TIME;
      SATLON := AMOD (SATLON, TWOPI);
      If SATLON > PI Then
         SATLON := SATLON - TWOPI;
      End If;
      SATLON := SATLON*DEGREES_PER_RADIAN;
      If SATLON <= -180.0 Then
         SATLON := SATLON + 360.0;
      End If;
      If SATLON > 180.0 Then
         SATLON := 360.0 - SATLON;
      End If;
--
      Return;
--
      End LOCSAT;
--
--
      Procedure LOCTAN (ECCEN: in float;
                        EANOM: in float;
                        TANOM: out float) is
--
--#PURPOSE: LOCTAN calculates the true anomaly of an orbit as a
--          function of the eccentricity of the orbit and the
--          eccentric anomaly.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Orbit Calculation.
--
--#PARAMETER DESCRIPTIONS:
--IN        ECCEN  := the eccentricity of orbit ellipse.
--IN        EANOM  := the eccentric anomaly (radians).
--OUT       TANOM  := the true anomaly (radians).
--
--#CALLED BY:
--          LOCSAT
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          LOCTAN calculates the true anomaly of an orbit as a
--          function of the eccentricity of the orbit and the
--          eccentric anomaly.  Standard formulae based on Kepler
--          orbit state vectors are employed in the computation.
--
      EAN, EA2, EAT, TANEA2, COSEA2, ARG1: float;
--
      Begin
--
      EAN := AMOD (EANOM, TWOPI);
      EA2 := EAN*0.5;
      EAT := ABS (ABS(EA2) - HALFPI);
      If EAT >= 0.001 Then
         TANEA2 := 0.0;
         COSEA2 := COS(EA2);
         If COSEA2 /= 0.0 Then
            TANEA2 := SIN(EA2)/COSEA2;
         End If;
         ARG1 := SQRT ((1.0 + ECCEN)/(1.0 - ECCEN))*TANEA2;
         TANOM := 2.0*ATAN (ARG1);
      Else
         TANOM := SIGN (PI, EAN);
      End If;
--
      TANOM := TANOM + SIGN (PI, 1.0) - SIGN (PI, TANOM);
--
      Return;
--
      End LOCTAN;
--
--
      Procedure LOCUPD (NUM: in integer;
                        YLAT: out float;
                        YLON: out float;
                        YALT: out float) is
--
--#PURPOSE: LOCUPD computes a node's location at a given time based on
--          the type of node (fixed, moving, or satellite) and the
--          associated position generation data.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Geometry.
--
--#PARAMETER DESCRIPTIONS:
--IN        NUM    = position of the node in the data structure.
--OUT       YLAT   = node latitude (deg. north).
--OUT       YLON   = node longitude (deg. east).
--OUT       YALT   = node altitude (km).
--
--#CALLED BY:
--          RF_PROPAGATION_HANDLER
--
--#CALLS TO:
--          LOCGRB
--          LOCNEW
--          LOCSAT
--
--#TECHNICAL DESCRIPTION:
--
--     LOCUPD updates a node's location based on its type in terms of fixed,
--     moving or satellite. The procedure followed is to first determine
--     whether the node is fixed, moving or a satellite type.  If fixed,
--     nothing is done to update the location.  If moving or satellite, an
--     interpolated position update is performed prior to returning to the
--     calling routine.
--
      XTIM, XLAT, XLON, XALT, YTIM: float;
      ZTIM, ZLAT, ZLON, ZALT: float;
      FRAC: float;
      EPH: F_ARRAY(1..6);
      BRNG1, BRNG2, DISTANCE: float;
--
      Begin
--
      Case ITYSND(NUM) is
--FIXED.
         When FIXED =>
            YTIM := XPSSND(1,1,NUM);
            YLAT := XPSSND(2,1,NUM);
            YLON := XPSSND(3,1,NUM);
            YALT := XPSSND(4,1,NUM);
--
--MOVING.
         When MOVING =>
            XTIM := XPSSND(1,1,NUM);
            XLAT := XPSSND(2,1,NUM);
            XLON := XPSSND(3,1,NUM);
            XALT := XPSSND(4,1,NUM);
            If NLSND(NUM) < 2 Then
               YTIM := XTIM;
               YLAT := XLAT;
               YLON := XLON;
               YALT := XALT;
            Else
               For I in 2..NLSND(NUM) Loop
                  ZTIM := XTIM;
                  ZLAT := XLAT;
                  ZLON := XLON;
                  ZALT := XALT;
                  XTIM := XPSSND(1,I,NUM);
                  XLAT := XPSSND(2,I,NUM);
                  XLON := XPSSND(3,I,NUM);
                  XALT := XPSSND(4,I,NUM);
                  Exit When XTIM > CURRENT_TIME;
                  IF XTIM = CURRENT_TIME Then
                     YTIM := XTIM;
                     YLAT := XLAT;
                     YLON := XLON;
                     YALT := XALT;
                     Return;
                  End If;
               End Loop;
        --
        --INTERPOLATION.
               FRAC := (CURRENT_TIME - ZTIM)/(XTIM - ZTIM);
        --
        --DETERMINE GROUND RANGE BETWEEN POINTS.
               LOCGRB (ZLAT, ZLON, XLAT, XLON, BRNG1, BRNG2, DISTANCE);
               DISTANCE := DISTANCE*FRAC;
        --
        --COMPUTE NEW LOCATION.
               LOCNEW (ZLAT, ZLON, BRNG1, DISTANCE, YLAT, YLON);
               YALT := ZALT + (XALT - ZALT)*FRAC;
            End If;
--
--SATELLITE.
         When SATELLITE =>
            For I in 1..6 Loop
               EPH(I) := EPHSND(I,NUM);
            End Loop;
            LOCSAT (EPH, YLAT, YLON, YALT);
--
         When others =>
            null;
         End Case;
         Return;
--
      End LOCUPD;
--
--
End NODELOC;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--FARKLER
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package FARKLER is
      FARKLE: array (integer range 1..5,
                     integer range 1..73,
                     integer range 1..2) of float :=
       ((( 80.60,  129.00),
       (   80.20,  130.50),
       (   79.90,  131.80),
       (   79.60,  133.30),
       (   79.20,  135.00),
       (   79.00,  136.90),
       (   78.70,  138.70),
       (   78.50,  140.60),
       (   78.20,  142.60),
       (   78.00,  144.90),
       (   77.90,  147.00),
       (   77.70,  149.20),
       (   77.50,  151.50),
       (   77.40,  153.80),
       (   77.30,  156.20),
       (   77.20,  158.60),
       (   77.10,  161.00),
       (   77.00,  163.60),
       (   77.00,  166.10),
       (   76.90,  168.60),
       (   76.90,  171.10),
       (   76.90,  173.60),
       (   76.90,  176.00),
       (   76.90,  178.50),
       (   76.90,  180.90),
       (   76.90,  183.40),
       (   77.00,  185.70),
       (   77.10,  188.00),
       (   77.20,  190.20),
       (   77.30,  192.40),
       (   77.40,  194.50),
       (   77.60,  196.60),
       (   77.70,  198.60),
       (   77.90,  200.60),
       (   78.20,  202.40),
       (   78.40,  204.20),
       (   78.70,  205.80),
       (   79.00,  207.40),
       (   79.40,  208.90),
       (   79.70,  210.20),
       (   80.10,  211.30),
       (   80.50,  212.40),
       (   80.90,  213.40),
       (   81.40,  214.20),
       (   81.90,  214.70),
       (   82.30,  214.80),
       (   82.80,  214.80),
       (   83.30,  214.50),
       (   83.90,  213.50),
       (   84.40,  212.10),
       (   84.90,  210.00),
       (   85.30,  207.20),
       (   85.80,  203.40),
       (   86.20,  196.50),
       (   86.50,  189.60),
       (   86.70,  181.40),
       (   86.80,  172.30),
       (   86.80,  162.90),
       (   86.60,  153.90),
       (   86.30,  146.00),
       (   86.00,  139.40),
       (   85.60,  134.40),
       (   85.10,  130.70),
       (   84.60,  128.10),
       (   84.20,  126.40),
       (   83.70,  126.30),
       (   83.20,  125.50),
       (   82.70,  125.20),
       (   82.30,  125.40),
       (   81.80,  126.40),
       (   81.40,  127.00),
       (   81.00,  127.90),
       (   80.60,  129.00)),
       ((  41.60,   77.50),
       (   40.90,   81.50),
       (   40.40,   85.60),
       (   40.00,   89.70),
       (   39.70,   93.80),
       (   39.50,   98.00),
       (   39.30,  102.30),
       (   39.30,  106.70),
       (   39.40,  111.20),
       (   39.50,  115.80),
       (   39.60,  120.50),
       (   39.70,  125.30),
       (   39.80,  130.10),
       (   39.90,  135.10),
       (   40.00,  140.00),
       (   40.00,  145.00),
       (   40.00,  150.00),
       (   40.00,  155.10),
       (   40.00,  160.10),
       (   40.00,  165.20),
       (   39.90,  170.30),
       (   39.90,  175.40),
       (   39.70,  180.60),
       (   39.50,  185.70),
       (   39.20,  190.80),
       (   38.90,  195.70),
       (   38.50,  200.60),
       (   38.20,  205.40),
       (   37.80,  210.00),
       (   37.50,  214.40),
       (   37.30,  218.70),
       (   37.20,  222.80),
       (   37.30,  226.90),
       (   37.50,  230.90),
       (   37.80,  234.90),
       (   38.30,  238.90),
       (   38.90,  242.90),
       (   39.60,  247.00),
       (   40.30,  251.10),
       (   41.20,  255.40),
       (   42.00,  259.70),
       (   43.00,  264.10),
       (   43.90,  268.60),
       (   44.90,  273.20),
       (   45.90,  277.80),
       (   47.00,  282.60),
       (   48.00,  287.50),
       (   49.20,  292.60),
       (   50.30,  297.80),
       (   51.40,  303.30),
       (   52.50,  309.00),
       (   53.60,  315.00),
       (   54.60,  321.30),
       (   55.50,  327.90),
       (   56.30,  334.80),
       (   56.80,  342.00),
       (   57.10,  349.40),
       (   57.20,   -3.10),
       (   56.90,    4.30),
       (   56.40,   11.60),
       (   55.70,   18.60),
       (   54.70,   25.20),
       (   53.60,   31.50),
       (   52.30,   37.40),
       (   50.90,   42.80),
       (   49.50,   47.90),
       (   48.20,   52.60),
       (   46.80,   57.10),
       (   45.50,   61.40),
       (   44.40,   65.50),
       (   43.30,   69.60),
       (   42.40,   73.60),
       (   41.60,   77.50)),
       ((  -6.00,   70.80),
       (   -7.10,   75.50),
       (   -7.90,   80.20),
       (   -8.40,   85.00),
       (   -8.70,   89.80),
       (   -8.60,   94.80),
       (   -8.20,   99.70),
       (   -7.70,  104.70),
       (   -8.10,  109.80),
       (   -6.40,  114.80),
       (   -5.70,  119.90),
       (   -5.10,  124.90),
       (   -4.70,  129.90),
       (   -4.60,  134.80),
       (   -4.70,  139.70),
       (   -4.90,  144.70),
       (   -5.20,  149.60),
       (   -5.30,  154.70),
       (   -5.30,  159.60),
       (   -5.20,  164.70),
       (   -5.00,  169.80),
       (   -4.70,  174.80),
       (   -4.00,  179.80),
       (   -3.90,  184.70),
       (   -3.20,  189.60),
       (   -2.90,  194.50),
       (   -2.90,  199.40),
       (   -2.90,  204.40),
       (   -3.00,  209.30),
       (   -3.00,  214.30),
       (   -2.80,  219.20),
       (   -2.40,  224.40),
       (   -1.90,  229.30),
       (   -1.00,  234.30),
       (    0.00,  239.30),
       (    1.00,  244.10),
       (    2.00,  249.10),
       (    2.90,  254.10),
       (    3.70,  258.90),
       (    4.30,  263.80),
       (    4.90,  269.00),
       (    5.40,  273.90),
       (    5.90,  278.80),
       (    6.30,  283.70),
       (    6.60,  288.60),
       (    7.00,  293.60),
       (    7.40,  298.50),
       (    7.80,  303.40),
       (    8.30,  308.30),
       (    8.80,  313.10),
       (    9.50,  317.90),
       (   10.40,  322.80),
       (   11.30,  327.70),
       (   12.50,  332.60),
       (   13.70,  337.70),
       (   14.90,  342.90),
       (   16.00,  348.30),
       (   16.80,   -6.10),
       (   17.40,   -0.40),
       (   17.40,    5.30),
       (   17.00,   11.10),
       (   16.10,   16.90),
       (   14.60,   22.50),
       (   12.80,   28.00),
       (   10.60,   33.20),
       (    8.10,   38.30),
       (    5.60,   43.10),
       (    3.20,   47.90),
       (    0.80,   52.50),
       (   -1.30,   57.00),
       (   -3.10,   61.60),
       (   -4.70,   66.20),
       (   -6.00,   70.80)),
       (( -44.80,   55.30),
       (  -45.90,   60.10),
       (  -47.00,   65.00),
       (  -47.90,   70.00),
       (  -48.70,   74.90),
       (  -49.50,   79.90),
       (  -50.10,   84.90),
       (  -50.70,   89.70),
       (  -51.30,   94.50),
       (  -51.80,   99.30),
       (  -52.40,  104.00),
       (  -53.10,  108.80),
       (  -53.70,  113.60),
       (  -54.50,  118.50),
       (  -55.30,  123.60),
       (  -56.10,  129.00),
       (  -56.90,  134.60),
       (  -57.70,  140.60),
       (  -58.40,  146.80),
       (  -59.00,  153.30),
       (  -59.40,  160.00),
       (  -59.80,  166.90),
       (  -60.00,  174.00),
       (  -60.00,  181.00),
       (  -60.00,  188.10),
       (  -59.80,  195.10),
       (  -59.50,  202.00),
       (  -59.10,  208.80),
       (  -58.50,  215.60),
       (  -57.90,  222.20),
       (  -57.20,  228.60),
       (  -56.40,  234.90),
       (  -55.50,  241.00),
       (  -54.60,  246.90),
       (  -53.60,  252.60),
       (  -52.60,  258.20),
       (  -51.50,  263.60),
       (  -50.40,  268.80),
       (  -49.40,  273.90),
       (  -48.30,  279.00),
       (  -47.30,  283.90),
       (  -46.20,  288.80),
       (  -45.20,  293.60),
       (  -44.20,  298.40),
       (  -43.30,  303.10),
       (  -42.30,  307.80),
       (  -41.30,  312.50),
       (  -40.40,  317.20),
       (  -39.40,  321.80),
       (  -38.40,  326.40),
       (  -37.40,  330.80),
       (  -36.40,  335.20),
       (  -35.40,  339.50),
       (  -34.40,  343.60),
       (  -33.50,  347.60),
       (  -32.70,  351.40),
       (  -32.00,  355.10),
       (  -31.40,   -1.30),
       (  -31.10,    2.10),
       (  -31.00,    5.40),
       (  -31.10,    8.70),
       (  -31.50,   12.00),
       (  -32.10,   15.40),
       (  -32.90,   18.70),
       (  -34.00,   22.20),
       (  -35.20,   25.80),
       (  -36.50,   29.50),
       (  -37.90,   33.40),
       (  -39.30,   37.40),
       (  -40.70,   41.60),
       (  -42.10,   46.00),
       (  -43.50,   50.60),
       (  -44.80,   55.30)),
       (( -71.60,   26.40),
       (  -71.80,   27.10),
       (  -72.10,   27.90),
       (  -72.40,   28.50),
       (  -72.70,   29.10),
       (  -73.00,   29.70),
       (  -73.30,   30.10),
       (  -73.60,   30.50),
       (  -74.00,   30.90),
       (  -74.30,   31.10),
       (  -74.60,   31.20),
       (  -75.00,   31.20),
       (  -75.30,   31.00),
       (  -75.60,   30.80),
       (  -76.00,   30.60),
       (  -76.30,   30.10),
       (  -76.60,   29.40),
       (  -76.90,   28.60),
       (  -77.10,   27.70),
       (  -77.40,   26.60),
       (  -77.60,   25.40),
       (  -77.80,   24.00),
       (  -77.90,   22.60),
       (  -78.10,   21.10),
       (  -78.10,   19.50),
       (  -78.20,   17.90),
       (  -78.20,  376.30),
       (  -78.10,  374.70),
       (  -78.10,  373.20),
       (  -77.90,  371.70),
       (  -77.80,  370.30),
       (  -77.60,  368.50),
       (  -77.40,  367.50),
       (  -77.20,  366.50),
       (  -76.90,  365.60),
       (  -76.60,  364.90),
       (  -76.30,  364.30),
       (  -76.00,  363.40),
       (  -75.60,  363.20),
       (  -75.30,  363.00),
       (  -74.90,  362.90),
       (  -74.60,  362.90),
       (  -74.20,  363.10),
       (  -73.90,  363.40),
       (  -73.50,  363.40),
       (  -73.20,  363.80),
       (  -72.90,  364.30),
       (  -72.60,  364.90),
       (  -72.30,  365.50),
       (  -72.00,  366.10),
       (  -71.70,  366.80),
       (  -71.50,  367.60),
       (  -71.20,  368.20),
       (  -71.00,  369.00),
       (  -70.80,  369.90),
       (  -70.70,  370.80),
       (  -70.50,  371.70),
       (  -70.40,   12.60),
       (  -70.30,   13.60),
       (  -70.30,   14.50),
       (  -70.20,   15.40),
       (  -70.20,   16.40),
       (  -70.20,   17.40),
       (  -70.20,   18.30),
       (  -70.30,   19.20),
       (  -70.40,   20.30),
       (  -70.50,   21.20),
       (  -70.60,   22.10),
       (  -70.80,   23.00),
       (  -70.90,   23.90),
       (  -71.10,   24.80),
       (  -71.30,   25.60),
       (  -71.60,   26.40)));
--
END FARKLER;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--HFATMOS
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Mathlib; Use Mathlib, numeric_primitives, core_functions, trig_functions;
With Nodeloc;
With Text_IO;
With Constants; use Constants;
With Propagation_constants; Use Propagation_constants;
With Farkler;
With Debugger2; Use Debugger2;
Package HF_ATMOSPHERICS is
--
--
      Procedure AMBION (CLAT: in float;
                        ELON: in float;
                        PHI: in float;
                        TMO: in float;
                        RZUR: in float;
                        EMAX: out float;
                        HEMAX: out float;
                        THICKE: out float;
                        F1MAX: out float;
                        HF1MAX: out float;
                        THIKF1: out float;
                        F2MAX: out float;
                        HF2MAX: out float;
                        THIKF2: out float);

      Procedure CGMCS;

      Procedure CLOCKS (SLAT: in float;
                        SLON: in float;
                        COSCHI: out float);


      Procedure DENS (TINF: in float;
                      ALT: in float;
                      TEMP: out float;
                      AVH: out float);

      Procedure ECALC (TM: in float;
                       F0E: out float;
                       HME: out float);

      Function EDAT return float;

      Function EPHT (EDX: float) return float;

      Function EXOT (FBAR: float;
                     F: float;
                     SOLDEC: float;
                     GLATR: float;
                     HA: float) return float;

      Function F0F2FN (GMT: float;
                       THRL: float) return float;

      Procedure F1CALC (F0F1: out float;
                        HMF1: out float);

      Procedure FETCH (XP: in float;
                       YP: in float;
                       FF: out float;
                       GG: out float);

      Function HMF2FN (TIME: float) return float;

      Procedure IONDAT (IENTER: in integer;
                        NHOPS: in integer;
                        EHT: out float;
                        FHT: out float;
                        F0EMAX: out float;
                        F0EMIN: out float;
                        F0FMAX: out float;
                        F0FMIN: out float);

      Procedure IONFT1 (ZMAX: out float;
                        EMAX: out float;
                        THICK: out float;
                        LAYER: in integer;
                        RZUR: in float;
                        PHI: in float;
                        TMO: in float;
                        RLT: in float;
                        RLTM: in float;
                        RLGM: in float;
                        DIP: in float);

      Procedure MAGNET (H: in float;
                        COLAT: in float;
                        ELONG: in float;
                        BFELD: out float;
                        SINDIP: out float;
                        SINDEC: out float;
                        COSDEC: out float;
                        COSMAG: out float;
                        ELONMG: out float);

      Procedure POLAR (PLAT: in float;
                       PLONG: in float;
                       F0E: out float;
                       HME: out float;
                       F0F1: out float;
                       HMF1: out float;
                       F0F2: out float;
                       HMF2: out float);

      Function POLR (RLTM: float;
                     RLGM: float;
                     R: float;
                     PHI: float;
                     TMO: float) return float;

      Procedure SCALHT (FBAR: in float;
                        F: in float;
                        SOLDEC: in float;
                        GLATR: in float;
                        HA: in float;
                        HEIGHT: in float;
                        TATR: out float;
                        SMULT: out float);

      Function TABINT (K: integer;
                       I: integer;
                       J: integer) return float;

      Function TATRFN (TINF: float; HEIGHT: float) return float;

      Function TVARF2 (RLTM: float;
                       RLGM: float;
                       DIP: float;
                       R: float;
                       PHI: float;
                       TMO: float;
                       DEC: float;
                       CLTM: float;
                       SLTM: float) return float;

      Function TVEF1 (A: float;
                      B: float;
                      C: float;
                      D: float;
                      RLT: float;
                      R: float;
                      PHI: float;
                      DEC: float) return float;

      Function YONII (RLTM: float;
                      RF: float;
                      R: float;
                      PHI: float;
                      TMO: float;
                      DEC: float;
                      CLTM: float;
                      SLTM: float) return float;

--
--
--
End HF_ATMOSPHERICS;
--
Package body HF_ATMOSPHERICS is
--
-- HF_ATMOSPHERICS Package of PROP_LINK
-- Version 1.0,  March 13, 1985.
--
-- This HF_ATMOSPHERICS Package contains all of the procedures that are used
-- to compute the behavior of the ionosphere for HF propagation.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
-- Instantiate integer and floating point IO.
--      Package IO_INTEGER is new INTEGER_IO(INTEGER);
--      Package IO_FLOAT is new FLOAT_IO(FLOAT);
--      Use IO_INTEGER,IO_FLOAT;
--
   pragma source_info(on);
--
--TYPES:
--
--VARIABLES THAT ARE TO VISIBLE TO ALL ROUTINES WITHIN THIS PACKAGE ONLY:
      SD, CD, SSL, Q, DTDR, DTDT: float;
      NJ: integer;
      JD, ED, FD: float;
      GLONG, GLAT, HRMT, SECCHI, GMLAT, GMLONG: float;
      NYEAR: integer := 1977;
      NDAY: integer := 1;
      NHOUR, MIN, NSEC: integer := 0;
      UTIME: float;
      AP, PMA, R, SOLFX: float;
      T0: float := 300.0;
      T90: float := 183.0;
      TB, TX, GX, TR: float;
      F0HT: array (1..15, 1..4) of float;
      CDATA: array (integer range 1..5, integer range 1..6) of float;
--
--
      Procedure AMBION (CLAT: in float;
                        ELON: in float;
                        PHI: in float;
                        TMO: in float;
                        RZUR: in float;
                        EMAX: out float;
                        HEMAX: out float;
                        THICKE: out float;
                        F1MAX: out float;
                        HF1MAX: out float;
                        THIKF1: out float;
                        F2MAX: out float;
                        HF2MAX: out float;
                        THIKF2: out float) is
--
--#PURPOSE: AMBION determines the ionospheric parameters for the
--          ambient ionosphere for HF reflection calculations.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        CLAT   = Degrees Latitude (North)
--IN        ELON   = Degrees Longitude (East)
--IN        PHI    = Time of day in radians (1 day = 2 pi radians)
--IN        TMO    = Month (0-12; starting from December 15;
--                          e.g., June 1 := 6.5)
--IN        RZUR   = Smoothed Zurich Sunspot number
--OUT       EMAX   = Maximum electron density of E layer
--OUT       HEMAX  = Height of maximum electron density of E layer
--OUT       THICKE = Thickness of E layer
--OUT       F1MAX  = Maximum electron density of F1 layer
--OUT       HF1MAX = Height of maximum electron density of F1 layer
--OUT       THIKF1 = Thickness of F1 layer
--OUT       F2MAX  = Maximum electron density of F2 layer
--OUT       HF2MAX = Height of maximum electron density of F2 layer
--OUT       THIKF2 = Thickness of F2 layer
--
--#CALLED BY:
--          IONDAT
--
--#CALLS TO:
--          IONFT1
--          MAGNET
--
--#TECHNICAL DESCRIPTION:
--          AMBION is the driver module for Procedures employed
--          to calculate the ambient ionospheric parameters using a
--          three parabola fit to the Aerospace Model.
--          These Procedures were adapted from the Mission Research HFNET
--          FORTRAN Subroutines.
--
      H: float := 0.0;
      CLATR, ELONR, RLT, RLTM, DIP: float;
      ZMAX, VMAX, THICK, BF, SINDIP, COSMAG, ELONMG: float;
      LAYER: integer;
      VLMAX, HLMAX: array (integer range 1..3) of float;
      THICKL: array (integer range 1..33) of float;
--
      Begin
--
      CLATR := (90.0 - CLAT)*RADIANS_PER_DEGREE;
      ELONR := ELON*RADIANS_PER_DEGREE;
      For LAYER in 1..3 Loop
         MAGNET (H, CLATR, ELONR, BF, SINDIP, SD, CD, COSMAG, ELONMG);
         RLT := HALFPI - CLATR;
         RLTM := ASIN(COSMAG);
         DIP := ASIN(SINDIP);
         IONFT1 (ZMAX, VMAX, THICK, LAYER, RZUR, PHI, TMO, RLT,
                 RLTM, ELONMG, DIP);
         VLMAX(LAYER) := VMAX;
         HLMAX(LAYER) := ZMAX*1.0E5;
         THICKL(LAYER) := THICK*1.0E5;
      End Loop;
--
      EMAX := VLMAX(1);
      HEMAX := HLMAX(1);
      THICKE := THICKL(1);
      F1MAX := VLMAX(2);
      HF1MAX := HLMAX(2);
      THIKF1 := THICKL(2);
      F2MAX := VLMAX(3);
      HF2MAX := HLMAX(3);
      THIKF2 :=THICKL(3);
--
      Return;
--
      End AMBION;
--
--
      Procedure CGMCS is
--
--#PURPOSE:CGMCS converts from geographic coordinates to geomagnetic.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Procedure
--
--#PARAMETER DESCRIPTIONS:
--         'NONE'
--
--#CALLED BY:
--          POLAR
--
--#CALLS TO:
--          FETCH
--
--#TECHNICAL DESCRIPTION:
--          CGMCS converts geographic coordinates to geomagnetic
--          coordinates by first computing the colatitude of the
--          point and then calling Procedure FETCH.  The returned
--          longitude is then tested to ensure that it is within
--          the interval of 0 to +360 degrees.
--
      YP, XP, FF, GG: float;
--
      Begin
--
      YP := GLONG;
      XP := 90.0 - GLAT;
      FETCH(XP, YP, FF, GG);
      GMLAT := FF;
      GMLONG := GG;
      If GMLONG < 0.0 Then
         GMLONG := GMLONG + 360.0;
      End If;
      If GMLONG >= 360.0 Then
         GMLONG := GMLONG - 360.0;
      End If;
--
      Return;
--
      End CGMCS;
--
--
      Procedure CLOCKS (SLAT: in float;
                        SLON: in float;
                        COSCHI: out float) is
--
--#PURPOSE: CLOCKS determines the solar zenith angle.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Procedure
--
--#PARAMETER DESCRIPTIONS:
--IN        SLAT   = Latitude (degrees north)
--IN        SLON   = Longitude (degrees east)
--OUT       COSCHI = Cosine of zenith angle
--
--#CALLED BY:
--          F1CALC
--
--#CALLS TO:
--          EDAT
--          EPHT
--
--#TECHNICAL DESCRIPTION:
--          CLOCKS determines the solar zenith angle through the use
--          of a purely geometrical analysis of the sun's position in
--          relation to a point on the earth at a specified time.
--
      ETIM0: float := -1.0E20;
      ARG, ETIME, SLONG, HA: float;
--
      Begin
--
      ETIME := EDAT;
      If ETIME /= ETIM0 Then
         SLONG := EPHT(ETIME);
      End If;
      ARG := SLAT*RADIANS_PER_DEGREE;
      HA := SLON - SSL;
      COSCHI := SD*SIN(ARG) + CD*COS(ARG)*COS(HA*RADIANS_PER_DEGREE);
--
      Return;
--
      End CLOCKS;
--
--
      Procedure DENS (TINF: in float;
                      ALT: in float;
                      TEMP: out float;
                      AVH: out float) is
--
--#PURPOSE: DENS determines atmospheric parameters.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Procedure
--
--#PARAMETER DESCRIPTIONS:
--IN        TINF   = Exospheric (550 - 60,000 km) temperature
--IN        ALT    = Altitude
--OUT       TEMP   = Temperature
--OUT       AVH    = Average height
--
--#CALLED BY:
--          SCALHT
--
--#CALLS TO:
--          TATRFN
--
--#TECHNICAL DESCRIPTION:
--          DENS determines atmospheric parameters based on a three
--          parabolic approximation to a model known as the Aerospace
--          model.  This model is semi-empirical in nature in that it
--          is based on ionospheric measurements taken only at the
--          low and mid latitudes and may not be reliable at higher
--          latitudes where auroral effects, extended days/nights, ect.,
--          influence ionospheric behavior.
--
      DEN: array (integer range 1..5) of float;
      H: array (integer range 1..5) of float;
      MASS: array (integer range 1..5) of float :=
         (28.0134, 31.9988, 15.9994, 4.00260, 39.9480);
      QO: array (integer range 1..4) of float :=
         (0.7811, 0.20955, 0.0093432, 6.1471E-6);
      DENB: array (integer range 1..5) of float :=
         (0.0, 0.0, 0.0, 0.0, 0.0);
      XMIL: float := 1.0E-3;
      HKM: float := 1000.0;
      RTM90: float := 21.965E-6;
      Z100: float := 100.0;
      Z90: float := 90.0;
      B0: float := 28.82678;
      B1: float := -7.40066E-2;
      B2: float := -1.19407E-2;
      B3: float := 4.51103E-4;
      B4: float := -8.21895E-6;
      B5: float := 1.07561E-5;
      B6: float := -6.97444E-7;
      AN: float := 6.02257E+26;
      AVM0: float := 28.960;
      RO: float := 6356766.0;
      RB: float := 6481766.0;
      GMB: float := 1.134449;
      FOF90: float := 0.1806478;
      ALPHA: float := -0.38;
      AMU: float := 1.6605313E-27;
      H1: float := 125.0;
      DZA: float := 6.25;
      HEIGHT: float := 0.0;
      TEX: float := 0.0;
      F2: float := 0.0;
      FB: float := 0.0;
      TB: float := 0.0;
      IEXIT, J: integer;
      DZX, F0, F1, DZI, RBR, AVM, AV2, DENM, XNM, DENT, DEN0, DMDR,
         DNDR, DZZ, RAT, FI: float;
--
      Begin
--
      IEXIT := 0;
      If TINF /= TEX or HEIGHT < Z100 or ALT <= Z100 Then
         DZX := 5.0;
         If ALT <= Z100 Then
            DZX := 0.5*(ALT - Z90);
            IEXIT := 1;
         End If;
         F0 := FOF90;
         F1 := FOF90;
         F2 := FOF90;
         FB := 0.0;
         HEIGHT := Z90;
         For J in 1..2 Loop
            F1 := F2;
            HEIGHT := HEIGHT + DZX;
            DZI := HEIGHT - Z90;
            RBR := RB/(HKM*HEIGHT + RO);
            TEMP := TATRFN(TINF,HEIGHT);
            F2 := GMB*RBR*RBR/TEMP;
            If HEIGHT >= Z90 Then
               AVM := B0 + DZI*(B1 + DZI*(B2 + DZI*(B3 + DZI*(B4 + DZI*
                      (B5 + DZI*B6)))));
            Else
               AVM := B0 + DZI*B1;
               If AVM > AVM0 Then
                  AVM := AVM0;
               End If;
            End If;
            F2 := AVM*F2;
         End Loop;
         FB := FB + (F0 + 4.0*F1 + F2)*DZX/3.0;
--
         AVH := DZI/FB;
         AV2 := 1.0/F2;
         DENM := (RTM90*AVM/TEMP)*EXP(-FB);
         XNM := AN*DENM;
         DENT := XNM/AVM;
         DEN0 := XNM/AVM0;
         XNM := DENT - DEN0;
         DMDR := B1 + DZI*(2.0*B2 + DZI*(3.0*B3 + DZI*(4.0*B4 + DZI*
                 (5.0*B5 + DZI*6.0*B6))));
         DNDR := -XMIL*DENM*(F2 + DTDR/TEMP + DMDR/AVM);
         For J in 1..4 Loop
            DEN(J) := QO(J)*DEN0;
         End Loop;
         DEN(5) := DEN(3);
         DEN(3) := XNM + XNM;
         DEN(2) := DEN(2) - XNM;
         For J in 1..5 Loop
            H(J) := AVM*AV2/MASS(J);
            DENB(J) := DEN(J)*TEMP;
         End Loop;
--
         TB := TEMP;
         FB := 0.0;
         F2 := F2/AVM;
         If IEXIT = 1 Then
            TEX := TINF;
            Return;
         End If;
      End If;
--
      DZX := DZA;
      If ALT < HEIGHT Then
         DZX := -DZA;
      End If;
--
      Loop
         DZZ := 0.5*(ALT - HEIGHT);
         If DZX*DZX >= DZZ*DZZ Then
            DZX := DZZ;
            IEXIT := 1;
         End If;
         F0 := F2;
         For J in 1..2 Loop
            F1 := F2;
            HEIGHT := HEIGHT + DZX;
            RBR := RB/(HKM*HEIGHT + RO);
            TEMP := TATRFN(TINF,HEIGHT);
            F2 := GMB*RBR*RBR/TEMP;
         End Loop;
         FB := FB + (F0 + 4.0*F1 + F2)*DZX/3.0;
         RAT := 100.0*TEMP/TINF - 50.0;
         If RAT <= DZA or HEIGHT <= H1 Then
            RAT := DZA;
         End If;
         If DZZ < 0.0 Then
            RAT := -RAT;
         End If;
         DZX := RAT;
         Exit When IEXIT /= 0;
      End Loop;
      DENT := 0.0;
      DENM := 0.0;
      DNDR := 0.0;
      For J in 1..5 Loop
         FI := FB*MASS(J);
         H(J) := 1.0/(F2*MASS(J));
         DEN(J) := (DENB(J)/TEMP)*EXP(-FI);
         If J = 4 Then
            DEN(J) := DEN(J)*((TB/TEMP)**ALPHA);
         End If;
         DENT := DENT + DEN(J);
         DENM := DENM + DEN(J)*MASS(J);
         DNDR := DNDR - DEN(J)*MASS(J)/H(J);
      End Loop;
      AVM := DENM/DENT;
      DZI := HEIGHT - Z100;
      AVH := DZI/(FB*AVM);
      AV2 := 1.0/(AVM*F2);
      DNDR := AMU*XMIL*(DNDR + DENM*DTDR/TEMP);
      DENM := DENM*AMU;
      TEX := TINF;
--
      Return;
--
      End DENS;
--
--
      Procedure ECALC (TM: in float;
                       F0E: out float;
                       HME: out float) is
--
--#PURPOSE: ECALC calculates critical frequency and height of E layer.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Procedure
--
--#PARAMETER DESCRIPTIONS:
--IN        TM     = Corrected geomagnetic time (hours)
--OUT       F0E    = Critical frequency (MHz) for E layer
--OUT       HME    = Height of maximum electron density for E layer (Km)
--
--#CALLED BY:
--          POLAR
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          ECALC calculates E layer atmospheric parameters based on
--          the revised RADC-POLAR model as obtained from Mission
--          Research Corp.
--
      TOL, AMO, COSARG, DEC, ARG, HA, COSCHI, PHI1, PHI2, PHIA, PHIB,
         SPMD, SPUP, SPLO, ZSPMD, ZSPUP, ZSPLO, A1, A2, A3, A4, A5, A6,
         A7, A8, A, B, C, D, AMP, EMM, EMAXMD, ZMAXMD, F0ES, F0, ALONG,
         ALT, AE1, AE2: float;
--
      Begin
--
      TOL := 0.000001;
      AMO := FLOAT(MIN - 3)*PI3;
      COSARG := COS(AMO);
      If GLAT > 89.8 Then
         GLAT := 89.8;
      End If;
      DEC := -0.409*COS(PI/182.5*(FLOAT(NJ)+8.0));
      ARG := GLAT*RADIANS_PER_DEGREE;
      HA := GLONG - GMLAT;
      COSCHI := SIN(DEC)*SIN(ARG) + COS(DEC)*COS(ARG)*
                                    COS(HA*RADIANS_PER_DEGREE);
      SECCHI := 1.0/COSCHI;
      PHI1 := 71.0 - 2.5*PMA*COS(PI12*(TM - 1.0));
      PHI2 := 78.0 - 2.5*PMA;
      PHIA := PHI2;
      If TM < 6.0 or TM > 18.0 Then
         PHIA := PHI1;
      End If;
      PHIB :=  PHIA + 4.0 *(1.0 + 0.25*PMA);
--
      Loop
         If GMLAT >= PHIB Then   --........REGION I VALUES FOLLOW
            SPMD := 3.9 - 0.1*PMA;
            SPUP := 7.8 - 0.4*PMA;
            SPLO := 2.0;
            Exit;
         Elsif GMLAT >= PHIA Then  --........REGION II VALUES FOLLOW
            SPMD := 4.0 + 0.05*PMA;
            SPUP := 6.6 + 0.2*PMA;
            SPLO := 2.2 + 0.03*PMA;
            Exit;
         Else                      --........REGION III VALUES FOLLOW
            SPMD := 3.0;
            SPUP := 5.3;
            SPLO := 1.6;
            Exit;
         End If;
      End Loop;
--
      ZSPMD := 117.0 - 1.13*SPMD;
      ZSPUP := 117.0 - 1.13*SPUP;
      ZSPLO := 117.0 - 1.13*SPLO;
--.....FOES MODEL.....
      A1 := 3.62 + 0.00596*R;
      A2 := 0.143 + 0.000567*R;
      A3 := -0.0041 - 3.9*R*1.0E-05;
      A4 := -0.00195;
      A5 := 0.293 + 0.00045*R;
      A6 := 0.01;
      A7 := -0.00062 - 0.81*R*1.0E-05;
      A8 := -0.000668 - 2.5*R*1.0E-06;
      A := A1 + A2*COSARG;
      B := A3 + A4*COSARG;
      C := A5 + A6*COSARG;
      D := A7 + A8*COSARG;
      AMP := A + B*GLAT;
      EMM := C + D*GLAT;
      EMAXMD := 0.00001;
      ZMAXMD := 0.00001;
      F0ES := 0.0;
      F0 := 0.0;
      If COSCHI >= TOL Then
         If COSCHI > 0.00001 Then
            F0 := AMP*(COSCHI**EMM);
         End If;
         ALONG := GLONG;
         If GLONG > 180.0 Then
            ALONG := GLONG - 360.0;
         End If;
         ALT := UTIME + ALONG/15.0;
         If ALT < 0.0 Then
            ALT := 12.0 + ALT;
         End If;
         If ALT > 24.0 Then
            ALT := ALT - 24.0;
         End If;
         F0ES := F0*(1.0 - 0.0038*(12.0 - ALT) - 0.00013*AP);
--.....F0ES HAS NOW BEEN FULLY DEFINED.....
         EMAXMD := F0ES;
         ZMAXMD := 100.0 + 20.0*LOG(1.0/COSCHI);
      End If;
      AE1 := EMAXMD*EMAXMD;
      AE2 := SPMD*SPMD;
      If EMAXMD >= 0.1 Then
         F0E := SQRT(SQRT(1.5*AE2*AE2 + AE1*AE1));
      Else
         F0E := SPMD;
      End If;
      HME := (ZMAXMD*AE1 + ZSPMD*AE2)/(AE1 + AE2);
--
      Return;
--
      End ECALC;
--
--
      Function EDAT return float is
--
--#PURPOSE: EDAT calculates elapsed time in days from 1900 January
--          1, 12 hours, for consistent dating routines CLOCKS and
--          POLAR.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Procedure
--
--#PARAMETER DESCRIPTIONS:
--
--OUT       EDAT   := Elapsed time in days from Jan 1, 1900
--
--#CALLED BY:
--          CLOCKS
--          POLAR
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          EDAT calculates elapsed time in days from 1900 January
--          1, 12 hours, for consistent dating in routines CLOCKS and
--          POLAR.  The technique employed is simply to convert all
--          input time specifications into a common set of units and to
--          then compute the time difference in days.
--
      L1, L2, L3, L4, LY: boolean;
      MONDAY: array (integer range 1..13) of integer :=
         (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365);
      N1, N2, N3, NX: integer;
--
      Begin
--
--COMPUTE: JD = JULIAN DAY OF DATE
--         NJ = DAY OF YEAR
--         ED = ELAPSED TIME IN DAYS FROM January, 1900, 0 Days, 12 Hours
--              TO DATE
--
      N1 := NYEAR/4;
      If (NYEAR - 4*N1) = 0 Then
         L1 := TRUE;
      Else
         L1 := FALSE;
      End If;
      N2 := NYEAR/100;
      If (NYEAR - 100*N2) /= 0 Then
         L2 := TRUE;
      Else
         L2 := FALSE;
      End If;
      N3 := NYEAR/400;
      If (NYEAR - 400*N3) = 0 Then
         L3 := TRUE;
      Else
         L3 := FALSE;
      End If;
      N1 := Integer(long_integer(365)*long_integer(NYEAR)-693961) +
                       N1 - N2 + N3 + MONDAY(MONTH) + NDAY;
      LY := (L1 and L2) or L3;
      If MONTH <= 2 Then
         L4 := TRUE;
      Else
         L4 := FALSE;
      End If;
      If (LY and L4) Then
         N1 := N1 - 1;
      End If;
      If MONTH = 2 Then
         L4 := TRUE;
      Else
         L4 := FALSE;
      End If;
--
      Loop
         NX := MONDAY(MONTH + 1) - MONDAY(MONTH);
         If (LY and L4) Then
            NX := NX + 1;
         End If;
         Exit When NDAY <= NX;
         MONTH := MONTH + 1;
         NDAY := NDAY - NX;
      End Loop;
--
      JD := float(N1) + 2.41502E6;
      NJ := MONDAY(MONTH) + NDAY;
      If MONTH >= 2 Then
         L4 := TRUE;
      Else
         L4 := FALSE;
      End If;
      If (LY and L4) Then
         NJ := NJ + 1;
      End If;
      ED := FLOAT(N1) + 0.5;
      FD := FLOAT(NHOUR*3600 + MIN*60 + NSEC);
      FD := FD/86400.0;
      ED := ED + FD;
--
      Return ED;
--
      End EDAT;
--
--
      Function EPHT (EDX: float) return float is
--
--#PURPOSE: EPHT determines solar orbital parameters.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Function
--
--#PARAMETER DESCRIPTIONS:
--IN        EDX    = Elapsed time in days from Jan. 1, 1900
--OUT       EPHT   = Ephemerial time
--
--#CALLED BY:
--          CLOCKS
--          POLAR
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          EPHT determines solar orbital parameters.
--          The technique employed is an extrapolation of the Kepler
--          orbital state vector as computed for January 1, 1900.
--
      PH: array (integer range 1..14) of float;
      PCON: array (integer range 1..17) of float
       :=(2.267E-13, 0.98564734, 279.69668, 1.93434E-14, 6.57098224E-2,
          6.6460655, -1.23E-15, -3.5626E-7, 23.452294, 3.39E-13,
          4.70684E-5, 281.22084, -9.4E-17, -1.1444E-9, 0.01675104,
          1.03E-20, 7.0E-20);
      EDLAST: float := 1.0E6;
      C15: float := 15.0;
      C24: float := 24.0;
      C360: float := 360.0;
      HIP: float := 3.8197786;
      E2, E3, UT, O, X, X1, X2, U, PIR, SO, COLOC, PM, SL, CL, E, SM, CM,
         P, PQ, SE, CE, W, V, Y, Z, RH2, RH1, B: float;
      K, KK, KKK, NGM, N1, J: integer;
      KSTEPS: array (integer range 1..5) of integer := (1, 3, 5, 7, 9);
--
      Begin
--
--
      If EDX = EDLAST Then
         Return Q;
      End If;
      E2 := EDX*EDX;
      E3 := E2*EDX;
      UT := FD*C24;
--
--     COMPUTE SOLAR ORBITAL ELEMENTS
--
      K := 1;
      For KKK in 1..5 Loop
         KK := KSTEPS(KKK);
         PH(KK) := PCON(K)*E2 + PCON(K + 1)*EDX + PCON(K + 2);
         K := K + 3;
      End Loop;
      PH(5) := PCON(16)*E3 + PH(5);
      PH(7) := PCON(17)*E3 + PH(7);
      O := PH(3) + UT;
      NGM := INTEGER(O/C24);
      X := FLOAT(NGM*24);
      O := O - X;
      If O < 0.0 Then
         O := O + C24;
      End If;
      X1 := PH(1);
      N1 := INTEGER(X1/C360);
      X2 := FLOAT(N1*360);
      X1 := X1 - X2;
      If X1 < 0.0 Then
         X1 := X1 + C360;
      End If;
      PH(6) := X1;
      U := PH(7);
      PH(8) := PH(6) - PH(7);
      For J in 5..8 Loop
         PH(J) := PH(J)*RADIANS_PER_DEGREE;
      End Loop;
      PIR := PH(5);
      SO := SIN(PIR);
      COLOC := COS(PIR);
      PM := PH(8);
      SL := SIN(PM);
      CL := COS(PM);
      E := PH(9);
--
--     COMPUTE TRUE ANOMALY (P),SOLAR LONGITUDE (Q),RIGHT ASCENSION (B),
--             AND DECLINATION (D).
--
      SM := E*SL;
      CM := E*CL;
      PH(10) := PH(8) + 2.0*SM + 2.5*SM*CM + 3.0*E*E*SM - (13.0/3.0)*SM*SM*SM;
      PH(11) := PH(10) + PH(7);
      P := PH(10)*DEGREES_PER_RADIAN;
      Q := P + U;
      If Q >= C360 Then
         Q := Q - C360;
      End If;
      If Q < 0.0 Then
         Q := Q + C360;
      End If;
      PQ := PH(11);
      SE := SIN(PQ);
      CE := COS(PQ);
      W := CE;
      V := SE;
      X := W;
      Y := COLOC*V;
      Z := SO*V;
      RH2 := X*X + Y*Y;
      RH1 := SQRT(RH2);
      B := ATAN2(Y,X);
      B := B*HIP;
      If B < 0.0 Then
         B := B + C24;
      End If;
      SD := Z;
      CD := RH1;
      SSL := B - O;
      SSL := SSL*C15;
      If SSL < 0.0 Then
         SSL := SSL + C360;
      End If;
--
      Return Q;
--
      End EPHT;
--
--
      Function EXOT (FBAR: float;
                     F: float;
                     SOLDEC: float;
                     GLATR: float;
                     HA: float) return float is
--
--#PURPOSE: EXOT computes exospheric temprature.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Procedure
--
--#PARAMETER DESCRIPTIONS:
--IN        FBAR   = Average daily 10.7 cm. solar flux over 3
--                   solar rotations
--IN        F      = 10.7 cm. solar flux the previous day
--IN        SOLDEC = Solar declination (radians)
--IN        GLATR  = Geographic latitude (radians)
--IN        HA     = Solar angle (radians)
--OUT       EXOT   = Exospheric temperature
--
--#CALLED BY:
--          SCALHT
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          EXOT computes exospheric temprature.  The exosphere is that
--          region above the earth between 550 and 60,000 kilometers.
--          The technique employed is a curve-fit to tabular data.
--
      R, XM, XN, B, P, G, TC1, TC2, TC3, DT1, DT0, HLF, T0, T0R, CSD,
         SSD, CGL, SGL, PROCOS, PROSIN, SIN2TH, COS2ET, T2, T1, DT3,
         TAU, COSTAU, XTAU: float;
--
      Begin
--
      R := 0.30;
      XM := 1.10;
      XN := 1.50;
      B := -0.6487;
      P := 0.1047;
      G := 0.7504;
      TC1 := 379.0;
      TC2 := 3.24;
      TC3 := 1.3;
      DT1 := 28.0;
      DT0 := 0.03;
      HLF := 0.5;
      T0 := TC1 + TC2*FBAR + TC3*(F - FBAR);
      T0R := T0*R;
      CSD := COS(SOLDEC);
      SSD := SIN(SOLDEC);
      CGL := COS(GLATR);
      SGL := SIN(GLATR);
      PROCOS := CSD*CGL;
      PROSIN := SSD*SGL;
      SIN2TH := HLF*(1.0 - PROCOS + PROSIN);
      COS2ET := HLF*(1.0 + PROCOS + PROSIN);
      T2 := T0R*COS2ET**XM;
      T1 := T0R*SIN2TH**XM;
      DT3 := HLF*P*SIN(HA + G);
      TAU := HLF*(HA + B) + DT3;
      COSTAU := COS(TAU);
      XTAU := (COSTAU*COSTAU)**XN;
--
      Return (T0 + T1 + (T2 - T1)*XTAU) + (DT1*PMA + DT0*EXP(PMA));
--
      End EXOT;
--
--
      Function F0F2FN (GMT: float;
                       THRL: float) return float is
--
--#PURPOSE: F0F2FN determines the critical frequency of the F2 layer.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Function
--
--#PARAMETER DESCRIPTIONS:
--IN        GMT    = Corrected geomagnetic time (hours)
--IN        THRL   = Local time in hours
--OUT       F0F2FN = Critical frequency for F2 layer in Mhz.
--
--#CALLED BY:
--          POLAR
--
--#CALLS TO:
--          FOURS
--          GFUNC
--
--#TECHNICAL DESCRIPTION:
--          F0F2FN determines the critical frequency of the F2 layer.
--          This routine is based on the RADC-POLAR model of the ionosphere.
--
      type ROMANS is array (1..4) of float;
      type GREEKS is array (1..3) of float;
      A: ROMANS;
      AL: array (integer range 1..6) of float
         :=(0.0, -0.0439, 0.00386, -0.424, 0.739, 0.44);
      C: array (integer range 1..6) of float
         :=(4.8, 0.42, 0.6, 1.0, 0.008, -2.6E-5);
      PHI: GREEKS;
      CNST: array (integer range 1..2, integer range 1..5) of float
         :=((10.521, -0.0347, 0.000316, -0.133E-5, 0.142E-8),
            (0.0963, -0.0101, 0.000198, -0.853E-6, 0.106E-8));
      ROMAN: array (integer range 1..6) of ROMANS
         :=((1.368, 0.589, 0.0449, 0.0468),
            (0.2784, 0.1263, 0.06422, 0.03222),
            (0.1149, 0.04306, 0.01186, 0.01739),
            (15.57, 0.6066, 0.2784, 0.2574),
            (-0.1236, 1.112, 0.2338, 0.2562),
            (1.511, 1.325, 0.3508, 0.2319));
      GREEK: array (integer range 1..6) of GREEKS
         :=((-1.139, 113.0, 41.08),
            (-15.25, -5.563, -1.458),
            (-19.86, 97.99, 51.45),
            (176.5, 17.32, 68.02),
            (1.379, 7.242, 59.09),
            (2.221, 102.4, 2.9));
      PMAVAL: array (integer range 1..6) of float
         :=(0.3, 1.3, 2.3, 3.3, 4.3, 6.3);
      RHO: float := 10.0;
      PSI: float := -105.0;
      DATE, H, PMAI, G, FIS, B, F0F2N, F0F2D, DELTAX, CFN, CFD, BETA: float;
      I, II, J: integer;
--
      Function FOURS (ROMAN: ROMANS;
                      GREEK: GREEKS;
                      FACTOR: float;
                      VAR: float) return float is
--
--#PURPOSE: FOURS calculates a Fourier cosine series.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Function
--
--#PARAMETER DESCRIPTIONS:
--IN        ROMAN  = Fourier parameters
--IN        GREEK  = Fourier parameters
--IN        FACTOR = Fourier parameters
--IN        VAR    = Fourier parameters
--OUT       FOURS  = Fourier series
--
--#CALLED BY:
--          F0F2FN
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          FOURS calculates a Fourier cosine series using the
--          Fourier parameters passed as calling arguments.
--
      N: integer;
      RESULT: float;
--
      Begin
--
      RESULT := 0.0;
      For N in 1..3 Loop
         RESULT := RESULT + ROMAN(N+1)*COS(FLOAT(N)*FACTOR
                   *(VAR + GREEK(N)));
      End Loop;
      RESULT := ROMAN(1) + 2.0*RESULT;
--
      Return RESULT;
--
      End FOURS;
--
--
      Function GFUNC (GMLAT: float;
                      PMAI: float;
                      DATE: float) return float is
--
--#PURPOSE: GFUNC is one of the Fourier fits used in F0F2 calculation.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        GMLAT  = Geomagnetic latitude
--IN        PHAI   = Planetary magnetic activity index parameter
--IN        DATE   = Day of the year (1 - 366)
--OUT       GFUNC  = Fourier fit used in F0F2 calculation
--
--#CALLED BY:
--          F0F2FN
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          This routine is a component of the F0F2FN calculation
--          based in the ARCON model of the polar ionosphere.
--          It has no significance by itself.
--
      Q: array (integer range 1..5) of float
         :=(88.5, -2.5, 5.0, 55.0, 2.0);
      R: array (integer range 1..4) of float
         :=(3.2, -4.4, -1.0E-5, 1.5E-5);
      THETA1: float := -182.5;
      THETA2: float := -90.0;
      PX, P1, P2, A0LMIN, A0LMAX, X, S: float;
--
      Begin
--
      PX := COS(PI4365*(DATE - THETA2));
      P1 := R(1) + R(2)*PX;
      P2 := R(3) + R(4)*PX;
      A0LMIN := Q(1) + Q(2)*PMAI + Q(3)
                *COS(PI4365*(DATE + THETA1));
      A0LMAX := Q(4) + Q(5)*COS(PI4365*DATE);
      X := A0LMIN*A0LMAX;
      S := A0LMIN + A0LMAX;
      Return P1 + P2*GMLAT*(3.0*X + GMLAT*(GMLAT - 1.5*S));
--
      End GFUNC;
--
      Begin
--
      DATE := FLOAT(NJ);
      For I in 1..3 Loop
         A(I+1) := FOURS (ROMAN(I), GREEK(I), PI2365, DATE);
         PHI(I) := FOURS (ROMAN(I+3), GREEK(I+3), PI2365, DATE);
      End Loop;
      If GLAT > 58.0 Then
         A(2) := A(2)*(90.0 - GLAT)/32.0;
      End If;
      H := 0.0;
      If GLONG <= 165.0 Then
         Goto TEN;
      End If;
      If GLONG <= 195.0 Then
         Goto THIRTY_FIVE;
      End If;
      I := 1;
      If GLONG <= 345.0 Then
         Goto TWENTY;
      End If;
<<TEN>>
      I := 2;
<<TWENTY>>
      H := CNST(I,1);
      For J in 2..5 Loop
         H := H + CNST(I,J)*DATE**(J-1);
      End Loop;
<<THIRTY_FIVE>>
      For II in 1..7 Loop
         I := II;
         Exit When I = 7;
         Exit When PMA < PMAVAL(I);
      End Loop;
      PMAI := FLOAT(I);
      G := GFUNC (GMLAT, PMAI, DATE);
      A(1) := AL(1) + AL(2)*GLAT + AL(3)*GLAT*
           COS( PI2365*2.0*( DATE + PSI))
           + AL(4)*PMAI + AL(5)*G + AL(6)*H;
      FIS := C(4) + R*(C(5) + R*C(6));
      B := C(3)*COS(PI2365*(DATE + RHO));
      If R < 100.0 Then
         B := -B;
      End If;
      F0F2N := B + FIS*(C(1) + C(2)*FOURS (A, PHI, PI12, 0.0));
      F0F2D := B + FIS*(C(1) + C(2)*FOURS (A, PHI, PI12, 12.0));
--
--.....AURORAL OVAL CORRECTION
--
      If GMT < 18.0 and GMT >= 6.0 Then
         DELTAX := 80.0 - 1.2*PMA;
         CFN := 1.0 - 0.175*COS(PI12*(0.0 - PHI(1)))*
                (1.0 + COS(PI2365*(DATE + 8.0)));
         CFD := 1.0 - 0.175*COS(PI12*(12.0 - PHI(1)))*
                (1.0 + COS(PI2365*(DATE + 8.0)));
         F0F2N := F0F2N*(1.0 - (1.0 - CFN)*
                  EXP(( -(GMLAT - DELTAX )**2)/6.0));
         F0F2D := F0F2D*(1.0 - (1.0 - CFD)*
                  EXP(( -( GMLAT - DELTAX )**2)/6.0));
      Else
         BETA := 72.0 - 1.8*PMA + 5.1*COS(PI12*(GMT - 1.0));
         F0F2N := F0F2N +
                  COS(PI12*GMT)*EXP( -((GMLAT - BETA)**2)/6.0)*PMA/4.0;
         F0F2D := F0F2D +
                  COS(PI12*GMT)*EXP( -((GMLAT - BETA)**2)/6.0)*PMA/4.0;
      End If;
--
      Return F0F2N + (F0F2D - F0F2N)*SIN((PI*THRL)/24.0);
--
      End F0F2FN;
--
--
      Procedure F1CALC (F0F1: out float;
                        HMF1: out float) is
--
--#PURPOSE: F1CALC determines the critical frequency and height of F1 layer.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Procedure
--
--#PARAMETER DESCRIPTIONS:
--OUT       F0F1   = Critical frequency (MHz)
--OUT       HMF1   = Height (Km)
--
--#CALLED BY:
--          POLAR
--
--#CALLS TO:
--          CLOCKS
--
--#TECHNICAL DESCRIPTION:
--          F1CALC determines the critical frequency and height of
--          F1 layer.  This routine is based on the RADC-POLAR model.
--
      TOL, A1, UUT, A2, A3, A4, A5, A6, COSCHI, TEMP, CHI, AA, BB, CC,
         DD, AMP, EMM, F0, ALT, GCOLAT, SL: float;
      ID, LLL, MMM, NNN: integer;
--
      Begin
--
      TOL := 0.000001;
      A1 := UTIME - 0.2;
      ID := NDAY;
      If A1 < 0.0 Then
         UUT := 24.0 + UTIME;
         A1 := UUT - 0.2;
         ID := NDAY - 1;
      End If;
      LLL := INTEGER(A1);
      A2 := FLOAT(LLL);
      A3 := A1 - A2;
      A4 := A3*60.0 + TOL;
      MMM := INTEGER(A4);
      A5 := FLOAT(MMM);
      A6 := A4 - A5;
      NNN := INTEGER(A6*60.0 + TOL);
      CLOCKS (GLAT,GLONG,COSCHI);
      F0F1 := 0.0;
      TEMP := COSCHI;
      CHI := ACOS(COSCHI);
--     F0F1 GOES TO ZERO IN 5 DEG IN CHI
      If COSCHI >= 0.30071 Then
         If COSCHI <= 0.38268 Then
            COSCHI := 0.38268;
         End If;
         AA := 4.13 + 0.0111*R;
         BB := 0.00057 - 0.000044*R;
         CC := 0.106 + 0.000083*R;
         DD := (2.23*1.0E-06)*R + 0.0007714;
         AMP := AA + BB*GLAT;
         EMM := CC + DD*GLAT;
         F0 := AMP*(COSCHI**EMM);
         ALT := UTIME + GLONG/15.0;
         If ALT < 0.0 Then
            ALT := 12.0 + ALT;
         End If;
         If ALT > 24.0 Then
            ALT := ALT - 24.0;
         End If;
         F0F1 := F0*(1.0 - 0.005*(12.0 - ALT) - 0.0011*AP);
         If CHI >= 1.17810 Then
            F0F1 := F0F1*(1.265366 - CHI)/0.087266;
         End If;
         COSCHI := TEMP;
      End If;
      GCOLAT := 90.0 - GLAT;
      If F0F1 >= 0.1 Then
         SL := LOG(1.0/COSCHI);
         HMF1 := 156.0 + 0.15*R + 45.0*SL;
         Return;
      End If;
      F0F1 := 0.0;
      HMF1 := 0.0;
--
      Return;
--
      End F1CALC;
--
--
      Procedure FETCH (XP: in float;
                       YP: in float;
                       FF: out float;
                       GG: out float) is
--
--#PURPOSE: FETCH determines geomagnetic coordinates given geographic.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Tabular Procedure
--
--#PARAMETER DESCRIPTIONS:
--IN        XP     = Geographic latitude (degrees north)
--IN        YP     = Geographic longitude (degrees east)
--OUT       FF     = Corrected geomagnetic latitude (degrees north)
--OUT       GG     = Corrected geomagnetic longitude (degrees east)
--
--#CALLED BY:
--          CGMCS
--
--#CALLS TO:
--          TABINT
--
--#TECHNICAL DESCRIPTION:
--          FETCH looks up geomagnetic parameters using tables.
--
      XX, YY, DX, DY, DZ, FX, GX, FY, GY, FZ, GZ: float;
      I, J: integer;
--
      Begin
--
      XX := XP;
      YY := YP;
      DX := XX*0.5;
      I := INTEGER(DX);
      DX := DX - FLOAT(I);
      I := I + 1;
      DY := YY*0.2;
      J := INTEGER(DY);
      DY := DY - FLOAT(J);
      J := J + 1;
      DZ := DX*DY;
      If J <= 0 Then
         J := -J;
      End If;
      FF := TABINT(1, I, J);
      GG := TABINT(2, I, J);
      FX := TABINT(1, I + 1, J) - FF;
      GX := TABINT(2, I + 1, J) - GG;
      FY := TABINT(1, I, J + 1) - FF;
      GY := TABINT(2, I, J + 1) - GG;
      FZ := TABINT(1, I + 1, J + 1) - FF - FX - FY;
      GZ := TABINT(2, I + 1, J + 1) - GG - GX - GY;
--
--     MODIFY PATHOLOGICAL CASES
--
      If J = 23 Then
         Goto ZERO;
      End If;
      If J = 57 Then
         Goto THIRTY;
      End If;
      Goto SIXTY;
<<ZERO>>
      If I-85 < 0 Then
         Goto SIXTY;
      Elsif I-85 = 0 Then
         Goto TEN;
      Else
         Goto TWENTY;
      End If;
<<TEN>>
      GZ := GZ - 360.0;
      Goto SIXTY;
<<TWENTY>>
      GY := GY - 360.0;
      Goto SIXTY;
<<THIRTY>>
      If I-6 < 0 Then
         Goto SIXTY;
      Elsif I-6 = 0 Then
         Goto FORTY;
      Else
         Goto FIFTY;
      End If;
<<FORTY>>
      GZ := GZ + 360.0;
      Goto SIXTY;
<<FIFTY>>
      GY := GY + 360.0;
<<SIXTY>>
      If I = 1 Then
         FY := DX*FZ;
         GY := DX*GZ;
      End If;
      FF := FF + FX*DX + FY*DY + FZ*DZ;
      GG := GG + GX*DX + GY*DY + GZ*DZ;
--
      Return;
--
      End FETCH;
--
--
      Function HMF2FN (TIME: float) return float is
--
--#PURPOSE: HMF2FN determines the height of the maximum electron density
--          of the F2 layer.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Function
--
--#PARAMETER DESCRIPTIONS:
--IN        TIME   = Local time (hours)
--OUT       HMF2FN = Height of F2 layer (Km)
--
--#CALLED BY:
--          POLAR
--
--#CALLS TO:
--          SCALHT
--
--#TECHNICAL DESCRIPTION:
--          HMF2FN computes the height of the F2 layer in terms of the
--          maximum electron density.  This routine is based on the
--          RADC-POLAR model.
--
      CSSZ: array (integer range 1..3) of float :=(-0.2, 0.052, 0.208);
      ZACONS: array (integer range 1..5) of float;
      I: integer;
      GLATR, GMLATR, DATE, DEC, SDEC, CDEC, SAT, CAT, TP, AA, H12, H24,
         BTA1, BTA2, SP1, TATR, SMULT: float;
--
      Begin
--
--  GLATR  = GEOGRAPHIC LATITUDE IN RADIANS. = GLAT  IN DEG.
--  GMLATR = CORRECTED GEOMAGNETIC LATITUDE IN RADIANS. = GMLAT IN DEG.
      GLATR  := GLAT*RADIANS_PER_DEGREE;
      GMLATR  := GMLAT*RADIANS_PER_DEGREE;
--  NJ := DAY OF YEAR
--  CSSZ IS COS VECTOR FOR ANGLES   102,87,78 DEGREES
--
      DATE := FLOAT(NJ);
      For I in 1..5 Loop
         ZACONS(I) := 0.0;
      End Loop;
      DEC := - 0.409*COS(PI/182.5*FLOAT(NJ + 8));
      SDEC := SIN(DEC);
      CDEC := COS(DEC);
      SAT := SIN(GLATR);
      CAT := COS(GLATR);
--
--  COS OF ZENITH ANGLE AT NOON LOCAL TIME
      ZACONS(1) := SDEC*SAT + CDEC*CAT;
--  COS OF ZENITH ANGLE AT MIDNIGHT LOCAL TIME
      ZACONS(2) := SDEC*SAT - CDEC*CAT;
      For I in 1..3 Loop
         TP := (CSSZ(I) - SDEC*SAT)/(CDEC*CAT);
         TP := - TP;
         If TP < - 1.0 Then
            TP := - 1.0;
         End If;
         If TP > 1.0 Then
            TP := 1.0;
         End If;
         TP := ACOS(TP);
--
--  TIME AT WHICH COS OF ZENITH ANGLE IS CSSZ(I)
         ZACONS(2 + I) := 12.0*TP/PI;
      End Loop;
      AA := 0.55*(GMLAT - 45.0);
      H12 := (197.0 + 0.79*R - 0.0011*R**2 + AA);
      H24 := (297.0 + 0.603*R + AA);
--  H24 := (297.0 + 0.603*R - AA)
      If ZACONS(2) >= CSSZ(1) Then  --  CASE IA
         Return H12;
      End If;
      If ZACONS(1) <= CSSZ(1) Then  --  CASE IB
         SCALHT(SOLFX,SOLFX,DEC,GLATR,0.524,1000.0,TATR,SMULT);
         BTA1 := GMLAT;
         BTA2 := 67.0 - 2.0*PMA;
         Return H24 + 0.08*TATR*EXP(-(BTA1 - BTA2)**2/20.0);
      End If;
--
--     CASE II - IV TIME LT T(102DEG)
      If TIME < ZACONS(3) Then      -- Actually CASE IB again
         SCALHT(SOLFX,SOLFX,DEC,GLATR,0.524,1000.0,TATR,SMULT);
         BTA1 := GMLAT;
         BTA2 := 67.0 - 2.0*PMA;
         Return H24 + 0.08*TATR*EXP(-(BTA1 - BTA2)**2/20.0);
      End If;
--
      If ZACONS(1) <= CSSZ(2) Then  --    CASE II TIME GE T(102DEG)
         If TIME <= 12.0 Then       --    CASE II  T(102DEG) LT TIME LE 12.0
            SP1 := (H24 - H12)/(12.0 - ZACONS(3));
            Return H24 - SP1*(TIME - ZACONS(3));
         Else                       --     CASE II   12.0 LT TIME LE 24.0
            SP1 := (H24 - H12)/12.0;
            Return H12 + SP1*(TIME - 12.0);
         End If;
      End If;
--  CASES III AND IV   T(102DEG) LE TIME
      If ZACONS(1) >= CSSZ(3) Then   --     REDIFINE H12 FOR CASE IV
         H12 := H12 - (H24 - H12)*(12.0 - ZACONS(5))/12.0;
      End If;
--  CASES III AND IV
      If TIME <= ZACONS(4) Then
--          CASES III AND IV  T(102DEG) LT TIME LE T(87DEG)
         SP1 := (H24 - H12)/(ZACONS(4) - ZACONS(3));
         Return H24 - SP1*(TIME - ZACONS(3));
      End If;
      If TIME <= ZACONS(5) Then
--          CASES III AND IV   T(87DEG) LT TIME LE T(78DEG)
         Return H12;
      End If;
--  CASES III AND IV   T(78DEG) LT TIME LE 24.0
      SP1 := (H24 - H12)/(24.0 - ZACONS(5));
      Return H12 + SP1*(TIME - ZACONS(5));
--
      End HMF2FN;
--
--
      Procedure IONDAT (IENTER: in integer;
                        NHOPS: in integer;
                        EHT: out float;
                        FHT: out float;
                        F0EMAX: out float;
                        F0EMIN: out float;
                        F0FMAX: out float;
                        F0FMIN: out float) is
--
--#PURPOSE: IONDAT calculates ionospheric layer data relative to the
--          number of hops of an HF signal.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        IENTER = Entry code.
--IN        NHOPS  = Number of hops.
--OUT       EHT    = Average E-layer height in kilometers.
--OUT       FHT    = Average F-layer height in kilometers.
--OUT       FOEMAX = Maximum frequency for E-layer hops in MHz/secant.
--OUT       FOEMIN = Minimum frequency for E-layer hops in MHz/secant.
--OUT       FOFMAX = Maximum frequency for F-layer hops in MHz/secant.
--OUT       FOFMIN = Minimum frequency for F-layer hops in MHz/secant.
--
--#CALLED BY:
--          HFNORM
--
--#CALLS TO:
--          AMBION
--          LOCGRB
--          LOCNEW
--          POLAR
--
--#TECHNICAL DESCRIPTION:
--     IONDAT calculates the heights of the various layers of the
--     ionosphere. Specifically, it computes the average, minimum and
--     maximum heights of the E-layer and F-layer for each of the possibl
--     path/hop geometries. This routine is basically a data distribution
--     routine with the majority of the actual ionospheric computations
--     being performed in Procedures AMBION and POLAR.
--
      ISTRTM: array (integer range 1..5) of integer := (1, 2, 4, 7, 11);
      IENDM: array (integer range 1..5) of integer := (1, 3, 6, 10, 15);
      PLAT, PLON, PTIME: array (integer range 1..15) of float;
--      F0HT: array (integer range 1..15, integer range 1..4) of float;
--
--  F0HT CONTAINS THE FOLLOWING
--     COL 1 := F0E
--     COL 2 := HTE
--     COL 3 := F0F2
--     COL 4 := HTF2
--
--  CDATA CONTAINS THE FOLLOWING
--     COL 1 := #
--     COL 2 := #
--     COL 3 := #
--     COL 4 := #
--     COL 5 := #
--     COL 6 := #
--
      TMO, HOPS, RNGINC, RNG, TRSEC, TIMEX, YLAT, YLON, PHI, EMAX,
         HEMAX, THICKE, F1MAX, HF1MAX, THIKF1, F2MAX, HF2MAX, THIKF2, FOE,
         HME, F0F1, HMF1, F0F2, HMF2, HE, HF, AVEHE, AVEHF, FMINE, FMINF,
         FMAXE, FMAXF, F0E: float;
      ISTRT, IEND, I, J, NMNTH, K: integer;
--
      Begin

      R := float(AVERAGE_SUN_SPOT_NUMBER);
      PMA := 2.0;
      NMNTH := MONTH;
      TMO := FLOAT(MONTH);
      HOPS := FLOAT(NHOPS);
      ISTRT := ISTRTM(NHOPS);
      IEND := IENDM(NHOPS);
      If IENTER <= 1 Then
         For I in 1..15 Loop
            For J in 1..4 Loop
               F0HT(I,J) := 0.0;
            End Loop;
         End Loop;
      End If;
      If F0HT(ISTRT, 1) > 0.0 Then
         EHT := CDATA(NHOPS,1);
         FHT := CDATA(NHOPS,2);
         F0FMAX := CDATA(NHOPS,3);
         F0FMIN := CDATA(NHOPS,4);
         F0EMAX := CDATA(NHOPS,5);
         F0EMIN := CDATA(NHOPS,6);
         Return;
      End If;
--
      RNGINC := DPATH/HOPS;
      RNG := 0.0;
      TRSEC := (REFERENCE_TIME - (REFERENCE_TIME/100.0)*40.0)*60.0;
      TIMEX := (TIMSEC + TRSEC)/3600.0;
--
      For J in ISTRT..IEND Loop
         RNG := RNG + RNGINC;
         If J <= ISTRT Then
            RNG := RNGINC*0.5;
         End If;
         NODELOC.LOCNEW (TLAT, TLON, BRNG1, RNG, YLAT, YLON);
         If YLON < 0.0 Then
            YLON := YLON + 360.0;
         End If;
         PLAT(J) := YLAT;
         PLON(J) := YLON;
         PTIME(J) := TIMEX + YLON*0.0666666;
         Loop
            Exit When PTIME(J) >= 0.0 and PTIME(J) <= 24.0;
            If PTIME(J) > 24.0 Then
               PTIME(J) := PTIME(J) - 24.0;
            End If;
            If PTIME(J) < 0.0 Then
               PTIME(J) := PTIME(J) + 24.0;
            End If;
         End Loop;
      End Loop;
      TMO := FLOAT(MONTH);
      For K in ISTRT..IEND Loop
         If F0HT(1,1) >= 1.0 Then
            If  K = 5 Then
               F0HT(5,1) := F0HT(1,1);
               F0HT(5,2) := F0HT(1,2);
               F0HT(5,3) := F0HT(1,3);
               F0HT(5,4) := F0HT(1,4);
            Elsif K = 13 Then
               F0HT(13,1) := F0HT(1,1);
               F0HT(13,2) := F0HT(1,2);
               F0HT(13,3) := F0HT(1,3);
               F0HT(13,4) := F0HT(1,4);
            End If;
         Elsif ABS(PLAT(K)) <= 60.0 Then
            PHI := PTIME(K)*0.04166666*TWOPI;
            AMBION (PLAT(K), PLON(K), PHI, TMO, R,
                    EMAX, HEMAX, THICKE,
                    F1MAX, HF1MAX, THIKF1,
                    F2MAX, HF2MAX, THIKF2);
            F0HT(K,1) := 8977.9*SQRT(EMAX)*1.0E-6;
            F0HT(K,3) := 8977.9*SQRT(F2MAX)*1.0E-6;
            F0HT(K,2) := HEMAX*1.0E-5;
            F0HT(K,4) := HF2MAX*1.0E-5;
         Else
            NHOUR := INTEGER(PTIME(K));
            MIN := INTEGER(PTIME(K) - FLOAT(NHOUR))*60;
            POLAR(PLAT(K), PLON(K), F0E, HME, F0F1, HMF1, F0F2, HMF2);
            F0HT(K,1) := F0E;
            F0HT(K,2) := HME;
            F0HT(K,3) := F0F2;
            F0HT(K,4) := HMF2;
         End If;
      End Loop;
      HE := 0.0;
      HF := 0.0;
      For K in ISTRT..IEND loop
         HE := F0HT(K,2) + HE;
         HF := F0HT(K,4) + HF;
      End Loop;
      AVEHE := HE/HOPS;
      AVEHF := HF/HOPS;
      FMINE := 1.0E20;
      FMINF := 1.0E20;
      FMAXE := 0.0;
      FMAXF := 0.0;
--
      For K in ISTRT..IEND Loop
         FMINE := AMIN1(FMINE, F0HT(K,1));
         FMAXE := AMAX1(FMAXE, F0HT(K,1));
         FMINF := AMIN1(FMINF, F0HT(K,3));
         FMAXF := AMAX1(FMAXF, F0HT(K,3));
      End Loop;
      CDATA(NHOPS,1) := AVEHE;
      CDATA(NHOPS,2) := AVEHF;
      CDATA(NHOPS,3) := FMAXF;
      CDATA(NHOPS,4) := FMINF;
      CDATA(NHOPS,5) := FMAXE;
      CDATA(NHOPS,6) := FMINE;
      EHT := CDATA(NHOPS,1);
      FHT := CDATA(NHOPS,2);
      F0FMAX := CDATA(NHOPS,3);
      F0FMIN := CDATA(NHOPS,4);
      F0EMAX := CDATA(NHOPS,5);
      F0EMIN := CDATA(NHOPS,6);
--
      Return;
--
      End IONDAT;
--
--
      Procedure IONFT1 (ZMAX: out float;
                        EMAX: out float;
                        THICK: out float;
                        LAYER: in integer;
                        RZUR: in float;
                        PHI: in float;
                        TMO: in float;
                        RLT: in float;
                        RLTM: in float;
                        RLGM: in float;
                        DIP: in float) is
--
--#PURPOSE: IONFT1 supplies inonospheric parameters for a single
--           ambient layer using a parabolic fit.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--OUT       ZMAX   = Height of maximum elctron density
--OUT       EMAX   = Maximum electron density
--OUT       THICK  = Thickness of layer
--IN        LAYER  = layer of ionosphere(E=1,F1=2,F2=3)
--IN        RZUR   = Smothed Zurich Sunspot number
--IN        PHI    = Time of day( 0 - 2PI, 1 day = 2PI)
--IN        TMO    = Month of year,starting December 15 (0 - 12)
--                   (eg. June 1 := 6.5 )
--IN        RLT    = Latitude (geographic)
--IN        RLTM   = Geomagnetic latitude
--IN        RLGM   = Geomagnetic longitude
--IN        DIP    = Dip angle
--
--#CALLED BY:
--          AMBION
--
--#CALLS TO:
--          TVARF2
--          TVEF1
--
--#TECHNICAL DESCRIPTION:
--          IONFT1 supplies inonospheric parameters for a single
--           ambient layer using a parabolic fit.  This routine is
--           based on Mission Research Corp.'s FORTRAN program HFNET.
--
      ZMAXE, HMAXE, ZMAX1, HMAX1, SDEC, DEC, DELP, SEASN, R, XLAM, CLTM,
         SLTM, ZALF, ZBA, ZBAR, Z, H2, ZP, RATIO, PHIT: float;
--
      Begin

      ZMAXE := 110.0;
      HMAXE := 10.0;
      ZMAX1 := 180.0;
      HMAX1 := 34.0;
      PHIT := PHI;
      SDEC := 0.39795*SIN(PI6*(TMO - 3.167));
      DEC := ASIN(SDEC);
      DELP := ABS(ABS(RLT) - HALFPI);
      If DELP <= 1.0E-03 Then
         SEASN := RLT*DEC;
         If SEASN < 0.0 Then
            PHIT := 0.0;
         Else
            PHIT := PI;
         End If;
      End If;
      R := RZUR/100.0;
--
--CHECK TO SEE IF E- LAYER IS DESIRED, LAYER = 1
      If LAYER = 1 Then
         EMAX := 1.36E5*TVEF1(1.15 ,0.0, 0.4, 2.0, RLT, R, PHIT, DEC);
         ZMAX := ZMAXE;
         THICK := 1.9626*HMAXE;
         Return;
      End If;
--
--NOW TRY FOR THE F1 LAYER.  LAYER = 2
      If LAYER = 2 Then
         XLAM := 1.0 + 0.5*LOG(1.0 + 30.0*R);
         EMAX := 2.44E5*TVEF1(1.24, 0.25, 0.25, XLAM, RLT, R, PHIT, DEC);
         ZMAX := ZMAX1;
         THICK := 1.9626*HMAX1;
         Return;
      End If;
--
--ALL ELSE FAILING, IT MUST BE THE F3 LAYER.
      CLTM := COS(RLTM);
      SLTM := SIN(RLTM);
      ZALF := -4.5*ABS(RLTM) - PI;
      ZBA := 240.0 + 10.0*CLTM*COS(PI*(TMO/3.0 - 1.5));
      ZBAR := ZBA + R*(75.0 + 83.0*CLTM*SDEC*SLTM);
      ZMAX := ZBAR + 30.0*COS(PHIT + ZALF);
      EMAX := 0.66E5*TVARF2(RLTM, RLGM, DIP, R, PHIT, TMO, DEC, CLTM, SLTM);
      Z := ZMAX - 100.0;
      H2 := 0.2*Z + 40.0;
      ZP := -100.0/H2;
      RATIO := EXP(1.0 - ZP - EXP(-ZP));
      THICK := 100.0/SQRT(1.0 - RATIO);
--
      Return;
--
      End IONFT1;
--
--
      Procedure MAGNET (H: in float;
                        COLAT: in float;
                        ELONG: in float;
                        BFELD: out float;
                        SINDIP: out float;
                        SINDEC: out float;
                        COSDEC: out float;
                        COSMAG: out float;
                        ELONMG: out float) is
--
--#PURPOSE: MAGNET calculates the geomagnetic coordinates given the
--          geographic latitude, longitude and altitude of a point.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        H      = Height, Km.
--IN        COLAT  = Colatitude, radians
--IN        ELONG  = Geographic east longitude, radians
--OUT       BFELD  = Magnetic field of Earth
--OUT       SINDIP = Sine of dip angle
--OUT       SINDEC = Sine of declination
--OUT       COSDEC = Cosine of declination
--OUT       COSMAG = Cosine of magnetic longitude
--OUT       ELOMNG = East geomagnetic longitude, radians
--
--#CALLED BY:
--          AMBION
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          MAGNET calculates the geomagnetic coordinates given the
--          geographic latitude, longitude and altitude of a point.
--          This routine is based on Mission Research Corp.'s FORTRAN
--          program HFNET.
--
      SINC, COSC, SINEW, COSEW, ROOT, SINMAG: float;
--
      Begin
--
      SINC := SIN(COLAT);
      COSC := COS(COLAT);
      SINEW := SIN(ELONG + WMERID);
      COSEW := COS(ELONG + WMERID);
      COSMAG := COSC*SINPOL + SINC*COSPOL*COSEW;
      ROOT := SQRT(1.0 + 3.0*COSMAG**2);
      SINMAG := SQRT(1.0 - COSMAG**2);
      BFELD := DIPOLE*(RADIUS_OF_EARTH_IN_KM/
                      (RADIUS_OF_EARTH_IN_KM + H))**3*ROOT;
      SINDIP := 2.0*COSMAG/ROOT;
      If ABS(SINDIP) < 0.1 Then
         SINDIP := SIGN(0.1, SINDIP);
      End If;
      SINDEC := -COSPOL*SINEW/SINMAG;
      COSDEC := (SINPOL - COSC*COSMAG)/(SINC*SINMAG);
      ELONMG:=ATAN2(SINC*SINEW, SINC*SINPOL*COSEW-COSC*COSPOL);
--
      Return;
--
      End MAGNET;
--
--
      Procedure POLAR (PLAT: in float;
                       PLONG: in float;
                       F0E: out float;
                       HME: out float;
                       F0F1: out float;
                       HMF1: out float;
                       F0F2: out float;
                       HMF2: out float) is
--
--#PURPOSE: POLAR calculates ambient ionosphere parameters at high
--          latitudes.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Procedure
--
--#PARAMETER DESCRIPTIONS:
--IN        PLAT   = North latitude (degrees)
--IN        PLONG  = East longitude (degrees)
--OUT       F0E    = Critical frequency for E layer (MHz)
--OUT       HME    = Height of maximum electron density for E layer (Km)
--OUT       F0F1   = Critical frequency for F1 layer (MHz)
--OUT       HMF1   = Height of maximum electron density for F1 layer (Km)
--OUT       F0F2   = Critical frequency for F2 layer (MHz)
--OUT       HMF2   = Height of maximum electron density for F2 layer (Km)
--
--#CALLED BY:
--          IONDAT
--
--#CALLS TO:
--          CGMCS
--          ECALC
--          EDAT
--          EPHT
--          F0F2FN
--          F1CALC
--          HMF2FN
--
--#TECHNICAL DESCRIPTION:
--          POLAR calculates ambient ionosphere parameters at high
--          latitudes.  This routine is based on the RADC-POLAR model.
--
      SEC, XMIN, HOUR, THRL, RSX, EDATE, GMT: float;
--
      Begin
--
      R := FLOAT(AVERAGE_SUN_SPOT_NUMBER);
      GLAT := PLAT;
      GLONG := PLONG;
      SEC := FLOAT(NSEC);
      XMIN := FLOAT(MIN);
      HOUR := FLOAT(NHOUR);
      THRL := HOUR + XMIN/60.0 + SEC/3600.0;
--
--.....UNIVERSAL TIME
--
      GLONG := AMOD(GLONG, 360.0);
      If GLONG < 0.0 Then
         GLONG := GLONG + 360.0;
      End If;
      UTIME := HOUR + ((XMIN + SEC/60.0) - GLONG/15.0);
      If UTIME < 0.0 Then
         UTIME := UTIME + 24.0;
      End If;
--
--COMPUTE SOLAR FLUX
      RSX := R;
      If RSX <= 8.0 Then
         RSX := 8.00001;
      End If;
      SOLFX := 69.0 + 0.38*(RSX - 8.0)**1.17;
      AP := 10.0**(0.25*PMA + 0.4);
--
      EDATE := EDAT;
      EDATE := EPHT(EDATE);
      CGMCS;
      GMT := GMLONG/15.0 + 12.0;
      GMT := AMOD(GMT, 24.0);
      IF GMT < 0.0 Then
         GMT := GMT + 24.0;
      End If;
      ECALC (GMT, F0E, HME);
      F1CALC (F0F1, HMF1);
      F0F2 := F0F2FN (GMT, THRL);
      HMF2 := HMF2FN (GMT);
--
      Return;
--
      End POLAR;
--
--
      Function POLR (RLTM: float;
                     RLGM: float;
                     R: float;
                     PHI: float;
                     TMO: float) return float is
--
--#PURPOSE: POLR calculates geomagnetic influence on density
--          variations for F2 layer.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        RLTM   = Geomagnetic latitude
--IN        RLGM   = Geomagnetic longitude
--IN        R      = Smoothed Zurich sunspot number divided by 100
--IN        PHI    = Time of day in radians( 1 day := 2pi radians )
--IN        TMO    = month, starting December 15 ( 0 - 12 )
--                   (eg. 1 day := 6.5 )
--OUT       POLR   = Geomagnetic influence on density variations
--
--#CALLED BY:
--          TVARF2
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          POLR calculates geomagnetic influence on density
--          variations for F2 layer.  This routine is based on
--          HFNET -- a propagation prediction model for HF as
--          developed by Mission Research Corp.
--
      C: float := -0.4101524;
      T, V, U, Y, YS, Z, ZA, AM, P, WFNCTN, B, POLER: float;
--
      Begin
--
      T := PI12*TMO;
      V := SIN(T);
      U := COS(T + T);
      Y := SIN(RLGM/2.0);
      YS := COS(RLGM/2.0 - PI20);
      Z := SIN(RLGM);
      ZA := SQRT(ABS(Z));
      AM := 1.0 + V;
      If RLTM >= 0.0 Then               --  COMPUTE WEIGHT FUNCTION
         P := RLTM + C*COS(PHI);
         WFNCTN := EXP(-1.2*(COS(P) - COS(RLTM)));
         Return (2.0 + 1.2*R)*WFNCTN*(1.0 + 0.3*V);
      End If;
      B := V*(0.5*Y - 0.5*Z - Y**8) - AM*U*(Z/ZA)*EXP(-4.0*Y*Y);
      POLER := 2.5 + 2.0*R + U*(0.5 + (1.3 + 0.2*R)*YS**4);
      POLER := POLER + (1.3 + 0.5*R)*COS(PHI - PI*(1.0 + B));
      Return POLER*(1.0 + 0.4*(1.0 - V*V))*EXP(-1.0*V*YS**4);
--
      End POLR;
--
--
      Procedure SCALHT (FBAR: in float;
                        F: in float;
                        SOLDEC: in float;
                        GLATR: in float;
                        HA: in float;
                        HEIGHT: in float;
                        TATR: out float;
                        SMULT: out float) is
--
--#PURPOSE: SCALHT calculates a Jacchia model neutral atmosphere.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Procedure
--
--#PARAMETER DESCRIPTIONS:
--IN        FBAR   = Average daily 10.7 cm. solar flux values
--                   over 3 solar rotations
--IN        F      = Value of 10.7 cm. solar flux the previous day
--IN        SOLDEC = Solar declination (radians)
--IN        GLATR  = Geographic latitude (radians)
--IN        HA     = Solar hour angle (radians)
--IN        HEIGHT = Altitude (Km)
--OUT       TATR   = Temperature
--OUT       SMULT = Scale height
--
--#CALLED BY:
--          HMF2FN
--
--#CALLS TO:
--          DENS
--          EXOT
--
--#TECHNICAL DESCRIPTION:
--          SCALHT calculates a Jacchia model neutral atmosphere.
--          The method used is based on the RADC-POLAR model.
--
      TINF: float;
--
      Begin
--
      TINF := EXOT(FBAR,F,SOLDEC,GLATR,HA);
      DENS (TINF, HEIGHT, TATR, SMULT);
--
      Return;
--
      End SCALHT;
--
--
--
      Function TABINT (K: integer;
                       I: integer;
                       J: integer) return float is
--
--#PURPOSE: TABINT replaces the 13286 element TABLE1 sequential
--          data file with a 730 element data array. The values for
--          TABLE1 are regenerated by interpolation.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Table Look-up
--
--#PARAMETER DESCRIPTIONS:
--IN        K      = Coordinate type where-
--                      1 = latitude, and
--                      2 = longitude.
--IN        I      = Polar latitude index (degrees*2).
--IN        J      = Polar longitiude index (degrees*2).
--OUT       TABINT = Geomagnetic coordinate.
--
--#CALLED BY:
--          FETCH
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          Aitken's iteration method is used to  interpolate between
--          the data array values. Depending on the polar latitude,
--          a polynomial of degree two or three is used.
--
      POLE: array (integer range 1..2, integer range 1..2) of float :=
         ((81.69, -74.13),
         (171.12, 17.07));
      F0, F1, F2, F01, F02, F012, F3, F03, F023, F0123, F4, F6, F5, F56,
         F46, F456, F36, F346, F3456, RESULT: float;

      Function DETERM (A: float; B: float;
                      IC: integer; ID: integer) return float is
--
--STATEMENT FUNCTION FOR SECOND ORDER DETERMINANT AS USED BY Function TABINT.
--
--    DETERM(A, B, IC, ID) := A*ID - B*IC
--
      Begin
--
         Return A*FLOAT(ID) - B*FLOAT(IC);
--
      End DETERM;
--
      Begin
      If I <= 24 Then
         F0 := POLE(K, 1);
         F1 := FARKLER.FARKLE(1,J,K);
         F2 := FARKLER.FARKLE(2,J,K);
         F01 := (1.0/3.0)*DETERM(F0, F1, 1-I, 4-I);
         F02 := (1.0/23.0)*DETERM(F0, F2, 1-I, 24-I);
         F012 := (1.0/20.0)*DETERM(F01, F02, 4-I, 24-I);
         RESULT := F012;
         If I <= 4 Then
            Return RESULT;
         End If;
         F3 := FARKLER.FARKLE(3,J,K);
         F03 := (1.0/43.0)*DETERM(F0, F3, 1-I, 44-I);
         F023 := (1.0/20.0)*DETERM(F02, F03, 24-I, 44-I);
         F0123 := (1.0/40.0)*DETERM(F012, F023, 4-I, 44-I);
         RESULT := F0123;
         Return RESULT;
      Elsif I <= 69 Then
         F2 := FARKLER.FARKLE(2,J,K);
         F4 := FARKLER.FARKLE(4,J,K);
         RESULT := (1.0/45.0)*DETERM(F2, F4, 24-I, 69-I);
         Return RESULT;
      Else
         F6 := POLE(K, 2);
         F5 := FARKLER.FARKLE(5,J,K);
         If F5 > 360.0 Then
            F6 := F6 + 360.0;
         End If;
         F4 := FARKLER.FARKLE(4,J,K);
         F56 := (1.0/2.0)*DETERM(F5, F6, 89-I, 91-I);
         F46 := (1.0/22.0)*DETERM(F4, F6, 69-I, 91-I);
         F456 := (1.0/20.0)*DETERM(F46, F56, 69-I, 89-I);
         RESULT := F456;
         If I >= 89 Then
            Return RESULT;
         End If;
         F3 := FARKLER.FARKLE(3,J,K);
         F36 := (1.0/47.0)*DETERM(F3, F6, 44-I, 91-I);
         F346 := (1.0/25.0)*DETERM(F36, F46, 44-I, 69-I);
         F3456 := (1.0/45.0)*DETERM(F346, F456, 44-I, 89-I);
         RESULT := F3456;
         Return RESULT;
      End If;
--
      End TABINT;
--
--
      Function TATRFN (TINF: float; HEIGHT: float) return float is
--
--#PURPOSE: TATRFN calculates temperatures of the atmosphere
--          after the F2 layer at a specific height.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        TINF   = Exospheric temperature
--IN        HEIGHT = Height at which temperature is calculated
--OUT       TATRFN = Temperature at altitude HEIGHT
--
--#CALLED BY:
--          DENS
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          TATRFN is based on the RADC-POLAR model.
--
      C90: array (integer range 1..4) of float := (1.9, 0.0, -1.7, -0.8);
      C1: float := 371.6678;
      C2: float := 0.0518806;
      C3: float := -294.3505;
      C4: float := -0.00216222;
      Z90: float := 90.0;
      Z125: float := 125.0;
      BX: float := 4.5E-6;
      BETA: float := 2.5;
      PIBY2: float := 1.57079633;
      F2, DBDT, F1, F3, DGDT, DZI, F4, AX, DZEX, ARG, GXR, DADT, RESULT: float;
--
      Begin
--
      TX := TINF;
--                           TB := C1 + C2*TINF + C3*EXP(C4*TINF)
--                           GX := C90(1)*(TB - T90)/(Z125 - Z90)
      F2 := EXP(C4*TINF);
      TB := C1 + C2*TINF + C3*F2;
      DBDT := C2 + C3*C4*F2;
      F1 := TB - T90;
      F3 := C90(1)/(Z125 - Z90);
      GX := F1*F3;
      DGDT := DBDT*F3;
      If HEIGHT > Z90 Then
         DZI := HEIGHT - Z125;
         If DZI < 0.0 Then
            DZI := DZI/(Z125 - Z90);
--                           RESULT := TB + (TB - T90)*DZI*(C90(1) +
--                                     DZI*(C90(2) + DZI*(C90(3) + DZI*C90(4))
            F4 := DZI*(C90(1) + DZI*(C90(2) + DZI*(C90(3) + DZI*C90(4))));
            RESULT := TB + F1*F4;
            DTDR := F1*(C90(1) + DZI*(2.0*C90(2) + DZI*(3.0*C90(3) +
                    DZI*4.0*C90(4))))/(Z125 - Z90);
            DTDT := DBDT + DBDT*F4;
            TR := RESULT;
            Return RESULT;
         Elsif DZI = 0.0 Then
            RESULT := TB;
            DTDR := GX;
            DTDT := DBDT;
            TR := RESULT;
            Return RESULT;
         Else
            AX := (TINF - TB)/PIBY2;
            DZEX := BX*(DZI**BETA);
            ARG := (GX/AX)*DZI*(1.0 + DZEX);
            GXR := GX*((1.0 + DZEX) + BETA*DZEX);
            DADT := (1.0 - DBDT)/PIBY2;
            F4 := ATAN(ARG);
            RESULT := TB + AX*F4;
            DTDT := DBDT + DADT*F4 + (DGDT*AX/GX - DADT)*ARG/(1.0 + ARG*ARG);
            DTDR := GXR/(1.0 + ARG*ARG);
            TR := RESULT;
            Return RESULT;
         End If;
      End If;
      DTDR := (T90 - T0)/Z90;
      DTDT := 0.0;
      RESULT := T0 + DTDR*HEIGHT;
      TR := RESULT;
      Return RESULT;
--
      End TATRFN;
--
--
      Function TVARF2 (RLTM: float;
                       RLGM: float;
                       DIP: float;
                       R: float;
                       PHI: float;
                       TMO: float;
                       DEC: float;
                       CLTM: float;
                       SLTM: float) return float is
--
--#PURPOSE: TVARF2 calculates seasonal and hourly variabilty
--          of density for the F2 layer.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        RLTM   = Geomagnetic latitude
--IN        RLGM   = Geomagnetic longitude
--IN        DIP    = Dip angle
--IN        R      = Sunspot number divided by 100
--IN        PHI    = Time of day in radians; (1day := 2pi radians)
--IN        TMO    = Month (0-12; starting from december 15;
--                   e. g. June 1 := 6.5)
--IN        DEC    = Declination angle of sun
--IN        CLTM   = Cosine of geomagnetic latitude
--IN        SLTM   = Sine of geomagnetic latitude
--OUT       TVARF2 = Density for F2 layer variation
--
--#CALLED BY:
--          IONFT1
--
--#CALLS TO:
--          POLR
--          YONII
--
--#TECHNICAL DESCRIPTION:
--          TVARF2 is based on HFNET -- an HF propagation prediction code
--          developed by Mission Research Corp.
--
      SHIFT, ALTM, ATMO, SEMI, REQ, SD, X, FF, GG, CPD, EF, EMF, ADIUR,
         BQ, AQE, AQT, AEQ, EQ, VEQ, VDIUR, VLT, RTL, VLAT, RF, CQ, VUT,
         POLER, ER, VLONG, ADIP, DP, VDP, VDIP, F2, RESULT: float;
--
      Begin
      SHIFT := 1.2217305;
      ALTM := ABS(RLTM);
      ATMO := TMO*PI6;
      SEMI := 0.5 - COS(2.0*ATMO) + COS(ATMO);
      REQ := 1.0 - 0.2*R + 0.6*SQRT(R);
      SD := SIN(DEC)*SIN(RLTM);
      X := (2.2 + (0.2 + 0.1*R)*SLTM)*CLTM;
      X := AMIN1(X, 2.0);
      FF := EXP(-X**6);
      GG := 1.0-FF;
      CPD := COS(PHI - 0.873);
      EF := COS(PHI + PI4);
      EMF := EF*EF;
      ADIUR := (0.9 + 0.32*SD)*(1.0 + SD*EMF);
      BQ := COS(ALTM - 0.2618);
      AQE := CLTM**8;
      AQT := AQE*CLTM*CLTM;
      AEQ := AQE*REQ*EXP(0.25*(1.0 - CPD));
      EQ := (1.0 - 0.4*AQT)*(1.0+AEQ*BQ**12)*(1.0 + 0.6*AQT*EMF);
      VEQ := EQ*(1.0 + 0.05*SEMI);
      VDIUR := ADIUR*EXP(-1.1*(CPD + 1.0));
      VLT := (EXP(3.0*COS(RLTM*(SIN(PHI) - 1.0)/2.0)))*(1.2 - 0.5*CLTM*CLTM);
      VLT := VLT*(1.0 + 0.05*R*COS(ATMO)*SLTM**3);
      RTL := SQRT((12.0*RLTM+PI43)**2 + (TMO/2.0 - 3.0)**2);
      VLAT := VLT*(1.0 - 0.15*EXP(-RTL));
      RF := 1.0 + R + (0.204 + 0.03*R)*R*R;
      If R - 1.1 > 0.0 Then
         CQ := 1.53*SLTM*SLTM;
         RF := 2.39+CQ*(RF - 2.39);
      End If;
      VUT := YONII(RLTM, RF, R, PHI, TMO, DEC, CLTM, SLTM);
      POLER := POLR(RLTM, RLGM, R, PHI, TMO);
      VLONG := 1.0 + 0.1*(CLTM**3)*COS(2.0*(RLGM - SHIFT));
      ADIP := ABS(DIP);
      DP :=  0.15 - 0.5*(1.0 + R)*(1.0 - CLTM)*EXP(-0.33*(TMO - 6.0)**2);
      VDP := 1.0 + DP*EXP(-18.0*(ADIP - PI29)**2);
      VDIP := VDP*(1.0 + 0.03*SEMI);
      F2 := VDIUR*VLAT*VUT*VEQ*RF*VLONG*VDIP;
      Return FF*POLER+GG*F2;
--
      End TVARF2;
--
      Function TVEF1 (A: float;
                      B: float;
                      C: float;
                      D: float;
                      RLT: float;
                      R: float;
                      PHI: float;
                      DEC: float) return float is
--
--#PURPOSE: TVEF1 calculates seasonal and hourly variation
--          of density function for the E and F1 layers.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        A      = Parameter (= 1.15 for E layer, := 1.24 for
--                   F1 layer)
--IN        B      = Parameter (= 0 for both E and F1)
--IN        C      = Parameter (= .4 for E and .25 for F1 layer)
--IN        D      = parameter (= 2. for E and .25 for F1 layer)
--IN        RLT    = Latitude
--IN        R      = The smootheed Zurich sunspot number divided
--                   by 100.
--IN        PHI    = Time of day in radians; (1day := 2pi radians)
--IN        DEC    = Declination angle of sun
--OUT       TVEF1  = Density for E, F1 layer variation
--
--#CALLED BY:
--          IONFT1
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          TVEF1 is based on HFNET -- an HF propagation
--          prediction code developed by Mission Research Corp.
--
      RF, CSL, CSX, CSX2, XF, P, VUT, VDIUR: float;
--
      Begin
--
      RF := SQRT(1.0 + A*R+B*R*R);
      CSL := COS(RLT);
      CSX := -CSL*COS(DEC)*COS(PHI) + SIN(RLT)*SIN(DEC);
      CSX2 := SQRT(ABS(CSX));
      XF := SIGN(CSX2,CSX);
--
--COMPUTE WEIGHT FUNCTION
      P := RLT + DEC*COS(PHI);
      VUT := EXP(-C*(COS(P) - COS(RLT)));
--
      VDIUR := EXP(D*(XF - 1.0));
      Return RF*VDIUR*VUT;
--
      End TVEF1;
--
--
      Function YONII (RLTM: float;
                      RF: float;
                      R: float;
                      PHI: float;
                      TMO: float;
                      DEC: float;
                      CLTM: float;
                      SLTM: float) return float is
--
--#PURPOSE: YONII is used in the calculation of density
--          variations for the F2 layer.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        RLTM   = Geomagnetic latitude
--IN        RF     = Variation due to sunspot number at specified
--                   magnetic latitude
--IN        R      = Sunspot number divided by 100
--IN        PHI    = Time of day in radians; 1day := 2pi radians
--IN        TMO    = Month of year
--IN        DEC    = Declination angle of sun
--IN        CLTM   = Cosine of geomagnetic latitude
--IN        SLTM   = Sine of geomagnetic latitude
--OUT       YONII  = Density variations for F2 layer
--
--#CALLED BY:
--          TVARF2
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          YONII is based on HFNET -- an HF propagation
--          prediction model developed by Mission Research Corp.
--
      W1, W2, B, DRF, DE, ALTM, SNX, AE, BLTM, SX, FE, YM, CPHG, XTC, YTC, T1,
         TRIV, QQ, P, WFNCTN, T2, T3: float;
--
      Begin
--
      W1 := 0.5235988;
      W2 := 1.047198;
      B := 1.3 + (0.139*(1.0 + COS(RLTM - PI4)) + 0.0517*R)*R*R;
      DRF := 1.0/RF;
      DE := 0.1778*R*R;
      ALTM := ABS(RLTM);
      SNX := SIN(ALTM - 0.5236);
      AE := 0.2*(1.0 - SNX);
      BLTM := ABS(ALTM - PI9);
      SX := SIN(BLTM);
      FE := 0.13 - 0.06*SX;
      YM := COS(RLTM + DEC);
      CPHG := COS(PHI);
      XTC := YM**3*(1.0 - CPHG)**0.25;
      YTC := -(0.15 + 0.3*SIN(ALTM))*XTC;
      T1 := AE*(1.0 + 0.6*COS(W2*(TMO - 4.0)))*COS(W1*(TMO - 1.0));
      TRIV := (COS(RLTM - W1))*(COS(W1*(0.5*TMO - 1.0)))**3;
      TRIV := TRIV + (COS(RLTM + PI4))*(COS(W1*(0.5*TMO - 4.0)))**2;
      QQ := 1.0 + 0.085*TRIV;
--
--COMPUTE WEIGHT FUNCTION
      P := RLTM + DEC*COS(PHI);
      WFNCTN := EXP(-B*(COS(P) - COS(RLTM)));
--
      T2 := 0.7*(QQ + DE*DRF*COS(W2*(TMO - 4.3)))*WFNCTN;
      T3 := FE*COS(W2*(TMO - 4.5)) + YTC;
      Return (T1 + T3)*DRF + T2;
--
      End YONII;
--
--
End HF_ATMOSPHERICS;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--RFUTIL
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Debugger2; Use Debugger2;
With Text_IO; Use Text_io, integer_io, float_io;
With Types; Use Types;
With Mathlib; Use Mathlib, numeric_primitives,
                           core_functions, trig_functions;
With Complex_numbers; Use complex_numbers;
With Constants; Use Constants;
With Propagation_constants; use Propagation_constants;
With Constant3; Use Constant3;
With NODELOC;

Package RFUTIL is
--
      Function ADJBW (FREQT: float;
                      BANDT: float;
                      FREQR: float;
                      BANDR: float)
                      return float;
      Function AOW (FREQ: float; ELV: float) return float;
      Procedure COORDX (HO: in float;
                        MODE: in integer;
                        RXSE: in float;
                        AYAA: in float;
                        HZEH: in float;
                        R: out float;
                        A: out float;
                        H: out float;
                        X: out float;
                        Y: out float;
                        Z: out float;
                        S: out float;
                        E: out float);
      Function CTANH (VAL: complex) return complex;
      Procedure DAYNIT (IDN: out DAY_OR_NIGHT;
                        TLON: in float;
                        RLON: in float);
      Procedure DNTR;
      Procedure GNDCON (XLAT: in float;
                        XLONG: in float;
                        COND: out float);
      Function HTOS (H1: float;
                     H2: float;
                     COSE: float;
                     SINE: float) return float;
      Function LOS (XLA1: float;
                    XLO1: float;
                    AL1: float;
                    XLA2: float;
                    XLO2: float;
                    AL2: float) return boolean;
      Function PLYVAL (YARRAY: F_ARRAY;
                       MAXY: integer;
                       X: float) return float;
      Procedure ZENITH (XLAT: in float;
                        XLONG: in float;
                        CHI: out float;
                        TOD: out float;
                        IDN: out DAY_OR_NIGHT);
--
End RFUTIL;
--
Package body RFUTIL is
--
-- RF_UTILITIES Package of PROP_LINK
-- Version 1.0,  March 12, 1985.
--
-- This RF_UTILITIES Package contains all of the procedures that are used
-- as RF propagation utilities.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
-- Instantiate integer and floating point IO.
--      Package IO_INTEGER is new INTEGER_IO(INTEGER);
--      Package IO_FLOAT is new FLOAT_IO(FLOAT);
-- Use IO_INTEGER,IO_FLOAT;
--
      Pragma Source_info(on);
      Function ADJBW (FREQT: float;
                      BANDT: float;
                      FREQR: float;
                      BANDR: float)
                      return float is
--
--#PURPOSE:ADJBW computes an adjustment factor for possible bandwidth mismatch.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Module
--
--#PARAMETER DESCRIPTIONS:
--IN        FREQT  = Frequency of transmitter
--IN        BANDT  = Bandwidth of transmitter
--IN        FREQR  = Frequency of receiver
--IN        BANDR  = Bandwidth of receiver
--OUT       ADJBW  = Adjustment factor
--
--#CALLED BY:
--          RF_PROPAGATION_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          A comparison is made between the frequency of the transmitter
--          and the frequency of the receiver -- considering the impact of
--          overlap caused by non-equal bandwidths.  An adjustment factor
--          is computed based on the degree of this overlap.
--
      OFFSET: float;
--
      Begin
--
      OFFSET := ABS(FREQT - FREQR);
--
--NO OVERLAP BETWEEN BANDS.
      If 2.0*OFFSET  >=  BANDT + BANDR Then
         Return 0.0;
      End If;
--
--RECEIVER BAND WITHIN TRANSMITTER BAND.
      If 2.0*OFFSET + BANDR <= BANDT Then
         Return 1.0;
      End If;
--
--TRANSMITTER BAND WITHIN RECEIVER BAND.
      If 2.0*OFFSET + BANDT <= BANDR Then
         Return BANDT/BANDR;
      End If;
--
--BANDS OVERLAP.
      Return ((BANDR + BANDT)*0.5 - OFFSET)/BANDR;
--
      End ADJBW;
--
--
      Function AOW (FREQ: float; ELV: float) return float is
--
--#PURPOSE: AOW calculates the absorption due to oxygen and water
--          vapor for a path which passes through the atmosphere.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        FREQ   = Frequency in MHz
--IN        ELV    = Elevation angle of path in radians
--OUT       AOW    = Absorption, dB
--
--#CALLED BY:
--          VHF_UHF_SHF_EHF_HANDLER
--
--#CALLS TO:
--          PLYVAL
--
--#TECHNICAL DESCRIPTION:
--          Curve fits for the absorption due to water and oxygen
--          have been represented by 5th order polynomials for
--          frequencies from 100MHz to 54 GHz.  For frequencies
--          between 100MHz and 20GHz, a simple formulation is
--          employed.  For frequencies between 20GHz and 54GHz, direct
--          5th order polynomial fits of AOW versus frequency are
--          used.
--
      PCOEFF: F_ARRAY (integer range 1..6)
      := (-0.1133607, -0.4605316, 0.2858249, 2.37588, 0.3513365, -2.849912);
      COEFFK: F_ARRAY(integer range 1..6)
      := (-0.1260167, -0.587672, -0.2332291, 1.184484, -1.476704, -3.377323);
      BOUNDS: F_ARRAY (integer range 1..6)
      := (1.570796, 1.0, 0.5, 0.2, 0.1, 0.05);
      COEFS: array (integer range 1..6, integer range 1..6) of float
      := ((0.5759213E-6,  -0.1058284E-3,      0.7698042E-2,
          -0.2740164,      0.4744495E1,      -0.3163005E2),
          (0.635214E-6,   -0.1144331E-3,      0.8143891E-2,
          -0.2839701,      0.4817095E1,      -0.3140205E2),
          (0.6259988E-7,  -0.9344444E-5,      0.5452778E-3,
          -0.9251671E-2,  -0.1647310,         0.5061962E1),
          (0.3834260E-5,  -0.6391562E-3,      0.4176852E-1,
          -0.1328056E1,    0.2041086E2,      -0.1189484E3),
         (-0.4923502E-5,   0.8537153E-3,     -0.5817072E-1,
           0.1956157E1,   -0.3258934E2,       0.2189743E3),
          (0.1668294E-4,  -0.2963053E-2,      0.2077701,
          -0.7180226E1,    0.1221736E3,      -0.8126215E3));
      COEF: F_ARRAY(integer range 1..6);
      FLOG, ELOG, PLOG, P, CAY, ELE, ELEMAX, ELEMIN, DBMIN,
                                              DBMAX, RATIO: float;
      I, II, J, K: Integer;
--
      Begin
--
      If FREQ <= 100.0 Then
         Return 0.0;
      End If;
      If FREQ < 2.1E4 Then
         FLOG := LOG10(FREQ);
         ELOG := LOG10(AMAX1(ELV,0.001));
         PLOG := PLYVAL(PCOEFF,6,ELOG);
         P:=4.3 + 10.0**PLOG;
         CAY := PLYVAL(COEFFK,6,ELOG);
         CAY := 10.0**CAY;
         Return CAY*(1.0/(P - FLOG) - 1.0/(P - 2.0));
      Else
         FLOG := AMIN1(5.4E4,FREQ);
         FLOG := FLOG*0.001;
         For I in 1..5 Loop
            II := I;
            J := I + 1;
            ELE := AMAX1(ELV,0.05);
            Exit When (ELE >= BOUNDS(J) and ELE <= BOUNDS(I));
         End Loop;
         ELEMAX := BOUNDS(II);
         ELEMIN := BOUNDS(J);
         For K in 1..6 Loop
            COEF(K) := COEFS(K,II);
         End Loop;
         DBMIN := PLYVAL(COEF,6,FLOG);
         For K in 1..6 Loop
            COEF(K) := COEFS(K,J);
         End Loop;
         DBMAX := PLYVAL(COEF,6,FLOG);
         RATIO := (ELEMIN - ELE)/(ELEMIN - ELEMAX);
         Return DBMAX - RATIO*(DBMAX - DBMIN);
      End If;
--
      End AOW;
--
--
      Procedure COORDX (HO: in float;
                        MODE: in integer;
                        RXSE: in float;
                        AYAA: in float;
                        HZEH: in float;
                        R: out float;
                        A: out float;
                        H: out float;
                        X: out float;
                        Y: out float;
                        Z: out float;
                        S: out float;
                        E: out float) is
--
--#PURPOSE: COORDX performs geometrical transformations on the
--          coordinates of a point given in any one of several systems
--          and returns the coordinates in all of the systems.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Geometric Transformation
--
--#PARAMETER DESCRIPTIONS:
--IN        HO     = Altitude of the origin of the coordinate
--                   system (Km)
--IN        MODE   = 1, 2, 3, 4
--IN        RXSE   = Ground range (Km), X(East,(Km)), Slant
--                   range(Km), Elevation(Degrees)
--IN        AWAA   = Azimuth (Degrees), Y (North, Km),
--                   Azimuth (Degrees), Azimuth (Degrees)
--IN        HZEH   = Altitude (Km), Z (Up, Km)
--                   Elevation (Degrees), Altitude(Km)
--OUT       R      = Ground range
--OUT       A      = Azimuth
--OUT       H      = Altitude
--OUT       X      = Tangent-plane coordinate
--OUT       Y      = Tangent-plane coordinate
--OUT       Z      = Tangent-plane coordinate
--OUT       S      = Slant range
--OUT       E      = Elevation angle
--
--#CALLED BY:
--          IONCAL
--          NOISE_HANDLER
--          VHF_UHF_SHF_EHF_HANDLER
--
--#CALLS TO:
--          HTOS
--
--#TECHNICAL DESCRIPTION:
--          COORDX performs geometrical transformations on the
--          coordinates of a point given in any one of several systems
--          and returns the coordinates in all of the systems.
--          The input MODE determines how the input data is to be treated
--          so that the proper trigonometric conversions can be made.
--
--            MODE              INPUTS
--            ____              ______
--             1              Ground range, Azimuth and Altitude
--             2              X,Y,Z tamgent plane coordinates
--             3              Slant range, Azimuth and Elevation
--             4              Elevation, Azimuth and Altitude
--
      REH, U0, U1, U2, U3: float;
      COSE, SINE: float;
--
      Begin
--
      REH := RADIUS_OF_EARTH_IN_KM + HO;
--
      If MODE = 1 Then   --  SURFACE RANGE, AZIMUTH, ALTITUDE GIVEN
         R := RXSE;
         A := AYAA;
         H := HZEH;
         U0 := R/RADIUS_OF_EARTH_IN_KM;
         U2 := A*RADIANS_PER_DEGREE;
         U3 := RADIUS_OF_EARTH_IN_KM + H;
         U1 := U3*SIN(U0);
         X := U1*SIN(U2);
         Y := U1*COS(U2);
         Z := U3*COS(U0) - REH;
         If U0 = 0.0 Then
            Z := H - HO;
         End If;
         If U1 = 0.0 Then
            S := ABS(Z);
            E := 90.0;
            If Z < 0.0 Then
               E := -90.0;
            End If;
         Else
            S := SQRT(U1**2 + Z**2);
            E := ASIN(Z/S)*DEGREES_PER_RADIAN;
         End If;
         Return;
      End If;
--
      If MODE = 2 Then  --  X,Y,Z COORDINATES GIVEN
         X := RXSE;
         Y := AYAA;
         Z := HZEH;
         U1 := X**2 + Y**2;
         If U1 = 0.0 Then
            R := 0.0;
            A := 0.0;
            H := HO + Z;
            S := ABS(Z);
            E := 90.0;
            If Z < 0.0 Then
               E := -90.0;
            End If;
         Else
            U2 := REH + Z;
            U3 := SQRT(U1 + U2**2);
            U1 := SQRT(U1);
            R := ASIN(U1/U3)*RADIUS_OF_EARTH_IN_KM;
            If U2 < 0.0 Then
               R := PI*RADIUS_OF_EARTH_IN_KM - R;
            End If;
            A := ASIN(X/U1)*DEGREES_PER_RADIAN;
            If Y < 0.0 Then
               A := 180.0 - A;
            End If;
            H := U3 - RADIUS_OF_EARTH_IN_KM;
            S := SQRT(U1**2 + Z**2);
            E := ASIN(Z/S)*DEGREES_PER_RADIAN;
         End If;
         Return;
      End If;
--
      If MODE = 3 Then  --  SLANT RANGE, AZIMUTH, ELEVATION GIVEN
         S := RXSE;
         A := AYAA;
         E := HZEH;
         U2 := A*RADIANS_PER_DEGREE;
         U3 := E*RADIANS_PER_DEGREE;
         U1 := S*COS(U3);
         X := U1*SIN(U2);
         Y := U1*COS(U2);
         Z := S*SIN(U3);
         U2 := REH + Z;
         U3 := SQRT(U1**2 + U2**2);
         R := ASIN(U1/U3)*RADIUS_OF_EARTH_IN_KM;
         If U2 < 0.0 Then
            R := PI*RADIUS_OF_EARTH_IN_KM - R;
         End If;
         H := U3 - RADIUS_OF_EARTH_IN_KM;
         Return;
      End If;
--
      If MODE = 4 Then  --  ELEVATION, AZIMUTH, ALTITUDE GIVEN
         E := RXSE;
         A := AYAA;
         H := HZEH;
         U2 := A*RADIANS_PER_DEGREE;
         U3 := E*RADIANS_PER_DEGREE;
         COSE := COS(U3);
         SINE := SIN(U3);
         S := HTOS (HO, H, COSE, SINE);
         U1 := S*COSE;
         X := U1*SIN(U2);
         Y := U1*COS(U2);
         Z := S*SINE;
         U3 := RADIUS_OF_EARTH_IN_KM + H;
         R := ASIN(U1/U3)*RADIUS_OF_EARTH_IN_KM;
         If REH + Z < 0.0 Then
            R := PI*RADIUS_OF_EARTH_IN_KM - R;
         End If;
      End If;
      Return;
--
      End COORDX;
--
--
      Function CTANH (VAL: complex) return complex is
--
--#PURPOSE: CTANH computes complex hyperbolic tangent.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        VAL    = Input value array (a complex number)
--OUT       CTANH  = Computed complex hyperbolic tangent array
--                   (a complex number)
--
--#CALLED BY:
--          REFCAL
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          CTANH computes complex hyperbolic tangent using:
--
--             CTANH = CMPLX(SINH(X), SIN(Y))/(COSH(X) + COS(Y))
--
--              where:
--                 X := 2.0*AREAL(VAL)     the real part
--                 Y := 2.0*AIMAG(VAL)     the imaginary part
--
      X, Y: float;
--
      Begin
--
      X := 2.0*AREAL(VAL);
      Y := 2.0*AIMAG(VAL);
      If X <= 86.0 Then
         Return (CMPLX(SINH(X), SIN(Y))/(COSH(X) + COS(Y)));
      Else
         Return CMPLX(1.0, 0.0);
      End If;
--
      End CTANH;
--
--
      Procedure DAYNIT (IDN: out DAY_OR_NIGHT;
                        TLON: in float;
                        RLON: in float) is
--
--#PURPOSE: DAYNIT determines whether transmission on a given link
--          is in daytime, nighttime, or mixed day-night conditions.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--OUT       IDN    = Indicator as to whether day or night
--                   conditions prevail over the link;
--IN        TLON   = Transmitter longitude in degrees east
--IN        RLON   = Receiver longitude in degrees east
--
--#CALLED BY:
--          ELF_HANDLER
--          LF_HANDLER
--          REFCAL
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          The day-night indicator is set according to the sun
--          conditions prevailing at the longitude midway between the
--          transmitter and the receiver.  The seasonal tilt of the
--          earth's axis is ignored.
--
      NHR, III: integer;
      SUNRIS, SUNSET, T1, T2, CENLON: float;
--
      Begin
--
      NHR := INTEGER(REFERENCE_TIME/100.0);
      SUNRIS := -90.0 - FLOAT(NHR)*15.0 -
                (REFERENCE_TIME - 100.0*FLOAT(NHR))*0.25 -
                 CURRENT_TIME*0.25;
      Loop
         Exit When SUNRIS > -180.0;
         SUNRIS := SUNRIS + 360.0;
      End Loop;
      SUNSET := SUNRIS + 180.0;
      If SUNSET > 180.0 Then
         SUNSET := SUNSET - 360.0;
      End If;
      If SUNRIS >= SUNSET Then
         III := 1;
         T1 := SUNRIS;
         T2 := SUNSET;
      Else
         III := 0;
         T1 := SUNSET;
         T2 := SUNRIS;
      End If;
      CENLON := (TLON + RLON)*0.5;
      If ABS(TLON - RLON) > 180.0 Then
         CENLON := CENLON + 180.0;
         If CENLON > 180.0 Then
            CENLON := CENLON - 360.0;
         End If;
      End If;
      If CENLON >= T1  and  CENLON <= T2 Then
         III := 1 - III;
      End If;
      If III = 0 Then
         IDN := NIGHT;
      Else
         IDN := DAY;
      End If;
--
      Return;
--
      End DAYNIT;
--
--
      Procedure DNTR is
--
--#PURPOSE: DNTR determines if and where a day-night terminator
--          crosses a transmitter/receiver path.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--OUT       IDNT & IDNR (globally visible -- see technical description)
--
--#CALLED BY:
--          ELF_HANDLER
--          MF_HF_HANDLER
--          VLF_HANDLER
--
--#CALLS TO:
--          LOCNEW
--          ZENITH
--
--#TECHNICAL DESCRIPTION:
--          Subroutine ZENITH is used to determine IDNT and IDNR.
--          If both are in day or night, the other outputs are set and
--          there is a return to the calling program.  If IDNT /=
--          IDNR, a terminator crosses the path.  The location of the
--          terminator is established by iteration on LOCNEW and ZENITH.
--          Each iteration divides the path in half until the location
--          of the intersection of the terminator and communication
--          path is known within 100 Km.  All output from DNTR is via
--          the globally visible variables IDNT and IDNR.
--
      IT: array (integer range 1..3) of DAY_OR_NIGHT;
      DX: array (integer range 1..3) of float;
      ERR, XLAT, XLON, CHI, TOD: float;
--
      Begin
--
      DISTOT := DPATH;
      ZENITH (TLAT, TLON, CHI, TOD, IT(1));
      IDNT := IT(1);
      ZENITH (RLAT, RLON, CHI, TOD, IT(3));
      IDNR := IT(3);
      TRBRNG := BRNG1;
      RTBRNG := BRNG2;
      DISDAY := DPATH;
      DISNIT := 0.0;
      TERLAT := -1000.0;
      TERLON := -1000.0;
      If IDNT = NIGHT and IDNR = NIGHT Then
          DISDAY := 0.0;
          DISNIT := DPATH;
      End If;
      If IDNT = IDNR Then
         Return;
      End If;
--
--  FIND DAY-NIGHT TERMINATOR.
      DX(1) := 0.0;
      DX(3) := DPATH;
      DX(2) := 0.5*DPATH;
--
      Loop
         NODELOC.LOCNEW (TLAT, TLON, BRNG1, DX(2), XLAT, XLON);
         ZENITH (XLAT, XLON, CHI, TOD, IT(2));
         If IT(2) = IT(1) Then
            DX(1) := DX(2);
         End If;
         If IT(2) = IT(3) Then
            DX(3) := DX(2);
         End If;
         DX(2) := (DX(1) + DX(3))*0.5;
         ERR := ABS((DX(3) - DX(2))/DPATH);
         Exit When ERR <= 1.0E-5;
      End Loop;
      NODELOC.LOCNEW (TLAT, TLON, BRNG1, DX(2), TERLAT, TERLON);
      DISDAY := DX(2);
      If IDNT = NIGHT Then
          DISDAY := DPATH - DISDAY;
      End If;
      DISNIT := DPATH - DISDAY;
      End DNTR;
--
--
      Procedure GNDCON (XLAT: in float;
                        XLONG: in float;
                        COND: out float) is
--
--#PURPOSE: GNDCON computes the ground conductivity at a location
--          on the earth's surface, given the latitude and longitude
--          of the location.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Table Look-up.
--
--#PARAMETER DESCRIPTIONS:
--IN        XLAT   = Latitude (north positive)
--IN        XLONG  = Longitude (east positive)
--OUT       COND   = Ground conductivity in Mhos/m.
--
--#CALLED BY:
--          MF_HF_HANDLER
--          LF_HANDLER
--          VLF_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          A ground gonductivity map has been specified with
--          a granularity of 5 degrees (i.e., the map is separated
--          into 5 degree X 5 degree boxes) with one of eight
--          conductivity code numbers is assigned to each box.
--          A ground conductivity is associated with each code
--          number.
--
--          When the latitude and longitude of a location
--          are input, the appropriate box is referenced.  The ground
--          conductivity associated with the conductivity code of this
--          referenced box is returned to the calling routine.
--
      SIGMA: array (integer range 1..8) of float
      := (1.0E-5, 1.0E-4, 3.0E-4, 1.0E-3, 3.0E-3, 1.0E-2, 5.0E-2, 4.0);
      IA, IB, ILAT, ILONG, ICODE: integer;
      XLAT_TEMP: float:=XLAT;

--DATA TO DEFINE THE GROUND CONDUCTIVITY MAP:
--
      NCODE: array (integer range 1..72, integer range 1..36) of integer
      :=((8,  8,  8,  8,  8,  8,  8,  8,  6,  7,  8,  7,
          7,  5,  6,  6,  5,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  3,  1,  1,  1),
         (8,  8,  8,  8,  8,  6,  7,  7,  7,  8,  8,  7,
          7,  5,  7,  6,  5,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  2,  1,  1,  1),
         (8,  8,  6,  3,  7,  6,  7,  7,  6,  8,  8,  7,
          7,  7,  7,  7,  5,  5,  5,  6,  6,  6,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  2,  1,  1,  1),
         (8,  8,  5,  8,  6,  6,  7,  7,  7,  7,  8,  8,
          7,  6,  7,  7,  6,  5,  6,  6,  6,  6,  5,  6,
          7,  8,  8,  8,  8,  8,  8,  8,  2,  1,  1,  1),
         (8,  7,  6,  8,  6,  6,  7,  7,  7,  6,  7,  8,
          7,  7,  6,  5,  5,  5,  6,  6,  7,  7,  7,  6,
          7,  8,  8,  8,  8,  8,  8,  8,  2,  1,  1,  1),
         (8,  8,  8,  7,  5,  6,  6,  6,  7,  7,  7,  8,
          7,  7,  6,  5,  5,  5,  5,  6,  6,  6,  5,  6,
          7,  8,  8,  8,  8,  8,  8,  8,  2,  1,  1,  1),
         (8,  8,  8,  8,  6,  6,  7,  7,  7,  8,  6,  8,
          6,  6,  6,  5,  7,  5,  5,  5,  5,  5,  7,  7,
          8,  8,  8,  8,  8,  8,  8,  6,  2,  1,  1,  1),
         (8,  8,  8,  8,  6,  7,  7,  7,  7,  8,  7,  7,
          7,  6,  5,  6,  6,  5,  5,  5,  5,  6,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  2,  1,  1,  1),
         (8,  8,  8,  8,  7,  7,  7,  7,  7,  6,  7,  7,
          6,  5,  6,  6,  6,  7,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  5,  2,  1,  1,  1),
         (8,  8,  8,  8,  7,  7,  7,  7,  7,  7,  6,  7,
          7,  7,  7,  7,  7,  8,  8,  8,  7,  6,  6,  8,
          8,  8,  8,  8,  8,  8,  8,  4,  2,  1,  1,  1),
         (8,  8,  8,  6,  7,  7,  7,  7,  7,  8,  7,  6,
          7,  7,  7,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  3,  1,  1,  1,  1),
         (8,  8,  7,  5,  6,  6,  6,  5,  7,  7,  6,  7,
          7,  7,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  4,  1,  1,  1,  1),
         (8,  7,  5,  8,  5,  6,  6,  6,  7,  7,  7,  7,
          7,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  4,  2,  2,  1,  1),
         (8,  8,  6,  7,  5,  7,  7,  7,  7,  7,  6,  7,
          7,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  5,  3,  2,  1,  1),
         (8,  8,  8,  6,  5,  6,  7,  7,  7,  7,  5,  7,
          7,  6,  7,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  5,  2,  2,  1,  1),
         (8,  8,  8,  6,  5,  6,  7,  7,  7,  7,  5,  5,
          7,  6,  6,  6,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  5,  2,  2,  1,  1),
         (8,  8,  8,  6,  5,  6,  7,  7,  7,  7,  6,  6,
          6,  6,  7,  8,  7,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  4,  1,  2,  1,  1),
         (8,  8,  8,  5,  5,  6,  7,  6,  6,  7,  5,  6,
          6,  7,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  3,  1,  1,  1,  1),
         (8,  7,  7,  5,  4,  5,  5,  5,  5,  7,  6,  6,
          5,  7,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  3,  1,  1,  1,  1),
         (8,  8,  6,  5,  4,  5,  6,  4,  5,  7,  7,  6,
          6,  6,  7,  8,  8,  7,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  2,  1,  1,  1,  1),
         (8,  8,  5,  4,  4,  5,  6,  5,  4,  7,  7,  7,
          6,  6,  7,  7,  8,  8,  7,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  2,  1,  1,  1,  1),
         (8,  8,  6,  4,  4,  5,  5,  5,  5,  7,  7,  7,
          7,  7,  7,  7,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  3,  1,  1,  1,  1),
         (8,  8,  7,  5,  4,  5,  4,  4,  5,  7,  7,  7,
          6,  7,  8,  8,  8,  7,  7,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  3,  1,  1,  1,  1),
         (8,  8,  8,  5,  4,  5,  3,  4,  5,  7,  7,  7,
          6,  8,  8,  8,  8,  7,  8,  8,  8,  8,  5,  5,
          5,  8,  8,  8,  8,  8,  8,  3,  1,  1,  1,  1),
         (8,  8,  8,  5,  5,  5,  3,  4,  5,  7,  8,  8,
          8,  8,  8,  8,  8,  8,  7,  8,  8,  7,  5,  5,
          5,  8,  8,  8,  8,  8,  8,  3,  1,  1,  1,  1),
         (8,  8,  8,  6,  5,  5,  4,  4,  5,  5,  6,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  5,  6,  6,
          8,  8,  8,  8,  8,  8,  8,  3,  1,  1,  2,  2),
         (8,  8,  8,  7,  5,  5,  4,  4,  6,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  7,  6,  6,  6,
          8,  8,  8,  8,  8,  8,  8,  3,  1,  1,  2,  2),
         (8,  8,  7,  7,  5,  5,  4,  6,  7,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  7,  8,  8,  6,  6,  7,
          6,  8,  8,  8,  8,  8,  8,  3,  1,  1,  2,  2),
         (8,  8,  7,  6,  5,  5,  7,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  7,  8,  7,  7,  7,
          7,  7,  8,  8,  8,  8,  8,  3,  1,  1,  3,  2),
         (8,  8,  8,  6,  5,  5,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  7,  7,  7,
          6,  7,  8,  8,  8,  8,  8,  4,  2,  1,  3,  2),
         (8,  8,  8,  7,  5,  5,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  7,
          7,  8,  8,  8,  8,  8,  8,  5,  2,  2,  3,  2),
         (8,  8,  8,  7,  5,  5,  7,  7,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  2,  3,  3,  2),
         (8,  8,  8,  8,  5,  5,  7,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  3,  4,  3,  2),
         (8,  8,  8,  8,  5,  5,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  4,  5,  3,  2),
         (8,  8,  8,  8,  5,  6,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  5,  4,  2),
         (8,  8,  8,  8,  5,  6,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  5,  4,  2),
         (8,  8,  8,  8,  5,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  6,  4,  3),
         (8,  8,  8,  8,  6,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  6,  4,  3),
         (8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  6,  4,  2),
         (8,  8,  8,  8,  5,  6,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  5,  4,  2),
         (8,  8,  8,  8,  5,  6,  7,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  5,  4,  2),
         (8,  8,  8,  8,  5,  6,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  4,  3,  2),
         (8,  8,  8,  8,  5,  6,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  3,  3,  2),
         (8,  8,  8,  8,  5,  6,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  2,  2,  2),
         (8,  8,  8,  8,  6,  6,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  2,  2,  2),
         (8,  8,  8,  8,  5,  6,  6,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  2,  2,  2),
         (8,  8,  8,  8,  5,  6,  6,  6,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  5,  2,  2,  2),
         (8,  8,  7,  5,  5,  6,  7,  6,  7,  7,  7,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  5,  2,  2,  2),
         (8,  8,  5,  5,  4,  5,  7,  5,  6,  6,  6,  7,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  6,  1,  2,  2),
         (8,  8,  5,  4,  4,  4,  6,  7,  7,  7,  7,  7,
          7,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  6,  1,  1,  2),
         (8,  8,  6,  5,  4,  4,  5,  7,  7,  7,  7,  7,
          6,  7,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  7,  1,  1,  2),
         (8,  8,  5,  6,  4,  4,  4,  7,  7,  7,  7,  7,
          7,  6,  7,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  5,  1,  1,  2),
         (8,  8,  4,  5,  4,  4,  4,  6,  6,  7,  7,  7,
          7,  7,  7,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  4,  1,  1,  2),
         (8,  6,  4,  4,  3,  5,  6,  5,  5,  7,  7,  7,
          8,  8,  7,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  4,  1,  2,  2),
         (8,  5,  4,  4,  4,  8,  8,  5,  6,  7,  7,  7,
          8,  8,  7,  7,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  4,  2,  2,  2),
         (8,  4,  3,  3,  5,  6,  8,  7,  5,  7,  5,  5,
          7,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  4,  2,  2,  2),
         (8,  3,  4,  3,  6,  5,  4,  4,  5,  7,  5,  8,
          8,  8,  8,  8,  7,  7,  7,  7,  3,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  4,  2,  2,  2),
         (8,  3,  6,  4,  3,  4,  3,  3,  4,  6,  8,  8,
          8,  8,  8,  8,  7,  7,  7,  7,  6,  7,  8,  8,
          7,  7,  7,  6,  6,  8,  8,  8,  3,  3,  2,  2),
         (8,  5,  3,  8,  3,  5,  3,  3,  5,  8,  8,  8,
          8,  8,  8,  8,  6,  5,  6,  7,  7,  6,  5,  5,
          6,  7,  7,  7,  8,  8,  8,  5,  3,  3,  2,  2),
         (8,  5,  2,  8,  4,  8,  5,  3,  7,  8,  8,  8,
          8,  8,  8,  8,  6,  5,  6,  6,  6,  6,  7,  7,
          7,  7,  7,  8,  8,  8,  7,  3,  3,  3,  2,  2),
         (8,  4,  1,  8,  8,  8,  8,  5,  6,  8,  8,  8,
          8,  8,  8,  8,  7,  5,  6,  6,  6,  7,  7,  7,
          7,  8,  8,  8,  8,  8,  7,  8,  8,  4,  2,  2),
         (8,  4,  1,  2,  4,  8,  8,  8,  7,  8,  8,  8,
          8,  8,  8,  8,  8,  5,  6,  5,  6,  7,  7,  7,
          7,  8,  8,  8,  8,  8,  8,  8,  8,  4,  2,  2),
         (8,  3,  1,  1,  1,  2,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  7,  6,  5,  6,  6,  7,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  5,  3,  2),
         (8,  3,  1,  1,  1,  2,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  7,  6,  5,  5,  6,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  5,  3,  2),
         (8,  3,  1,  1,  2,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  7,  5,  7,  7,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  5,  3,  2),
         (8,  3,  1,  1,  3,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  4,  2,  2),
         (8,  4,  1,  1,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  3,  2,  2),
         (8,  5,  2,  3,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  6,  3,  2,  2),
         (8,  5,  6,  8,  8,  7,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  4,  2,  2,  2),
         (8,  6,  8,  8,  8,  8,  8,  8,  8,  8,  8,  8,
          7,  5,  6,  6,  6,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  4,  2,  2,  2),
         (8,  8,  8,  8,  8,  8,  8,  8,  8,  7,  7,  7,
          6,  6,  7,  5,  5,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8,  8,  3,  2,  2,  2),
         (8,  8,  8,  8,  8,  8,  7,  8,  7,  7,  7,  7,
          7,  7,  7,  5,  5,  8,  8,  8,  8,  8,  8,  8,
          8,  8,  8,  8,  8,  8,  8, 8 ,  3,  2,  2,  2));

--
      Begin
--
      IA := 1;
      IB := 1;
      If XLAT < 0.0 Then
         IA := 0;
      End If;
      If XLONG < 0.0 Then
         IB := 0;
      End If;
      If XLAT = 90.0 Then
         XLAT_TEMP := 89.0;
      End If;
      If XLAT = -90.0 Then
         XLAT_TEMP := -89.0;
      End If;
--
      ILAT := INTEGER(TRUNCATE(XLAT_TEMP/5.0));
      ILAT := ILAT + IA;
      ILONG := INTEGER(TRUNCATE(XLONG/5.0));
      ILONG := ILONG + IB;
      ILAT := 19 - ILAT;
      If XLONG < 0.0 Then
         ILONG := 72 + ILONG;
      End If;
--
      ICODE := NCODE(ILONG, ILAT);
      COND := SIGMA(ICODE);
--
      Return;
--
      End GNDCON;
--
--
      Function HTOS (H1: float;
                     H2: float;
                     COSE: float;
                     SINE: float) return float is
--
--#PURPOSE: HTOS computes the slant range between two points, given
--          their altitudes and the elevation angle of point 2 with
--          respect to point 1.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        H1     = Altitude of point 1 in km
--IN        H2     = Altitude of point 2 in km
--IN        COSE   = Elevation of point 2 with respect to point1, cosine
--IN        SINE   = Elevation of point 2 with respect to point1, sine
--OUT       HTOS   = Slant range between the points in km
--
--#CALLED BY:
--          COORDX
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          HTOS computes the slant range between two points, given
--          their altitudes and the elevation angle of point 2 with
--          respect to point 1.  Standard spherical trigonometry is
--          used to perform the computation.
--
      R1, R2, SIND, COSD: float;
--
      Begin
--
      R1 := RADIUS_OF_EARTH_IN_KM + H1;
      R2 := RADIUS_OF_EARTH_IN_KM + H2;
      SIND := R1*COSE/R2;
      SIND := AMIN1(SIND,1.0);
      COSD := SQRT(1.0 - SIND**2);
      Return R2*COSD - R1*SINE;
--
      End HTOS;
--
--
      Function LOS (XLA1: float;
                    XLO1: float;
                    AL1: float;
                    XLA2: float;
                    XLO2: float;
                    AL2: float) return boolean is
--
--#PURPOSE: LOS determines if there is a line-of-sight path between
--          a point above the earth's surface and point on or above
--          the earth's surface.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        XLA1   = Latitude of first point in radians
--IN        XLO1   = Longitude of first point in radians
--IN        AL1    = Altitude of first point in kilometers
--IN        XLA2   = Latitude of second point in radians
--IN        XLO2   = Longitude of second point in radians
--IN        AL2    = Altitude of second point in kilometers
--OUT       LOS    = TRUE or FALSE as to whether line-of-sight exists
--
--#CALLED BY:
--          RF_PROPAGATION_HANDLER
--          VHF_UHF_SHF_EHF_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          This routine first determines which point is higher and
--          makes it point 1.  The remaining point becomes point 2.
--          The routine operates by determining the angular
--          width, A, of the cone subtended by the earth at point l as
--          well as the distance, DISN, from point 1 to a tangential
--          intersection with the earth.  Point 2 is in line-of-sight
--          from point 1 if either point 2 is outside the shadow cone
--          subtended by the earth or if point 2 is closer than the
--          tangential distance, DISN.
--
      PONE: array (integer range 1..3) of float;
      PTWO: array (integer range 1..3) of float;
      XLAT1, XLON1, ALT1, RHO1, XLAT2, XLON2, ALT2, RHO2: float;
      A1, A2, B1, B2, C1, C2: float;
      DISC, DISO, DISN, COSA, A, H, COSB: float;
--
      Begin
--
--  TEST FOR COLOCATION
      If (XLA1 = XLA2 and XLO1 = XLO2 and AL1 = AL2) Then
         Return TRUE;
      End If;
--  CONVERT TO ECI COORDINATES
      If (AL2 - AL1) >= 0.0 Then
         XLAT1 := XLA1;
         XLON1 := XLO1;
         ALT1 := AL1;
         XLAT2 := XLA2;
         XLON2 := XLO2;
         ALT2 := AL2;
      Else
         XLAT1 := XLA2;
         XLON1 := XLO2;
         ALT1 := AL2;
         XLAT2 := XLA1;
         XLON2 := XLO1;
         ALT2 := AL1;
      End If;
--
      RHO1 := RADIUS_OF_EARTH_IN_KM + ALT1;
      PONE(1) := RHO1*COS(XLAT1)*COS(XLON1);
      PONE(2) := RHO1*COS(XLAT1)*SIN(XLON1);
      PONE(3) := RHO1*SIN(XLAT1);
      RHO2 := RADIUS_OF_EARTH_IN_KM + ALT2;
      PTWO(1) := RHO2*COS(XLAT2)*COS(XLON2);
      PTWO(2) := RHO2*COS(XLAT2)*SIN(XLON2);
      PTWO(3) := RHO2*SIN(XLAT2);
--
--  FIND DIRECTION NUMBERS FOR EARTH CENTER TO TRANSMITTER AND
--  TRANSMITTER TO RECEIVER VECTORS
      A1 := -PONE(1);
      A2 := PTWO(1) - PONE(1);
      B1 := -PONE(2);
      B2 := PTWO(2) - PONE(2);
      C1 := -PONE(3);
      C2 := PTWO(3) - PONE(3);
--
--  RESPECTIVE DISTANCES OF POINTS IN SPACE
      DISC := RADIUS_OF_EARTH_IN_KM + ALT1;
      DISO := SQRT(A2**2 + B2**2 + C2**2);
      DISN := SQRT(ALT1**2 + 2.0*ALT1*RADIUS_OF_EARTH_IN_KM);
--
--  ANGLE OF EARTH SHADOW
      COSA := DISN/DISC;
--
--  DIRECTION COSINE FOR LOS ANGLE
      A := A1*A2 + B1*B2 + C1*C2;
      H := DISC*DISO;
      COSB := A/H;
--
--  CAN TRANSMITTER SEE RECEIVER?
      If DISO <= DISN Then
         Return TRUE;
      End If;
      If COSA <= COSB Then
         Return FALSE;
      Else
         Return TRUE;
      End If;
--
      End LOS;
--
--
      Function PLYVAL (YARRAY: F_ARRAY;
                       MAXY: integer;
                       X: float) return float is
--
--#PURPOSE: PLYVAL evaluates a general polynomial in one variable.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        YARRAY = The array of coefficients, highest order
--                   first
--IN        MAXY   = The number of coefficients in the polynomial
--                   including the zeroth order coefficient
--                   (= n + 1)
--IN        X      = The value of the independent variable at
--                   which the polynomial is to be calculated
--OUT       PLYVAL = The value of the polynomial (= f(x))
--
--#CALLED BY:
--          AOW
--          IONCAL
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          PLYVAL evaluates a general polynomial in one variable.
--          A simple LOOP with a summation step is employed.
--
      SUM: float;
      I: integer;
--
      Begin
--
      SUM := YARRAY(1);
      For I in 2..MAXY Loop
         SUM := SUM*X + YARRAY(I);
      End Loop;
      Return SUM;
--
      End PLYVAL;
--
--
      Procedure ZENITH (XLAT: in float;
                        XLONG: in float;
                        CHI: out float;
                        TOD: out float;
                        IDN: out DAY_OR_NIGHT) is
--
--#PURPOSE: ZENITH calculates the local time of day and the solar
--          zenith angle and determines whether it is day or night.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        XLAT   = Latitude in degrees north
--IN        XLONG  = Longitude in degrees east
--OUT       CHI    = Solar zenith angle in degrees
--OUT       TOD    = Local time of day in hours
--OUT       IDN    = Day/Night indicator
--
--#CALLED BY:
--          DNTR
--          MF_HF_HANDLER
--          NOISE_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          Local time of day, TOD is calculated from:
--
--               TOD = (T+RT)/3600.0 + XLONG/15.0
--
--               Where:
--                     T = Current time in seconds
--                     RT = GMT reference time in seconds
--
--          Solar zenith angle, CHI is then calculated and if
--          less than or equal to 90 degrees it is deemed to be
--          daytime, otherwise it is night.
--
      T, RT, GT, SLAT, SLONG: float;
      NHR: integer;
--
      Begin
--
      T := CURRENT_TIME*60.0;
      NHR := INTEGER(REFERENCE_TIME*0.01);
      RT := (REFERENCE_TIME - FLOAT(NHR)*40.0)*60.0;
      GT := (T + RT)/3600.0;
      TOD := GT + XLONG/15.0;
      Loop
         Exit When TOD > 0.0;
         TOD := TOD + 24.0;
      End Loop;
      Loop
         Exit When TOD < 24.0;
         TOD := TOD - 24.0;
      End Loop;
--
--  SOLAR SUB POINT LAT - LONG, DEGREES
      SLAT := - 23.5*COS(FLOAT(MONTH)*PI6);
      SLONG := 180.0 - 15.0*GT;
--
--  ZENITH CALCULATION
      CHI := ACOS(SIN(SLAT*RADIANS_PER_DEGREE)*SIN(XLAT*RADIANS_PER_DEGREE) +
             COS(SLAT*RADIANS_PER_DEGREE)*COS(XLAT*RADIANS_PER_DEGREE)*
             COS(RADIANS_PER_DEGREE*(SLONG - XLONG)))/RADIANS_PER_DEGREE;
--
--  DAY VS NIGHT
      IDN := NIGHT;
      If CHI <= 90.0 Then
         IDN := DAY;
      End If;
--
      Return;
--
      End ZENITH;
--
--
End RFUTIL;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--ELFLFHFA
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Debugger2; Use Debugger2;
With Mathlib; Use Mathlib, numeric_primitives,
              core_functions,trig_functions;
With Rfutil;
With Propagation_constants; use Propagation_constants;
With COMPLEX_NUMBERS; use COMPLEX_NUMBERS;
With Constants;use Constants;

Package ELF_LF_HF_ATMOSPHERICS is
--
      Type IONO_LAYERS is array (integer range 1..20) of float;

      Procedure ATMOSD (MODE: in integer;
                        H: in float;
                        RHO: out float;
                        HS: out float;
                        TEM: out float;
                        CONN2: out float;
                        CONO2: out float;
                        CONO: out float;
                        WTMOL: out float);

      Procedure CHEMD (H: in float;
                       NDI: in DAY_OR_NIGHT;
                       RHO: in float;
                       TEM: in float;
                       CONN2: in float;
                       CONO2: in float;
                       CONO: in float;
                       ALPHAD: out float;
                       ALPHAI: out float;
                       A: out float;
                       D: out float;
                       VEAIR: out float;
                       VEOX: out float;
                       VIAIR: out float);

      Function FITRAT (C1: float; C2: float; C3: float; C4: float; DH: float)
                      return float;

      Procedure IONCAL (XLAT: in float;
                        XLON: in float;
                        TIME: in float;
                        IDN: in DAY_OR_NIGHT;
                        EN: out IONO_LAYERS;
                        PN: out IONO_LAYERS;
                        VEAIR: out IONO_LAYERS;
                        VIAIR: out IONO_LAYERS);

      Procedure IONOSD (HC: in float;
                        NDI: in DAY_OR_NIGHT;
                        ALPHAD: in float;
                        ALPHAI: in float;
                        A: in float;
                        D: in float;
                        QA: out float;
                        ENPQ: out float;
                        ENEQ: out float);

      Procedure REFCAL (XLAT: in float;
                        XLON: in float;
                        TIME: in float;
                        FREQ: in float;
                        HXR: out float;
                        ALP1: out float);
--
--
End ELF_LF_HF_ATMOSPHERICS;
--
Package body ELF_LF_HF_ATMOSPHERICS is
--
-- ELF_LF_HF_ATMOSPHERICS Package of PROP_LINK
-- Version 1.0,  April 21, 1985.
--
-- This ELF_LF_HF_ATMOSPHERICS Package contains all of the procedures that
-- are used to compute the behavior of the ionosphere for ELF & LF
-- propagation, as well as some of the procedures required for HF propagation.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
--      Instantiate integer and floating point IO.
--      Package IO_INTEGER is new INTEGER_IO(INTEGER);
--      Package IO_FLOAT is new FLOAT_IO(FLOAT);
--      Use IO_INTEGER,IO_FLOAT;
--
      Pragma Source_info (on);
--
      Procedure ATMOSD (MODE: in integer;
                        H: in float;
                        RHO: out float;
                        HS: out float;
                        TEM: out float;
                        CONN2: out float;
                        CONO2: out float;
                        CONO: out float;
                        WTMOL: out float) is
--
--#PURPOSE: ATMOSD calculates the atmospheric properties at a point
--          below 120Km.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        MODE   = 1...Return full set of output quantities
--                   0...Return only density, scale height,
--                     and temperature
--IN        H      = Altitude of point (Km)
--OUT       RHO    = Density (gm/(CM**3))
--OUT       HS     = Local density scale height (Km) Scale height
--                   provided is not the same as CIRA 1965
--                   pressure scale heights.
--OUT       TEM    = Temperature in degrees Kelvin
--OUT       CONN2  = Nitrogen concentration (/(CM**3))
--OUT       CONO2  = (Oxygen)2 concentration (/(CM**3))
--OUT       CONO   = (Oxygen) + (Oxygen)3 concentration
--                   (/(CM**3))
--OUT       WTMOL  = Mean molecular weight
--
--#CALLED BY:
--          IONCAL
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          ATMOSD is a natural atmosphere model that computes the
--          atmospheric properties from 0 to 50 Km using the 1962
--          U.S. Standard Atmosphere model and from 50 to 120Km using
--          the CIRA (CCSPAR International Reference Atmospheres)
--          2965 mean atmosphere model.  The routine uses internally
--          defined tabularized data and linear interpolation to
--          provide fast accurate calculations.
--
--
      ISD: integer;
      HSA: array (integer range 1..61) of float;
--
--  DENSITY (0 TO 120 KM, 2 KM INTERVALS)
      RHOA: array (integer range 1..61) of float
      := (1.225E-3, 1.007E-3, 8.194E-4, 6.601E-4, 5.258E-4, 4.135E-4,
          3.119E-4, 2.279E-4, 1.665E-4, 1.217E-4, 8.891E-5, 6.451E-5,
          4.694E-5, 3.426E-5, 2.508E-5, 1.841E-5, 1.356E-5, 9.887E-6,
          7.258E-6, 5.367E-6, 3.996E-6, 2.995E-6, 2.259E-6, 1.714E-6,
          1.317E-6, 1.041E-6, 8.271E-7, 6.543E-7, 5.151E-7, 4.034E-7,
          3.142E-7, 2.433E-7, 1.873E-7, 1.433E-7, 1.090E-7, 8.234E-8,
          6.199E-8, 4.629E-8, 3.427E-8, 2.513E-8, 1.825E-8, 1.276E-8,
          8.926E-9, 6.245E-9, 4.369E-9, 3.058E-9, 2.091E-9, 1.445E-9,
          1.009E-9, 7.114E-10, 5.062E-10, 3.570E-10, 2.557E-10, 1.858E-10,
          1.367E-10, 1.019E-10, 7.354E-11, 5.449E-11, 4.127E-11, 3.186E-11,
          2.501E-11);
--  TEMPERATURE (0 TO 120 KM, 2 KM INTERVALS)
      TEMPA: array (integer range 1..61) of float
      := (288.2, 275.2, 262.2, 249.2, 236.2, 223.3, 216.7, 216.7, 216.7,
          216.7, 216.7, 218.6, 220.6, 222.5, 224.5, 226.5, 228.5, 233.7,
          239.3, 244.8, 250.4, 255.9, 261.4, 266.9, 270.7, 271.0, 265.5,
          259.9, 254.4, 248.8, 243.3, 238.0, 232.6, 227.3, 221.9, 216.6,
          210.5, 204.4, 198.2, 192.1, 186.0, 186.0, 185.9, 185.9, 185.9,
          185.8, 190.9, 195.9, 200.4, 204.4, 208.1, 215.7, 224.6, 233.4,
          242.3, 251.1, 271.9, 292.7, 313.1, 334.0, 355.0);
--  O + O3 CONCENTRATION (0 TO 120 KM, 2 KM INTERVALS)
      CONOA: array (integer range 1..61) of float
      := (1.0E+10, 1.5E+10, 2.75E+10, 4.8E+10, 8.0E+10, 1.3E+11, 2.0E+11,
          3.1E+11, 4.8E+11, 7.2E+11, 1.0E+12, 1.65E+12, 2.25E+12, 2.8E+12,
          2.9E+12, 3.0E+12, 2.75E+12, 2.25E+12, 1.8E+12, 1.3E+12, 8.0E+11,
          5.5E+11, 3.25E+11, 1.95E+11, 1.15E+11, 7.0E+10, 4.6E+10, 3.4E+10,
          2.7E+10, 2.3E+10, 2.0E+10, 1.95E+10, 1.95E+10, 2.0E+10, 2.05E+10,
          2.15E+10, 2.3E+10, 2.65E+10, 3.0E+10, 3.5E+10, 4.0E+10, 5.0E+10,
          6.0E+10, 7.6E+10, 1.0E+11, 1.25E+11, 1.68E+11, 2.66E+11, 4.10E+11,
          4.8E+11, 5.0E+11, 4.76E+11, 4.05E+11, 3.21E+11, 2.51E+11, 2.0E+11,
          1.64E+11, 1.35E+11, 1.13E+11, 9.25E+10, 7.6E+10);
--  N2 CONCENTRATION (80 TO 120 KM, 2 KM INTERVALS)
      CONN2A: array (integer range 1..21) of float
      := (2.963E+14, 2.072E+14, 1.449E+14, 1.014E+14, 7.095E+13, 4.965E+13,
          3.544E+13, 2.349E+13, 1.626E+13, 1.146E+13, 8.178E+12, 5.704E+12,
          4.060E+12, 2.950E+12, 2.174E+12, 1.620E+12, 1.164E+12, 8.606E+11,
          6.513E+11, 5.057E+11, 4.008E+11);
--  O2 CONCENTRATION (80 TO 120 KM, 2 KM INTERVALS)
      CONO2A: array (integer range 1..21) of float
      := (7.950E+13, 5.559E+13, 3.888E+13, 2.721E+13, 1.906E+13, 1.332E+13,
          9.188E+12, 6.146E+12, 4.296E+12, 2.936E+12, 1.994E+12, 1.359E+12,
          9.443E+11, 6.693E+11, 4.809E+11, 3.492E+11, 2.443E+11, 1.757E+11,
          1.292E+11, 9.744E+10, 7.495E+10);
--  MEAN MOLECULAR WEIGHT (80 TO 120 KM, 2 KM INTERVALS)
      WTMOLA: array (integer range 1..21) of float
      := (28.96, 28.96, 28.95, 28.95, 28.95, 28.94, 28.89, 28.83, 28.70,
          28.52, 28.30, 28.02, 27.92, 27.82, 27.74, 27.66, 27.49, 27.34,
          27.19, 27.08, 27.01);
--
      Z, X: float;
      I: integer;
--
      Begin
--
      Z := H;
--
--COMPUTE DENSITY SCALE HEIGHTS.
      If ISD /= 1 Then
         ISD := 1;
         For I in 2..60 Loop
            HSA(I) := 4.0/LOG(RHOA(I-1)/RHOA(I+1));
         End Loop;
         HSA(1) := 2.0*HSA(2) - HSA(3);
         HSA(61) := 8.3;
      End If;
--
--INTERPOLATE FOR DENSITY, SCALE HEIGHT, AND TEMPERATURE.
      I := MIN(MAX(INTEGER(TRUNCATE(Z/2.0)) + 1, 1), 60);
      X := (Z - 2.0*FLOAT(I-1))/2.0;
      RHO := RHOA(I)*(RHOA(I+1)/RHOA(I))**X;
      HS := HSA(I) + (HSA(I+1) - HSA(I))*X;
      TEM := TEMPA(I) + (TEMPA(I+1) - TEMPA(I))*X;
      If MODE = 0 Then
         Return;
      End If;
--
--INTERPOLATE FOR NUMBER DENSITIES AND MEAN MOLECULAR WEIGHT.
      CONO := CONOA(I)*(CONOA(I+1)/CONOA(I))**X;
      If (Z - 80.0) <= 0.0 Then
         CONN2 := 1.6236E+22*RHO;
         CONO2 := 4.3562E+21*RHO;
         WTMOL := 28.96;
      Else
         I := I - 40;
         CONN2 := CONN2A(I)*(CONN2A(I+1)/CONN2A(I))** X;
         CONO2 := CONO2A(I)*(CONO2A(I+1)/CONO2A(I))**X;
         WTMOL := WTMOLA(I) + (WTMOLA(I+1) - WTMOLA(I))*X;
      End If;
      Return;
--
      End ATMOSD;
--
--
      Procedure CHEMD (H: in float;
                       NDI: in DAY_OR_NIGHT;
                       RHO: in float;
                       TEM: in float;
                       CONN2: in float;
                       CONO2: in float;
                       CONO: in float;
                       ALPHAD: out float;
                       ALPHAI: out float;
                       A: out float;
                       D: out float;
                       VEAIR: out float;
                       VEOX: out float;
                       VIAIR: out float) is
--
--
--#PURPOSE: CHEMD computes deionization reaction rate coefficients
--          for a point below 100 Km.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        H      = Altitude of Point (Km)
--IN        NDI    = Day/night indicator
--IN        RHO    = Mass density (GM/CM**-3)
--IN        TEM    = Gas temperature (deg. Kelvin)
--IN        CONN2  = Nitrogen concentration (CM**-3
--IN        CONO2  = (Oxygen)2 concentraion (CM**-3)
--IN        CONO   = (Oxygen) + (Oxygen)3 concentration (CM**-3)
--OUT       ALPHAD = Electron-ion recombination rate
--                   coefficient (CM**3/sec)
--OUT       ALPHAI = ION-ION recombination rate coefficient
--                   (CM**3/sec-)
--OUT       A      = Attachment rate (sec**-1)
--OUT       D      = Detachment rate (sec**-1)
--OUT       VEAIR  = Electronic molecule collision frequency
--                   (sec**-1)
--OUT       VEOX   = Electron atom collision frequency (sec**-1)
--OUT       VIAIR  = Ion molecule collision frequency (sec**-1)
--
--#CALLED BY:
--          IONCAL
--
--#CALLS TO:
--          FITRAT
--
--#TECHNICAL DESCRIPTION:
--          An altitude index is computed by dividing the input
--          altitude by the increment (5Km) between reference
--          altitudes for which data is stored.  If the input
--          altitude is within 0.5Km of a reference altitude,
--          stored values are returned for the reaction rates
--          corresponding to the altitude index computed.  If
--          the input altitude differs from the reference
--          altitude by more than 0.5Km, Function FITRAT is
--          called and interpolated values for reaction rates
--          are returned.
--
      AN: array (integer range 1..20) of float
      := (2.19E+07, 5.42E+06, 1.04E+06, 2.38E+05, 5.00E+04, 1.08E+04,
          2.43E+03, 5.81E+02, 1.50E+02, 4.30E+01, 1.27E+01, 3.58E+00,
          9.94E-01, 3.23E-01, 1.80E-01, 1.11E-01, 4.13E-02, 1.31E-02,
          3.35E-03, 9.23E-04);
      DN: array (integer range 1..20) of float
      := (1.00E-11, 1.00E-11, 1.00E-11, 1.73E-11, 1.01E-10, 3.93E-10,
          2.34E-09, 1.69E-08, 7.47E-08, 2.31E-07, 1.29E-07, 1.66E-07,
          3.60E-07, 7.44E-07, 3.58E-04, 5.07E-01, 8.46E+00, 2.92E+01,
          9.44E+01, 1.49E+02);
      ALIN: array (integer range 1..20) of float
      := (3.00E-08, 3.00E-08, 3.00E-08, 3.00E-08, 3.00E-08,
          3.00E-08, 3.00E-08, 3.00E-08, 3.01E-08, 3.03E-08,
          3.06E-08, 3.11E-08, 3.21E-08, 3.51E-08, 5.55E-08,
          1.95E-07, 2.00E-07, 2.00E-07, 2.00E-07, 2.00E-07);
      ALDN: array (integer range 1..20) of float
      := (7.00E-6,  7.00E-6,  7.00E-6,  7.00E-6,  7.00E-6,
          7.00E-6,  7.00E-6,  7.00E-6,  6.99E-6,  6.98E-6,
          6.97E-6,  6.94E-6,  6.89E-6,  6.75E-6,  5.94E-6,
          6.09E-07, 4.88E-07, 4.85E-07, 4.54E-07, 4.32E-07);
      AD: array (integer range 1..20) of float
      := (2.19E+07, 5.47E+06, 1.04E+06, 2.38E+05, 5.00E+04, 1.08E+04,
          2.43E+03, 5.81E+02, 1.50E+02, 4.30E+01, 1.27E+01, 3.50E+00,
          8.95E-01, 2.10E-01, 4.48E-02, 8.53E-03, 1.56E-03, 4.27E-04,
          4.84E-04, 6.61E-04);
      DD: array (integer range 1..20) of float
      := (1.01E-2,  1.01E-2,  1.01E-2,  1.01E-2,  1.01E-2,
          1.01E-2,  1.01E-2,  1.05E-2,  1.27E-2,  2.63E-2,
          8.06E-2,  3.64E-1,  1.76,    4.88,    8.46,
          12.4,    20.7,    37.9,    99.4,    150.0);
      ALID: array (integer range 1..20) of float
      := (3.00E-08, 3.00E-08, 3.00E-08, 3.00E-08, 3.00E-08,
          3.00E-08, 3.00E-08, 3.00E-08, 3.00E-08, 3.01E-08,
          3.04E-8,  3.57E-8,  8.96E-8,  1.57E-7,  1.86E-7,
          1.97E-07, 2.00E-07, 2.00E-07, 2.00E-07, 2.00E-07);
      ALDD: array (integer range 1..20) of float
      := (7.00E-6,  7.00E-6,  7.00E-6,  7.00E-6,  7.00E-6,
          7.00E-6,  7.00E-6,  7.00E-6,  7.00E-6,  7.00E-6,
          6.98E-6,  6.76E-6,  4.54E-6,  1.92E-6,  9.12E-7,
          5.80E-07, 4.92E-07, 4.85E-07, 4.54E-07, 4.32E-07);
--
      RHO2, ENOFO, TS, X, HX, DX, DH: float;
      I, INTRP: integer;
--
      Begin
--
--  NUMBER DENSITY OF ATOMIC OXYGEN,DAYTIME
      RHO2:= RHO**2;
      ENOFO:= 1.3E-13*CONO/(RHO2 + 1.3E-13);
      If NDI /= DAY Then  --  NUMBER DENSITY OF ATOMIC OXYGEN, NIGHTTIME
         TS := 2.0E4;
         X := 4.0E10*RHO2*TS;
         If X > 85.0 Then
            ENOFO := 0.0;
         End If;
         If  X <= 85.0 Then
            ENOFO := ENOFO * EXP(-X);
         End If;
      End If;
      INTRP := 0;
      I := integer(TRUNCATE((H + 0.01)/5.0));
      HX := FLOAT(I)*5.0;
      DH := H - HX;
      If DH > 0.5 Then
         INTRP := 1;
      End If;
      If NDI /= DAY Then
         If INTRP <= 0 and (I = 1 or I >= 19) Then
            ALPHAD := ALDN(I);
            ALPHAI := ALIN(I);
            D := DN(I);
            A := AN(I);
            VEAIR := (2.6E-11*CONN2 + 1.5E-11*CONO2)*TEM;
            VEOX := 8.0E-10*ENOFO*SQRT(TEM);
            VIAIR := VEAIR/20.0;
            Return;
         End If;
         ALPHAD := FITRAT(ALDN(I-1),ALDN(I),ALDN(I+1),ALDN(I+2),DH);
         ALPHAI := FITRAT(ALIN(I-1),ALIN(I),ALIN(I+1),ALIN(I+2),DH);
         D := FITRAT(DN(I-1),DN(I),DN(I+1),DN(I+2),DH);
         A := FITRAT(AN(I-1),AN(I),AN(I+1),AN(I+2),DH);
         VEAIR := (2.6E-11*CONN2 + 1.5E-11*CONO2)*TEM;
         VEOX := 8.0E-10*ENOFO*SQRT(TEM);
         VIAIR := VEAIR/20.0;
         Return;
      End If;
      If INTRP <= 0 and (I = 1 or I >= 19) Then
         ALPHAD := ALDD(I);
         ALPHAI := ALID(I);
         D := DD(I);
         A := AD(I);
         VEAIR := (2.6E-11*CONN2 + 1.5E-11*CONO2)*TEM;
         VEOX := 8.0E-10*ENOFO*SQRT(TEM);
         VIAIR := VEAIR/20.0;
         Return;
      End If;
      ALPHAD := FITRAT(ALDD(I-1),ALDD(I),ALDD(I+1),ALDD(I+2),DH);
      ALPHAI := FITRAT(ALID(I-1),ALID(I),ALID(I+1),ALID(I+2),DH);
      D := FITRAT(DD(I-1),DD(I),DD(I+1),DD(I+2),DH);
      A := FITRAT(AD(I-1),AD(I),AD(I+1),AD(I+2),DH);
      VEAIR := (2.6E-11*CONN2 + 1.5E-11*CONO2)*TEM;
      VEOX := 8.0E-10*ENOFO*SQRT(TEM);
      VIAIR := VEAIR/20.0;
      Return;
--
      End CHEMD;
--
--
      Function FITRAT (C1: float; C2: float; C3: float; C4: float; DH: float)
                      return float is
--
--#PURPOSE: FITRAT obtains the reaction rates at altitudes between
--          reference altitudes for which reaction rate data is
--          stored by Lagrangian interpolation.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        C1     = Reaction rate value for altitude below the
--                   point of interest
--IN        C2     = Reaction rate value for altitude below the
--                   point of interest
--IN        C3     = Reaction rate value for altitude above the
--                   point of interest
--IN        C4     = Reaction rate value for altitude above the
--                   point of interest
--IN        DH     = Altitude difference between point of
--                   interest and the reference altitude
--                   corresponding to C2 (km)
--#CALLED BY:
--          CHEMD
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          Standard Lagrangian interpolation formulas are used.
--
      X1, X2, X3, X4, W1, W2, W3, W4, Y: float;
--
      Begin
--
      X1 := -5.0 - DH;
      X2 := -DH;
      X3 := 5.0 - DH;
      X4 := 10.0 - DH;
      W1 := -X2/(X1 - X2)*X3/(X1 - X3)*X4/(X1 - X4);
      W2 := -X1/(X2 - X1)*X3/(X2 - X3)*X4/(X2 - X4);
      W3 := -X1/(X3 - X1)*X2/(X3 - X2)*X4/(X3 - X4);
      W4 := -X1/(X4 - X1)*X2/(X4 - X2)*X3/(X4 - X3);
      Y  := W1*LOG(C1) + W2*LOG(C2) + W3*LOG(C3) + W4*LOG(C4);
      Return EXP(Y);
--
      End FITRAT;
--
--
      Procedure IONCAL (XLAT: in float;
                        XLON: in float;
                        TIME: in float;
                        IDN: in DAY_OR_NIGHT;
                        EN: out IONO_LAYERS;
                        PN: out IONO_LAYERS;
                        VEAIR: out IONO_LAYERS;
                        VIAIR: out IONO_LAYERS) is
--
--
--#PURPOSE: IONCAL calculates the electron and positive ion
--          densities as well as the collision frequencies for an
--          array of altitudes in ambient environments for a specified
--          latitude and longitude.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        XLAT   = The geographic coordinate of a point,
--                   positive degrees north
--IN        XLON   = The geographic coordinate of a point,
--                   positive degrees east
--IN        TIME   = Evaluation time in seconds
--                   (-TIME is a flag for ambient calculations)
--IN        IDN    = Day/night indicator
--OUT       EN     = Equilibrium positive ion concentration (/CM**3) array
--OUT       PN     = Equilibrium electron concentration (/CM**3) array
--OUT       VEAIR  = Electron molecule collision frequency (sec**-1) array
--OUT       VIAIR  = Ion molecule collision frequency (sec**-1) array
--
--#CALLED BY:
--          HFNORM
--          REFCAL
--
--#CALLS TO:
--          ATMOSD
--          CHEMD
--          IONOSD
--
--#TECHNICAL DESCRIPTION:
--          Ambient electron and positive ion densities are calculated
--          using the standard atmospheric routines contained in
--          subroutines ATMOSD, CHEMD, and IONOSD.  The routine is
--          called initially to set ambient values at 5 kilometer
--          increments.  These values are stored in arrays ENA and ENP.
--
      TEM: array (integer range 1..20) of float;
      CONN2: array (integer range 1..20) of float;
      CONO2: array (integer range 1..20) of float;
      ALPHAI: array (integer range 1..20) of float;
      A: array (integer range 1..20) of float;
      D: array (integer range 1..20) of float;
      ALPHAD: array (integer range 1..20) of float;
      QA: array (integer range 1..20) of float;
      PNA: array (integer range 1..20) of float;
      ENA: array (integer range 1..20) of float;
      RHO: array (integer range 1..20) of float;
      HS: array (integer range 1..20) of float;
      VEO, CONO, WTMOL: float;
--
      Begin
--
      For I in 1..20 Loop
         ATMOSD (1, HP(I), RHO(I), HS(I), TEM(I), CONN2(I),
                 CONO2(I), CONO, WTMOL);
         CHEMD  (HP(I), IDN, RHO(I), TEM(I), CONN2(I), CONO2(I), CONO,
                 ALPHAD(I), ALPHAI(I), A(I), D(I), VEAIR(I), VEO, VIAIR(I));
         IONOSD (HP(I), IDN, ALPHAD(I), ALPHAI(I), A(I), D(I),
                 QA(I), PNA(I), ENA(I));
         EN(I) := ENA(I);
         PN(I) := PNA(I);
      End Loop;
--
      End IONCAL;
--
--
      Procedure IONOSD (HC: in float;
                        NDI: in DAY_OR_NIGHT;
                        ALPHAD: in float;
                        ALPHAI: in float;
                        A: in float;
                        D: in float;
                        QA: out float;
                        ENPQ: out float;
                        ENEQ: out float) is
--
--
--#PURPOSE: IONOSD computes normal ionosheric properties at a point
--          below 120 Km..
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        HC     = Height of point (Km)
--IN        NDI    = Day/night indicator
--IN        ALPHAD = Electron-Ion recombination rate coefficient
--                   (CM**3/SEC)
--IN        ALPHAI = Ion-Ion recombination rate coefficient
--                   (CM**3/SEC)
--IN        A      = Attachment rate (/SEC)
--IN        D      = Detachment rate (/SEC)
--OUT       QA     = Normal ion-production rate (/CM**3)
--OUT       ENPQ   = Equilibrium positive ion concentration
--                   (/CM**3)
--OUT       ENEQ   = Equilibrium electron concentration
--                   (/CM**3)
--
--#CALLED BY:
--          IONCAL
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          The normal ion production rate is computed using
--          exponential interpolation between data stored for an
--          array of reference altitudes.  The production rate is then
--          used to determine a quasi-equilibrium solution for
--          electron and positive ion concentrations.
--
      QADN: array (integer range 1..7) of float;
      QAN: array (integer range 1..7) of float;
      QAD: array (integer range 1..7) of float;
      X, ALPHA: float;
      I, J: integer;
--
      Begin
--
      QADN:=(1.2E2, 3.1E1, 7.0E0, 1.8E0, 4.0E-1, 2.0E-1, 1.0E-1);
      QAN:=(1.0E-1, 2.0E-2, 1.0E-2, 5.0E-2, 2.0E-1, 5.68E-1, 8.4E-1);
      QAD:=(1.0E-1, 3.0E-1, 1.0E0, 1.0E1, 1.0E3, 2.17E3,2.69E3);
      I := MIN(MAX(INTEGER(TRUNCATE(HC/10.0)) + 1,1),12);
      X := (HC - 10.0*FLOAT(I - 1))/10.0;
      If I - 7 < 0 Then
         QA := QADN(I)*(QADN(I+1)/QADN(I))**X;
      Else
         I := I - 6;
         If NDI = NIGHT Then
            QA := QAN(I)*(QAN(I+1)/QAN(I))**X;
         Else
            QA := QAD(I)*(QAD(I+1)/QAD(I))**X;
         End If;
      End If;
      ALPHA := (A*ALPHAI+D*ALPHAD)/(A + D);
      ENPQ := SQRT(QA/ALPHA);
      For J in 1..2 Loop
         ALPHA := (A*ALPHAI + D*ALPHAD + ALPHAD*ALPHAI*ENPQ)/
                  (A + D + ALPHAI*ENPQ);
      End Loop;
      ENPQ := SQRT(QA/ALPHA);
      ENEQ := (QA + D*ENPQ)/(A + D + ALPHAD*ENPQ);
--
      End IONOSD;
--
--
      Procedure REFCAL (XLAT: in float;
                        XLON: in float;
                        TIME: in float;
                        FREQ: in float;
                        HXR: out float;
                        ALP1: out float) is
--
--#PURPOSE: REFCAL computes the ionospheric reflection coefficient
--          (float part) at calculated altitude above a point in an
--          ambient or nuclear environment.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        XLAT   = Latitude of point +north
--IN        XLON   = Longitude of point +east
--IN        TIME   = Evaluation time, in seconds (-TIME is a flag
--                   for ambient calculations)
--IN        FREQ   = Signal Frequency in KHz
--OUT       HXR    = Ionosphere reflection height in km
--OUT       ALP1   = float part of reflection coefficient to be
--                   used in an exponential expansion
--
--#CALLED BY:
--          ELF, HIGHTF, VLFNUC
--
--#CALLS TO:
--          CTANH
--          DAYNIT
--          IONCAL
--
--#TECHNICAL DESCRIPTION:
--          The reflection coefficients are calculated using a method
--          described by Wait, 1962.  In this method, the ionized
--          layer is represented by homogeneous slabs where the wave
--          is incident on the layer bottom at an angle.  A recursive
--          algorithm is employed to compute the float and the imaginary
--          parts of the reflection coefficient -- however, only the
--          float part is returned to the calling routine.
--
      BBB, X, Y, Z, XK, ZX, TEST, TH, R: complex;
      CID: array (integer range 1..2) of float := (0.1, 0.2);
      A: array (integer range 1..20) of float;
      B: array (integer range 1..20) of float;
      AMP: array (integer range 1..20) of float;
      ALPHX: array (integer range 1..2) of float;
      C: constant float := 2.997956E8;
      NH: constant integer := 20;
      DELTAH: constant float := 5.0;
      DH: constant float := 1000.0;
      EPS: constant float := 8.854E-12;
      U: constant float := 1.256637E-6;
      OMEGA, OMEGA2, WAVE, WE, TMIN, AE, BE, AI, BI, B1, HBS, XI, RIPREV,
      C2, OK, A1, HAS, XN, HOUT, RIM, RI, RRR, TESTI, TESTR, AMTEST: float;
      K, NINV, KK, N, I, NPHASE, L: integer;
      IDN: DAY_OR_NIGHT;
      EN, PN, VEAIR, VIAIR: IONO_LAYERS;
--
      Begin
--
--  CALCULATE CONSTANTS FOR LATER USE.
      OMEGA := TWOPI*FREQ*1.0E3;
      OMEGA2 := OMEGA*OMEGA;
      WAVE := OMEGA/C;
      WE    := EPS*OMEGA;
      TMIN := ABS(TIME)/60.0;
--
--
--CALCULATE IONOSPHERIC PROFILES
--
       RFUTIL.DAYNIT (IDN, XLON, XLON);
       IONCAL (XLAT, XLON, TIME, IDN, EN, PN, VEAIR, VIAIR);
--
--COMPUTE THE float AND IMIGINARY PARTS OF THE INDEX OF REFRACTION
--
      For K in 1..NH Loop
         AE := (3.18E9*EN(K))/(OMEGA2 + (0.7745967*VEAIR(K))**2);
         BE := VEAIR(K)*AE/OMEGA;
         AI := (5.45E4*PN(K))/(OMEGA2 + VIAIR(K)*VIAIR(K));
         BI := VIAIR(K)*AI/OMEGA;
         A(K) := AE + AI;
         B(K) := BE + BI;
      End Loop;
--
--FIX SLAB THICKNESS, NUMBER OF SUBSLABS AND SUBSLAB THICKNESS
      NINV := integer(TRUNCATE(DELTAH));
      KK := 0;
      HXR := -1.0;
--
--INDEX OF REFRACTION COMPONENTS AND REFERENCE ALTITUDE
--
--BEGIN ALTITUDE LOOP
      For K in 1..NH Loop
--FIRST ALTITUDE
         If K <= 1 Then
--SET IMAGINARY COMPONENT OF THE INDEX OF REFRACTION
            B1 := B(K);
--COMPUTE THE EXPONENTIAL EXPANSION COEFFICIENT FOR KTH SLAB
         Else
            HBS := DELTAH/LOG((B(K))/B1);
--HAS THE PHASE REFERENCE ALTITUDE BEEN FOUND
            If HXR < 0.0 Then
--BEGIN SUBSLAB LOOP
               For N in 1..NINV Loop
--CAN A PHASE REFERENCE ALTITUDE BE FOUND IN THIS SLAB SATISFYING
--CRAIN-BOOKER CRITERION
                  XI := FLOAT(N);
                  B1 := B1*EXP(DH/HBS/1000.0);
                  If B1 > 0.04 Then
                     HXR := HP(K-1)+XI*DH/1000.0;
                     exit ;
                  End If;
               End Loop;
               Goto FIFTY;
--CAN A MAXIMUM ALTITUDE INDEX BE FOUND
            End If;
            If KK <= 0 Then
              KK := MIN(NH,integer(TRUNCATE(AMIN1(15.0/DELTAH,
                                        5.0*ABS(HBS)/DELTAH)))+1+K);
              Goto FIFTY;
            End If;
            If K >= KK  Then
               exit;
            End If;
--SET COMPLEX COMPONENT OF INDEX OF REFRACTION OF KTH SLAB AS
--ADJACENT TO (K+1)TH SLAB
--
<<FIFTY>>
            B1 := B(K);
--END ALTITUDE LOOP
         End If;
      End Loop;
--
--REFLECTION COEFFICIENT DOWN TO ALTITUDE H
--
--BEGIN IONOSPHERIC INCIDENT ANGLE LOOP
--
      For I in 1..2 Loop
         NPHASE := 0;
         RIPREV := 0.0;
         C2 := CID(I)**2;
         OK := SQRT(U*C2/EPS);
--BEGIN SLAB LOOP
         For L in 1..KK Loop
            K := KK + 1 - L;
--TOP OF IONOSPHERE
            If L <= 1 Then
--SET COMPONENTS OF COMPLEX INDEX OF REFRACTION
               A1 := A(K);
               B1 := B(K);
            Else
--EXPONENTIAL INTERPOLATION PARAMETERS FOR THE COMPONENTS, A AND B
--OF THE INDEX OF REFRACTION
               HAS := DELTAH/LOG(A1/A(K));
               HBS := DELTAH/LOG(B1/B(K));
--BOTTOM OF TOP SLAB
               If L <= 2 Then
--USING THE COMPLEX VALUE, BBB, OBTAIN THE IMPEDANCE
                  BBB := CMPLX(A1 - C2, B1);
                  BBB := CSQRT(BBB)*CMPLX(SIGN(1.0, AREAL(CSQRT(BBB))),0.0);
                  Z := (CMPLX(WAVE,0.0)*BBB)/CMPLX(WE*B1, WE*(1.0 - A1));
--BEGIN SUBSLAB LOOP
               End If;
               For N in 1..NINV Loop
                  XN := FLOAT(N);
                  HOUT := HP(K) + 5.0 - XN;
--INTERPOLATE FOR COMPONENTS OF COMPLEX INDEX OF REFRACTION
                  A1 := A1*EXP(-DH/HAS/1000.0);
                  B1 := B1*EXP(-DH/HBS/1000.0);
                  BBB := CMPLX(A1 - C2, B1);
                  BBB := CSQRT(BBB)*CMPLX(SIGN(1.0, AREAL(CSQRT(BBB))),0.0);
                  BBB := CMPLX(WAVE,0.0) * BBB;
                  XK := BBB/CMPLX (WE*B1, WE*(1.0 - A1 ));
                  TH :=  RFUTIL.CTANH (CMPLX(DH,0.0)*BBB);
                  X := XK*TH;
                  Y := Z*TH;
                  ZX := (Z + X)/(XK + Y );
                  Z := ZX*XK;
                  R := (CMPLX(OK,0.0) - Z)/(CMPLX(OK, 0.0) + Z);
--IS THE REFERENCE ALTITUDE LESS THAN FIELD ALTIUDE
                  If HOUT < HXR Then
--COUNT THE NUMBER OF REVOLUTIONS OF THE REFLECTION
--COEFFICIENT VECTOR
                     RIM := AIMAG (R);
                     If ABS(RIPREV) >= 0.000001 or AREAL(R) >= 0.0 Then
                        If RIPREV > 0.0 and RIM < 0.0 Then
                           NPHASE := NPHASE + 1;
                        End If;
                        If RIPREV < 0.0 and RIM > 0.0 Then
                           NPHASE := NPHASE - 1;
                        End If;
                     End If;
                     RIPREV := RIM;
--END OF SUBINTERVAL LOOP OBTAINING THE IMPEDANCE FOR THE KTH SLAB
                  End If;
               End Loop;
--RESET THE COMPONENTS OF THE INDEX OF REFRACTION , OBTAIN THE
--COMPONENTS OF THE REFLECTION COEFFICIENT AND CALCULATE
--THE ATTENUATION DIVIDED BY COSINE OF THE INCIDENCE ANGLE
               A1 := A(K);
               B1 := B(K);
               RRR := AREAL(R);
               RI  := AIMAG(R);
               AMP(K) := -8.7*LOG(1.0/SQRT(RRR*RRR + RI*RI))/CID(I);
--OBTAIN THE FRESNEL REFLECTION COEFFICIENT
               TEST := (CMPLX(OK, 0.0) - XK)/(CMPLX(OK,0.0) + XK);
               TESTR := AREAL(TEST);
               TESTI := AIMAG (TEST);
               AMTEST := 8.7*LOG(1.0/SQRT(TESTR**2 + TESTI**2));
--IS 40 DB GREATER THAN SUM OF ATTENUATION OF THE REFLECTION
--COEFFICIENT + FRESNEL REFLECTION
               If AMTEST + AMP(K)*CID(I) > 40.0 Then
                  exit;
               End If;
--END OF FIELD ALTITUDE LOOP
            End If;
         End Loop;
--
--AMPLITUDE  OF REFLECTION COEFFICIENT: 960
--
--COMPUTE THE PHASES FOR THIS INCIDENCE ANGLE
--
         ALPHX(I) := AMP(K)/8.7;
--END OF INCIDENCE ANGLE LOOP
      End Loop;
--OBTAIN THE EXPANSION COEFFICIENTS OF THE REFLECTION COEFFICIENT
      ALP1 := (ALPHX(1) + ALPHX(2))/2.0;
--
      Return;
      End REFCAL;
--
--
End ELF_LF_HF_ATMOSPHERICS;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--AIR
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Debugger2; Use Debugger2;
With text_io; Use Text_io;
With Complex_numbers; Use Complex_numbers;
With Mathlib; Use Mathlib, Numeric_primitives, Core_functions, Trig_functions;

package AIR is

      Function CXSQRT (Z: complex) return complex;
      Procedure ZEXP (A: in float;
                      B: in float;
                      X: out float;
                      Y: out float;
                      MAGTUD: out integer);
      Function AIRY (ZZ: complex; K: integer) return complex;
      MEXP: integer;

end AIR;
package body AIR is
      Pragma source_info (on);
      Function ANM (Z: complex) return float is
--
--#PURPOSE: Calculates the sum of the absolute values of the real and
--          imaginary parts of the input argument.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Math utility
--
--#PARAMETER DESCRIPTIONS:
--IN        Z      = Function argument
--
--#CALLED BY:
--          AIRY
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          Calculates the sum of the absolute values of the real and
--          imaginary parts of the input argument.
--
      Begin
--
      Return ABS(AREAL(Z)) + ABS(AIMAG(Z));

--
      End ANM;
--
      Function CXSQRT (Z: complex) return complex is
--
--#PURPOSE: Calculates the complex square root with positive sense.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Math utility
--
--#PARAMETER DESCRIPTIONS:
--IN        Z      = Function argument
--
--#CALLED BY:
--          AIRY
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          The complex square root of a complex number is computed and
--          the sign of the real paart of the input argument is placed
--          on the return argument.
--
      Begin
--
      Return CSQRT(Z)*SIGN(1.0,AREAL(CSQRT(Z)));
--
      End CXSQRT;

      Procedure ZEXP (A: in float;
                      B: in float;
                      X: out float;
                      Y: out float;
                      MAGTUD: out integer) is
--
--#PURPOSE:ZEXP converts the form representing a complex number
--          from a complex exponential to a real exponential times a
--          complex number.
--
--#AUTHOR: J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        A      = Real part of the argument
--IN        B      = Complex part of the argument
--OUT       X      = A scalar quantity
--OUT       Y      = A scalar quantity
--OUT       MAGTUD = The largest integer less than or equal to A
--
--#CALLED BY:
--          AIRY
--          GRWAVE
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          ZEXP converts the form representing a complex number
--          from a complex exponential to a real exponential times a
--          complex number.
--
      E, SCALE: float;
--
      Begin
--
      MAGTUD := INTEGER(A);
      SCALE := FLOAT(MAGTUD);
      E := EXP(A - SCALE);
      X := E*COS(B);
      Y := E*SIN(B);
      Return;
--
      End ZEXP;
--
            Function AIRY (ZZ: complex; K: integer) return complex is
--
--#PURPOSE: AIRY calculates Airy functions.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Computational Subroutine
--
--#PARAMETER DESCRIPTIONS:
--IN        ZZ     = Airy function argument
--IN        K      = Branching index
--
--#CALLED BY:
--          CWAIRY
--
--#CALLS TO:
--          ANM
--          CXSQRT
--          ZEXP
--
--#TECHNICAL DESCRIPTION:
--          Hufford's normalization of the Airy functions is used.
--
      WI1, WI1P, WI2, WI2P: complex;
      Z, U, ZT, ZA, ZB, ZE, ZR, B0, B1, B2, B3: complex;
      LG: array (integer range 1..3) of boolean := (FALSE, FALSE, FALSE);
      X:array (integer range 1..2) of float;
      X1: array (integer range 1..2) of float;
      XT: array (integer range 1..2) of float;
      AN, P, Q, SX, SY, T, XA, ZM: float;
      IP, IQ, N, IK, I, NT, LA, LB, LC: integer;
      A, AP, Z1: complex;
      AV, APV: array (integer range 1..70) of complex;
      ASLT: array (integer range 1..17) of float :=
        (1.1407E+02, 1.1549E+02,
         1.1779E+02, 1.2124E+02, 1.2619E+02, 1.3319E+02,
         1.4307E+02, 1.5716E+02, 1.7774E+02, 2.0884E+02,
         2.5832E+02, 3.4294E+02, 5.0339E+02, 8.5678E+02,
         1.8336E+03, 5.7270E+03, 3.5401E+04);
--
      ASV: array (integer range 1..21) of float :=
        (1.83357669E+10,
         1.92937554E+09, 2.14288037E+08, 2.51989198E+07,
         3.14825741E+06, 4.19524875E+05, 5.98925135E+04,
         9.20720660E+03, 1.53316943E+03, 2.78465080E+02,
         5.56227853E+01, 1.23415733E+01, 3.07945303E+00,
         8.77666969E-01, 2.91591399E-01, 1.16099064E-01,
         5.76491904E-02, 3.79930591E-02, 3.71334876E-02,
         6.94444444E-02, 1.00000000E+00);
--
      APSV: array (integer range 1..21) of float :=
       (-1.86439310E+10,
        -1.96352378E+09,-2.18293420E+08,-2.56979083E+07,
        -3.21453652E+06,-4.28952400E+05,-6.13357066E+04,
        -9.44635482E+03,-1.57635730E+03,-2.87033237E+02,
        -5.75083035E+01,-1.28072930E+01,-3.21049358E+00,
        -9.20479992E-01,-3.08253764E-01,-1.24105896E-01,
        -6.26621635E-02,-4.24628307E-02,-4.38850308E-02,
        -9.72222222E-02, 1.00000000E+00);
--
      NQTT: array (integer range 1..15) of integer :=
         (1, 3, 7, 12, 17, 23, 29, 35, 41, 47, 53, 59, 64, 68, 71);
--
   begin
      Z1 := CMPLX(0.0,0.0);
      A := CMPLX(0.35502805,0.0);
      AP := CMPLX(-0.25881940,0.0);
--
-- A TEMPORARY BLOCK IS USED TO LOAD COMPLEX ARRAYS
      declare
         TEMP: array (integer range 1..70, integer range 1..2) of float;
      begin
         TEMP :=
        ((-3.29145173E-01, 0.00000000E+00),
        (-2.67800356E+00, 1.47745895E+00),
        ( 3.50761009E-01, 0.00000000E+00),
        ( 2.41222621E+00, 6.98651244E-01),
        ( 3.36355311E+01,-3.46009596E+00),
        ( 3.44497396E+02,-3.36908902E+02),
        (-7.02655329E-02, 0.00000000E+00),
        (-5.48182192E-01,-1.92073659E+00),
        (-1.33833953E+01,-1.60225908E+01),
        (-2.29677959E+02,-3.20724526E+01),
        (-1.80407804E+03, 2.19176750E+03),
        (-3.78814293E-01, 0.00000000E+00),
        (-1.34918360E+00, 8.49690772E-01),
        (-6.04533393E+00, 1.06231755E+01),
        ( 3.11696216E+01, 9.88135176E+01),
        ( 9.89253493E+02, 1.39052860E+02),
        ( 2.27407428E-01, 0.00000000E+00),
        ( 7.18574034E-01, 9.78090941E-01),
        ( 6.06210880E+00, 2.72030148E+00),
        ( 3.63070848E+01,-2.09613558E+01),
        (-6.71397891E+01,-3.09046387E+02),
        (-2.80016536E+03, 4.66493659E+02),
        ( 5.35560883E-01, 0.00000000E+00),
        ( 9.24073653E-01,-1.91065600E-01),
        ( 1.87161859E+00,-2.57433103E+00),
        (-7.21884363E+00,-1.29242001E+01),
        (-8.17873778E+01, 3.20870138E+01),
        ( 2.99339485E+02, 5.69221792E+02),
        ( 3.55028053E-01, 0.00000000E+00),
        ( 3.12034381E-01,-3.88453850E-01),
        (-5.28399993E-01,-1.09764112E+00),
        (-4.20093515E+00, 1.19401511E+00),
        ( 7.18588328E+00, 1.96009125E+01),
        ( 1.01291210E+02,-7.59512332E+01),
        ( 1.35292416E-01, 0.00000000E+00),
        ( 3.26184783E-02,-1.70848727E-01),
        (-3.42153810E-01,-8.90676463E-02),
        (-1.45096414E-01, 1.03280157E+00),
        ( 4.10019685E+00,-6.89369117E-01),
        (-1.30301240E+01,-1.69105414E+01),
        ( 3.49241304E-02, 0.00000000E+00),
        (-8.44647266E-03,-4.20451544E-02),
        (-6.93132689E-02, 3.53647987E-02),
        ( 1.52276226E-01, 1.28484544E-01),
        ( 1.06813731E-01,-6.77661535E-01),
        (-2.61934327E+00, 1.56998599E+00),
        ( 6.59113935E-03, 0.00000000E+00),
        (-3.94439855E-03,-6.80601061E-03),
        (-5.98201310E-03, 1.17990101E-02),
        ( 2.99224984E-02,-5.97729307E-03),
        (-7.74641302E-02,-5.22924027E-02),
        ( 1.12765858E-01, 3.51124424E-01),
        ( 9.51563851E-04, 0.00000000E+00),
        (-8.08429956E-04,-7.65901326E-04),
        ( 1.61478160E-04, 1.76617551E-03),
        ( 2.01387183E-03,-3.19767166E-03),
        (-9.50867844E-03, 4.53778324E-03),
        ( 3.75601918E-02, 5.73619168E-04),
        ( 1.08344428E-04, 0.00000000E+00),
        (-1.09686064E-04,-5.99023296E-05),
        ( 1.07781913E-04, 1.57715962E-04),
        (-6.89809378E-05,-3.76264573E-04),
        (-1.61661261E-04, 9.74577732E-04),
        ( 9.94769436E-06, 0.00000000E+00),
        (-1.09568239E-05,-2.95087996E-06),
        ( 1.47090745E-05, 8.10420897E-06),
        (-2.44460151E-05,-2.06381431E-05),
        ( 7.49212886E-07, 0.00000000E+00),
        (-8.46190689E-07,-3.68073383E-08),
        ( 1.21839633E-06, 8.35891994E-08));
         for I in 1..70 loop
            AV(I):=CMPLX(TEMP(I,1),TEMP(I,2));
         end loop;

         TEMP :=
        (( 3.45935487E-01, 0.00000000E+00),
        ( 4.17088765E+00, 6.24144377E+00),
        ( 3.27192818E-01, 0.00000000E+00),
        ( 1.08287427E+00,-5.49283025E+00),
        (-2.33635179E+01,-7.49018481E+01),
        (-1.02648775E+03,-5.67079408E+02),
        (-7.90628575E-01, 0.00000000E+00),
        (-3.80858333E+00, 1.51296051E+00),
        (-2.60863790E+01, 3.55407099E+01),
        ( 1.07618382E+02, 5.12399449E+02),
        ( 6.65977971E+03, 1.80961862E+03),
        ( 3.14583769E-01, 0.00000000E+00),
        ( 1.87154254E+00, 2.05448365E+00),
        ( 2.25917369E+01, 4.85629954E+00),
        ( 1.61629978E+02,-1.43355971E+02),
        (-8.00471616E+02,-2.15274542E+03),
        ( 6.18259020E-01, 0.00000000E+00),
        ( 1.30196038E+00,-1.22907749E+00),
        ( 1.50361187E-01,-1.10080928E+01),
        (-7.01168003E+01,-4.04808227E+01),
        (-4.83171669E+02, 4.96927557E+02),
        ( 4.89706556E+03, 4.86272908E+03),
        (-1.01605671E-02, 0.00000000E+00),
        (-5.48266364E-01,-7.13652884E-01),
        (-4.67491340E+00,-1.19242452E-01),
        (-1.05363978E+01, 2.49437113E+01),
        ( 1.63337706E+02, 9.03949106E+01),
        ( 5.64494552E+02,-1.42483244E+03),
        (-2.58819403E-01, 0.00000000E+00),
        (-4.86207541E-01, 1.56899249E-01),
        (-4.73481318E-01, 1.70934381E+00),
        ( 7.03738407E+00, 3.62818249E+00),
        ( 1.77395863E+01,-4.03604224E+01),
        (-2.97915119E+02,-3.84088929E+01),
        (-1.59147441E-01, 0.00000000E+00),
        (-1.13404235E-01, 1.97305049E-01),
        ( 4.01262091E-01, 3.92229958E-01),
        ( 1.33486524E+00,-1.43772724E+00),
        (-7.90224947E+00,-4.20636446E+00),
        (-1.38927521E+00, 5.12294167E+01),
        (-5.30903844E-02, 0.00000000E+00),
        (-1.68329655E-03, 6.83669678E-02),
        ( 1.37894013E-01,-1.16138040E-02),
        (-1.47137306E-01,-3.71519857E-01),
        (-1.00701964E+00, 1.15913484E+00),
        ( 7.50450491E+00, 4.69131153E-01),
        (-1.19129767E-02, 0.00000000E+00),
        ( 5.14685749E-03, 1.36608912E-02),
        ( 1.83097105E-02,-1.88085884E-02),
        (-6.44615931E-02,-1.36117947E-02),
        ( 1.05162399E-01, 1.93130535E-01),
        ( 2.05200462E-01,-9.17726173E-01),
        (-1.95864095E-03, 0.00000000E+00),
        ( 1.46956495E-03, 1.80863846E-03),
        ( 5.97099479E-04,-3.83326992E-03),
        (-6.89108930E-03, 5.44674252E-03),
        ( 2.61679277E-02,-8.40920002E-04),
        (-8.82844741E-02,-4.64753121E-02),
        (-2.47413890E-04, 0.00000000E+00),
        ( 2.37078374E-04, 1.64611095E-04),
        (-1.74655698E-04,-4.20267839E-04),
        (-1.03945161E-04, 9.47618443E-04),
        ( 1.30041105E-03,-2.24466568E-03),
        (-2.47652003E-05, 0.00000000E+00),
        ( 2.67148709E-05, 9.86915650E-06),
        (-3.35397741E-05,-2.71132849E-05),
        ( 4.91978431E-05, 6.93490920E-05),
        (-2.00815089E-06, 0.00000000E+00),
        ( 2.26712445E-06, 2.78485083E-07),
        (-3.26921327E-06,-7.39434886E-07));
         for I in 1..70 loop
            APV(I):=CMPLX(TEMP(I,1),TEMP(I,2));
         end loop;
      end;
--
      If K = 1 or K = 2 Then
         LA := 1;
      Else
         LA := -1;
      End If;
      If K = 1 or K = 3 Then
         LB := 0;
      Else
         LB := 1;
      End If;
--
      Z := ZZ;
      If LA /= 0 Then
         If LA > 0 Then
            U := CMPLX(-0.5, 0.86602540);
         Else
            U := CMPLX(-0.5, -0.86602540);
         End If;
         Z := U*Z;
      End If;
--
      LC := 0;
      X(1) := AREAL (Z);
      X(2) := AIMAG (Z);
      If X(2) < 0.0 Then
         LC := 1;
         X(2) := -X(2);
         Z := CMPLX (X(1), X(2));
      End If;
--
--COMPARE WITH PREVIOUS.
--
      X1(1) := AREAL (Z1);
      X1(2) := AIMAG (Z1);
      If X(1) /= X1(1)  or  X(2) /= X1(2) Then
         Goto AFFINE_COORDINATES;
      End If;
      If LG(LB+1) Then
         Goto EXXIT;
      End If;
      If LB /= 0 Then
         Goto APSTAR;
      End If;
      Goto ASTAR;
--
<<EXXIT>>
--
      If LB /= 0 Then
         Goto SIXTY;
      End If;
--
<<FIFTY>>
      ZT := A;
      If LC /= 0 Then
         XT(1) := AREAL(ZT);
         XT(2) := AIMAG(ZT);
         XT(2) := -XT(2);
         ZT := CMPLX (XT(1), XT(2));
      End If;
      If LA < 0 Then
         Goto EIGHTY;
      Elsif LA = 0 Then
         Return ZT;
      Else
         Goto SEVENTY;
      End If;
--
<<SIXTY>>
      ZT := AP;
      XT(1) := AREAL(ZT);
      XT(2) := AIMAG(ZT);
      If LC /= 0 Then
         XT(2) := -XT(2);
         ZT := CMPLX (XT(1), XT(2));
      End If;
      If LA = 0 Then
         Return ZT;
      Elsif LA > 0 Then
         Goto EIGHTY;
      End If;
--
<<SEVENTY>>
      U := CMPLX(1.0, -1.73205080);
      Goto NINETY;
--
<<EIGHTY>>
      U := CMPLX(1.0, 1.73205080);
--
<<NINETY>>
      ZT := U*ZT;
      Return ZT;
--
<<AFFINE_COORDINATES>>
--
      MEXP := 0;
      Z1 := Z;
      X1(1) := AREAL(Z1);
      X1(2) := AIMAG(Z1);
      XT(1) := AREAL(ZT);
      XT(2) := AIMAG(ZT);
      X(1) := AREAL(Z);
      X(2) := AIMAG(Z);
      LG(1) := FALSE;
      LG(2) := FALSE;
      LG(3) := FALSE;
      If X(1) <= -7.0  or  X(1) > 7.0  or  X(2) > 6.92820323 Then
         Goto ASYMPTOTICS;
      End If;
      IP := INTEGER(7.0 - X(1));
      IP := 7 - IP;
      P := FLOAT(IP);
      IQ := INTEGER(0.86602540*X(2) + 0.5*(P - X(1)));
      Q := FLOAT(IQ);
      N := NQTT(IP + 7) + IQ;
      If N >= NQTT(IP + 8) Then
         Goto ASYMPTOTICS;
      End If;
--
--SERIES.
--
      XT(1) := P;
      XT(2) := 1.15470053*Q;
      ZT := CMPLX (XT(1), XT(2));
      U := Z - ZT;
      B1 := AV(N);
      B3 := B1*ZT*U;
      AP := APV(N);
      B2 := AP*U;
      A := B2 + B1;
      AP := AP + B3;
      AN := 1.0;
      IK := 3;
      I := 1;
 --
<<TWENTY>>
      I := I + 1;
      AN := AN + 1.0;
      B3 := B3*U/AN;
      A := B3 + A;
      B0 := B1;
      B1 := B2;
      B2 := B3;
      B3 := (ZT*B1 + U*B0)*U/AN;
      AP := B3 + AP;
      If ANM(B2) >= 0.5E-10*ANM(A) or
         ANM(B3) >= 0.5E-10*ANM(AP) Then
         If I < 99 Then
            Goto TWENTY;
         End If;
         New_Line;
         Put ("Possible error in Procedure AIRY...no convergence");
         New_Line;
         Put ("after 99 iterations.  Groundwave signal level may");
         New_Line;
         Put ("be incorrect by a significant amount.");
      End If;
      LG(1) := TRUE;
      LG(2) := TRUE;
      Goto EXXIT;
--
<<ASYMPTOTICS>>
      ZA := CXSQRT(Z);
      ZB := 0.28209479/CXSQRT(ZA);
      ZT := -0.66666666*Z*ZA;
      XT(1) := AREAL(ZT);
      XT(2) := AIMAG(ZT);
      T := XT(1)**2 + XT(2)**2;
      ZEXP(XT(1), XT(2), SX, SY, MEXP);
      ZE := CMPLX(SX , SY);
      XA := FLOAT(MEXP + MEXP);
      IF 2*MEXP > 50 tHEN
         XA := 50.0;
      End If;
      If 2*MEXP < -50 Then
         XA := -50.0;
      End If;
      ZM := EXP(-XA);
      ZR := 1.0/ZT;
      If XT(2) > 0.0  and  XT(1) < 11.8595 Then
         LG(3) := TRUE;
      End If;
      For I in 2..19 Loop
         NT := I;
         Exit When (NT = 19 or T < ASLT(NT-1));
      End Loop;
      If LB /= 0 Then
         Goto APSTAR;
      End If;
--
<<ASTAR>>
      ZT := CMPLX(ASV(NT-1), 0.0);
      If NT <= 21 Then
         For I in NT..21 Loop
            ZT := ASV(I) + ZT*ZR;
         End Loop;
      End If;
      A := ZT*ZE;
      If LG(3) Then
         Goto A1310;
      End If;
--
<<A1300>>
      A := ZB*A;
      LG(1) := TRUE;
      Goto FIFTY;
--
<<A1310>>
      ZT := CMPLX(ASV(NT-1),0.0);
      If NT <= 21 Then
         For I in NT..21 Loop
            ZT := ASV(I) - ZT*ZR;
        End Loop;
      End If;
      A := A + CMPLX(0.0, 1.0)*ZT/(ZE)*ZM;
      Goto A1300;
--
<<APSTAR>>
      ZT := CMPLX(APSV(NT-1),0.0);
      If NT <= 21 Then
         For I in NT..21 Loop
            ZT := APSV(I) + ZT*ZR;
         End Loop;
      End If;
      AP := -ZT*ZE;
      If LG(3) Then
         Goto AP1380;
      End If;
--
<<AP1370>>
      AP := ZA*ZB*AP;
      LG(2) := TRUE;
      Goto SIXTY;
--
<<AP1380>>
      ZT := CMPLX(APSV(NT-1),0.0);
      If NT <= 21 Then
         For I in NT..21 Loop
            ZT := APSV(I) - ZT*ZR;
         End Loop;
      End If;
      AP := AP + CMPLX(0.0, 1.0)*ZT/(ZE)*ZM;
      Goto AP1370;
--
      End AIRY;

End AIR;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--LFHFGROU
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Debugger2; Use Debugger2;
With Complex_numbers; Use Complex_numbers;
With Mathlib; Use Mathlib, Numeric_primitives, Core_functions, Trig_functions;
With Text_io; Use Text_io;
With Constants; Use Constants;
With Propagation_constants; Use Propagation_Constants;
With Air; Use Air;

Package LF_HF_GROUNDWAVES is
--
--
      Procedure GRWAVE (COND: in float;
                        FREQ: in float;
                        SURDIS: in float;
                        NPOL: in integer;
                        POWER: in float;
                        HLOWER: in float;
                        HHIGHR: in float;
                        VOLTPM: out float;
                        DBLOSS: out float);
--
--
End LF_HF_GROUNDWAVES;
--
Package body LF_HF_GROUNDWAVES is
--
-- LF_HF_GROUNDWAVES Package of PROP_LINK
-- Version 1.0,  April 23, 1985.
--
-- This LF_HF_GROUNDWAVES Package contains all of the procedures that
-- are used to compute groundwave RF propagation at LF and HF frequencies.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
      Pragma Source_info (on);
--
--VARIABLES THAT ARE TO BE VISIBLE TO ALL ROUTINES WITHIN THIS PACKAGE ONLY:
      Q: complex;
      AK1, V, ZC, Y1, Y2, COTH, STH, X, HTKM, HRKM, FLF, A: float;

      Procedure UP (A: in COMPLEX; E: out COMPLEX);
      Function OMCOS (X: float) return float;
      Function RGW (MMM: in integer) return complex;
      Procedure TW (I: in integer;
                    Q: in complex;
                    T: out complex;
                    W1: out complex;
                    MW1: out integer;
                    DW1: out complex;
                    MD1: out integer;
                    W2: out complex;
                    MW2: out integer;
                    DW2: out complex;
                    MD2: out integer);
--
--
--
--
      Procedure CWAIRY (KK: in integer;
                        T: in complex;
                        F1: out complex;
                        M1: out integer;
                        F2: out complex;
                        M2: out integer) is
--
--#PURPOSE: CWAIRY calculates the Airy functions.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        KK     = Flag indicating types of calculations desired;
--                   1...For Kind 1 and 2
--                   2...For derivatives
--IN        T      = The complex argument MEXP
--OUT       F1     = The Airy function coefficient for the
--                   Airy function Kind 1 or its derivative,
--                   depending on KK.  The Airy function
--                   value equals F1*(E**M1) where E is
--                   the Napierian base.
--OUT       M1     = The Airy function exponent for the Airy
--                   function Kind 1 or its derivatives,
--                   depending on KK.  The Airy function
--                   value equals F1*(E**M1) where E is
--                   the Napierian base.
--OUT       F2     = Same as F1 for Kind 2
--OUT       M2     = Same as M1 for Kind 2
--
--#CALLED BY:
--          GRWAVE
--          RGW
--          TW
--
--#CALLS TO:
--          AIRY
--
--#TECHNICAL DESCRIPTION:
--          CWAIRY is the master subroutine for calculating Airy
--          functions of Kinds 1 and 2, and their derivatives.
--          See Function AIRY.  Subroutine CWAIRY enters Function
--          AIRY at different points depending on the type of
--          function or its derivative that is being evaluated.
--
--
      Begin
--
      If KK = 1 Then
         F2 := AIRY(T, 1);
         M2 := MEXP;
         F1 := AIRY(T, 3);
         M1 := MEXP;
      Else
         F2 := AIRY(T, 2);
         M2 := MEXP;
         F1 := AIRY(T, 4);
         M1 := MEXP;
      End If;
      F1 := 1.77245385*CMPLX(0.0, -1.0)*F1;
      F2 := 1.77245385*CMPLX(0.0, +1.0)*F2;
      Return;
--
      End CWAIRY;
--
--
--
--
      Procedure DOWN (A: in complex;
                      E: out complex) is
--
--#PURPOSE: DOWN calculates error function values.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        A      = Complex argument
--OUT       E      = CEXP (A**2) + ERF(A)
--
--#CALLED BY:
--          UP
--
--#CALLS TO:
--          UP
--
--#TECHNICAL DESCRIPTION:
--          The essence of this routine has been extracted from:
--          GW SNR (Ground Wave Signal-to-Noise Ratio) a FORTRAN code
--          developed by Leslie A. Berry of the U.S. Department of
--          Commerce, Institute for Telecommunication Sciences, Bolder,
--          Colorado.
--
      U: complex;
      Z,ZI, CR, CI, BR, BI, Z2R, Z2I, EM, PR, PI, EI, ER: float;
--
      Begin
--
      If (CABS(A) - 3.5) > 0.0 Then
         UP(A,U);
         E := CEXP(A**2) - U;
      Else
         Z := AREAL (A);
         ZI := AIMAG (A);
         CR := 1.12837916*Z;
         CI := 1.12837916*ZI;
         BR := CR;
         BI := CI;
         Z2R := Z*Z-ZI*ZI;
         Z2I := 2.0*Z*ZI;
         EM := 1.5;
         Loop
            PR := Z2R*CR - Z2I*CI;
            PI := Z2R*CI + Z2I*CR;
            CR := PR/EM;
            CI := PI/EM;
            BR := BR + CR;
            BI := BI + CI;
            Exit When ((CR*CR+CI*CI)/(BR*BR+BI*BI)-1.0E-11) <= 0.0;
            EM := EM + 1.0;
         End Loop;
         ER := BR;
         EI := BI;
         E := CMPLX (ER,EI);
      End If;
      Return;
--
      End DOWN;
--
--
      Function ECOM (Z: complex) return complex is
--
--#PURPOSE:ECOM calculates the values of complementary error
--          functions with complex arguments.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        Z      = The complex argument
--OUT       ECOM   = ECOM := CEXP (Z**2)*ERFC(Z)
--
--#CALLED BY:
--          GRWAVE
--
--#CALLS TO:
--          UP
--
--#TECHNICAL DESCRIPTION:
--          ECOM calls UP for evaluation of the complementary error
--          function value, ERFC.
--
--          The essence of this routine has been extracted from:
--          GW SNR (Ground Wave Signal-to-Noise Ratio) a FORTRAN code
--          developed by Leslie A. Berry of the U.S. Department of
--          Commerce, Institute for Telecommunication Sciences, Bolder,
--          Colorado.
--
      ZP, RESULT: complex;
      ZR, XA: float;
--
      Begin
--
      ZR := AREAL(Z);
      XA := AREAL(Z**2);
      If ZR >= 0.0 Then
         UP (Z, RESULT);
      Else
         UP (-Z,ZP);
         RESULT := CMPLX(1.0E15,0.0);
         If XA < 50.0 Then
            RESULT := CMPLX(2.0,0.0)*CEXP(Z**2) - ZP;
         End If;
      End If;
      Return RESULT;
--
      End ECOM;
--
--
      Procedure GRWAVE (COND: in float;
                        FREQ: in float;
                        SURDIS: in float;
                        NPOL: in integer;
                        POWER: in float;
                        HLOWER: in float;
                        HHIGHR: in float;
                        VOLTPM: out float;
                        DBLOSS: out float) is
--
--#PURPOSE: GRWAVE calculates ground wave signal levels at HF.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        COND   = Ground conductivity at transmitterin mho/m
--IN        FREQ   = Frequency in kHz
--IN        SURDIS = Great circle path surface distance in km
--IN        NPOL   = Polarization flag (1:=Vertical, 2:=Horizontal)
--IN        POWER  = Transmitter radiated power in kW
--IN        HLOWER = Height of the lower antenna in m
--IN        HHIGHR = Height of the higher antenna in m
--OUT       VOLTPM = Electric field intensity at the receiving
--                   location in the polarized direction in V/m
--OUT       DBLOSS = A relative loss factor in dB
--
--#CALLED BY:
--          HFGSIG
--          LFPROP
--
--#CALLS TO:
--          CWAIRY
--          ECOM
--          OMCOS
--          RGW
--          TW
--          ZEXP
--
--#TECHNICAL DESCRIPTION:
--          The essence of this routine has been extracted from:
--          GW SNR (Ground Wave Signal-to-Noise Ratio) a FORTRAN code
--          developed by Leslie A. Berry of the U.S. Department of
--          Commerce, Institute for Telecommunication Sciences, Bolder,
--          Colorado.
--
--
      LAMBDA, DMIN, HTC, HRC, EPS, DELT, DMAX, ALFA, START, WAVE, V2, Z: float;
      TEST, FTEST, FTESTT, B, R, DEGTST, THETA, DEGTH, HT2, HR2, A1, A2: float;
      XA, D, D1, D2, CSQD, SD2, SD, S, SSQ, ASQ, SE, SSE, SA, DELANG: float;
      BOT, YONE, TOP, FTX, SGN, TX, XONE, F, FF, TY, DCHECK, AMP: float;
      PHASE, EJ, ER, DT: float;
      ILOS, IGAUSS, NN, NNN, MGW, KOUNT, N, MZ, MA, KK, I, K, MY1, M: integer;
      ISKIP, MY2, MT, FLG: integer;
      ETA, DELTAX, RO, U, CZW, E, Z2, RR: complex;
      TS, ZZ, TZ, WY1, WY2, EEK, EAK, ECK, ZR, ZT, ZO: complex;
      M1: array (integer range 1..96) of integer;
      M2: array (integer range 1..96) of integer;
      MD1: array (integer range 1..96) of integer;
      MD2: array (integer range 1..96) of integer;
      MPT: array (integer range 1..96) of integer;
      PT: array (integer range 1..96) of complex;
      O: array (integer range 1..96) of complex;
      W1: array (integer range 1..96) of complex;
      W2: array (integer range 1..96) of complex;
      DW1: array (integer range 1..96) of complex;
      DW2: array (integer range 1..96) of complex;
      WX: array (integer range 1..96) of complex;
      WW1: array (integer range 1..96) of complex;
      WW2: array (integer range 1..96) of complex;
--
      Begin
--
      DMIN := SURDIS;
      If DMIN <= 1.0E-10 Then
         E := CMPLX(1.0, 0.0);
         New_Line;
         Put ("WARNING--In routine GRWAVE the surface distance is zero.");
         New_Line;
         Put ("The signal has been set to assure successful communications.");
         Goto MASTER_NODE;
      End If;
--
      HTC := HLOWER;
      HRC := HHIGHR;
      ILOS := 4;
      IGAUSS := 1;
      EPS := 10.0;
      If COND > 0.30 Then
         EPS := 80.0;
      End If;
      DELT := 0.0;
      DMAX := DMIN;
      ALFA := 1.33333333;
--
--     ALFA  = EFFECTIVE EARTH RADIUS FACTOR,
--           = EFFECTIVE RADIUS/ACTUAL RADIUS
--
      NN := 1;
      NNN := 1;
      START := DMIN;
      A := ALFA*RADIUS_OF_EARTH_IN_KM;
      LAMBDA := 2.997925E2/FREQ;
--
--     LAMBDA = WAVELENGTH IN KM FOR FREQ IN KHZ.
--
      WAVE := TWOPI/LAMBDA;
--
--     WAVE  = WAVE NUMBER IN RADIANS/KM.
--
      AK1 := A*WAVE;
      V := (AK1/2.0)**0.33333333;
      V2 := V*V;
      Z := 0.5/V2;
      ZC := 2.5*Z;
      FLF := 300.0*SQRT(POWER);
      ETA := CMPLX(EPS,-18.0E6*COND/FREQ);
      DELTAX := CXSQRT(ETA - 1.0);
      If NPOL /= 2 Then
         DELTAX:=DELTAX/ETA;
      End If;
      Q := CMPLX(0.0,-V)*DELTAX;
      MGW := 1;
      TEST := 0.0;
      DMIN := START;
      HTKM := HTC/1000.0;
      HRKM := HRC/1000.0;
      Y1 := WAVE*HTKM/V;
      Y2 := WAVE*HRKM/V;
      FTEST := AMAX1(5.0,437.0/(FREQ**0.38));
      FTESTT := FTEST*(POWER**0.5);
      If WAVE*(HTKM + HRKM)*CABS(DELTAX) > 0.1 Then
         FTEST := 0.0;
      End If;
--
--     FTEST IMPLIES FLAT EARTH O.K. TO 5 KM FOR ALL
--     FREQUENCIES, AND > 5 KM FOR FREQUENCIES <
--     128,599 KHZ (8.69KM AT 30MHZ; 20.85KM AT 3MHZ).
--
      If HTC + HRC > 0.0 Then
         B := A + HTKM;
         R := A + HRKM;
         TEST := A*(ACOS(A/R) + ACOS(A/B));
         DEGTST := DEGREES_PER_RADIAN*TEST/A;
      End If;
      THETA := DMIN/A;
      DEGTH := DEGREES_PER_RADIAN*THETA;
      X := V*THETA;
      STH := SIN(THETA);
      COTH := COS(THETA)/STH;
      E := CMPLX(0.0,0.0);
      If DMIN <= FTEST Then
         Goto FLAT_EARTH;
      Elsif DMIN > TEST Then
         Goto RESIDUE_SERIES;
      Else
         Goto GEOMETRIC_OPTICS;
      End If;
--
--     IF DMIN > TEST, THE TRANSMITTER AND RECEIVER
--     ARE BEYOND LINE-OF-SIGHT BASED ON A SPHERICAL
--     EARTH OF ALFA*REARTH RADIUS, I.0E. A RADIUS
--     ADJUSTED FOR NORMAL ATMOSPHERIC REFRACTION IN
--     THE TROPOSPHERE.
--
<<FLAT_EARTH>>
--     CALCULATION OF THE GROUND WAVE WITH A FLAT EARTH.
--
      R := SQRT(DMIN*DMIN*1.0E6 + (HTC - HRC)**2);
      RO := CMPLX(0.886227, 0.886227)*SQRT(WAVE*R*1.0E-3);
      U := R*DELTAX*(1.0 + (HTC + HRC)/(DELTAX*R));
      CZW := U*CMPLX(0.5, 0.5)*SQRT(WAVE/(R*1.0E-3))*0.001;
      E := (1.0 - RO*DELTAX*ECOM(CZW))*FLF/(1000.0*DMIN);
      Goto MASTER_NODE;
--
<<GEOMETRIC_OPTICS>>
--     CALCULATION OF THE GROUND WAVE WITH GEOMETRIC OPTICS.
--
      HT2 := HTKM*HTKM;
      HR2 := HRKM*HRKM;
      A1 := 2.0*A*HTKM + HT2;
      A2 := 2.0*A*HRKM + HR2;
      XA := OMCOS(THETA);
      D := SQRT((2.0*A*A + 2.0*A*(HTKM + HRKM))*XA + HT2 + HR2 - 2.0
           *HTKM*HRKM*COS(THETA));
--
      If HTC = 0.0 Then
         D1 := 0.0;

         CSQD := (((A + HRKM)*SIN(THETA))/D)**2.0;
         SD2 := 1.0 - CSQD;
         If ABS(SD2) < 0.0001 Then
            SD2:= 0.0001;
         End If;
         SD := SQRT(SD2);
         Goto G1090;
      End If;
--
      KOUNT := 1;
      S := 1.0/SQRT(1.0 + (DMIN/(HTKM + HRKM))**2);
      SSQ := S*S;
      ASQ := A*A;
      D1 := SQRT(ASQ*SSQ + A1) - A*S;
      D2 := SQRT(ASQ*SSQ + A2) - A*S;
      SE := (D1 + D2)**2 - 4.0*D1*D2*SSQ - D*D;
      SD := S + SIGN(0.01,SE);
      SD2 := SD*SD;
<<G1080>>
      D1 := SQRT(ASQ*SD2 + A1) - A*SD;
      D2 := SQRT(ASQ*SD2 + A2) - A*SD;
      SSE := (D1 + D2)**2 - 4.0*D1*D2*SD2 - D*D;
      KOUNT := KOUNT + 1;
      If KOUNT > 20 Then
         Goto G1090;
      End If;
      XA := SSE - SE;
      If ABS(XA) < 1.0E-10 Then
         XA := 1.0E-10*SIGN(1.0,XA);
      End If;
      SA := SD + (S - SD)*SSE/XA;
      S := SD;
      SSQ := S*S;
      SE := SSE;
      SD := SA;
      SD2 := SD*SD;
      If ABS(SSE) >= 0.1*LAMBDA Then
         Goto G1080;
      End If;
      CSQD := 1.0 - SD2;
--
<<G1090>>
      DELANG := ASIN(SD);
      DELANG := DEGREES_PER_RADIAN*DELANG;
--
-- *** NEAR THE HORIZON (SMALL SD) USE NUMERICAL INTEGRATION.
--
      If IGAUSS = 0 or SD >= 2.0/V Then
         Z2 := CXSQRT(ETA-CSQD);
         If NPOL = 1 Then
            Z2 := Z2/ETA;
         End If;
         RR := (SD - Z2)/(SD + Z2);
         DT := 4.0*D1*D2*SD2/(D1 + D2 + D);
         E := FLF*CEXP(CMPLX(0.0,-WAVE*(D-DMIN)))/(2000.0*D)*(1.0 +
              RR*CEXP(CMPLX(0.0,-WAVE*DT)));
         Goto MASTER_NODE;
      End If;
--
--     CALCULATION OF THE GROUND WAVE WITH GAUSSIAN NUMERICAL INTEGRATION
--
      N := 0;
      TW (N,Q,TZ,EEK,MZ,EAK,MA,ECK,MZ,ECK,MZ);
      BOT := 0.5*AIMAG(TZ);
      YONE := BOT;
      XONE := AREAL(TZ);
      TOP := -AMIN1(6.0/X,100.0);
      TOP := AMIN1(TOP,-SQRT(Y1)-SQRT(Y2));
      FTX := 0.5*(TOP - BOT);
      KK := 0;
      SGN := 1.0;
--
-- *** COMPUTE INTEGRAND FACTOR THAT IS INDEPENDENT OF DISTANCE.
--
      For I in 1..2 Loop
         SGN := -SGN;
         For K in 1..48 Loop
            KK := KK + 1;
            TX := ((TOP - BOT)*G(K) + TOP + BOT)*0.5;
            O(KK) := CMPLX(XONE + SGN*(TX - YONE),TX);
         End Loop;
      End Loop;
--
      For K in 1..96 Loop
         If ABS(AREAL(O(K)) - Y2) > 5.0 and Y1 > 0.0 and CABS(O(K)) > 5.0 Then
            Goto G1140;
         End If;
         CWAIRY(1,O(K),W1(K),M1(K),W2(K),M2(K));
         CWAIRY(2,O(K),DW1(K),MD1(K),DW2(K),MD2(K));
         F := 2.7182818**(MD1(K) - M1(K));
         WX(K) := F*DW1(K)/W1(K) - Q;
         CWAIRY(1,O(K) - Y2,WY1,MY1,EEK,M);
         MPT(K) := MY1 - M1(K);
         PT(K) := WY1/W1(K)/WX(K);
         If Y1 <= 0.0 Then
            Goto G1160;
         End If;
         WW1(K) := 2.7182818**(MD1(K) - M1(K))*DW1(K) - W1(K)*Q;
         WW2(K) := 2.7182818**(MD2(K) - M2(K))*DW2(K) - W2(K)*Q;
         CWAIRY(1,O(K) - Y1,WY1,MY1,WY2,MY2);
         F := 2.7182818**(MY1 + M2(K));
         FF := 2.7182818**(MY2 + M1(K));
         PT(K) := CMPLX(0.0,-0.5)*(FF*WY2*WW1(K) - F*WY1*WW2(K))*PT(K);
         Goto G1160;
--
<<G1140>>
         MPT(K) := 0;
         If K > 48 Then
            Goto G1150;
         End If;
         TS := CXSQRT(O(K));
         ZO := 0.66666666* O(K)*TS;
         ZR := CXSQRT(O(K) - Y2);
         ZT := CXSQRT(O(K) - Y1);
         ZZ := CXSQRT(ZR*ZT);
         ZR := 0.66666666*ZR*(O(K) - Y2);
         ZT := 0.66666666*ZT*(O(K) - Y1);
--
--SEE IF EXPONENTIAL HAS EXCEEDED MACHINE LIMITS
         FLG:=0;
         If CABS(ZR-ZT) >= 88.0 or CABS(2.0*ZT-ZO) >= 88.0 Then
            E := CMPLX(1.0E-11,0.0);
            FLG:=1;
            EXIT;
         End If;
         PT(K) := 0.5*CEXP(ZR-ZT)*(1.0+CEXP(2.0*(ZT-ZO))*(TS+Q)/(TS-Q))/ZZ;
         Goto G1160;
--
<<G1150>>
         TS := CXSQRT(-O(K));
         ZO := -0.66666666*O(K)*TS;
         ZR := CXSQRT(Y2 - O(K));
         ZT := CXSQRT(Y1 - O(K));
         ZZ := CXSQRT(ZR*ZT);
         ZR := 0.66666666*ZR*(Y2 - O(K));
         ZT := 0.66666666*ZT*(Y1 - O(K));
         PT(K) := 0.5*CEXP(CMPLX(0.0,-1.0)*(ZR - ZT))*
                  (1.0 + CEXP(CMPLX(0.0,-2.0)*
                  (ZT - ZO))*(CMPLX(0.0,1.0)*TS + Q)/(CMPLX(0.0,1.0)*TS - Q))/
                  (CMPLX(0.0,1.0)*ZZ);
<<G1160>>
         Null;
      End Loop;
      if FLG=1 then Goto MASTER_NODE; end if;
      NN := 3;
      KK := 0;
      SGN := 1.0;
--
-- *** INTEGRATE FOR THIS DISTANCE.
--
      For I in 1..2 Loop
         SGN := -SGN;
         For K in 1..48 Loop
            KK := KK + 1;
            ZEXP(X*AIMAG(O(KK)),-X*AREAL(O(KK)),TX,TY,MT);
            F := 2.718282**(MT + MPT(KK));
            E := E + W(K)*FTX*F*CMPLX(TX,TY)*CMPLX(1.0,SGN)*PT(KK);
         End Loop;
      End Loop;
      E := FLF*SQRT(V/(6.0*STH))/(2000.0*A)*E*CMPLX(-1.0,-1.0);
      Goto MASTER_NODE;
--
<<RESIDUE_SERIES>>
--
--     CALCULATION OF THE GROUND WAVE WITH THE FOK-WAIT
--     RESIDUE SERIES.
--
      E:=CMPLX(1.0E-11,0.0);
--
--     LOOP AROUND RGW BASED ON LINE-OF-SIGHT DISTANCE,
--     INPUT VARIABLE ILOS, AND MINIMUM DISTANCE VARIABLE FTESTT.
--
      If ILOS = 1 Then
         Goto G1200;
      End If;
      DCHECK := FLOAT(ILOS - 1)*TEST;
      DCHECK := AMAX1(DCHECK,20.0*FTESTT);
      If COND > 0.30 Then
         DCHECK := AMAX1(DCHECK,100.0*FTESTT);
      End If;
--
--     THIS MEANS THAT EVEN IF BOTH ANTENNAS ARE AT GROUND, CALCULATIONS
--     WILL BE PERFORMED TO AT LEAST 417 KM FOR 3 MHZ, AND 173.8 KM
--     FOR 30 MHZ OVER LAND, AND 5 TIMES THESE DISTANCES OVER SEA.
--
      If DMIN > DCHECK Then
         Goto MASTER_NODE;
      End If;
--
<<G1200>>
      E := RGW(MGW);
--
--     MASTER NODE AFTER E HAS BEEN CALCULATED.
--
<<MASTER_NODE>>
      AMP := CABS(E);
      AMP := AMAX1(1.0E-10,AMP);
      AMP := AMIN1(AMP,1.0E10);
      ISKIP := 0;
      If AMP > 0.999E10 or AMP < 1.0001E-10 Then
         ISKIP := 1;
      End If;
      PHASE := 0.0;
      If ISKIP /= 1 Then
         EJ := AIMAG(E);
         ER := AREAL(E);
         If EJ > 0.0 Then
            PHASE := HALFPI;
         End If;
         If EJ < 0.0 Then
            PHASE := PI + HALFPI;
         End If;
         If ER > 0.0001 Then
            PHASE := ATAN(EJ/ER);
         End If;
      End If;
--
--     CALCULATE DB LOSS AND SIGNAL STRENGTH IN VOLTS/METER
--
      VOLTPM := AMP;
      DBLOSS := 400.0;
      If AMP > 0.9999E10 Then
         DBLOSS := 0.0;
      End If;
      If ISKIP /= 1 Then
         DBLOSS := 10.0*LOG10(POWER*(FREQ/AMP)**2) + 22.45;
      End If;
      Return;
--
      End GRWAVE;
--
--
      Function OMCOS (X: float) return float is
--
--#PURPOSE: OMCOS calculates ( l.0 - cos (x)) for very small x.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        X      = Argument
--OUT       OMCOS  = 1. - cos (x)
--
--#CALLED BY:
--          GRWAVE
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          OMCOS calculates (l.0 - cos (x)) for very small x by
--          using the sum of Taylor series.
--
      S, T, R, RESULT: float;
--
      Begin
--
      If ABS(X) > 0.15 Then
         Return 1.0 - COS(X);
      Elsif X = 0.0 Then
         Return 0.0;
      Else
         S := X*X;
         T := 0.5*S;
         RESULT := T;
         R := 4.0;
         Loop
            T := -T*S/(R*(R - 1.0));
            RESULT := RESULT + T;
            Exit When ABS(T/RESULT) <= 0.5E-9;
            R := R + 2.0;
         End Loop;
         Return RESULT;
      End If;
--
      End OMCOS;
--
--
      Function RGW (MMM: in integer) return complex is
--
--#PURPOSE: RGW calculates the values of a residue series used for
--          ground wave signal level determination at HF.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        MMM     = Flag indicating a new case (MM=1) of that
--                   only the distance has been changed from the
--                   last case (MM=2)
--OUT       RGW    = Ground wave signal strength in V/M
--
--#CALLED BY:
--          GRWAVE
--
--#CALLS TO:
--          CWAIRY
--          TW
--
--#TECHNICAL DESCRIPTION:
--          The essence of this routine has been extracted from:
--          GW SNR (Ground Wave Signal-to-Noise Ratio) a FORTRAN code
--          developed by Leslie A. Berry of the U.S. Department of
--          Commerce, Institute for Telecommunication Sciences, Bolder,
--          Colorado.
--
      G, GW, CZERO, ARG, RATIO, W1, DW1, S, WY1, WY2: complex;
      T: array (integer range 1..200) of complex;
      W: array (integer range 1..200) of complex;
      J1, J2, J, MW1, MD1, M, MY1, MY2: integer;
      MM: integer := MMM;
--
      Begin
--
      CZERO := CMPLX(0.0, 0.0);
      GW := CMPLX(0.0, 0.0);
      If MM = 2 Then
         Goto R1070;
      End If;
      J2 := 1;
      MM := 2;
--
<<R1010>>
      For J in J2..200 Loop
         TW (J-1 , Q, T(J), W1, MW1, DW1, MD1, S,M,S,M);
         If HTKM > 0.0 Then
           Goto R1030;
         Elsif HRKM > 0.0 Then
           Goto R1020;
         End If;
         W(J) := CMPLX(1.0,0.0);
         Goto R1040;
--
-- *** COMPUTE HEIGHT GAIN FACTORS
--
<<R1020>>
         CWAIRY(1,T(J)-Y2,WY2,MY2,S,M);
         W(J) := 2.7182818**(MY2-MW1)*WY2/W1;
         Goto R1040;
--
<<R1030>>
         CWAIRY(1,T(J)-Y1,WY1,MY1,S,M);
         W(J) := 2.7182818**(MY1-MW1)*WY1/W1;
         If HRKM <= 0.0 Then
            Goto R1040;
         End If;
         CWAIRY(1,T(J)-Y2,WY2,MY2,S,M);
         S := 2.7182818**(MY2-MW1)*WY2/W1;
         W(J) := W(J)*S;
--
<<R1040>>
         W(J) := W(J)/(T(J)-Q*Q);
--
-- *** W(J) IS THE COEFFICIENT OF THE DISTANCE FACTOR FOR
--     THE J-TH TERM.
--
         ARG := CMPLX(0.0,-1.0)*X*T(J);
         If AREAL(ARG) >= -69.0 Then
            G:=W(J)*CEXP(ARG);
         Else
            G := CMPLX(0.0,0.0);
         End If;
         GW := GW + G;
         If J = 1 Then
            Goto R1050;
         End If;
         If AREAL(GW) = AREAL(CZERO) and AIMAG(GW) = AIMAG(CZERO) Then
            Goto R1050;
         End If;
         RATIO := G/GW;
         If CABS(RATIO)  > 0.0005 Then
            Goto R1050;
         End If;
         J1 := J;
         Exit;
<<R1050>>
         Null;
      End Loop;
--
      if J1<200 and J1>J2 then
         J2:=J1;
      else
         J2 := 200;
      end if;
      Goto R1090;
--
-- *** SUM THE RESIDUE SERIES FOR THIS DISTANCE.
--
<<R1070>>
      For J in 1..J2 Loop
         G := W(J)*CEXP(CMPLX(0.0,-1.0)*X*T(J));
         GW := GW + G;
         If J = 1 Then
            Goto R1080;
         End If;
         If AREAL(GW) = AREAL(CZERO) and AIMAG(GW) = AIMAG(CZERO) Then
            Goto R1080;
         End If;
         RATIO := G/GW;
         If CABS(RATIO)  < 0.0005 Then
            Exit;
         End If;
<<R1080>>
         Null;
      End Loop;
--
      If J2 >= 200 or CABS(RATIO)  < 0.0005 then
         Goto R1090;
      End If;
      J2 := J2 + 1;
      Goto R1010;
--
<<R1090>>
      Return GW*(FLF*PI*1.0E-3*SQRT(V/(6.0*STH))/A)*CMPLX(1.0,-1.0);
--
      End RGW;
--
--
      Procedure TW (I: in integer;
                    Q: in complex;
                    T: out complex;
                    W1: out complex;
                    MW1: out integer;
                    DW1: out complex;
                    MD1: out integer;
                    W2: out complex;
                    MW2: out integer;
                    DW2: out complex;
                    MD2: out integer) is
--
--#PURPOSE: TW calculates the roots of Airy function equations.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        I      = The root of interest
--IN        Q      = A coefficient in the equation
--OUT       T      = The I-th root
--OUT       W1     = Airy function root
--OUT       MW1    = Airy function root
--OUT       DW1    = Airy function root
--OUT       MD1    = Airy function root
--OUT       W2     = Airy function root
--OUT       MW2    = Airy function root
--OUT       DW2    = Airy function root
--OUT       MD2    = Airy function root
--
--#CALLED BY:
--          GRWAVE,
--          RGW
--
--#CALLS TO:
--          CWAIRY
--
--
--#TECHNICAL DESCRIPTION:
--          The essence of this routine has been extracted from:
--          GW SNR (Ground Wave Signal-to-Noise Ratio) a FORTRAN code
--          developed by Leslie A. Berry of the U.S. Department of
--          Commerce, Institute for Telecommunication Sciences, Bolder,
--          Colorado.
--
      A: complex;
      PH: complex := CMPLX(0.5, -0.8660254);
--
--      W-SUB-ONE-PRIME(TZERO(I)) := 0.0
      TZERO: array (integer range 1..11) of float :=
         (1.018793, 3.2481975, 4.8200992, 6.1633074, 7.3721773, 8.4884868,
          9.5354490, 10.52766, 11.475057, 12.384788, 13.262219);
--
--      W-SUB-ONE(TINFIN(I)) := 0.0
      TINFIN: array (integer range 1..11) of float :=
         (2.3380997, 4.0879494, 5.5205598, 6.7867081, 7.9441336, 9.0226508,
          10.040174, 11.008524, 11.936016, 12.828777, 13.691489);
      CON: float := 1.17809724;
      YS, TZ: float;
      K: integer;
--
      Begin
--
      If AREAL(Q)**2 + AIMAG(Q)**2 > 1.0 Then
         Goto T1020;
      Elsif I > 10 Then
         Goto T1000;
      End If;
      TZ := TZERO(I+1);
      Goto T1010;
--
<<T1000>>
      YS := (float(4*I + 1)*CON)**2;
      TZ := YS** 0.33333333*(1.0 - 0.1458333/YS);
--
<<T1010>>
      T := TZ*PH;
--
--     T IS NOW SOLUTION FOR Q :=0.0  THE NEXT STEP IS THE FIRST NEWTON
--     ITERATION.
--
      T := T + Q/T;
      Goto T1050;
--
<<T1020>>
      If I > 10 Then
         Goto T1030;
      End If;
      TZ := TINFIN(I+1);
      Goto T1040;
--
<<T1030>>
      YS := (float(4*I + 3)*CON)**2;
      TZ := YS** 0.33333333*(1.0 + 0.1041667/YS);
--
<<T1040>>
      T := TZ*PH;
--
--  T IS SOLUTION FOR Q:=INFINITY.  NEXT STEP IS THE FIRST NEWTON
--     ITERATION.
--
      T := T + 1.0/Q;
--
<<T1050>>
      K := 0;
--
--      NOW, USE NEWTONS ITERATION TO CONVERGE ON SOLUTION
--        CWAIRY COMPUTES  W(T) AND W PRIME (T)
--
<<T1060>>
      CWAIRY (1,T,W1,MW1,W2, MW2);
      CWAIRY (2,T,DW1,MD1,DW2,MD2);
      A := (2.71828182**(MD1 - MW1))*DW1/W1;
      A := (A - Q)/(T - A*Q);
      T := T - A;
      K := K + 1;
      If K > 30 Then
         Goto T1070;
      Elsif CABS(A/T) > 0.5E-6 Then
         Goto T1060;
      Else
         Return;
      End If;
--
<<T1070>>
      New_Line;
      Put ("Convergence failed in Procedure TW.");
      Return;
--
      End TW;
--
--
      Procedure UP (A: in complex;
                    E: out complex) is
--
--#PURPOSE: UP calculates the value of a complementary error
--          function by a power series summation.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        A      = The complex argument
--OUT       E      = CEXP (A**2) *ERFC(A)
--
--#CALLED BY:
--          DOWN
--          ECOM
--
--#CALLS TO:
--          DOWN
--
--#TECHNICAL DESCRIPTION:
--          The essence of this routine has been extracted from:
--          GW SNR (Ground Wave Signal-to-Noise Ratio) a FORTRAN code
--          developed by Leslie A. Berry of the U.S. Department of
--          Commerce, Institute for Telecommunication Sciences, Bolder,
--          Colorado.
--
      Z, EP, Z2, GN: complex;
      ZB2, EN: float;
--
      Begin
--
      Z := A;
      If CABS(Z) - 3.5 <= 0.0 Then
         DOWN (Z,EP);
         E := CEXP(Z**2) - EP;
         Return;
      End If;
      Z2 := -Z*Z;
      ZB2 := CABS(Z2);
      GN := CMPLX(0.56418958,0.0)/Z;
      EP := GN;
      EN := 0.5;
--
<<D1020>>
      GN := EN*GN/Z2;
      EP := EP + GN;
      If CABS(GN/EP) - 1.0E-05 <= 0.0 Then
         Goto D1040;
      End If;
--
<<D1030>>
      EN := EN + 1.0;
      If EN - ZB2 < 0.0 Then
         Goto D1020;
      End If;
--
<<D1040>>
      E := EP;
      Return;
--
      End UP;
--
--
--
--
End LF_HF_GROUNDWAVES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--VHFUHFSH
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Debugger2; Use Debugger2;
With Constants; Use Constants;
With Propagation_Constants; Use Propagation_constants;
With Mathlib; Use Mathlib, Core_functions;
With RFUtil;

Package VHF_UHF_SHF_EHF_PROPAGATION is
--
      Procedure VHF_UHF_SHF_EHF_HANDLER;
--
End VHF_UHF_SHF_EHF_PROPAGATION;
--
Package body VHF_UHF_SHF_EHF_PROPAGATION is
--
-- VHF_UHF_SHF_EHF_PROPAGATION Package of PROP_LINK
-- Version 1.0,  July 2, 1985.
--
-- This VHF_UHF_SHF_EHF_PROPAGATION Package contains all of the procedures
-- that are used to perform VHF_UHF_SHF_EHF propagation prediction.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
      Pragma Source_info (on);
--
      Procedure VHF_UHF_SHF_EHF_HANDLER is
--
--#PURPOSE: VHF_UHF_SHF_EHF_HANDLER computes the signal strength at a receiver
--          location for HF links.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        TALT   = Transmitter altitude in kilometers
--IN        RALT   = Receiver altitude in kilometers
--IN        DPATH  = Creat circle path length between transmitter & receiver
--                   in km
--IN        BRNG2  = Bearing from receiver to transmitter in degrees
--IN        FREQMC = Frequency in MHz
--IN        TERP   = Transmitter power in dBW
--IN        RLL    = Receiver line loss in dB
--OUT       SIGNAL = Signal strength at receiver in dBW
--
--#CALLED BY:
--          RF_PROPAGATION_HANDLER
--
--#CALLS TO:
--          AOW
--          COORDX
--
--#TECHNICAL DESCRIPTION:
--     VHF_UHF_SHF_EHF_HANDLER is the RF propagation prediction routine
--     VHF/UHF/SHF/EHF electromagnetic waves.
--
      ATMOS2: constant float:= 60.0;
      AW0, ELEV, FSL: float;
      R, AZSATD, H, XR, YR, ZR, SRSATJ, ELSATD: float;
--
      Begin
--
--COMPUTE AMBIENT SIGNAL STRENGTH AT RECEIVER EXCLUSIVE OF ANTENNA GAIN
--  WHICH IS ADDED IN Procedure NOISY AS PART OF G/T.
      AW0 := 0.0;
      RFUTIL.COORDX (RALT, 1, DPATH, BRNG2, TALT, R, AZSATD, H,
              XR, YR, ZR, SRSATJ, ELSATD);
      If RALT <= ATMOS2 or TALT <= ATMOS2 Then
         ELEV := ABS(ELSATD)*RADIANS_PER_DEGREE;
         AW0 := RFUTIL.AOW (FREQMC, ELEV);
      End If;
      FSL := 0.0;
      SRSATJ := ABS(SRSATJ);
      If SRSATJ /= 0.0 Then
         FSL := 32.5 + 20.0*LOG10(FREQMC) + 20.0*LOG10(SRSATJ);
      End If;
      SIGNAL := TERP - FSL - AW0 - RLL;
--
      Return;
--
      End VHF_UHF_SHF_EHF_HANDLER;
--
--
End VHF_UHF_SHF_EHF_PROPAGATION;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--MFHFPROP
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Debugger2; Use Debugger2;
With Text_IO; Use Text_io, integer_io, float_io;
With Constants; Use Constants;
With Propagation_constants; Use Propagation_constants;
With Mathlib; Use Mathlib, numeric_primitives, core_functions, trig_functions;
With Complex_numbers; Use Complex_numbers;
With RFUtil;
With Nodeloc;
With Hf_atmospherics;
With Elf_Lf_Hf_atmospherics;
With Lf_Hf_Groundwaves;

Package MF_HF_PROPAGATION is
--
      Procedure MF_HF_HANDLER;
--
End MF_HF_PROPAGATION;
--
Package body MF_HF_PROPAGATION is
--
-- MF_HF_PROPAGATION Package of PROP_LINK
-- Version 1.0,  July 2, 1985.
--
-- This MF_HF_PROPAGATION Package contains all of the procedures that
-- are used to perform MF_HF propagation prediction.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
-- Use Text_IO;
-- Instantiate integer and floating point IO.
--     Package IO_INTEGER is new INTEGER_IO(INTEGER);
--     Package IO_FLOAT is new FLOAT_IO(FLOAT);
--Use IO_INTEGER,IO_FLOAT;
--
   Pragma Source_info (on);
--
      EFDATA: array (integer range 1..5,
                     integer range 1..6,
                     integer range 1..6) of float;
      NSUCC: array (integer range 1..20) of integer;
      SECACP: array (integer range 1..20) of float;
      ACPLAT: array (integer range 1..140) of float;
      ACPLON: array (integer range 1..140) of float;
      ACPABS: array (integer range 1..140) of float;
      SPLOSS, RELOSS, GT, GR, PL, GRSIG, CHI, AMBAB: float;
      GTANT: array (integer range 1..21) of float;
      GRANT: array (integer range 1..21) of float;
      SIGPWR: array (integer range 1..20) of float;
      PLOSS: array (integer range 1..20) of float;
      PLNA: array (integer range 1..20) of float;
      FMX: array (integer range 1..20) of float;
      FMN: array (integer range 1..20) of float;
      ALOS: array (integer range 1..20) of float;
      SPLHF: array (integer range 1..20) of float;
      RELHF: array (integer range 1..20) of float;
--**************************************************************************
--
      Function FPSI (HANGLE: float; CONST: float) return float is
--
--FPSI IS THE RADIATION ANGLE DETERMINED FROM THE HALF CENTRAL ANGLE AND
--A CONSTANT.
--
      Begin
--
      Return ATAN((COS(HANGLE)-CONST)/(AMAX1(1.0E-10, SIN(HANGLE))));
--
      End FPSI;
--
--
      Function FAVG (A: float; B: float) return float is
--
      Begin
--
      Return (A + B)*0.5;
--
      End FAVG;
--
--
      Function FRANG (HEIGHT: float; HANG: float) return float is
--
      Begin
      Return ATAN ((RADIUS_OF_EARTH_IN_KM + HEIGHT - RADIUS_OF_EARTH_IN_KM*
             COS(HANG))/(RADIUS_OF_EARTH_IN_KM*AMAX1(1.0E-10,SIN(HANG)))) -
             HANG;
--
      End FRANG;
--
--
      Function FSEC (HANGLE: float; RANGLE: float) return float is
--
      Begin
--
      Return 1.0/SIN(HANGLE+RANGLE);
--
      End FSEC;
--
--
      Function FHANG (PSI: float; CONST: float) return float is
--
      Begin
--
      Return ACOS(CONST*COS(PSI)) - PSI;
--
      End FHANG;
--
--
      Function FLHS (A1: float; BETA: float; ALPF: float) return float is
--
      Begin
--
      Return SIN(A1*ALPF - BETA);
--
      End FLHS;
--
--
      Function FRHS (CE: float; CF: float; AK: float; BETA: float; ALPF: float)
                    return float is
--
      Begin
--
      Return CE*SIN(ALPF) + CF*SIN(AK*ALPF - BETA);
--
      End FRHS;
--
--
      Function CXSQRT (ZT: complex) return complex is
--
      Begin
--
      Return CSQRT(ZT)*SIGN(1.0,AREAL(CSQRT(ZT)));
--
      End CXSQRT;
--
--
      Function FD20 (R: float; D: float) return float is
--
--    FD20 IS FOR CALCULATING SPACE LOSS.
--
      Begin
--
      Return 71.0 + 8.7*LOG(R/COS(D));
--
      End FD20;
--
--
      Function FEPS (SIGMA: float) return float is
--
--    FEPS IS FOR CALCULATING AN EPS CONSISTENT WITH THE
--          INPUT CONDUCTIVITY.  FOR POOR EARTH WITH A
--          CONDUCTIVITY OF 0.001, EPS := 4.0  FOR A GOOD
--          EARTH WITH A CONDUCTIVITY OF 0.01, EPS := 10.0
--          EPS IS EXTRAPOLATED/INTERPOLATED IN BOTH DIRECTIONS
--          BUT NOT ALLOWED TO BE LESS THAN 1.
--          IF SIGMA IS > 0.9 MHO/M, IT IS ASSUMED THAT
--          THE REFLECTION MEDIUM IS WATER, AND EPS IS SET := 80.0
--
      Begin
--
      Return AMAX1 (1.0, 6.0*LOG10(1000.0*SIGMA) + 4.0);
--
      End FEPS;
--
      Procedure AEORAF (EHTD: in float;
                        EHTN: in float;
                        FHTD: in float;
                        FHTN: in float) is
--
--#PURPOSE: AEORAF calculates which single modes are possible and
--          fills EFDATA with variable values for the possible cases.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        EHTD   = Height of the E layer of the ionosphere in
--                   DAY conditions in kilometers
--IN        EHTN   = Height of the E layer of the ionosphere in
--                   NIGHT conditions in kilometers
--IN        FHTD   = Height of the F layer of the ionosphere in
--                   DAY conditions in kilometers
--IN        FHTN   = Height of the F layer of the ionosphere in
--                   NIGHT conditions in kilometers
--
--#CALLED BY:
--          EFMODE
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          Straightforward spherical geometry is employed to determine
--          which of five E layer modes and which of five F layer modes
--          are feasible (i.e., launch angles do not intersect the earth).
--
      EHT, FHT, DUMA, DUMB, DHOP, ALPE, RADANG, SECX: float;
      I, J, NMODE, NHOPS, IYEFD, IZEFD: integer;
--
      Begin

      If IDNT = DAY and IDNR = DAY Then
         EHT := EHTD;
         FHT := FHTD;
      Elsif IDNT /= IDNR Then
         DUMA := DISDAY/DISTOT;
         DUMB := DISNIT/DISTOT;
         EHT := DUMA*EHTD + DUMB*EHTN;
         FHT := DUMA*FHTD + DUMB*FHTN;
      Else
         EHT := EHTN;
         FHT := FHTN;
      End If;
--
--DO E MODES.
      J := 0;
      For I in 1..5 Loop
         NMODE := IJTMD(I+1,J+1);
         NHOPS := IHFMD(NMODE,3);
         IYEFD := IHFMD(NMODE,6);
         IZEFD := IHFMD(NMODE,7);
         DHOP := DISTOT/FLOAT(NHOPS);
         ALPE := 0.5*DHOP/RADIUS_OF_EARTH_IN_KM;
         RADANG := FRANG(EHT, ALPE);
         SECX := FSEC(ALPE, RADANG);
         If RADANG >= RADIANS_PER_DEGREE Then
            EFDATA(1,IYEFD,IZEFD) := ALPE;
            EFDATA(3,IYEFD,IZEFD) := RADANG;
            EFDATA(4,IYEFD,IZEFD) := SECX;
         Elsif RADANG > 0.0 Then
            EFDATA(3,IYEFD,IZEFD) := -TWOPI;
         End If;
      End Loop;
--
--DO F MODES.
      I:=0;
      For J in 1..5 Loop
         NMODE := IJTMD(I+1,J+1);
         NHOPS := IHFMD(NMODE,3);
         IYEFD := IHFMD(NMODE,6);
         IZEFD := IHFMD(NMODE,7);
         DHOP := DISTOT/FLOAT(NHOPS);
         ALPE := 0.5*DHOP/RADIUS_OF_EARTH_IN_KM;
         RADANG := FRANG(FHT, ALPE);
         SECX := FSEC(ALPE, RADANG);
         If RADANG >= RADIANS_PER_DEGREE Then
            EFDATA(2,IYEFD,IZEFD) := ALPE;
            EFDATA(3,IYEFD,IZEFD) := RADANG;
            EFDATA(5,IYEFD,IZEFD) := SECX;
         Elsif RADANG > 0.0 Then
            EFDATA(3,IYEFD,IZEFD) := -TWOPI;
         End If;
      End Loop;
--
      Return;
--
      End AEORAF;
--
--
      Procedure EFHOP (EHTD: in float;
                       FHTN: in float;
                       NITMAX: in integer) is
--
--#PURPOSE: EFHOP calculates which mixed modes are possible and
--          fills EFDATA with variable values for the possible cases.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        EHTD   = Height of the E layer of the ionosphere in
--                   DAY conditions in kilometers
--IN        FHTN   = Height of the F layer of the ionosphere in
--                   NIGHT conditions in kilometers
--IN        NITMAX = The maximum number of iterations allowed for
--                   convergence
--
--#CALLED BY:
--          EFMODE
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          EFHOP calculates the geometrically viable number of hops
--          in mixed mode HF skywave communications.  All output data is
--          passed via COMMON EFMDAT.
--
--          The technique employed is one of iterative search for each
--          of the possible combinations of mixed E and F layer hop
--          modes.  The launch angle is adjusted each time until
--          convergence is found -- unless the mode is found to be
--          divergent because it is geometrically impossible.
--
      ALP: array (integer range 1..3) of float;
      ALPERR: array (integer range 1..3) of float;
      ALFMXA, ALPTOT, ERRBND, ALPFMN, ALFMXB, ALPFMX, DUMA, DUMB, DUMC: float;
      A1, BETA, C, ALPE, ALPF, A2, PSIF, PSIE: float;
      NMODE, NEHOPS, NFHOPS, NHOPS, IYEFD, IZEFD, NIT, INFLG: integer;
      KA, KB, IFLG: integer;
      CE, CF, AK: float;
--
      Begin
--
      CE := RADIUS_OF_EARTH_IN_KM/(EHTD + RADIUS_OF_EARTH_IN_KM);
      CF := RADIUS_OF_EARTH_IN_KM/(FHTN + RADIUS_OF_EARTH_IN_KM);
      ALFMXA := ACOS(CF);
      ALPTOT := 0.5*DISTOT/RADIUS_OF_EARTH_IN_KM;
      ERRBND := 0.001*RADIANS_PER_DEGREE;
--
--START THE LOOP OVER THE MODES.
--
      For NMODE in 11..20 Loop
         NEHOPS := IHFMD(NMODE,1);
         NFHOPS := IHFMD(NMODE,2);
         NHOPS  := IHFMD(NMODE,3);
         IYEFD  := IHFMD(NMODE,6);
         IZEFD  := IHFMD(NMODE,7);
         ALPFMN := ALPTOT/FLOAT(NHOPS);
         ALFMXB := ALPTOT/FLOAT(NFHOPS);
         ALPFMX := AMIN1(ALFMXA, ALFMXB);
--
--DO A QUICK CHECK ON THE TERMINATOR.
--     USE THE MAXIMUM ALPHA F TO DETERMINE THE MAXIMUM
--          F HOP SEGMENT DISTANCE.
--     USE THE MINIMUM ALPHA F TO DETERMINE THE MINIMUM
--          F HOP SEGMENT DISTANCE.
--     IF THE MINIMUM DISTANCE IS GREATER THAN DISNIT
--          OR IF THE MAXIMUM DISTANCE IS LESS THAN DISNIT
--          THE MODE IS NOT POSSIBLE.
--
         DUMA := (2.0*FLOAT(NFHOPS) + 1.0)*RADIUS_OF_EARTH_IN_KM*ALPFMX;
         DUMB := (2.0*FLOAT(NFHOPS) - 1.0)*RADIUS_OF_EARTH_IN_KM*ALPFMN;
         If DUMA >= DISNIT and DUMB <= DISNIT Then
            BETA := ALPTOT/FLOAT(NEHOPS);
            AK := FLOAT(NFHOPS)/FLOAT(NEHOPS);
            A1 := 1.0 + AK;
            DUMC := FPSI(ALPFMN,CF);
            If DUMC >= 0.0 Then
               NIT := 0;
               INFLG := 0;
               KA := 0;
               KB := 0;
               ALP(1) := ALPFMN;
               ALP(3) := ALPFMX;
               ALP(2) := FAVG(ALPFMN, ALPFMX);
--
               For K in 1..3 Loop
                  ALPERR(K) := FLHS(A1,BETA, ALP(K))-
                               FRHS(CE, CF, AK, BETA, ALP(K));
                  If ALPERR(K) > 0.0 Then
                     KA := KA + 1;
                  End If;
                  If ALPERR(K) < 0.0 Then
                     KB := KB + 1;
                  End If;
               End Loop;
--
               If KA <= 2 and KB <= 2 Then
                  Loop
                     NIT := NIT + 1;
                     If NIT > NITMAX Then
                        New_Line;
                        Put("ERROR...Convergence failed in EFHOP.");
                        INFLG := 1;
                        Exit;
                     Else
                        If ALPERR(2) >= 0.0 Then
                           ALP(3) := ALP(2);
                           ALPERR(3) := ALPERR(2);
                        Else
                           ALP(1) := ALP(2);
                           ALPERR(1) := ALPERR(2);
                        End If;
                        ALP(2) := FAVG(ALP(1), ALP(3));
                        ALPERR(2) := FLHS(A1, BETA, ALP(2)) -
                                     FRHS(CE, CF, AK, BETA, ALP(2));
                        Exit When ABS(ALPERR(2)) <= ERRBND;
                     End If;
                  End Loop;
--
--THERE IS A POTENTIALLY SUCCESSFUL RESULT.
--
                  ALPF := ALP(2);
                  ALPE := BETA - AK*ALPF;
--
--CASE IS GEOMETRICALLY POSSIBLE FOR SOME LOCATION OF THE TERMINATOR,
--CHECK IF ACTUAL TERMINATOR LOCATION NULLIFIES SUCCESSFUL PROPAGATION
--
                  A1 := (2.0*FLOAT(NEHOPS) - 1.0)*ALPE*RADIUS_OF_EARTH_IN_KM;
                  A2 := (2.0*FLOAT(NEHOPS) + 1.0)*ALPE*RADIUS_OF_EARTH_IN_KM;
                  IFLG := 0;
                  If A1 <= DISDAY and A2 >= DISDAY Then
                     IFLG := 1;
                  End If;
                  If IFLG >= 1 Then
--
--CHECK THAT THE TWO PSI-S PRODUCED ARE EQUAL WITHIN 1 PERCENT.
--
                     PSIF := FPSI(ALPF,CF);
                     PSIE := FPSI(ALPE,CE);
                     DUMA := FAVG(PSIE,PSIF);
                     If INFLG > 0 Then
                        EFDATA(1,IYEFD,IZEFD) := ALPE;
                        EFDATA(2,IYEFD,IZEFD) := ALPF;
                        EFDATA(3,IYEFD,IZEFD) := DUMA;
                        DUMB := FSEC(ALPE, DUMA);
                        EFDATA(4,IYEFD,IZEFD) := DUMB;
                        DUMB := FSEC(ALPF,DUMA);
                        EFDATA(5,IYEFD,IZEFD) := DUMB;
                     Else
                        If DUMA >= 0.0 Then
                           If DUMA >= RADIANS_PER_DEGREE Then
                              DUMB := ABS(PSIE - PSIF)/DUMA;
                              If DUMB > 0.01 Then
                                 New_Line;
                                 Put("ERROR...Convergence failed in EFHOP.");
                                 INFLG := 1;
                              Else
                                 EFDATA(1,IYEFD,IZEFD) := ALPE;
                                 EFDATA(2,IYEFD,IZEFD) := ALPF;
                                 EFDATA(3,IYEFD,IZEFD) := DUMA;
                                 DUMB := FSEC(ALPE, DUMA);
                                 EFDATA(4,IYEFD,IZEFD) := DUMB;
                                 DUMB := FSEC(ALPF,DUMA);
                                 EFDATA(5,IYEFD,IZEFD) := DUMB;
                              End If;
                           Else  --PSI IS > 0.0 BUT < 1 DEG.  SET PSI := -TWOPI
                              EFDATA(3,IYEFD,IZEFD) := -TWOPI;
                           End If;
                        End If;
                     End If;
                  End If;
               End If;
            End If;
         End If;
      End Loop;
--
      Return;
--
      End EFHOP;
--
--
      Procedure EFMODE (EHTD: in float;
                        EHTN: in float;
                        FHTD: in float;
                        FHTN: in float) is
--
--#PURPOSE: EFMODE controls the subroutines that determine the
--          viable single and mixed modes for HF skywave communication
--          for the particular geometry and solar conditions.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Control Module
--
--#PARAMETER DESCRIPTIONS:
--IN        EHTD   = Height of the E layer of the ionosphere in
--                   DAY conditions in kilometers
--IN        EHTN   = Height of the E layer of the ionosphere in
--                   NIGHT conditions in kilometers
--IN        FHTD   = Height of the F layer of the ionosphere in
--                   DAY conditions in kilometers
--IN        FHTN   = Height of the F layer of the ionosphere in
--                   NIGHT conditions in kilometers
--
--#CALLED BY:
--          MF_HF_HANDLER
--
--#CALLS TO:
--          AEORAF
--          EFHOP
--
--#TECHNICAL DESCRIPTION:
--          EFMODE is the control routine for identifying the
--          geometrically viable HF communication skywave modes.
--          It controls all of the other routines that determine the
--          viable single and mixed modes for HF skywave communication
--          for the particular geometry and solar conditions.
--
      J, I, K: integer;
--
      Begin
--
--INITIALIZE EFDATA.
      For J in 1..6 Loop
         For I in 1..6 Loop
            For K in 1..5 Loop
               EFDATA(K,I,J) := 0.0;
            End Loop;
         End Loop;
      End Loop;
--
--EVALUATE THE ALL E AND ALL F MODES OF PROPAGATION.
--
      AEORAF (EHTD, EHTN, FHTD, FHTN);
--
--EVALUATE THE MIXED MODES IF A DAY/NITE TERMINATOR CROSSES THE PATH.
--
      If IDNT /= IDNR Then
         EFHOP (EHTD, FHTN, 10);
      End If;
--
      Return;
--
      End EFMODE;
--
      Function CSZ1 (X: float) return complex is
--
--#PURPOSE: CSZ1 evaluates the sine and cosine integral functions.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        X      = Integrand
--OUT       CSZ1   = Value of cosine or sine integral function
--
--#CALLED BY:
--          HFGAIN
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          CSZ1 evaluates the sine and cosine integral functions.
--          A series expansion is used to numerically evaluate the
--          cosine integral.  The calculation is taken from
--          Barghausen, 1969.
--
      A, AM1, AM2, B, BM1, BM2, SA: complex;
      EN, X2, TN, SI, CI, P, TM1, T: float;
      K: integer;
      TESTQ: float := 4.0E-10;
      GAMA: float := 0.5772156;
--
      Begin
--
      If X <= 6.0 Then
         EN := 0.0;
         X2 := X*X;
         TN := X;
         SI := X;
         Loop
            EN := EN + 1.0;
            TN := -TN*X2*(2.0*EN - 1.0)/((2.0*EN)*(2.0*EN + 1.0)**2);
            Exit When ABS(TN/SI) <= TESTQ;
            SI := SI + TN;
         End Loop;
         EN := 1.0;
         TN := - X2/4.0;
         CI := TN + GAMA + LOG(X);
         Loop
            EN := EN + 1.0;
            TN := -TN*X2*(2.0*EN - 2.0)/((2.0*EN - 1.0)*(2.0*EN)**2);
            Exit When ABS(TN/CI) <= TESTQ;
            CI := CI + TN;
         End Loop;
         Return CMPLX(CI, -SI);
      Else
         AM1 := CMPLX(1.0,0.0);
         AM2 := CMPLX(1.0,0.0);
         BM1 := CMPLX(1.0,0.0);
         BM2 := CMPLX(0.0,0.0);
         P := 0.0;
         K := 0;
         TM1 := 0.0;
         Loop
            P := P + 1.0;
            K := K + 1;
            If K mod 2 /= 0 Then
               SA := CMPLX(0.0,(P + 1.0)/(2.0*X));
            Else
               SA := CMPLX(0.0,P/(2.0*X));
            End If;
            A := AM1 + SA*AM2;
            B := BM1 + SA*BM2;
            T := CABS(A/B);
            Exit When ABS((T - TM1)/T) < TESTQ;
            AM2 := AM1;
            AM1 := A;
            BM2 := BM1;
            BM1 := B;
            TM1 := T;
         End Loop;
         Return CONJG(CMPLX(0.0,HALFPI) +
                CMPLX(COS(X),SIN(X))/(CMPLX(0.0,X)*A/B));
      End If;
--
      End CSZ1;
--
      Procedure HFGAIN (IA: in integer;
                        IT: in integer;
                        DEL: in float;
                        XL: in float;
                        HI: in float;
                        A: in float;
                        GX: in float;
                        SIG: in float;
                        ER : in float;
                        G: out float) is
--
--#PURPOSE: HFGAIN calulates transmitter and receiver antenna gains.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        IA     = Antenna type:
--                   5 = Constant Gain
--                   6 = Rhombic
--                   7 = Vertical
--                   8 = Horizontal Half Wave Dipole
--IN        IT     = Type option (0 = ground losses, 1 = antenna gain)
--IN        DEL    = Radiation angle in radians
--IN        XL     = Antenna length term in meters (IA := 6 or 7 only)
--IN        HI     = Antenna height term in meters (IA := 6 or 8 only)
--IN        A      = Antenna tilt angle in degrees (IA := 6 only)
--IN        GX     = Antenna gain term in dB (IA := 5 only)
--IN        SIG    = Surface conductivity in MHOS/M
--IN        ER     = Surface relative dielectric constant
--OUT       G      = Ground loss or antenna gain in dB
--
--#CALLED BY:
--          HFGL
--
--#CALLS TO:
--          CSZ1
--
--#TECHNICAL DESCRIPTION:
--          Standard formulas for the gain of rhombic, vertical, and
--          horizontal half-wave dipole antennas are evaluated.  These
--          formulas are taken from Barghausen, 1969.
--
      DIF, ACSQ, QPER, QPAR, ZT, SQRD: complex;
      DID: array (integer range 1..2) of float;
      O: array (integer range 1..2) of complex;
      VOFL: float := 2.997925E5;
      GAMA: float := 0.5772156;
      RATIO: float := 1.414214E-3;
      WAVE, EFF, Q, T, CV, PSIV, CH, PSIH, EL, H, PHI, BETA, EL1: float;
      FAC, FAC2, FAC4, X, HWAVE, HQWAVE, RHI, SR, CR, RETA, SB, CB: float;
      TSC, TCS, U1, U2, W1, W3, RAIN, SFAC2, CFAC2, HQ, ACLOC, AS: float;
      FLOG, C2KEL, S2KEL, RIN, RZERO, W4, CFAC, W2, CPHI, SPHI2: float;
      GI, ETETA1, EPHI1, ETETA2, EPHI2, TT, UZ, VZ, V1, CXC, RAINE: float;
      J, IBRNCH: integer;
--
      Begin
--
      If IA = 5 and IT = 1 Then
         G := GX;
         Return;
      End If;
--
      WAVE := (VOFL*0.001)/FREQMC;
      EFF := 0.0;
      G := -10.0;
      Q := SIN(DEL);
      T := COS(DEL);
      DIF := CMPLX(ER,-60.0*SIG*WAVE);
      ACSQ := CXSQRT(DIF-T*T);
      If AREAL(ACSQ) < 0.0 Then
         ACSQ := -ACSQ;
      End If;
      QPER := (DIF*Q - ACSQ)/(DIF*Q + ACSQ);
      CV := CABS(QPER);
      PSIV := AIMAG(CLOG(QPER));
      QPAR := (Q - ACSQ)/(Q + ACSQ);
      CH := CABS(QPAR);
      PSIH := AIMAG(CLOG(QPAR));
      If IT <= 0 Then  --COMPUTE G AS GROUND LOSS
         G := 4.35*LOG(0.5*(CH*CH + CV*CV));
         Return;
      End If;
--
--BEGIN ANTENNA GAIN CALCULATIONS
      EL := XL;
      If IA = 8 Then
         EL := -0.5*WAVE;
      End If;
      H := HI;
      PHI := A;
      BETA := 0.0;
      EL1 := EL/WAVE;
      If EL < 0.0 Then
         EL1 := ABS(EL);
      End If;
      FAC := PI*EL1;
      FAC2 := TWOPI*EL1;
      FAC4 := 2.0*FAC2;
      X := H/WAVE;
      If H < 0.0 Then
         X := ABS(H);
      End If;
      HWAVE := TWOPI*X;
      HQWAVE := 2.0*HWAVE*Q;
      RHI := PHI*RADIANS_PER_DEGREE;
      SR := SIN(RHI);
      CR := COS(RHI);
      RETA := BETA*RADIANS_PER_DEGREE;
      SB := SIN(RETA);
      CB := COS(RETA);
--
--BRANCH TO PROPER ANTENNA TYPE FOR GAIN GALCULATIONS
      IBRNCH := IA - 5;
      If IBRNCH = 1 Then  -- TERMINATED RHOMBIC ANTENNA, IA = 6
         TSC := 1.0 - T*SR*CB;
         TCS := T*CR*SB;
         U1 := TSC - TCS;
         U2 := TSC + TCS;
         W1 := COS(PSIH - HQWAVE);
         W3 := COS(PSIV-HQWAVE);
         RAIN := 3.2*(CR*SIN(FAC*U1)*SIN(FAC*U2)/(U1*U2))**2*((CB -
                 SR*T)**2*(CH**2 + 1.0 + 2.0*CH*W1) + SB**2*(CV**2 +
                 1.0 - 2.0*CV*W3)*Q**2);
         EFF := -1.7;
--
      Elsif IBRNCH = 2 Then  -- VERTICAL ANTENNA, IA = 7
         If DEL = HALFPI Then
            G := -10.0;
            EFF := 0.0;
            Return;
         End If;
         SFAC2 := SIN(FAC2);
         CFAC2 := COS(FAC2);
         HQ := FAC2*Q;
         ACLOC := COS(HQ) - CFAC2;
         AS := SIN(HQ) - Q*SFAC2;
         FLOG := LOG(FAC2);
         C2KEL := 2.0*CFAC2*CFAC2 - 1.0;
         S2KEL := 2.0*CFAC2*SFAC2;
         If FAC4 < 1.0E-7 Then
            Return;
         End If;
         ZT := CSZ1(4.0*FAC2);
         RZERO := 0.5*(C2KEL*(AREAL(ZT) - FLOG - 1.3862943612 - GAMA) -
                  S2KEL*AIMAG(ZT));
         ZT := CSZ1(FAC4);
         RZERO := 30.0*(RZERO + (1.0 + C2KEL)*(AREAL(-ZT) + FLOG +
                  0.6931471806 + GAMA) + S2KEL*AIMAG(ZT));
         RIN := RZERO;
         W3 := COS(PSIV - HQWAVE);
         W4 := SIN(PSIV - HQWAVE);
         RAIN := 30.0*((ACLOC*(1.0 + CV*W3) + AS*CV*W4)**2 +
                 (ACLOC*CV*W4 + AS*(1.0 - CV*W3))**2)/(RIN*T**2);
         If EL1 < 0.35 Then
            EFF := -((((6416.702*EL1 - 6091.33)*EL1 + 2179.89)*EL1 -
                   364.817)*EL1 + 25.646);
         End If;
--
      Elsif IBRNCH = 3 Then  -- HORIZONTAL HALF WAVE DIPOLE ANTENNA, IA = 8
         CFAC := COS(FAC);
         W1 := COS(PSIH - HQWAVE);
         W2 := SIN(PSIH - HQWAVE);
         W3 := COS(PSIV - HQWAVE);
         W4 := SIN(PSIV - HQWAVE);
         CPHI := T*SB;
         SPHI2 := 1.0 - CPHI**2;
         If SPHI2 = 0.0 Then
            G := -10.0;
            EFF := 0.0;
            Return;
         End If;
         GI := (COS(FAC*CPHI) - CFAC)/SPHI2;
         ETETA1 := SB*Q*GI*(1.0 - CV*W3);
         EPHI1 := CB*GI*(1.0 + CH*W1);
         ETETA2 := -SB*Q*GI*CV*W4;
         EPHI2 := CB*GI*CH*W2;
         DID(1) := 2.0*HWAVE;
         DID(2) := RATIO*FAC2;
         SFAC2 := SIN(FAC2);
         CFAC2 := COS(FAC2);
         For J in 1..2 Loop
            TT := SQRT(DID(J)**2 + FAC2**2);
            UZ := TT - FAC2;
            If UZ < 1.0E-7 Then
               Return;
            End If;
            VZ := TT + FAC2;
            TT := SQRT(DID(J)**2+FAC2**2/4.0);
            U1 := TT - FAC;
            If U1 < 1.0E-7 Then
               Return;
            End If;
            V1 := TT + FAC;
            O(J) := (CSZ1(UZ) - 2.0*CSZ1(U1))*CMPLX(CFAC2,-SFAC2) +
                    (CSZ1(VZ)-2.0*CSZ1(V1))*CMPLX(CFAC2,SFAC2) -
                    2.0*(CSZ1(U1) + CSZ1(V1)) + 2.0*CSZ1(DID(J))*(CFAC2 + 2.0);
            O(J) := O(J)*60.0/(1.0 - CFAC2);
         End Loop;
         SQRD := CXSQRT(DIF);
         If AREAL(SQRD) < 0.0 Then
            SQRD := -SQRD;
         End If;
         CXC := AREAL(O(1)*((1.0 - SQRD)/(1.0 + SQRD)));
         RIN := AREAL(O(2)) + CXC;
         RAIN :=120.0*(ETETA1**2 + ETETA2**2 + EPHI1**2 + EPHI2**2)/RIN;
      End If;
--
--CALCULATES DECIBELS
      If RAIN <= 0.0 Then
         G := -10.0;
         EFF := 0.0;
         Return;
      End If;
      G := 10.0*LOG10(RAIN);
      If G < -10.0 Then
         G := -10.0;
         EFF := 0.0;
         Return;
      End If;
      RAINE := G + EFF;
      If RAINE < -10.0 Then
         RAINE := -10.0;
         EFF := RAINE - G;
      End If;
      G := RAINE;
--
      Return;
--
      End HFGAIN;
--
--
      Procedure HFGL (IGCALC: in integer;
                      IRONLY: in integer;
                      PL: in float;
                      ELANG: in float;
                      SIGMA: in float) is
--
--#PURPOSE: HFGL calculates ground reflection and path losses at HF.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        IGCALC = 1 causes only GT to be calculated; 2 causes
--                   only GR to be calculated; otherwise, all
--                   outputs may be calculated
--IN        IRONLY = 1 causes only reflection loss to be
--                   calculated; otherwise, all outputs may be calculated
--IN        PL     = Total surface path length in km
--IN        ELANG  = Radiation angle in degrees
--IN        SIGMA  = Surface conductivity in MHO/M
--
--#CALLED BY:
--          MF_HF_HANDLER
--
--#CALLS TO:
--          HFGAIN
--
--#TECHNICAL DESCRIPTION:
--          HFGL calculates ground reflection and path losses at HF.
--          It should be noted that hops are assumed between the end
--          points, and that the takeoff angle is specified by ELANG.
--          HFGAIN is called for ground reflection loss and
--          transmitter and receiver antenna gain calculations.
--
      EPS, GL: float;
--
      Begin
--
      If SIGMA >= 0.9 Then
         EPS := 80.0;
      Else
         EPS := FEPS(SIGMA);
      End If;
--
      If IGCALC = 1 Then  --TRANSMITTER GAIN.
         HFGAIN (IATYPT, 1, ELANG, LNX, HTX, TAX, GNX, SIGMA, EPS, GT);
         Return;
      End If;
      If IGCALC = 2 Then  --RECEIVER GAIN.
         HFGAIN(IATYPR, 1, ELANG, LNR, HTR, TAR, GNR, SIGMA, EPS, GR);
         Return;
      End If;
--
      If IRONLY /= 1 Then  --FREE SPACE LOSS PLUS GROUND REFLECTION LOSS.
         SPLOSS := 0.0;
         If PL/COS(ELANG) /= 0.0 Then
            SPLOSS := FD20(PL, ELANG);
         End If;
         HFGAIN (1, 0, ELANG, 0.0, 0.0, 0.0, 0.0, SIGMA, EPS, GL);
         RELOSS := GL;
         HFGAIN (IATYPT, 1, ELANG, LNX, HTX, TAX, GNX, SIGMA, EPS, GT);
         HFGAIN (IATYPR, 1, ELANG, LNR, HTR, TAR, GNR, SIGMA, EPS, GR);
      Else  --GROUND REFLECTION LOSS ONLY.
         HFGAIN (1, 0, ELANG, 0.0, 0.0, 0.0, 0.0, SIGMA, EPS, GL);
         RELOSS := GL;
      End If;
      Return;
--
      End HFGL;
--
--
      Procedure HFGSIG (SURDIS: in float;
                        SIGMA: in float;
                        GRSIGL: out float) is
--
--#PURPOSE: HFGSIG is a master subroutine for calculating ground
--          wave signal levels at HF.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        SURDIS = Great circle path surface distance in km
--IN        SIGMA  = Ground conductivity at transmitter in MHO/M
--OUT       GRSIG  = Ground wave signal stregth at receiver in dBW
--
--#CALLED BY:
--          MF_HF_HANDLER
--
--#CALLS TO:
--          GRWAVE
--
--#TECHNICAL DESCRIPTION:
--          HFGSIG sets the parameters for and calls GRWAVE to
--          calculate the volts/meter at the receiving antenna.  The
--          GRSIG is determined from:  GRSIG := 10.0* LOG10 (VOLTPM/
--          FREQMC) + 69.74  where VOLTPM is the value returned from
--          GRWAVE in volts/meter.
--
      HTRANS, HRECV, TPWRKW, HLOWER, HHIGHR, VOLTPM, DBLOSS: float;
      NPOL: integer;
--
      Begin
--
      HTRANS := 1000.0*TALT;
      HRECV := 1000.0*RALT;
      TPWRKW := 10.0**(TERP*0.1)*0.001;
--
-- CALCULATE GROUNDWAVE SIGNAL
      NPOL := 1;
      If IATYPR = 8 Then
         NPOL := 2;
      End If;
      HLOWER := AMIN1(HTRANS, HRECV);
      HHIGHR := AMAX1(HTRANS, HRECV);
      LF_HF_GROUNDWAVES.GRWAVE (SIGMA, FREQKC, SURDIS, NPOL, TPWRKW,
                                HLOWER, HHIGHR, VOLTPM, DBLOSS);
--
--CONVERT VOLTS/METER TO DBW .
--  NOTE:   GRSIG ASSUMES AN ISOTROPIC RECEIVING ANTENNA AT ZERO ALTITUDE.
      GRSIG := -3000.0;
      If VOLTPM >= 1.0001E-10 Then
         GRSIG := 20.0*LOG10(VOLTPM/FREQKC) + 71.5 - 1.761;
      End If;
--
      Return;
--
      End HFGSIG;
--
--
      Procedure HFNACP (NMODE: in integer) is
--
--#PURPOSE: HFNACP calculates the locations of the absorption
--          control points (ACPs) for HF links.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        NMODE  = The HF skywave mode number
--
--#CALLED BY:
--          MF_HF_HANDLER
--
--#CALLS TO:
--          LOCNEW
--
--#TECHNICAL DESCRIPTION:
--          The secant of the angle through the absorption control point
--          (SECACP) is determined directly from the input radiation
--          angle.  The mode number implies through HFINDX the number
--          of hops, J.  TR/J is the earth central angle per hop.
--          Knowing the radiation angle, the earth central angle, and
--          the raduis of the earth, the distance from each ground
--          reflection point to the ground zero point under an ACP
--          (altitude := 65 km) can be calculated.  The latitude and
--          longitude parameters input through COMMON /PATH/ are used
--          to associate the ground zero point distances with earth
--          based latitudes and longitudes.
--
      CACP, ALPE, ALPF, ALPD, DISD, DISE, DISF, DISX, DIS, RLATX, RLONX: float;
      RANGLE: float;
      NEHOPS, NFHOPS, LSTRT, LEND, IYEFD, IZEFD, IE, IFX, IEF, LPASS: integer;
      IEND, L: integer;
--
      Begin
--
      CACP := RADIUS_OF_EARTH_IN_KM/(65.0 + RADIUS_OF_EARTH_IN_KM);
      NEHOPS := IHFMD(NMODE,1);
      NFHOPS := IHFMD(NMODE,2);
      LSTRT  := IHFMD(NMODE,4);
      LEND   := IHFMD(NMODE,5);
      IYEFD  := IHFMD(NMODE,6);
      IZEFD  := IHFMD(NMODE,7);
--
      ALPE   := EFDATA(1,IYEFD,IZEFD);
      ALPF   := EFDATA(2,IYEFD,IZEFD);
      RANGLE := EFDATA(3,IYEFD,IZEFD);
--
      IE  := 0;
      IFX := 0;
      If NEHOPS > 0 Then
         IE := 1;
      End If;
      If NFHOPS > 0 Then
         IFX := 1;
      End If;
      IEF := IE*IFX;
--
      ALPD := FHANG (RANGLE, CACP);
      SECACP(NMODE) := FSEC(ALPD, RANGLE);
      DISD := RADIUS_OF_EARTH_IN_KM*ALPD;
      DISE := RADIUS_OF_EARTH_IN_KM*2.0*ALPE;
      DISF := RADIUS_OF_EARTH_IN_KM*2.0*ALPF;
      If IEF < 1 Then
         DISX := AMAX1(DISE, DISF) - 2.0*DISD;
      End If;
--
      LPASS := 0;
--
      IEND := LEND - 1;
      L := LSTRT;
      While L <= IEND Loop
         LPASS := LPASS + 1;
         If L <= LSTRT Then
            DIS := DISD;
         Else
            DIS := DIS + 2.0*DISD;
         End If;
         NODELOC.LOCNEW (TLAT, TLON, TRBRNG, DIS, RLATX, RLONX);
         ACPLAT(L) := RLATX;
         ACPLON(L) := RLONX;
         If IEF >= 1 Then  --HAVE A MIXED MODE.
            If IDNT = DAY and LPASS <= NEHOPS Then
               DISX := DISE - 2.0*DISD;
            End If;
            If IDNT =NIGHT and LPASS <= NFHOPS Then
               DISX := DISF - 2.0*DISD;
            End If;
            If IDNT = DAY and LPASS > NEHOPS Then
               DISX := DISF - 2.0*DISD;
            End If;
            If IDNT = NIGHT and LPASS > NFHOPS Then
               DISX := DISE - 2.0*DISD;
            End If;
         End If;
         DIS := DIS + DISX;
         NODELOC.LOCNEW (TLAT, TLON, TRBRNG, DIS, RLATX, RLONX);
         ACPLAT(L+1) := RLATX;
         ACPLON(L+1) := RLONX;
         L := L + 2;
      End Loop;
--
      Return;
--
      End HFNACP;
--
--
      Procedure MMMUF (IENTER: in integer;
                       ICALC: in integer;
                       NMODE: in integer;
                       EHTD: out float;
                       EHTN: out float;
                       FHTD: out float;
                       FHTN: out float;
                       FMAX: out float;
                       FMIN: out float) is
--
--#PURPOSE: MMMUF uses the layer heights to determine the
--          geometrically viable mixed modes.  The frequencies are
--          used to determine if the ray will penetrate the layer or
--          be reflected by a lower layer.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        IENTER = 1 if new geometry or time of evaluation; the
--                   number greater than one if only the number
--                   of hops have changed since the last call
--IN        ICALC  = 1 : return layer heights
--                   2 : return critical frequencies
--IN        NMODE  = Skywave mode number
--OUT       EHTD   = E layer height in day segment of path in km
--OUT       EHTN   = E layer height in night segment of path in km
--OUT       FHTD   = F layer height in day segment of path in km
--OUT       FHTN   = F layer height in night segment of path in km
--OUT       FMAX   = Maximum permissible frequency for the
--                   specified mode in MHz
--OUT       FMIN   = Minimum permissible frequency for the
--                   specified mode in MHz
--
--#CALLED BY:
--          MF_HF_HANDLER
--
--#CALLS TO:
--          IONDAT
--          LOCNEW
--
--#TECHNICAL DESCRIPTION:
--     MMMUF determines the layer heights of the ionosphere and the
--     critical frequencies for HF mixed mode skywave propagation. The
--     layer heights are used to determine the geometricaly viable mixed
--     modes and the critical frequencies are used to determine if the
--     ray will penetrate the layer or be reflected by a lower layer.
--
--     The procedure employed is to first determine whether the transmit-
--     ter is in day or night. If night, the problem is solved by begin-
--     ning at the transmitter and going to the receiver, starting first
--     with the F-layer modes. If day, the opposite path is followed but
--     still beginning with the F-layer modes first.
--
      EHT, FHT, DUMA, DUMB, DUMC, DUMD, EHANG, FHANG, SECE, SECF: float;
      FOEMAX, FOEMIN, FOFMAX, FOFMIN, FMAXF, FMAXE: float;
      SLAT1, SLON1, SLAT2, SLON2, TLATX, TLONX, RLATX, RLONX: float;
      NEHOPS, NFHOPS, KA, KB: integer;
--
      Begin
--
      If ICALC = 1 Then
         SLAT1 := RLAT;
         SLON1 := RLON;
         RLAT := TERLAT;
         RLON := TERLON;
         HF_ATMOSPHERICS.IONDAT(1, 1, EHT, FHT, DUMA, DUMB, DUMC, DUMD);
         RLAT := SLAT1;
         RLON := SLON1;
         EHTD:=EHT;
         FHTD:=FHT;
         SLAT1 := TLAT;
         SLON1 := TLON;
         TLAT := TERLAT;
         TLON := TERLON;
         HF_ATMOSPHERICS.IONDAT(1, 1, EHT, FHT, DUMA, DUMB, DUMC, DUMD);
         TLAT := SLAT1;
         TLON := SLON1;
         IF IDNR = DAY Then
            EHTN := EHTD;
            FHTN := FHTD;
            EHTD := EHT;
            FHTD := FHT;
         Else
            EHTN:=EHT;
            FHTN:=FHT;
         End If;
         Return;
      Else
         NEHOPS := IHFMD(NMODE,1);
         NFHOPS := IHFMD(NMODE,2);
         KA     := IHFMD(NMODE,6);
         KB     := IHFMD(NMODE,7);
         EHANG := EFDATA(1,KA,KB);
         FHANG := EFDATA(2,KA,KB);
         SECE  := EFDATA(4,KA,KB);
         SECF  := EFDATA(5,KA,KB);
         If IDNT = NIGHT Then  --WORK FROM THE TRANSMITTER TO THE RECEIVER
                               --STARTING WITH F MODES.
            TLATX := TLAT;
            TLONX := TLON;
            DUMA := RADIUS_OF_EARTH_IN_KM*FHANG*FLOAT(NFHOPS)*2.0;
            NODELOC.LOCNEW (TLATX, TLONX, TRBRNG, DUMA, RLATX, RLONX);
            SLAT1 := RLAT;
            SLON1 := RLON;
            RLAT := RLATX;
            RLON := RLONX;
            HF_ATMOSPHERICS.IONDAT (1, NFHOPS, DUMA, DUMB, FOEMAX, FOEMIN,
                                       FOFMAX, FOFMIN);
            RLAT := SLAT1;
            RLON := SLON1;
            FMAXF := FOFMIN*SECF;
            FMIN := FOEMAX*SECE;
            SLAT1 := TLAT;
            SLON1 := TLON;
            TLAT := RLATX;
            TLON := RLONX;
            HF_ATMOSPHERICS.IONDAT (1, NEHOPS, DUMA, DUMB, FOEMAX, FOEMIN,
                                       FOFMAX, FOFMIN);
            TLAT := SLAT1;
            TLON := SLON1;
            FMAXE := FOEMIN*SECE;
         Else --TRANSMITTER IS IN DAYLIGHT, WORK FROM THE RECEIVER
              --TO THE TRANSMITTER STARTING WITH F MODES.
            TLATX := RLAT;
            TLONX := RLON;
            DUMA := RADIUS_OF_EARTH_IN_KM*FHANG*FLOAT(NFHOPS)*2.0;
            NODELOC.LOCNEW (TLATX, TLONX, RTBRNG, DUMA, RLATX, RLONX);
            SLAT1 := TLAT;
            SLON1 := TLON;
            SLAT2 := RLAT;
            SLON2 := RLON;
            TLAT := TLATX;
            TLON := TLONX;
            RLAT := RLATX;
            RLON := RLONX;
            HF_ATMOSPHERICS.IONDAT (1, NFHOPS, DUMA, DUMB, FOEMAX, FOEMIN,
                                       FOFMAX, FOFMIN);
            FMAXF := FOFMIN*SECF;
            FMIN := FOEMAX*SECE;
            TLAT := RLAT;
            TLON := RLON;
            RLAT := SLAT1;
            RLON := SLON1;
            HF_ATMOSPHERICS.IONDAT (1, NEHOPS, DUMA, DUMB, FOEMAX, FOEMIN,
                                       FOFMAX, FOFMIN);
            TLAT := SLAT1;
            TLON := SLON1;
            RLAT := SLAT2;
            RLON := SLON2;
            FMAXE := FOEMIN*SECE;
         End If;
--
         FMAX := AMIN1(FMAXF, FMAXE);
         FMIN := AMAX1(FMIN, 0.0);
      End If;
--
      Return;
--
      End MMMUF;
--
--
      Procedure MF_HF_HANDLER is
--
--#PURPOSE: MF_HF_HANDLER computes the signal strength at a receiver location
--          for HF links.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        CURRENT_TIME  = Scenario time in minutes from reference time
--IN        TLAT   = Transmitter latitude in degrees north
--IN        TLON   = Transmitter longitude in degrees east
--IN        TALT   = Transmitter altitude in kilometers
--IN        RLAT   = Receiver latitude in degrees north
--IN        RLON   = Receiver longitude in degrees east
--IN        RALT   = Receiver altitude in kilometers
--IN        FREQMC = Frequency in MHz
--IN        TERP   = Transmitter power in dBW
--OUT       SIGNAL = Signal strength at receiver in dBW
--
--#CALLED BY:
--          RF_PROPAGATION_HANDLER
--
--#CALLS TO:
--          DNTR
--          EFMODE
--          GNDCON
--          HFGL
--          HFGSIG
--          HFNACP
--          IONCAL
--          IONDAT
--          LOCNEW
--          MMMUF
--          ZENITH
--
--#TECHNICAL DESCRIPTION:
--     MF_HF_HANDLER is the RF propagation prediction routine for HF (3-30 MHz
--     electromagnetic waves. This routine computes the signal strength
--     at a receiver location based on E-layer, F-layer as well as mixed
--     E and F-layer modes.
--
--     Upon entry, MF_HF_HANDLER first determines the path length that
--     is in daylight and the length that is in night. In addition, it
--     determines whether the transmitter and/or receiver is in daylight
--     or in night. It then initializes certain variables prior to the
--     initial computations and begins the computations for the heights
--     of the E and F-layers. The viable modes are determined next based
--     on geometrical considerations. MF_HF_HANDLER next determines whether
--     the frequency is in an acceptable band, thereby determining the
--     viable modes.
--
--     Once the viable modes are known, the solar zenith angle at the
--     path midpoint is computed as is the local time of day at path
--     midpoint. The ambient absorption index is set based on those
--     midpoint values of solar zenith angle and time. The transmitter's
--     effective radiated power is computed next based on the actual
--     transmitter power and considering that it is radiated into
--     an angle of 4*PI and considering the frequency.
--
--     The locations of the absorption control points are next computed,
--     followed by the reflection losses based on ground conductivity
--     at the ACP's. The total link signal strength is now computed
--     based on the radiated power minus the losses due to free space,
--     D-region absorption and reflection losses. Finally, the strength
--     of the groundwave signal is computed. The returned signal
--     strength is the maximum of the skywave modes and the groundwave
--     signals.
--
      NP, LEND, N, I, J, NHOPS, LSTRT, NHR, L, KA, KB: integer;
      IPASS, NMODE, NEHOPS, IYEFD, IZEFD, NFHOPS, IDUMA, LA, LB, IL: integer;
      IDN: DAY_OR_NIGHT;
      GGFREQ, TREFSE, EHT, FHT, DUMA, DUMB, DUMC, DUMD: float;
      EHTD, FHTD, EHTN, FHTN, SECE, FOEMAX, FOEMIN, FOFMAX: float;
      FOFMIN, ALPF, RADANG, AEDF, C, THETAE, FMAX, FMIN, HAFPL: float;
      HAFLAT, HAFLON, TODM, AI, P622, SIGMA, DUMX, DUMY, SUM: float;
      HANGLE, SIGMAT, SIGMAR, CONST, SECF: float;
      EN, PN, VEAIR, VIAIR: ELF_LF_HF_ATMOSPHERICS.IONO_LAYERS;
--
      Begin
--
--NP IS THE NUMBER OF MODES INCLUDED IN THE CALCULATIONS.
      NP := 20;
      If IHFMD(10,5) <= 1 Then
         LEND:=0;
         For N in 1..NP Loop
            I := IHFMD(N,1);
            J := IHFMD(N,2);
            NHOPS := I + J;
            LSTRT := LEND + 1;
            LEND := 2*NHOPS + LSTRT - 1;
            IHFMD(N,3) := NHOPS;
            IHFMD(N,4) := LSTRT;
            IHFMD(N,5) := LEND;
            IHFMD(N,6) := I + 1;
            IHFMD(N,7) := J + 1;
         End Loop;
      End If;
--
--DETERMINE THE PATH LENGTH THAT IS IS DAYLIGHT, THE PATH LENGTH
--THAT IS IN NIGHT, AND WHETHER THE TRANSMITTER AND RECEIVER ARE
--IN DAY OR NIGHT.
      RFUTIL.DNTR;
--
--CALCULATE TOTAL TRANSMITTER TO RECEIVER SURFACE DISTANCE.
      PL := DISTOT;
--
--SET SELECT CONSTANTS AND INITIALIZE SELECT VARIABLES FOR START OF
--CALCULATIONS.
--  GGFREQ IS GYRO FREQUENCY.
--  TREFSE IS "REFERENCE_TIME" CONVERTED TO SECONDS.
--  SIGMAT IS THE SURFACE CONDUCTIVITY AT THE TRANSMITTER.
--  SIGMAR IS THE SURFACE CONDUCTIVITY AT THE RECEIVER.
      GGFREQ := 1.5;
      SIGNAL := -1000.0;
      GRSIG := -1000.0;
      NHR := INTEGER(REFERENCE_TIME/100.0);
      TREFSE := (REFERENCE_TIME - FLOAT(NHR)*40.0)*60.0;
NEW_LINE;
      RFUTIL.GNDCON (TLAT, TLON, SIGMAT);
      RFUTIL.GNDCON (RLAT, RLON, SIGMAR);
      For N in 1..NP Loop
         ALOS(N)    := 0.0;
         FMX(N)     := 0.0;
         FMN(N)     := 0.0;
         GRANT(N)   := 0.0;
         GTANT(N)   := 0.0;
         IHFMD(N,8) := 0;
         IHFMD(N,9) := 0;
         NSUCC(N)   := 0;
         PLNA(N)    := 0.0;
         PLOSS(N)   := -3000.0;
         RELHF(N)   := 0.0;
         SECACP(N)  := 0.0;
         SIGPWR(N)  := -3000.0;
         SPLHF(N)   := 0.0;
      End Loop;
      GRANT(21) := 0.0;
      GTANT(21) := 0.0;
      For L in 1..140 Loop
         ACPLAT(L) := 0.0;
         ACPLON(L) := 0.0;
         ACPABS(L) := 0.0;
      End Loop;
--
--DETERMINE THE APPROPRIATE E & F LAYER HEIGHTS.
--
      If IDNT /= IDNR Then
         MMMUF (1, 1, 1, EHTD, EHTN, FHTD, FHTN, DUMA, DUMB);
      Else
         HF_ATMOSPHERICS.IONDAT (1, 1, EHT, FHT, DUMA, DUMB, DUMC, DUMD);
         EHTD := 0.0;
         FHTD := 0.0;
         EHTN := EHT;
         FHTN := FHT;
         If IDNT = DAY and IDNR = DAY Then
             EHTD := EHTN;
             FHTD := FHTN;
             EHTN := 0.0;
             FHTN := 0.0;
         End If;
      End If;
--
--DETERMINE THE VIABLE MODES BASED ON GEOMETRY ONLY.
--
      EFMODE (EHTD, EHTN, FHTD, FHTN);
--
--FILL IHFMD COLUMN 8 WITH A 1 IF THE MODE CAN EXIST BASED ON GEOMETRY
--CONSIDERATIONS ONLY.
--
      For I in 1..NP Loop
         KA := IHFMD(I,6);
         KB := IHFMD(I,7);
         If EFDATA(3,KA,KB) > 1.0E-10 Then
            IHFMD(I,8) := 1;
         End If;
      End Loop;
--
--DETERMINE IF THE FREQUENCY IS IN AN ACCEPTABLE BAND FOR THE MODE.
--       IF THE MODE CAN NOT EXIST DUE TO PURELY GEOMETRIC
--            REASONS, DO NOT CALCULATE THE MAX/MIN FREQUENCIES.
--       STOP AFTER THE FIRST SUCCESSFUL MODE OF EACH OF THE THREE TYPES.
--
--DO E MODES.
--
      IPASS := 0;
--
      For NMODE in 1..5 Loop
         If IHFMD(NMODE,8) >= 1 Then
            IPASS   := IPASS + 1;
            NEHOPS  := IHFMD(NMODE,1);
            IYEFD   := IHFMD(NMODE,6);
            IZEFD   := IHFMD(NMODE,7);
            SECE    := EFDATA(4,IYEFD,IZEFD);
            HF_ATMOSPHERICS.IONDAT (IPASS, NEHOPS, DUMA, DUMB,
                    FOEMAX, FOEMIN, FOFMAX, FOFMIN);
            FMX(NMODE) := FOEMIN*SECE;
            If FREQMC <= FMX(NMODE) Then
               IHFMD(NMODE,9) := 1;
               Exit;
            End If;
         End If;
      End Loop;
--
--DO F MODES.
--
      CONST := (RADIUS_OF_EARTH_IN_KM + 340.0)/(RADIUS_OF_EARTH_IN_KM + 110.0);
      For NMODE in 6..10 Loop
         IF IHFMD(NMODE,8) >= 1 Then
            IPASS  := IPASS + 1;
            NFHOPS := IHFMD(NMODE,2);
            IYEFD  := IHFMD(NMODE,6);
            IZEFD  := IHFMD(NMODE,7);
            ALPF   := EFDATA(2,IYEFD,IZEFD);
            RADANG := EFDATA(3,IYEFD,IZEFD);
            SECF   := EFDATA(5,IYEFD,IZEFD);
            DUMB   := HALFPI - ALPF - RADANG;
            DUMC   := AMIN1(0.9999, CONST*SIN(DUMB));
            THETAE := ASIN(DUMC);
            SECE   := 1.0/COS(THETAE);
            HF_ATMOSPHERICS.IONDAT (IPASS, NFHOPS, DUMA, DUMB,
                    FOEMAX, FOEMIN, FOFMAX, FOFMIN);
            FMAX   := FOFMIN*SECF;
            FMIN   := FOEMAX*SECE;
            FMX(NMODE) := FMAX;
            FMN(NMODE) := FMIN;
            If FREQMC >= FMIN and FREQMC <= FMAX Then
               IHFMD(NMODE,9) := 1;
               Exit;
            End If;
         End If;
      End Loop;
--
--DO MIXED MODES.
--
      If IDNT /= IDNR Then
         IPASS := 0;
--
         For N in 11..20 Loop
            NMODE := N;
            If IHFMD(NMODE,8) >= 1 Then
               IPASS := IPASS + 1;
               MMMUF (IPASS, 2, NMODE, DUMA, DUMB, DUMC, DUMD, FMAX, FMIN);
               FMX(NMODE) := FMAX;
               FMN(NMODE) := FMIN;
               If FREQMC >= FMIN and FREQMC <= FMAX Then
                  IHFMD(NMODE,9) := 1;
                  Exit;
               End If;
            End If;
         End Loop;
      End If;
--
--END OF PERMISSIBLE MODE CALCULATIONS.
--
--FILL NSUCC WITH THE MODE NUMBERS OF THE SUCCESSFUL MODES.
--
      IPASS:=0;
--
      For NMODE in 1..NP Loop
         If IHFMD(NMODE,8) >= 1 and IHFMD(NMODE,9) >= 1 Then
            IPASS := IPASS + 1;
            NSUCC(IPASS) := NMODE;
         End If;
      End Loop;
--
--MAKE THE SKYWAVE SIGNAL CALCULATIONS FOR THE MODES OF INTEREST AS LISTED
--IN NSUCC.
--
--DETERMINE TIME OF DAY AND SOLAR ZENITH ANGLE, CHI AT THE MIDPOINT.
--
      HAFPL := PL*0.5;
      NODELOC.LOCNEW (TLAT, TLON, TRBRNG, HAFPL, HAFLAT, HAFLON);
      RFUTIL.ZENITH (HAFLAT, HAFLON, CHI, TODM, IDN);
--
--"TODM" IS LOCAL TIME OF DAY AT PATH MIDPOINT, HRS, 0 TO 24.
--
--
--SET THE AMBIENT ABSORBTION INDEX BASED ON ASN AND CHI.
--
      AI := 0.01;
      If CHI < 102.0 Then
         AI := (1.0 + 0.0037*FLOAT(AVERAGE_SUN_SPOT_NUMBER))*
               (COS(0.881*RADIANS_PER_DEGREE*CHI))**1.3;
      End If;
--
--SET P622.  F622 IS THE TRANSMITTED POWER (NOT ERP)*WAVELENGTH**2/(4*PI).
      P622 := 38.5503 + TERP - 10.0*LOG10(FREQMC*FREQMC);
--
--SET "AMBAB" BASED ON THE AMBIENT ABSORPTION INDEX.
--
      AMBAB := 150.00*AI/((FREQMC + GGFREQ)**2);
--
--LOOP OVER THE MODES.
--
      For N in 1..NP Loop
         NMODE := NSUCC(N);
         Exit When NMODE < 1;
         NEHOPS := IHFMD(NMODE,1);
         NFHOPS := IHFMD(NMODE,2);
         NHOPS  := IHFMD(NMODE,3);
         LSTRT  := IHFMD(NMODE,4);
         LEND   := IHFMD(NMODE,5);
         IYEFD  := IHFMD(NMODE,6);
         IZEFD  := IHFMD(NMODE,7);
         RADANG := EFDATA(3,IYEFD,IZEFD);

--DETERMINE THE FREE SPACE LOSS, TRANSMITTER ANTENNA GAIN, AND RECEIVER
--ANTENNA GAIN.
--
         HFGL (1, 0, PL, RADANG, SIGMAT);
         GTANT(NMODE) := GT;
         HFGL (0, 0, PL, RADANG, SIGMAR);
         GRANT(NMODE) := GR;
         SPLHF(NMODE) := SPLOSS;
--
--DETERMINE THE LOCATIONS OF THE ABSORPTION CONTROL POINTS (ACP-S).
--
         HFNACP (NMODE);
--
--DETERMINE THE REFLECTION LOSSES USING THE NEAREST ACP LOCATION FOR
--CONDUCTIVITY DETERMINATIONS.
--
         LA := LSTRT + 1;
         LB := LEND - 2;
         L := LA;
         While L <= LB Loop
            DUMA := FAVG(ACPLAT(L), ACPLAT(L+1));
            DUMB := FAVG(ACPLON(L), ACPLON(L+1));
            If ABS(DUMB - ACPLON(L)) > 90.0 Then
               DUMB := DUMB + 180.0;
            End If;
            RFUTIL.GNDCON (DUMA, DUMB, SIGMA);
            HFGL ( 0, 1, PL, RADANG, SIGMA);
            RELHF(NMODE) := RELHF(NMODE) + RELOSS;
            L := L + 2;
         End Loop;
--
--COMPUTE PLNA FOR THE MODE.
--
         PLNA(NMODE) := SPLHF(NMODE) + RELHF(NMODE);
--
--CALCULATE THE ABSORPTION LOSS FOR THIS MODE.
--
         DUMX := 1.0/(TWOPI*1.0E6);
         DUMY := (FREQMC + GGFREQ)**2;
         IDN := NIGHT;
         If DISDAY > DISNIT Then
            IDN := DAY;
         End If;
         For L in LSTRT..LEND Loop
            ELF_LF_HF_ATMOSPHERICS.IONCAL(ACPLAT(L), ACPLON(L),
                                   -CURRENT_TIME*60.0, IDN,
                   EN, PN, VEAIR, VIAIR);
            SUM := 0.0;
            For IL in 10..18 Loop
               DUMA := 7.3E-3*EN(IL)*(VEAIR(IL) + VIAIR(IL))*DUMX;
               DUMB := DUMY + ((0.775*VEAIR(IL) + VIAIR(IL))*DUMX)**2;
               DUMA := DUMA/DUMB;
               SUM := SUM + 5.0*DUMA;
            End Loop;
            ACPABS(L) := SUM;
            ALOS(NMODE) := ALOS(NMODE) + ACPABS(L);
         End Loop;
         ALOS(NMODE) := AMAX1(ALOS(NMODE), 2.0*float(NHOPS)*AMBAB);
         ALOS(NMODE) := ALOS(NMODE)*SECACP(NMODE);
--
--CALCULATE THE NET PATH LOSS, PLOSS.
--
         PLOSS(NMODE) := PLNA(NMODE) + ALOS(NMODE)
                          - GTANT(NMODE) - GRANT(NMODE);
--
--SIGNAL POWER IN DBW
         SIGPWR(NMODE) := P622 - PLOSS(NMODE);
         SIGNAL := AMAX1(SIGNAL, SIGPWR(NMODE));
      End Loop;
--
-- CALCULATE GROUNDWAVE SIGNAL
      HFGSIG (PL, SIGMAT, GRSIG);
      DUMA := ABS(RALT - TALT);
      DUMA := RADIUS_OF_EARTH_IN_KM/(RADIUS_OF_EARTH_IN_KM + DUMA);
      HANGLE := 0.5*PL/RADIUS_OF_EARTH_IN_KM;
      RADANG := FPSI(HANGLE, DUMA);
      RADANG := AMAX1(0.0,DUMA);
      HFGL (1, 0, PL, RADANG, SIGMAT);
      GTANT(21) := GT;
      HFGL(2, 0, PL, RADANG, SIGMAR);
      GRANT(21) := GR;
      GRSIG := GRSIG + GTANT(21) + GRANT(21);
      SIGNAL := AMAX1(SIGNAL,GRSIG);
--
      Return;
--
      End MF_HF_HANDLER;
--
End MF_HF_PROPAGATION;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--LFPROP
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Debugger2; Use Debugger2;
With Mathlib; Use Mathlib, Numeric_primitives, trig_functions, core_functions;
With Constants; Use Constants;
With Propagation_Constants; Use Propagation_constants;
With Nodeloc;
With ELF_LF_HF_atmospherics;
With RFUTIL;
With LF_HF_Groundwaves;
With Text_IO; Use Text_io, Integer_io, Float_io;

Package LF_PROPAGATION is
--
      Procedure LF_HANDLER;
--
End LF_PROPAGATION;
--
Package body LF_PROPAGATION is
--
-- LF_PROPAGATION Package of PROP_LINK
-- Version 1.0,  June 28, 1985.
--
-- This LF_PROPAGATION Package contains all of the procedures that
-- are used to perform LF propagation prediction.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
--Use Text_IO;
-- Instantiate integer and floating point IO.
--      Package IO_INTEGER is new INTEGER_IO(INTEGER);
--      Package IO_FLOAT is new FLOAT_IO(FLOAT);
--Use IO_INTEGER,IO_FLOAT;
--
--
      Pragma Source_info (on);
--
--**************************************************************************
--VARIABLES THAT ARE TO BE VISIBLE TO ALL ROUTINES WITHIN THIS PACKAGE.
      PLAT: array (integer range 1..5) of float;
      PLONG: array (integer range 1..5) of float;
      COEF: array (integer range 1..5) of float;
      GAMMA: array (integer range 1..5) of float;
      BETA: array (integer range 1..5) of float;
      PALT: array (integer range 1..5) of float;
      MODFES: array (integer range 1..5) of integer;
--**************************************************************************
--
--
      Procedure HIGHTF is
--
--#PURPOSE: HIGHTF calculates the ionospheric reflection height for
--          LF propagation.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--          'NONE'
--
--#CALLED BY:
--          LF_HANDLER
--
--#CALLS TO:
--          LOCNEW
--          REFCAL
--
--#TECHNICAL DESCRIPTION:
--          Breaks the ionosphere into layers, determines electron and
--          positive ion densities, then calculates critical frequency
--          and the resulting height of reflection.
--
      I: integer;
      DISTPT: float;
--
      Begin
--
      For I in 1..NHOP Loop
         DISTPT := DPATH*PTS(I);
         NODELOC.LOCNEW (TLAT, TLON, BRNG1, DISTPT, PLAT(I), PLONG(I));
         ELF_LF_HF_Atmospherics.REFCAL (PLAT(I), PLONG(I), -CURRENT_TIME*60.0,
                          FREQKC, PALT(I), COEF(I));
         PALT(I) := PALT(I) + RADIUS_OF_EARTH_IN_KM;
      End Loop;
--
      Return;
--
      End HIGHTF;
--
--
      Procedure TERAIN (XLAT: in float;
                        XLONG: in float;
                        FREQ: in float;
                        D: in float;
                        TLOSS: out float) is
--
--
--#PURPOSE: TERAIN COMPUTES TERRAIN LOSS ON LF GROUNDWAVE PROPAGATION.
--          THIS IS A ZEROTH ORDER APPROXIMATION OF THE GROUND TERRAIN
--          IMPACT ON LF GROUNDWAVE WITHIN THE CONUS AREA ONLY. THIS
--          HAS BEEN DEVELOPED FOR THE PRELIMINARY EVALUATION OF THE
--          GROUNDWAVE EMERGENCY NETWORK(GWEN).
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis.
--
--#PARAMETER DESCRIPTIONS:
--IN         XLAT   = PATH MIDPOINT IN DEGREES NORTH
--IN         XLONG  = PATH MIDPOINT IN DEGREES EAST
--IN         FREQ   = LINK FREQUENCY IN MHZ
--IN         D      = PATH LENGTH IN KILOMETERS
--OUT        TLOSS  = PATH LOSS DUE TO TERRAIN ROUGHNESS IN DB
--
--#CALLED BY:
--          LFPROP
--
--#CALLS TO:
--          LOCGRB
--
--#TECHNICAL DESCRIPTION:
--          THIS IS A ZEROTH ORDER APPROXIMATION OF THE GROUND TERRAIN
--          IMPACT ON LF GROUNDWAVE WITHIN THE CONUS AREA ONLY. THIS
--          HAS BEEN DEVELOPED FOR THE PRELIMINARY EVALUATION OF THE
--          GROUNDWAVE EMERGENCY NETWORK(GWEN).  DATA SUPPLIED BY
--          ROCKWELL-COLLINS.
--
      HEIGHT: array (integer range 1..3) of float
      :=(1000.0, 500.0, 300.0);
      SEPART: array (integer range 1..3) of float
      :=(20.0, 20.0, 10.0);
      IAREA: integer;
      BRN1, BRN2, RANG: float;
--
      Begin
--
      TLOSS := 0.0;
--
--COMPUTE WHERE THE PATH MIDPOINT LIES.
--
--IS THE PATH MIDPOINT IN THE NORTHWEST OR SOUTHWEST CONUS?
--
      IAREA := 1;
      If XLONG > -105.0 Then
         Goto N_S_CENTRAL;
      End If;
      If XLAT <= 45.0 Then
         Goto COMPUTE;
      End If;
      If XLONG <= -110.0 and XLAT >= 45.0 Then
         Goto COMPUTE;
      End If;
      NODELOC.LOCGRB (45.0, -105.0, XLAT, XLONG, BRN1, BRN2, RANG);
      If BRN1 >= 180.0 and BRN1 < 315.0 Then
         Goto COMPUTE;
      End If;
--
--  IS THE PATH MIDPOINT IN THE NORTH CENTRAL OR SOUTH CENTRAL CONUS.
<<N_S_CENTRAL>>
      If XLONG < -85.0 Then
         Return;
      End If;
      If XLAT < 40.0 Then
         Goto NEW_ENGLAND;
      End If;
      NODELOC.LOCGRB (40.0, -85.0, XLAT, XLONG, BRN1, BRN2, RANG);
      If BRN1 <= 45.0 Then
         Return;
      End If;
--
--  IS THE PATH MIDPOINT IN THE NEW ENGLAND STATES?
<<NEW_ENGLAND>>
      IAREA := 2;
      If XLONG >= -75.0 Then
         Goto COMPUTE;
      End If;
--
--  IS THE PATH MIDPOINT IN GEORGIA OR FLORIDA?
      If XLAT <= 35.0 and XLONG <= -83.0 Then
         Return;
      End If;
      NODELOC.LOCGRB (35.0, -83.0, XLAT, XLONG, BRN1, BRN2, RANG);
      If BRN1 >= 135.0 Then
         Return;
      End If;
--
--  IS THE PATH MIDPOINT IN THE MID-ATLANTIC REGION.
--
      IAREA := 3;
--
--COMPUTE PATH LOSS DUE TO TERRAIN ROUGHNESS (TLOSS).
--
<<COMPUTE>>
      TLOSS := D*(3.7E-3*HEIGHT(IAREA)*FREQ + 1.65E-5*
               HEIGHT(IAREA)*HEIGHT(IAREA)*FREQ*FREQ)/
               SEPART(IAREA);
--
      Return;
--
      End TERAIN;
--
      Procedure LFPROP is
--
--#PURPOSE: LFPROP computes the RF signal strength of a LF transmitter
--          at a receiver location.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    NUMERICAL ANALYSIS
--
--#PARAMETER DESCRIPTIONS:
--          'NONE'
--#CALLED BY:
--          LF_HANDLER
--
--#CALLS TO:
--          DAYNIT
--          GNDCON
--          GRWAVE
--          LOCNEW
--          TERAIN
--
--#TECHNICAL DESCRIPTION:
--       At small distances (<500km) from an LF transmitter,the received
--       signal is predominantly a ground wave. For these distances the
--       E-field strength add vectorially the first hop skywave and the
--       groundwave. At greater distances, the signal is due to skywaves
--       reflected from the ionosphere. If the path length is greater
--       than 1500km, a RSS of the signals from ray paths with from 1-5
--       hops plus groundwave is computed. If the distance is greater than
--       7000km a warning message will be printed but the calculation
--       will continue.
--
      MED: array (integer range 1..2) of integer;
      RDB: array (integer range 1..2) of float;
      JJ: array (integer range 1..2) of integer;
      AFS: array (integer range 1..2) of float;
      FDN: array (integer range 1..5) of float;
      GPTS: array (integer range 1..5) of float
      :=(0.5, 0.25, 0.3, 0.6, 0.75);
      CND: array (integer range 1..5) of float;
      EEO: array (integer range 1..6) of float;
      SGR:array (integer range 1..5, integer range 1..5) of float
      :=((0.0,0.0,0.0,0.0,0.0),
         (0.0,0.0,0.0,0.0,0.0),
         (0.0,0.0,0.0,0.0,0.0),
         (0.0,0.0,0.0,0.0,0.0),
         (0.0,0.0,0.0,0.0,0.0));
      GDB: array (integer range 1..5) of float;
      INDX: array (integer range 1..4, integer range 1..4) of integer
      :=((1, 0, 0, 0),
         (3, 4, 0, 0),
         (1, 2, 5, 0),
         (2, 3, 4, 5));
--
--THE FOLLOWING DATA STATEMENTS
--  SPECIFY THE CONSTANTS FOR PIECEWISE LINEAR FITS TO
--  CCIR DATA.
--
--  FOR PARAMETERS WHICH ARE FUNCTIONS OF FREQUENCY, THE FOLLOWING
--  PIECEWISE LINEAR FORM IS USED
--  X(F) := X(FF(I)) + XD(I)*(F - FF(I))   WHERE X IS THE FUNCTION
--  BEING DETERMINED,  FF IS A SET OF FREQUENCY BREAKPOINTS FOR THE
--  PARAMETER X,  FF(I) IS THE LARGEST BREAKPOINT LESS THAN F, AND
--  XD (:=(X(FF(I+1))-X(FF(I)))/(FF(I+1)-FF(I)) )  IS GIVEN AS A SET
--  CONSTANTS.
--
--  CONSTANTS FOR ANTENNA FACTORS - PIECEWISE FITS TO CCIR DATA (REPT
--  PP 159-160)
      FAF: array (integer range 1..4) of float
      := (20.0, 50.0, 100.0, 200.0);
--
--  DATA FITS GOOD TO 500 KHZ.
--
--  SEA WATER.
--      -LOG AF := 0.                    PSI  GT  5.
--              := A(F)*(5. - PSI)**2  -2.5  LT  PSI  LT  5.
--              := B(F) - C(F)*PSI     PSI  LT  -2.5
      AFSA: array (integer range 1..4) of float
      :=(5.35E-3, 6.00E-3, 7.07E-3, 8.33E-3);
      AFSAD: array (integer range 1..4) of float
      :=(2.167E-5, 2.14E-5, 1.26E-5, 0.593E-5);
      AFSB: array (integer range 1..4) of float
      :=(0.0825, 0.035, 0.042, -0.019);
      AFSBD: array (integer range 1..4) of float
      :=(-1.583E-3, 1.4E-4, -6.1E-4, 4.4E-4);
      AFSC: array (integer range 1..4) of float
      :=(0.0785, 0.110, 0.135, 0.181);
      AFSCD: array (integer range 1..4) of float
      :=(1.05E-3, 0.5E-3, 0.46E-3, 0.293E-3);
--
--  LAND.
--     -LOG AF := A(F)                     PSI  GT  10.
--             := A(F) + B(F)*(10-PSI)**2  -2.5 LT PSI LT 10 AND F LT 100
--             := A(F) + B(F)*(10-PSI)**3  -2.5 LT PSI LT 10 AND F GT 100
--             := C(F) + D(F)*PSI        PSI  LT  -2.5
--
      AFLA : array (integer range 1..4) of float
      :=(0.036, 0.051, 0.0915, 0.137);
      AFLAD: array (integer range 1..4) of float
      :=(5.0E-4, 8.1E-4, 4.55E-4, 2.7E-4);
      AFLB: array (integer range 1..4) of float
      :=(1.86E-3, 2.68E-3, 3.52E-4, 5.41E-4);
      AFLBD: array (integer range 1..4) of float
      :=(2.733E-5, 1.68E-5, 1.89E-6, 4.23E-7);
      AFLC: array (integer range 1..4) of float
      :=(0.1255, 0.1835, 0.189, 0.188);
      AFLCD: array (integer range 1..4) of float
      :=(1.933E-3, 1.1E-4, -1.0E-5, 1.367E-3);
      AFLD: array (integer range 1..4) of float
      :=(-0.0767, -0.1075, -0.186, -0.333);
      AFLDD: array (integer range 1..4) of float
      :=(-1.0267E-3, -1.57E-3, -1.47E-3, -5.067E-3);
--
--CONSTANTS FOR IONOSPHERIC FOCUSSING FACTORS  -  PIECEWISE FITS TO
--  CCIR DATA (REPORT 265-2, PP 157-156)
--
      FFDN: array (integer range 1..4) of float
      :=(20.0, 50.0, 100.0, 150.0);
--
--  DATA FITS GOOD TO 200 KHZ.
--
--  DAYTIME.
--       FD := 1. + A*X + B*X**2             X  LT  1000
--          := C + D*X + E(F)*(X-800)**2     1000  LT  X  LT  1700
--          := F(F)                          1700  LT  X  LT  1900
--          := G(F) + H*X                    X  GT  1900
--  WHERE X IS DISTANCE PER HOP.
--
      FDA: float := -2.0E-5;
      FDB: float := 4.0E-7;
      FDC: float := 0.927;
      FDD: float := 4.33E-4;
      FDH: float := 4.8E-4;
      FDE: array (integer range 1..4) of float
      :=(0.0, 2.97E-7, 5.94E-7, 7.5E-7);
      FDED: array (integer range 1..4) of float
      :=(9.9E-9, 5.94E-9, 3.21E-9, 2.50E-9);
      FDF: array (integer range 1..4) of float
      :=(1.64, 1.89, 2.11, 2.25);
      FDFD: array (integer range 1..4) of float
      :=(8.33E-3, 4.4E-3, 2.8E-3, 2.6E-3);
      FDG: array (integer range 1..4) of float
      :=(0.724, 1.014, 1.264, 1.434);
      FDGD: array (integer range 1..4) of float
      :=(9.67E-3, 5.0E-3, 3.4E-3, 2.2E-3);
--
--  NIGHTTIME.
--     FN := 1. + A*X + B* X**2                  X  LT  1000.
--        := C + D*X + E(F)*(X-1000)**2          1000  LT  X  LT  1900
--        := F(F)                                1900  LT  X  LT  2100
--        := G(F) + H*X                          X  GT  2100
--  WHERE X IS DISTANCE PER HOP AND FREQ IS FREQUENCY.
--
      FNA: float := 3.0E-6;
      FNB: float := 0.26E-6;
      FNC: float := 0.79;
      FND: float := 5.0E-4;
      FNH: float := 0.00053;
      FNE: array (integer range 1..4) of float
      :=(0.0, 3.44E-7, 6.41E-7, 7.97E-7);
      FNED: array (integer range 1..4) of float
      :=(1.143E-8, 5.84E-9, 3.12E-9, 1.56E-9);
      FNF: array (integer range 1..4) of float
      :=(1.72, 2.00, 2.26, 2.39);
      FNFD: array (integer range 1..4) of float
      :=(0.00967, 0.0052, 0.0026, 0.0022);
      FNG: array (integer range 1..4) of float
      :=(0.585, 0.885, 1.155, 1.325);
      FNGD: array (integer range 1..4) of float
      :=(0.01, 0.0054, 0.0034, 0.0024);
--
      I, ITIM, ISOLC, ISOL, ITR, IAF, JDN, NPASS, K, IND, NHOPP1, J: integer;
      FLOG, Z, GA, GT, GR, RORO, XMI, D1, PSI: float;
      DF, PSID, AF, X, CONDT, CONDR: float;
      Y, EO, ANSN, PLSAV, HHIGHR, HLOWER, HTEMP, GRLOSS, CONDUC: float;
      TLOSS, S, THETA, CTHETA, PATH, SID1, SID2, SID5, SID3, SID4: float;
      PLOSS, REFLOS, REFION, ANS, SS, SSVOLT, SQUARE, DRADNS, DISTGP: float;
      XGVOLT, RRVOLT, XRVOLT, YRVOLT, XSUM, VOLTSM: float;
      XLAT, XLON, EEOTEMP: float;
      IDANIT: DAY_OR_NIGHT;
--
      Begin
--
--INITIALIZE SIGNAL STRENGTH ARRAY TO ZERO
      For I in 1..6 Loop
         EEO(I) := 0.0;
      End Loop;
--
--SET THE SEASON "ITIM" BASED ON MONTH
      If MONTH = 12 or MONTH = 1 or MONTH = 2 Then
         ITIM := 2;
      Elsif MONTH = 3 or MONTH = 4 or MONTH = 5 or
            MONTH = 9 or MONTH = 10 or MONTH = 11 Then
         ITIM := 3;
      Elsif MONTH = 6 or MONTH = 7 or MONTH = 8 Then
         ITIM := 4;
      End If;
--
--COMPUTE THE SOLAR CYCLE "ISOL" (1 = MAXIMUM, 2 = MINIMUM)
      ISOLC := INTEGER(FLOAT(AVERAGE_SUN_SPOT_NUMBER)*0.025);
      If ISOLC > 1 Then
         ISOLC := 1;
      End If;
      ISOL := 2 - ISOLC;
--
--MAKE SURE THAT ANTENNA TYPE IS PROPER & IF NOT DEFAULT TO LOOP TYPE
      If IATYPT >= 3  Then
         IATYPT := 1;
      End If;
--
--HEIGHT GAIN FACTORS.
--
--  GAIN FACTOR DATA IS FROM VLF RADIO ENGINEERING, FIG. 3.2.10, P 190.
--
--  SEA
--     G := 0
--
--  LAND
--     G := 0                            ALT  LT  Z(F)
--       := A(F)*LOG(ALT/Z(F))         ALT  GT  Z(F)
--  WHERE ALT IS ALTITUDE OF ANTENNA AND FREQ IS FREQUENCY.
--        Z(F) := 11.75 -4.67*LOG FREQKC
--        A(F) := 16.38*LOG FREQKC  -16.26
--  HOWEVER G IS NOT ALLOWED TO EXCEED 30 DB.
--
--  FIRST COMPUTE THE REFLECTION MEDIUM AT THE TRANSMITTER AND RECEIVER
      MED(1) := 1;
      RFUTIL.GNDCON (TLAT, TLON, CONDT);
      If CONDT > 0.05 Then
         MED(1) := 2;
      End If;
      MED(2) := 1;
      RFUTIL.GNDCON (RLAT, RLON, CONDR);
      If CONDR > 0.05 Then
         MED(2) := 2;
      End If;
--
--  NOW THE GAIN FUNCTIONS
      FLOG := LOG10(FREQKC);
      Z := 11.75 - 4.67*FLOG;
      GA := 16.38*FLOG - 16.26;
      GT := 0.0;
      If MED(1) /= 2 and TALT >= Z Then
         GT := GA*LOG10(TALT/Z);
         If GT > 30.0 Then
            GT := 30.0;
         End If;
      End If;
      GR := 0.0;
      If MED(2) /= 2 and RALT >= Z Then
         GR := GA*LOG10(RALT/Z);
         If GR > 30.0 Then
            GR := 30.0;
         End If;
      End If;
--
--GT, GR ARE THE HEIGHT GAIN FACTORS (IN DB) FOR THE TRANS AND REC.
--
      RORO := (RADIUS_OF_EARTH_IN_KM)**2;
--
--PROPAGATION CALCULATIONS.
      For I in 1..NHOP Loop
         XMI := FLOAT(I);
         D1 := DPATH/XMI;
         PSI := BETA(I) - HALFPI;
--
--PSI IS THE ELEVATION ANGLE.
         GDB(I) := float(IATYPT)*20.0*LOG10(COS(PSI));
--
--COMPUTE ANTENNA FACTOR, AF.
         For ITR in 1..2 Loop
             For J in 2..5 Loop
                IAF := J;
                Exit When FREQKC < FAF(IAF) or IAF = 5;
             End Loop;
             IAF := IAF - 1;
             DF := FREQKC - FAF(IAF);
             PSID := PSI*DEGREES_PER_RADIAN;
--
--IS TRANSMITTER/RECEIVER ON LAND (MED = 1) OR SEA (MED = 2)?
             IF MED(ITR) = 1 Then
                If PSID >= 10.0 Then
                   AF := AFLA(IAF) + AFLAD(IAF)*DF;
                Elsif PSID <= -2.5 Then
                   AF := (AFLC(IAF) + AFLCD(IAF)*DF) + PSID*(AFLD(IAF)
                         + AFLDD(IAF)*DF);
                Elsif IAF > 2 Then
                   AF := (AFLA(IAF) + AFLAD(IAF)*DF) + (AFLB(IAF)
                         + AFLBD(IAF)*DF)*((10.0 - PSID)**3);
                Else
                   AF := (AFLA(IAF) + AFLAD(IAF)*DF) + (AFLB(IAF) +
                         AFLBD(IAF)*DF)*((10.0 - PSID)**2);
                End If;
             Else
                If PSID >= 5.0 Then
                  AF := 0.0;
                Elsif PSID <= -2.5 Then
                  AF := (AFSB(IAF) + AFSBD(IAF)*DF) - PSID*(AFSC(IAF) +
                        AFSCD(IAF)*DF);
                Else
                   AF := (AFSA(IAF) + AFSAD(IAF)*DF)*((PSID - 5.0)**2);
             End If;
          End If;
          AFS(ITR) := AF;
      End Loop;
--
--AFS GIVES THE FOCUSSING FACTORS FOR THE ANTENNAE (-DB/20)  (1 IS THE
--  TRANSMITTER, 2 IS RECEIVER).
--
--  IONOSPHERIC FOCUSSING FACTOR.
--
         For J in 2..5 Loop
            JDN := J;
            Exit When FREQKC < FFDN(JDN) or JDN = 5;
         End Loop;
         JDN := JDN - 1;
         DF := FREQKC - FFDN(JDN);
         RFUTIL.DAYNIT (IDANIT, PLONG(I), PLONG(I));
         If IDANIT = DAY Then
--
--FD IS THE DAYTIME IONOSPHERIC FOCUSING FACTOR.
            If D1 <= 1000.0 Then
               FDN(I) := 1.0 + FDA*D1 + FDB*(D1**2);
            Elsif D1 <= 1700.0 Then
               FDN(I) := FDC + FDD*D1 + (FDE(JDN) + FDED(JDN)*DF) *
                        ((D1 - 800.0)**2);
            Elsif D1 <= 1900.0 Then
               FDN(I) := FDF(JDN) + FDFD(JDN)*DF;
            Else
               FDN(I) := (FDG(JDN) + FDGD(JDN)*DF) + FDH*D1;
            End If;
--
--FN IS THE NIGHTIME IONOSPHERIC FOCUSING FACTOR.
         Else
            If D1 <= 1000.0 Then
               FDN(I) := 1.0 + FNA*D1 + FNB*(D1**2);
            Elsif D1 <= 1900.0 Then
               FDN(I) := FNC + FND*D1 + (FNE(JDN) + FNED(JDN)*DF) *
                        ((D1 - 1000.0)**2);
            Elsif D1 <= 2100.0 Then
               FDN(I) := FNF(JDN) + FNFD(JDN)*DF;
            Else
               FDN(I) := (FNG(JDN) + FNGD(JDN)*DF) + FNH*D1;
            End If;
         End If;
--
--FDN(I) IS THE IONOSPHERIC FOCUSSING FACTOR.
--
         FDN(I) := 20.0*LOG10(FDN(I));
--
--GROUND REFLECTION FACTORS.
--  TECHNIQUE:  PARTIALLY FILL ARRAY OF (NHOPS,REFLECTION POINTS).
--
         If I /= 1 Then
            NPASS := I - 1;
            For K in 1.. NPASS Loop
--
--  CALCULATE SGR(I,K).
               X := ABS(SIN(PSI));
               If X < 1.0E-04 Then
                  X := 1.0E-04;
               End If;
               X := LOG10(X);
--
--  COMPUTE LOCATIONS AND CONDUCTIVITY AT GROUND REFLECTIONS.
               IND := INDX(NPASS, K);
               DISTGP := DPATH*GPTS(IND);
               NODELOC.LOCNEW (TLAT, TLON, BRNG1, DISTGP, XLAT, XLON);
--
--  IS POINT ON LAND OR SEA?
               RFUTIL.GNDCON (XLAT, XLON, CND(I));
               If CND(I) <= 0.05 Then
--
--  LAND REFLECTION.
                  If X <= -2.7 Then
                     Y := 1.7 + X;
                  Elsif X <= -0.3 Then
                     Y := -1.0 + 0.778*SIN((X + 2.7)*1.308997);
                  Else
                     Y := -1.3 - X;
                  End If;
               Else
--
--  SEA REFLECTION.
                  If X <= -4.1 Then
                     Y := 3.1 + X;
                  Elsif X <= -1.9 Then
                     Y := -1.0 + 0.778*SIN((X + 4.1)*1.427997);
                  Else
                     Y := -2.9 - X;
                  End If;
               End If;
               SGR(I,K) := -20.0*LOG10(1.0 - 10.0**Y);
--
--       SGR IS THE LOSS DUE TO A SINGLE GROUND REFLECTION.
--
            End Loop;
         End If;
      End Loop;
--
--FIELD STRENGTH CALCULATIONS.
--
      EO := 20.0*LOG10(295.0E03*SQRT(TERP));
      ANSN := 0.0;
      PLSAV := -100.0;
      NHOPP1 := NHOP + 1;
      For I in 1..NHOPP1 Loop
         If I = 1 Then
--
--  DO GROUND WAVE CALCULATION FIRST.
--
--  GROUND WAVE PROPAGATION.
            HHIGHR := TALT*1.0E3;
            HLOWER := RALT*1.0E3;
            If HLOWER > HHIGHR Then
               HTEMP := HHIGHR;
               HHIGHR := HLOWER;
               HLOWER := HTEMP;
            End If;
            LF_HF_GROUNDWAVES.GRWAVE(CONDT, FREQKC, DPATH, 1, TERP,
                                     HLOWER, HHIGHR, EEO(1), GRLOSS);
--
--CONVERT V/M TO DB/MICROVOLT/M
            EEO(1) := 20.0*LOG10(EEO(1)) + 120.0;
--
--      ACCOUNT FOR GROUNDWAVE LOSS DUE TERRAIN ROUGHNESS
            RFUTIL.GNDCON (PLAT(1), PLONG(1), CONDUC);
            If CONDUC <= 0.05 Then
               TERAIN (PLAT(1), PLONG(1), FREQMC, DPATH, TLOSS);
               EEO(1) := EEO(1) - TLOSS;
            End If;
--
         Else
--
--SKYWAVE CALCULATIONS.
            J := I - 1;
--
--  IF MODE IS BELOW HORIZION, SKY WAVE DOES NOT EXIST.
--
            EEO(I) := -200.0;
            If MODFES(J) >= 1 Then
--
--  COMPUTE PATH LENGTH AND PATH LOSS.
               S := DPATH/FLOAT(J);
               THETA := 0.5*S/RADIUS_OF_EARTH_IN_KM;
               CTHETA := COS(THETA);
               PATH := 0.0;
               SID1 := PALT(1);
               IF J = 1  or  J = 3  or  J = 5 Then
                  PATH := PATH + 2.0*SQRT(RORO + SID1*SID1 -
                          2.0*RADIUS_OF_EARTH_IN_KM*SID1*CTHETA);
               End If;
               SID2 := PALT(2);
               SID5 := PALT(5);
               If J > 2 Then
                  PATH := PATH + 2.0*SQRT(RORO + SID2*SID2 -
                          2.0*RADIUS_OF_EARTH_IN_KM*SID2*CTHETA) +
                          2.0*SQRT(RORO + SID5*SID5 - 2.0*
                          RADIUS_OF_EARTH_IN_KM*SID5*CTHETA);
               End If;
               SID3 := PALT(3);
               SID4 := PALT(4);
               If J = 2  or  J > 3 Then
                  PATH := PATH + 2.0*SQRT(RORO + SID4*SID4 - 2.0*
                          RADIUS_OF_EARTH_IN_KM*SID4*CTHETA) +
                          2.0*SQRT(RORO + SID3*SID3 -
                          2.0*RADIUS_OF_EARTH_IN_KM*SID3*CTHETA);
               End If;
               If PLSAV <= 0.0 Then
                  PLSAV := PATH;
               End If;
--
--  PLOSS IS THE LOSS DUE TO PATH LENGTH.
               PLOSS := 20.0*LOG10(PATH);
--
--COMPUTE IONOSPHERIC AND GROUND REFLECTION LOSSES.
               REFLOS := 0.0;
--
--  IONOSPHERIC LOSSES FIRST.
               If J = 1  or  J = 3  or  J = 5 Then
                  REFLOS := REFLOS + COEF(1)*GAMMA(J);
               End If;
               If J > 2 Then
                  REFLOS := REFLOS + COEF(2)*GAMMA(J) + COEF(5)*GAMMA(J);
               End If;
               If J = 2  or  J > 3 Then
                  REFLOS := REFLOS + COEF(3)*GAMMA(J) + COEF(4)*GAMMA(J);
               End If;
               REFLOS := -20.0*LOG10(EXP(AMAX1(REFLOS,-87.5)));
               REFION := REFLOS;
--
--  NOW GROUND REFLECTION LOSSES.
               If J = 2 Then
                  REFLOS := REFLOS + SGR(2,1);
               End If;
               If J = 3 Then
                  REFLOS := REFLOS + SGR(3,1) + SGR(3,2);
               End If;
               If J = 4 Then
                  REFLOS := REFLOS + SGR(4,1) + SGR(4,2) + SGR(4, 3);
               End If;
               If J = 5 Then
                  REFLOS := REFLOS + SGR(5,1) + SGR(5,2) + SGR(5,3) + SGR(5,4);
               End If;
--
--NOW COMPUTE TOTAL FIELD STRENGTH.
--
               EEO(I) := EO + 6.0 + GT + GR - REFLOS + GDB(J) +
                         FDN(J) - PLOSS - 20.0*(AFS(1) + AFS(2));
--
--  EEO IS REFERRED TO INVERSE DISTANCE.
            End If;
         End If;
      End Loop;
--
--DETERMINE RSS SIGNAL STRENGTH IF D > 1500KM.
--
      If DPATH > 1500.0 Then
         ANS := 0.0;
         For I in 1..NHOPP1 Loop
            SS := EEO(I);
            SSVOLT := 10.0**(SS*0.05);
            SQUARE := SSVOLT*SSVOLT;
            ANS := ANS + SQUARE;
         End Loop;
         ANS := 20.0*LOG10(SQRT(ANS));
      Else
--
--IF D < 1500
--  DETERMINE VECTOR SUM OF GROUND WAVE AND STRONGEST HOP SIGNAL.
--  (THIS IS USUALLY THE ONE HOP SIGNAL AS LONG AS BETA(1) > PI2)
--
         DRADNS := ABS(PLSAV - DPATH)*FREQKC*0.333333E-2;
         DRADNS := (DRADNS - TRUNCATE(DRADNS))*TWOPI;
         SS := EEO(1);
         XGVOLT := 10.0**(SS*0.05);
         EEOTEMP:=EEO(2);
         for I in 3..6 loop
            EEOTEMP := AMAX1(EEOTEMP, EEO(I));
         end loop;
         SS := EEOTEMP;
         RRVOLT := 10.0**(SS*0.05);
         XRVOLT := RRVOLT*COS(DRADNS);
         YRVOLT := RRVOLT*SIN(DRADNS);
         XSUM := XRVOLT + XGVOLT;
         VOLTSM := SQRT(XSUM*XSUM + YRVOLT*YRVOLT);
         ANS := 20.0*LOG10(VOLTSM);
      End If;
      SIGNAL := ANS;
--
      Return;
--
      End LFPROP;
--
      Procedure LF_HANDLER is
--
--#PURPOSE: LF_HANDLER controls LF propagation prediction calculations.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        CURRENT_TIME = Current scenario time in minutes.
--IN        TLAT   = Transmitter latitude in degrees north
--IN        TLON   = Transmitter longitude in degrees east
--IN        TALT   = Transmitter altitude in kilometers
--IN        RLAT   = Receiver latitude in degrees north
--IN        RLON   = Receiver longitude in degrees east
--IN        RALT   = Receiver altitude in kilometers
--IN        FREQKC = Frequency in Khz
--IN        TERP   = Transmitter radiated power in Kw
--IN        IATYPT = Transmitting antenna type (1 = loop, 2 = whip)
--OUT       SIGNAL = Signal strength at receiver in DB/MICROVOLT/METER
--
--#CALLED BY:
--          RF_PROPAGATION_HANDLER
--
--#CALLS TO:
--          HIGHTF
--          LFPROP
--
--#TECHNICAL DESCRIPTION:
--          LF_HANDLER is the set-up routine for LF propagation prediction
--          calculations. It first divides the propagation path in
--          segments and then computes the launch angle and reflection
--          angle geometries. Next, the height of the ionosphere along
--          the path is computed and passed to subroutine LFPROP for
--          the actual propagation prediction calculations.
--
      I: integer;
      ALPHA, BPG, PALTT, BMG: float;
--
      Begin
--
--PROPAGATION GEOMETRY.
--
--FIRST DIVIDE THE PATH INTO SEGMENTS AND COMPUTE THE
--  REFLECTION LOSS AND HEIGHT AT EACH OF FIVE POINTS.
--
--FILL PALT AND COEF ARRAY.
      HIGHTF;
      For I in 1..NHOP Loop
--
--ALPHA IS THE ANGLE BETWEEN LINES FROM EARTH CENTER
--TO GROUND AND IONOSPHERE REFLECTION POINTS RESPECTIVELY.
         ALPHA := DPATH/(2.0*RADIUS_OF_EARTH_IN_KM*FLOAT(I));
         BPG := 0.5*(PI - ALPHA);
         PALTT := PALT(1) - RADIUS_OF_EARTH_IN_KM;
         If I = 2 Then
            PALTT := PALT(3) - RADIUS_OF_EARTH_IN_KM;
         End If;
         If I > 2 Then
            PALTT := PALT(2) - RADIUS_OF_EARTH_IN_KM;
         End If;
         BMG := ATAN((PALTT/(PALTT + 2.0*RADIUS_OF_EARTH_IN_KM))*TAN(BPG));
--
--BETA IS THE ANGLE BETWEEN A LINE FROM EARTH CENTER TO
--GROUND POINT AND A LINE FROM GROUND POINT TO IONOSPHERIC
--REFLECTION POINT.
         BETA(I) := BPG + BMG;
--
--CHECK IS BETA IS BELOW HORZION.
         MODFES(I) := 1;
         If BETA(I) <= HALFPI Then
            MODFES(I) := 0;
         End If;
         GAMMA(I) := COS(BPG - BMG);
      End Loop;
--
--COMPUTE THE TOTAL SIGNAL STRENGTH AT THE RECEIVER
      LFPROP;
--
      Return;
--
      End LF_HANDLER;
--
End LF_PROPAGATION;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--VLFPROP
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Debugger2; Use Debugger2;
With Text_io; Use Text_io;
With Mathlib; use Mathlib, numeric_primitives, core_functions, trig_functions;
With Constants; Use Constants;
With Propagation_constants; Use Propagation_constants;
With RFUtil;
With Nodeloc;

Package VLF_PROPAGATION is
--
      Procedure VLF_HANDLER;
--
End VLF_PROPAGATION;
--
Package body VLF_PROPAGATION is
--
-- VLF_PROPAGATION Package of PROP_LINK
-- Version 1.0,  June 27, 1985.
--
-- This VLF_PROPAGATION Package contains all of the procedures that
-- are used to perform VLF propagation prediction.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
--Use Text_IO;
-- Instantiate integer and floating point IO.
--      Package IO_INTEGER is new INTEGER_IO(INTEGER);
--      Package IO_FLOAT is new FLOAT_IO(FLOAT);
--Use IO_INTEGER,IO_FLOAT;
--
  Pragma Source_info (on);
--
--**************************************************************************
--VARIABLES THAT ARE TO BE VISIBLE TO ALL ROUTINES WITHIN THIS PACKAGE
      MLA1, MLA2, MLA3, PLA1, PLA2, PLA3: float;
      IPERM: integer;
      MGZ1: array (integer range 1..2) of float;
      MGZ2: array (integer range 1..2) of float;
      MGZ3: array (integer range 1..2) of float;
      PGZ1: array (integer range 1..2) of float;
      PGZ2: array (integer range 1..2) of float;
      PGZ3: array (integer range 1..2) of float;
      ALPD1: float := 0.0;
      ALPD2: float := 0.0;
      ALPD3: float := 0.0;
      ALPN1: float := 0.0;
      ALPN2: float := 0.0;
      ALPN3: float := 0.0;
      VPD1: float := 0.0;
      VPD2: float := 0.0;
      VPD3: float := 0.0;
      VPN1: float := 0.0;
      VPN2: float := 0.0;
      VPN3: float := 0.0;
--**************************************************************************
--
      Function MAX0 (I,J:Integer) return float is
      begin
         if I>J then
            Return float(I);
         else
            Return float(J);
         end if;
      end MAX0;
--
      Function MIN0 (I,J: integer) return float is
      begin
         if I<J then
            Return float(I);
         else
            Return float(J);
         end if;
      end MIN0;
--
--
      Procedure VPDAY is
--
--#PURPOSE: VPDAY calculates the phase velocity for VLF mode
--          analysis for day conditions.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--          'NONE'
--
--#CALLED BY:
--          VLF_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          The phase velocities are based on curve fits to data in
--          Watt, 1967.  The independent variable is frequency.
--
      Begin
--
      VPD1 := 3.0E5*((3.0811 + (-0.41925 + (0.017934 - 0.00025929*FREQKC)*
              FREQKC)*FREQKC)*0.01 + 1.0);
      VPD2 := 3.0E5*((20.25 + (-2.2144 + (0.084483 - 0.0010997*FREQKC)*
              FREQKC)*FREQKC)*0.01 + 1.0);
      VPD3 := 3.0E5*((45.552 + (-4.4442 + (0.15493 - 0.0018666*FREQKC)*
              FREQKC)*FREQKC)*0.01 + 1.0);
--
      Return;
--
      End VPDAY;
--
--
      Procedure VPNITE is
--
--#PURPOSE: VPNITE calculates the phase velocity for VLF mode
--          analysis for night conditions.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--          'NONE'
--
--#CALLED BY:
--          VLF_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          The phase velocities are based on curve fits to data in
--          Watt, l967.  The independent variable is frequency.
--
      Begin
--
      VPN1 := 3.0E5*((((-0.00018012*FREQKC + 0.011752)*FREQKC - 0.2702)*
              FREQKC + 1.7143)*0.01 + 1.0);
      VPN2 := 3.0E5*((((-0.0006901*FREQKC + 0.05096)*FREQKC - 1.2867)*
              FREQKC + 11.144)*0.01 + 1.0);
      VPN3 := 3.0E5*((((-0.002474*FREQKC + 0.17879)*FREQKC - 4.4185)*
              FREQKC + 38.331)*0.01 + 1.0);
--
      Return;
--
      End VPNITE;
--
--
-- START CURVE FIT FUNCTIONS
--
--
      Function ALPID1 (F: float) return float is
      Begin
      Return 11.053-1.1706*F+0.048434*F**2-0.000574170*F**3;
      End ALPID1;
--
--
      Function ALPID2 (F: float) return float is
      Begin
      Return 46.121+(-4.0519+((0.14693-0.001842*F)*F))*F;
      End ALPID2;
--
--
      Function ALPID3 (F: float) return float is
      Begin
      Return (0.024184*F - 1.5467)*F + 35.352;
      End ALPID3;
--
--
      Function ALPIN1 (F: float) return float is
      Begin
      Return (((0.000052083*F - 0.0043692)*F + 0.1376)*F - 1.8338)*F +
                9.9667;
      End ALPIN1;
--
--
      Function ALPIN2 (F: float) return float is
      Begin
      Return ((-0.0013411*F + 0.10118)*F - 2.6140)*F + 25.563;
      End ALPIN2;
--
--
      Function ALPIN3 (F: float) return float is
      Begin
      Return ((-0.0016*F + 0.133)*F -3.865)*F + 44.55;
      End ALPIN3;
--
--
      Function KTTED1 (F: float) return float is
      Begin
      Return (0.00057143*F - 0.031257)*F + 0.473;
      End KTTED1;
--
--
      Function KTTWD1 (F: float) return float is
      Begin
      Return (0.0004*F - 0.0284)*F + 0.568;
      End KTTWD1;
--
--
      Function KTTED2 (F: float) return float is
      Begin
      Return (0.00033714*F -0.019846)*F + 0.3336;
      End KTTED2;
--
--
      Function KTTWD2 (F: float) return float is
      Begin
      Return (0.00045*F - 0.02695)*F + 0.48325;
      End KTTWD2;
--
--
      Function DSGD1 (F: float) return float is
      Begin
      Return float(MAX(0,2-IPERM))*((-0.0015429*F + 0.046114)*F + 0.3940);
      End DSGD1;
--
--
      Function DSGN1 (F: float) return float is
      Begin
      Return float(MAX(0,2-IPERM))*(((0.66667E-4*F - 0.0039143)*F + 0.050762)
             *F + 0.236);
      End DSGN1;
--
--
      Function SFA1 (F: float) return float is
      Begin
      Return (-0.0095577*F + 0.1302)*F + 0.66667;
      End SFA1;
--
--
      Function SFA2 (F: float) return float is
      Begin
      Return (-0.013058*F + 0.18804)*F + 0.071875;
      End SFA2;
--
--
      Function SFB1 (F: float) return float is
      Begin
      Return (0.001608*F + 0.047224)*F + 0.55361;
      End SFB1;
--
--
      Function SFB2 (F: float) return float is
      Begin
      Return (-0.00082783*F + 0.1154)*F + 0.0078095;
      End SFB2;
--
--
      Function SFC1 (F: float) return float is
      Begin
      Return (0.0030655*F - 0.087429)*F + 1.5417;
      End SFC1;
--
--
      Function SFD1 (F: float) return float is
      Begin
      Return (0.023772*F - 0.92938)*F + 11.367;
      End SFD1;
--
--
      Function SFD2 (F: float) return float is
      Begin
      Return (0.038839*F - 0.98464)*F + 12.177;
      End SFD2;
--
--
      Function SFE1 (F: float) return float is
      Begin
      Return (-0.00267*F - 0.14786)*F + 4.1943;
      End SFE1;
--
--
      Function SFE2 (F: float) return float is
      Begin
      Return (0.016518*F - 0.70821)*F + 8.5486;
      End SFE2;
--
--
      Function SFF1 (F: float) return float is
      Begin
      Return (-0.0039286*F + 0.12057)*F - 0.10343;
      End SFF1;
--
--
      Function SFAA1 (F: float) return float is
      Begin
      Return ((-0.15046E-2*F + 0.017634)*F - 0.27146)*F + 1.7667;
      End SFAA1;
--
--
      Function SFAA2 (F: float) return float is
      Begin
      Return ((-0.63657E-3*F - 0.022321)*F + 0.20661)*F - 0.16191;
      End SFAA2;
--
--
      Function SFBB1 (F: float) return float is
      Begin
      Return (((0.25228E-4*F - 0.0029724)*F + 0.099049)*F - 1.1238)*F +
                5.4726;
      End SFBB1;
--
--
      Function SFBB2 (F: float) return float is
      Begin
      Return (((0.52897E-4*F - 0.005089)*F + 0.15267)*F -1.6844)*F +
                 7.4821;
      End SFBB2;
--
--
      Function SFCC1 (F: float) return float is
      Begin
      Return ((-0.13021E-3*F + 0.0125)*F - 0.22292)*F + 2.15;
      End SFCC1;
--
--
      Function SFDD1 (F: float) return float is
      Begin
      Return (((-0.89518E-4*F + 0.0064743)*F - 0.1056)*F + 0.2174)*F +
                6.5119;
      End SFDD1;
--
--
      Function SFDD2 (F: float) return float is
      Begin
      Return ((-0.0025535*F + 0.18304)*F - 2.8216)*F + 18.455;
      End SFDD2;
--
--
      Function SFEE1 (F: float) return float is
      Begin
      Return ((0.00039063*F - 0.0066964)*F -0.38839)*F + 5.8557;
      End SFEE1;
--
--
      Function SFEE2 (F: float) return float is
      Begin
      Return ((-0.00026042*F + 0.051339)*F - 1.3744)*F + 11.053;
      End SFEE2;
--
--
      Function SFFF1 (F: float) return float is
      Begin
      Return ((0.00069922*F - 0.044149)*F + 0.81712)*F -3.6579;
      End SFFF1;
--
--
--
      Function MLAD1 return float is
      Begin
      Return MAX0(0,2-IPERM)*(SFA1(FREQKC)) +
                MIN0(1,IPERM/2)*(SFA2(FREQKC));
      End MLAD1;
--
--
      Function MLAD2 return float is
      Begin
      Return MAX0(0,2-IPERM)*(SFB1(FREQKC)) +
                MIN0(1,IPERM/2)*(SFB2(FREQKC));
      End MLAD2;
--
--
      Function MLAD3 return float is
      Begin
      Return SFC1(FREQKC);
      End MLAD3;
--
--
      Function PLAD1 return float is
      Begin
      Return MAX0(0,2-IPERM)*(SFD1(FREQKC)) +
                MIN0(1,IPERM/2)*(SFD2(FREQKC));
      End PLAD1;
--
--
      Function PLAD2 return float is
      Begin
      Return MAX0(0,2-IPERM)*(SFE1(FREQKC)) +
                MIN0(1,IPERM/2)*(SFE2(FREQKC));
      End PLAD2;
--
--
      Function PLAD3 return float is
      Begin
      Return SFF1(FREQKC);
      End PLAD3;
--
--
      Function MLAN1 return float is
      Begin
      Return MAX0(0,2-IPERM)*(SFAA1(FREQKC)) +
                MIN0(1,IPERM/2)*(SFAA2(FREQKC));
      End MLAN1;
--
--
      Function MLAN2 return float is
      Begin
      Return MAX0(0,2-IPERM)*(SFBB1(FREQKC)) +
                MIN0(1,IPERM/2)*(SFBB2(FREQKC));
      End MLAN2;
--
--
      Function MLAN3 return float is
      Begin
      Return SFCC1(FREQKC);
      End MLAN3;
--
--
      Function PLAN1 return float is
      Begin
      Return MAX0(0,2-IPERM)*(SFDD1(FREQKC)) +
                MIN0(1,IPERM/2)*(SFDD2(FREQKC));
      End PLAN1;
--
--
      Function PLAN2 return float is
      Begin
      Return MAX0(0,2-IPERM)*(SFEE1(FREQKC)) +
                MIN0(1,IPERM/2)*(SFEE2(FREQKC));
      End PLAN2;
--
      Function PLAN3 return float is
      Begin
      Return SFFF1(FREQKC);
      End PLAN3;
--
--
--END CURVE FIT FUNCTIONS
--
--
--START GENERAL EQUATIONS
--
      Function F1 (ALT: float; HION:float; X2PI:float) return float is
      Begin
      Return COS((X2PI*ALT)/(4.0*HION));
      End F1;
--
      Function F2 (ALT: float; HION:float; X2PI:float) return float is
      Begin
      Return  COS((X2PI*ALT)/(1.333333 * HION));
      End F2;
--
      Function F3 (ALT: float; HION:float; X2PI:float) return float is
      Begin
      Return COS((X2PI*ALT)/(0.8*HION));
      End F3;
--
      Function FDB (X: float) return float is
      Begin
      Return 20.0*LOG10(X);
      End FDB;
--
--END GENERAL EQUATIONS
--
--
      Procedure CLAMB is
--
--#PURPOSE: CLAMB calculates the relative excitation factors
--          at the transmitter and receiver for VLF mode
--          analysis.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--          'NONE'
--
--#CALLED BY:
--          VLF_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          The calculations are based on curve fits to data in
--          Watt,1967 .  If a terminator crosses the path (IDNT /=
--          IDNR), values for day and night are added and divided by
--          2 based on the relationship:
--
--          Effective Value = SQRT(Transmitter Value * Receiver Value)
--
      Begin
--
--ZERO OUT PHASORS
      MLA1 := 0.0;
      MLA2 := 0.0;
      MLA3 := 0.0;
      PLA1 := 0.0;
      PLA2 := 0.0;
      PLA3 := 0.0;
--
--CALCULATE MAGNITUDES
      If IDNT = DAY or IDNR = DAY Then
         MLA1 := MLAD1;
         MLA2 := MLAD2;
         MLA3 := MLAD3;
      End If;
      If IDNT = NIGHT or IDNR = NIGHT Then
         MLA1 := MLA1 + MLAN1;
         MLA2 := MLA2 + MLAN2;
         MLA3 := MLA3 + MLAN3;
      End If;
--
--CALCULATE PHASES
      If IDNT = DAY or IDNR = DAY Then
         PLA1 := PLAD1;
         PLA2 := PLAD2;
         PLA3 := PLAD3;
      End If;
      If IDNT = NIGHT or IDNR = NIGHT Then
         PLA1 := PLA1 + PLAN1;
         PLA2 := PLA2 + PLAN2;
         PLA3 := PLA3 + PLAN3;
      End If;
      If IDNT /= IDNR Then
         MLA1 := MLA1*0.5;
         MLA2 := MLA2*0.5;
         MLA3 := MLA3*0.5;
         PLA1 := PLA1*0.5;
         PLA2 := PLA2*0.5;
         PLA3 := PLA3*0.5;
      End If;
--
      Return;
--
      End CLAMB;
--
--
      Procedure GZN (ALT: in float;
                     HION: in float;
                     ITR: in integer) is
--
--#PURPOSE: GZN calculates the height gain functions for the
--          transmitter and receiver for VLF mode analysis.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        ALT    = Altitude in km
--IN        HION   = Height of the ionosphere in km
--IN        ITR    = 1 if a transmitter, 2 if a receiver
--
--#CALLED BY:
--          VLF_HANDLER
--
--#CALLS TO:
--          'NONE"
--
--#TECHNICAL DESCRIPTION:
--          For frequencies below 15 kHz, the height gain functions
--          are assumed to have the sinusoidal forms.  For frequencies
--          greater than 15 kHz, adjustments are made as follows:
--
--                    Mode 1 - curve fit to data in Watt, 1967 for
--               heights 20.1 km; and default message for heights
--               greater than or equal to 20.1 km.
--
--                    Mode 2 and 3 - effective height of the
--               ionosphere is raised to 1.16 * HION at 30 kHz and a
--               proportional amount for frequencies between 15 and 30
--               kHz;  sinusoidal distributions are retained.
--
      K: integer;
      FREQSF, HIONE: float;
--
      Begin
--
      K := ITR;
      MGZ1(K) := 1.0;
      MGZ2(K) := 1.0;
      MGZ3(K) := 1.0;
      If ALT >= 0.1  Then
         FREQSF := (FREQKC - 15.0)/15.0;
         If FREQKC > 15.0 and ALT < 20.1 Then
            MGZ1(K) := F1(ALT,HION,TWOPI) + 0.4*FREQSF*F1(ALT,HION,TWOPI);
            HIONE := 1.0 + FREQSF * 0.16;
            HIONE := HION*HIONE;
            MGZ2(K) := F2(ALT,HIONE,TWOPI);
            MGZ3(K) := F3(ALT,HIONE,TWOPI);
         Elsif FREQKC > 15.0 and ALT >= 20.1 Then
            New_line;
            Put("THIS TRANSMITTER/RECEIVER ALTITUDE AND FREQUENCY");
            New_line;
            Put("COMBINATION IS NOT INCLUDED IN THE MODE ANALYSIS MODELS.");
            New_line;
            Put("DEFAULT VALUES OF THE HEIGHT GAIN FUNCTION ARE EMPLOYED");
            New_line;
            Put("TO PERMIT PROBLEM CONTINUATION BUT THEIR ACCURACY IS");
            New_line;
            Put("UNCERTAIN.");
            MGZ1(K) := AMAX1(F1(ALT,HION,TWOPI)*ALT*5.25/HION*FREQSF,
                             F1(ALT,HION,TWOPI));
            HIONE := 1.0 + FREQSF * 0.16;
            HIONE := HION*HIONE;
            MGZ2(K) := F2(ALT,HIONE,TWOPI);
            MGZ3(K) := F3(ALT,HIONE,TWOPI);
         Else
            MGZ1(K) := F1(ALT,HION,TWOPI);
            MGZ2(K) := F2(ALT,HION,TWOPI);
            MGZ3(K) := F3(ALT,HION,TWOPI);
         End If;
      End If;
      PGZ1(K) := 0.0;
      PGZ2(K) := 0.0;
      PGZ3(K) := 0.0;
      If MGZ2(K) < 0.0 Then
         PGZ2(K) := 180.0;
      End If;
      If MGZ3(K) < 0.0 Then
         PGZ3(K) := 180.0;
      End If;
      If ALT > HION Then
         New_line;
         Put("THE INPUT ALTITUDE IS GREATER THAN THE IONOSPHERIC HEIGHT.");
         New_line;
         Put("SUCH A RELATIONSHIP IS NOT ACCOMODATED BY VLF MODE ANALYSIS.");
      End If;
      MGZ1(K) := FDB(ABS(MGZ1(K)));
      MGZ2(K) := FDB(ABS(MGZ2(K)));
      MGZ3(K) := FDB(ABS(MGZ3(K)));
--
      Return;
--
      End GZN;
--
      Procedure ALDAY (TLATX: in float;
                       TLONX: in float;
                       RLATX: in float;
                       RLONX: in float) is
--
--#PURPOSE: ALDAY determines the distance attenuation constant for day
--          conditions for VLF mode analysis.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        TLATX  = Transmitter latitude in degrees north
--IN        TLONX  = Transmitter longitude in degrees east
--IN        RLATX  = Receiver latitude in degrees north
--IN        RLONX  = Receiver longitude in degrees east
--
--#CALLED BY:
--          VLF_HANDLER
--
--#CALLS TO:
--          LOCGRB
--          LOCNEW
--          ALPID1
--          ALPID2
--          ALPID3
--          KTTED1
--          KTTWD1
--          KTTED2
--          KTTWD2
--          DSGD1
--
--#TECHNICAL DESCRIPTION:
--          The methods are based on curve fits as described in
--          Watt,1967 .  The same formulation is used for all 3
--          modes.
--
      ALPDI1, ALPDI2, ALPDI3, PHIA, KD1, KD2, KD3, PHIM, XA: float;
      MSIG1, MSIG2, MSIG3: float;
      BRN1, BRN2, BRNX, PL, XLAT, XLON: float;
      ITTE: integer;
--
      Begin
--
--CALCULATE ALPHAN(I,AVERAGE)
      ALPDI1 := ALPID1(FREQKC);
      ALPDI2 := ALPID2(FREQKC);
      ALPDI3 := ALPID3(FREQKC);
      If FREQKC < 8.0 Then
          ALPDI1 := ALPID1(8.0)*(8.0/FREQKC)**2.635046;
      End If;
      If FREQKC < 12.0 Then
          ALPDI2 := ALPID2(12.0)*(12.0/FREQKC)**2.624672;
      End If;
      If FREQKC < 16.0 Then
          ALPDI3 := ALPID3(16.0)*(16.0/FREQKC)**2.349624;
      End If;
      ALPD1 := ALPDI1;
      ALPD2 := ALPDI2;
      ALPD3 := ALPDI3;
--
--CALCULATE DEL-ALPHAN(I) DUE TO EARTH'S MAGNETIC FIELD.
      NODELOC.LOCGRB (TLATX, TLONX, RLATX, RLONX, BRN1, BRN2, PL);
      PL := PL*0.5;
      NODELOC.LOCNEW (TLATX, TLONX, BRN1, PL, XLAT, XLON);
      NODELOC.LOCGRB (TLATX, TLONX, XLAT, XLON, BRN1, BRNX, PL);
      BRNX := BRNX - 180.0;
      ITTE := 0;
      If BRNX < 180.0 Then
        ITTE := 1;
      End If;
      PHIA := BRNX*RADIANS_PER_DEGREE;
      If ITTE /= 1 Then
         KD1 := KTTWD1(FREQKC);
         KD2 := KTTWD2(FREQKC);
         KD3 := (KD2/KD1)**2 * KD1;
      Else
         KD1 := KTTED1(FREQKC);
         KD1 := 1.5*KD1;
         KD2 := KTTED2(FREQKC);
         KD3 := KD2;
      End If;
      PHIM := ABS(XLAT + TLATX)*0.5*RADIANS_PER_DEGREE;
      XA := COS(PHIM)*SIN(PHIA);
      ALPDI1 := -KD1*XA*ALPDI1;
      ALPDI2 := -KD2*XA*ALPDI2;
      ALPDI3 := -KD3*XA*ALPDI3;
      ALPD1 := ALPD1 + ALPDI1;
      ALPD2 := ALPD2 + ALPDI2;
      ALPD3 := ALPD3 + ALPDI3;
--
--CALCULATE DEL-ALPHN(SIGMA-GROUND)
      MSIG1 := DSGD1(FREQKC);
      MSIG2 := 2.0*MSIG1;
      MSIG3 := 3.0*MSIG1;
      ALPD1 := ALPD1 + MSIG1;
      ALPD2 := ALPD2 + MSIG2;
      ALPD3 := ALPD3 + MSIG3;
--
      Return;
--
      End ALDAY;
--
--
      Procedure ALNITE (TLATX: in float;
                        TLONX: in float;
                        RLATX: in float;
                        RLONX: in float) is
--
--#PURPOSE: ALNITE determines the distance attenuation constant for
--          night conditions for VLF mode analysis.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        TLATX  = Transmitter latitude in degrees north
--IN        TLONX  = Transmitter longitude in degrees east
--IN        RLATX  = Receiver latitude in degrees north
--IN        RLONX  = Receiver longitude in degrees east
--
--#CALLED BY:
--          VLF_HANDLER
--
--#CALLS TO:
--          LOCGRB
--          LOCNEW
--          ALPIN1
--          ALPIN2
--          ALPIN3
--          KTTED1
--          KTTWD1
--          KTTED2
--          KTTWD2
--          DSGN1
--
--#TECHNICAL DESCRIPTION:
--          The methods are based on curve fits as described in
--          Watt, 1967. The same formulation is used for all three
--          modes.
--
      ALPNI1, ALPNI2, ALPNI3, PHIA, KD1, KD2, KD3, PHIM, XA: float;
      MSIG1, MSIG2, MSIG3: float;
      BRN1, BRN2, BRNX, PL, XLAT, XLON: float;
      ITTE: integer;
--
      Begin
--
--CALCULATE ALPHAN(I,AVERAGE)
      ALPNI1 := ALPIN1(FREQKC);
      ALPNI2 := ALPIN2(FREQKC);
      ALPNI3 := ALPIN3(FREQKC);
      If FREQKC < 8.0 Then
          ALPNI1 := ALPIN1(8.0)*(8.0/FREQKC)**2.635046;
      End If;
      If FREQKC < 12.0 Then
          ALPNI2 := ALPIN2(12.0)*(12.0/FREQKC)**2.624672;
      End If;
      If FREQKC < 16.0 Then
          ALPNI3 := ALPIN3(16.0)*(16.0/FREQKC)**2.349624;
      End If;
      ALPN1 := ALPNI1;
      ALPN2 := ALPNI2;
      ALPN3 := ALPNI3;
--
--CALCULATE DEL-ALPHAN(I) DUE TO EARTH'S MAGNETIC FIELD.
      NODELOC.LOCGRB (TLATX, TLONX, RLATX, RLONX, BRN1, BRN2, PL);
      PL := PL*0.5;
      NODELOC.LOCNEW (TLATX, TLONX, BRN1, PL, XLAT, XLON);
      NODELOC.LOCGRB (TLATX, TLONX, XLAT, XLON, BRN1, BRNX, PL);
      BRNX := BRNX - 180.0;
      ITTE := 0;
      If BRNX < 180.0 Then
        ITTE := 1;
      End If;
      PHIA := BRNX*RADIANS_PER_DEGREE;
      If ITTE /= 1 Then
         KD1 := 0.6*KTTWD1(FREQKC);
         KD2 := KTTWD2(FREQKC);
         KD3 := (KD2/KD1)**2 * KD1;
      Else
         KD1 := KTTWD1(FREQKC);
         KD2 := KTTED2(FREQKC);
         KD3 := KD2;
      End If;
      PHIM := ABS(XLAT + TLATX)*0.5*RADIANS_PER_DEGREE;
      XA := COS(PHIM)*SIN(PHIA);
      ALPNI1 := -KD1*XA*ALPNI1;
      ALPNI2 := -KD2*XA*ALPNI2;
      ALPNI3 := -KD3*XA*ALPNI3;
      ALPN1 := ALPN1 + ALPNI1;
      ALPN2 := ALPN2 + ALPNI2;
      ALPN3 := ALPN3 + ALPNI3;
--
--CALCULATE DEL-ALPHN(SIGMA-GROUND)
      MSIG1 := DSGN1(FREQKC);
      MSIG2 := 2.0*MSIG1;
      MSIG3 := 3.0*MSIG1;
      ALPN1 := ALPN1 + MSIG1;
      ALPN2 := ALPN2 + MSIG2;
      ALPN3 := ALPN3 + MSIG3;
--
      Return;
--
      End ALNITE;
--
      Procedure VLF_HANDLER is
--
--#PURPOSE: VLF_HANDLER calculates the ambient signal level for a VLF
--          transmission link using mode analysis.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        TLAT         = Transmitter latitude in degrees north
--IN        TLON         = Transmitter longitude in degrees east
--IN        TALT         = Transmitter altitude in kilometers
--IN        RLAT         = Receiver latitude in degrees north
--IN        RLON         = Receiver longitude in degrees east
--IN        RALT         = Receiver altitude in kilometers
--IN        FREQKC       = Link frequency in Khz
--IN        TERP         = Transmitter radiated power in Kw
--OUT       SIGNAL       = Signal strength in dB above one micro(V)/m
--
--#CALLED BY:
--          RF_PROPAGATION_HANDLER
--
--#CALLS TO:
--          ALDAY
--          ALNITE
--          CLAMB
--          DNTR
--          GNDCON
--          GZN
--          VPDAY
--          VPNITE
--
--#TECHNICAL DESCRIPTION:
--    VLF_HANDLER is a master routine for performing waveguide mode calcula-
--    tions to determine received signal strengths for VLF links.  The
--    analytical approach is described in: Watt, 1967.
--
      MEZ1, MEZ2, MEZ3, MCONST, DIS, HION, XA: float;
      XD, XN, X21D, X31D, X21N, X31N: float;
      DPHI21 , DPHI31: float;
      AEZ1, AEZ2, AEZ3, AEZR, AEZJ, AEZ, EZ, COND: float;
      HIOND: float := 70.0;
      HIONN: float := 90.0;
      ITR: integer;
--
      Begin
--
--DETERMINE THE GROUND CONDUCTIVITY
      IPERM := 1;
      RFUTIL.GNDCON (RLAT, RLON, COND);
      If COND > 0.05 Then
         IPERM := 2;
      End If;
--
--DETERMINE THE PATH LENGTH THAT IS IN DAYLIGHT, AND THE PATH LENGTH THAT
--IS IN NITE, AND WHETHER THE TRANSMITTER AND RECEIVER ARE IN DAY OR NITE.
      RFUTIL.DNTR;
--
--CALCULATE TOTAL TRANSMITTER TO RECEIVER PATH LENGTH.
      DIS := DISDAY + DISNIT;
--
--CALCULATE CAP-LAMBDA, THE RELATIVE EXCITATION FACTOR
      CLAMB;
--
--CALCULATE GZN, THE HEIGHT GAIN FUNCTION FOR THE TRANSMITTER
      If IDNT = DAY Then
         HION := HIOND;
      Else
         HION := HIONN;
      End If;
      ITR := 1;
      GZN (TALT, HION, ITR);
--
--CALCULATE GZN, THE HEIGHT GAIN FUNCTION FOR THE RECEIVER
      If IDNR = DAY Then
         HION := HIOND;
      Else
         HION := HIONN;
      End If;
      ITR := 2;
      GZN (RALT, HION, ITR);
--
--CALCULATE ALPHAN, THE DISTANCE ATTENUATION RATE.
      If IDNT = DAY and IDNR = DAY Then
         ALDAY (TLAT, TLON, RLAT, RLON);
      ElsIf IDNT = NIGHT and IDNR = NIGHT Then
         ALNITE (TLAT, TLON, RLAT, RLON);
      ElsIf IDNT = DAY and IDNR = NIGHT Then
         ALDAY (TLAT, TLON, TERLAT, TERLON);
         ALNITE (TERLAT, TERLON, RLAT, RLON);
      ElsIf IDNT = NIGHT and IDNR = DAY Then
         ALDAY (TERLAT, TERLON, RLAT, RLON);
         ALNITE (TLAT, TLON, TERLAT, TERLON);
      End If;
--
--CALCULATE THE MODE PHASE VELOCITIES.
      If IDNT = NIGHT or IDNR = NIGHT Then
         VPNITE;
      End If;
      If IDNT = DAY or IDNR = DAY Then
         VPDAY;
      End If;
--
--CALCULATE THE MAGNITUDE OF THE FIELDS FOR EACH OF THE THREE MODES.
      XA := RADIUS_OF_EARTH_IN_KM*SIN(DIS/RADIUS_OF_EARTH_IN_KM);
      HION := SQRT(HIOND*HIONN);
      If IDNR = DAY and IDNT = DAY Then
         HION := HIOND;
      End If;
      If IDNR = NIGHT and IDNT = NIGHT Then
         HION := HIONN;
      End If;
      MCONST := 104.3 + 10.0*LOG10(TERP*1000.0) - 10.0*LOG10(FREQKC*1000.0)
                -20.0*LOG10(HION*1000.0) - 10.0*LOG10(XA*1000.0);
      MEZ1 := MCONST + MLA1 + MGZ1(1) + MGZ1(2) - ALPD1/1000.0*DISDAY -
              ALPN1/1000.0*DISNIT;
      MEZ2 := MCONST + MLA2 + MGZ2(1) + MGZ2(2) - ALPD2/1000.0*DISDAY -
              ALPN2/1000.0*DISNIT;
      MEZ3 := MCONST + MLA3 + MGZ3(1) + MGZ3(2) - ALPD3/1000.0*DISDAY -
              ALPN3/1000.0*DISNIT;
      If MEZ1 <= -400.0 Then
         MEZ1 := -400.0;
      End If;
      If MEZ2 <= -400.0 Then
         MEZ2 := -400.0;
      End If;
      If MEZ3 <= -400.0 Then
         MEZ3 := -400.0;
      End If;
--
--CALCULATE PHASE DIFFERENCE OF MODES 2 AND 3 RE MODE 1
      XD := TWOPI*FREQKC*DISDAY*1000.0;
      XN := TWOPI*FREQKC*DISNIT*1000.0;
      X21D := 0.0;
      X31D := 0.0;
      X21N := 0.0;
      X31N := 0.0;
      If VPD2*VPD1 > 1.0 Then
         X21D := XD*(VPD2 - VPD1)/VPD2/VPD1;
      End If;
      If VPD3*VPD1 > 1.0 Then
         X31D := XD*(VPD3 - VPD1)/VPD3/VPD1;
      End If;
      If VPN2*VPN1 > 1.0 Then
         X21N := XN*(VPN2 - VPN1)/VPN2/VPN1;
      End If;
      If VPN3*VPN1 > 1.0 Then
         X31N := XN*(VPN3 - VPN1)/VPN3/VPN1;
      End If;
      DPHI21 := X21D + X21N + ((PLA2 - PLA1) + (PGZ2(1) - PGZ1(1)) +
               (PGZ2(2) - PGZ1(2)))*RADIANS_PER_DEGREE;
      DPHI31 := X31D + X31N + ((PLA3 - PLA1) + (PGZ3(1) - PGZ1(1)) +
               (PGZ3(2) - PGZ1(2)))*RADIANS_PER_DEGREE;
--
--CALCULATE VERTICAL ELECTRIC FIELD AMPLITUDE
      AEZ1 := AMAX1(1.0E-20, 10.0**(MEZ1/20.0));
      AEZ2 := AMAX1(1.0E-20, 10.0**(MEZ2/20.0));
      AEZ3 := AMAX1(1.0E-20, 10.0**(MEZ3/20.0));
      AEZR := AEZ1 + AEZ2*COS(DPHI21) + AEZ3*COS(DPHI31);
      AEZJ := AEZ2*SIN(DPHI21) + AEZ3*SIN(DPHI31);
      IF ABS(AEZR) <= 1.0E-15 Then
         AEZR := 1.0E-15;
      End If;
      If ABS(AEZJ) <= 1.0E-15 Then
         AEZJ := 1.0E-15;
      End If;
      AEZ := AEZR*AEZR + AEZJ*AEZJ;
      AEZ := SQRT(AEZ);
      EZ := 20.0*LOG10(ABS(AEZ));
      SIGNAL := EZ + 120.0;
--
      Return;
--
      End VLF_HANDLER;
--
End VLF_PROPAGATION;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--ELFPROP
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Debugger2; Use Debugger2;
With Mathlib; Use Mathlib, Numeric_primitives, Trig_functions, Core_functions;
With Rfutil;
With NodeLoc;
With Elf_Lf_Hf_Atmospherics;
With Constants; Use Constants;
With Propagation_Constants; Use Propagation_Constants;

Package ELF_PROPAGATION is
--
--
      Procedure ELF_HANDLER;
--
End ELF_PROPAGATION;
--
Package body ELF_PROPAGATION is
--
-- ELF_PROPAGATION Package of PROP_LINK
-- Version 1.0,  June 26, 1985.
--
-- This ELF_PROPAGATION Package contains all of the procedures that
-- are used to perform ELF propagation prediction.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
      Pragma Source_info (on);
--
      Procedure ELFKS (JDN: in DAY_OR_NIGHT;
                       ALPHA: out float;
                       BETA: out float);
--
      Procedure ELF_HANDLER is
--
--#PURPOSE: ELF_HANDLER calculates the ELF signal strength of the vertical
--          E-Field at a receiver for ambient environments.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        CURRENT_TIME   = Time in seconds after scenario start
--IN        TLAT           = Transmitter lattitude in degrees north
--IN        TLON           = Transmitter longitude in degrees east
--IN        RLAT           = Receiver latitude in degrees north
--IN        RLON           = Receiver longitude in degrees east
--IN        FREQ           = Signal frequency (Hz)
--IN        TERP           = Transmitter I L product (current times length)
--                           in amp-meters
--OUT       SIGNAL         = Ambient signal strength of vertical E-
--                           Field at receiver dB/micro(V)/m
--#CALLED BY:
--          RF_PROPAGATION_HANDLER
--
--#CALLS TO:
--          DAYNIT
--          DNTR
--          ELFKS
--          LOCNEW
--          REFCAL
--
--#TECHNICAL DESCRIPTION:
--
--     Procedure ELF_HANDLER is the computation and control routine for ELF
--     electromagnetic propagation prediction. This routine calculates
--     the ELF signal strength of the vertical E-Field at a receiver for
--     both ambient environments.
--
--     The far-field vertical ELF field strength at the ocean
--     surface is considered to be adequately represented by:
--
--          IL                             ABS(SQRT(So))
--     Ev = --- x SQRT(PII x Uo / C) x F x --------------- x
--          2.0                            Hi x SQRT(Mhos)
--
--
--          EXP(-A x R) x SQRT(COS(Phi)/(Re x SIN(R/Re)))
--
--     Where:
--
--          Ev   = Vertical E-field in Volts/Meter
--          IL   = Current moment in Amp-Meters
--          PII  = 2 x PI := 6.283185308
--          Uo   = Permeability of free space, PI x 4E-7 Henries/Meter
--          C    = Speed of light, 3E+8 Meters/Second
--          F    = Signal frequency in Hertz
--          So   = Earth ionosphere wavequide propagation constant
--          Hi   = Effective height of ionosphere in Meters
--          Mhos = Effective ground conductivity in Mhos/Meter
--          A    = Normal attenuation rate in Nepers/Meter
--                  (from Procedure ELFKS)
--          R    = Great circle distance Xmtr-Rcvr in Meters
--          Re   = Earth radius (6,364,000 Meters)
--          Phi  = Azimuth angle
--
--     A factor which is not accounted for in this simple equation is the
--     interference of the wave propagating the long way around the earth
--     to the receiver. The relative strength of this component depends
--     on the difference in path lengths and the baud rate of the pseudo-
--     random modulation as well as the propagation conditions on the two
--     paths. The two signals may be combined as:
--
--          Et = Ef + (Er x K x COS(Pr - Pf))
--
--     Where:
--
--          Et   = Total combined signal in Volts/Meter
--          Ef   = Forward signal in Volts/Meter
--          Er   = Reverse signal in Volts/Meter
--          K    = Combining factor depending on autocorrelation
--                 function of MSK waveform
--               = (SIN(Ga x PI)/PI) + (1 - Ga) x COS(Ga x PI)
--          Ga   = BW x (40 - (2 x Rf))/600
--          PI   = 3.141592654
--          BW   = Bandwidth of signal in Hertz
--          Rf   = Path length of forward path in Meters
--          Pr   = Phase shift on reverse path in radians
--                 (from Procedure ELFKS)
--          Pf   = Phase shift on forward path in radians
--                 (from Procedure ELFKS)
--
      SRSO: array (DAY_OR_NIGHT range DAY..NIGHT) of float
      := (1.118034, 1.048809);
--
      COND: float := 3.0E-4;
      C: float := 2.998E8;
      XMUO: float := 1.255637E-6;
      XINC: float := 4000.0;
      DBONEP: float := 8.685889;
      PLFWD, PLBAK, HI, XCONST, ROMM, XNORMF, XNORMB, BPS, ALP, PHACTR: float;
      FINC, BINC, SUMATT, SUMBF, DEL, HAFDEL, EVPFWD, AFWD, BFWD: float;
      SUMATB, SUMBB, EVPBK, ABAK, BBAK, SIGTOT, EVPBAK: float;
      ALPHA, BETA, XLAT, XLON, HIT, HIR, DUM: float;
      IDN: Day_or_night;
      NFWD, NBAK, I: integer;
--
      Begin
--
--ZERO OUTPUT.
      SIGNAL := 0.0;
--
--CALCULATE THE FORWARD AND REVERSE PATH LENGTHS IN MEGAMETERS.
      PLFWD := DPATH * 0.001;
      PLBAK := 39.98619 - PLFWD;
--
--COMPUTE AMBIENT NORMALIZATIONS FOR PROPAGATION.
      ELF_LF_Hf_Atmospherics.REFCAL (TLAT, TLON, -CURRENT_TIME*60.0,
                                    FREQ*1.0E-3, HIT, DUM);
      ELF_LF_Hf_Atmospherics.REFCAL (RLAT, RLON, -CURRENT_TIME*60.0,
                                    FREQ*1.0E-3, HIR, DUM);
      HI := SQRT(HIT*HIR);
      RFUTIL.DAYNIT (IDN, TLON, TLON);
      XCONST := TERP*0.5*SQRT(2.0*PI*XMUO/C)*FREQ*SRSO(IDN)/
                (SQRT(COND*RADIUS_OF_EARTH_IN_KM*1.0E3)*HI*1.0E3);
      ROMM := RADIUS_OF_EARTH_IN_KM*1.0E-3;
      XNORMF := XCONST*SQRT(1.0/(ABS(SIN(PLFWD/ROMM))));
      XNORMB := XCONST*SQRT(1.0/(ABS(SIN(PLBAK/ROMM))));
--
--ASSUME THAT DATA RATE IS EQUAL TO THE BANDWIDTH.
      BPS := BW;
      ALP := BPS*(40.0 - 2.0*PLFWD)/600.0;
      PHACTR := SIN(ALP*PI)/PI + (1.0 - ALP)*COS(ALP*PI);
      If ABS(ALP) > 1.0 Then
         PHACTR := 0.0;
      End If;
--
--DIVIDE PATH INTO XINC INCREMENTS (AMBIENT INCREMENTS ARE 4000 KM.)
      NFWD := INTEGER(PLFWD*1.0E3/XINC) + 2;
      NBAK := INTEGER(PLBAK*1.0E3/XINC) + 2;
      FINC := PLFWD/FLOAT(NFWD - 1);
      BINC := PLBAK/FLOAT(NBAK - 1);
--
--BEGIN AMBIENT PROPAGATION CALCULATIONS, ONE INCREMENT AT A TIME.
--CALCULATE IONOSPHERIC PROFILES AT INCREMENT POINTS, ALPHA AND BETA.
      SUMATT := 0.0;
      SUMBF := 0.0;
      For I in 2..NFWD Loop
         DEL := FINC*FLOAT(I - 1)*1.0E3;
         HAFDEL := DEL*0.5;
         NODELOC.LOCNEW (TLAT, TLON, BRNG1, HAFDEL, XLAT, XLON);
         RFUTIL.DAYNIT (IDN, XLON, XLON);
         ELFKS (IDN, ALPHA, BETA);
         SUMATT := ALPHA*FINC + SUMATT;
         SUMBF := BETA*FINC + SUMBF;
      End Loop;
      EVPFWD := XNORMF*EXP(-AMIN1(50.0, SUMATT));
      AFWD   := SUMATT/PLFWD*DBONEP;
      BFWD   := 2.0E6*PI*FREQ*PLFWD/(C*SUMBF);
--
--NOW FOR THE REVERSE PATH
      SUMATB := 0.0;
      SUMBB := 0.0;
      For I in 2..NBAK Loop
         DEL := BINC*FLOAT(I - 1)*1.0E3;
         HAFDEL := DEL*0.5;
         NODELOC.LOCNEW (TLAT, TLON, BRNG2, HAFDEL, XLAT, XLON);
         RFUTIL.DAYNIT(IDN, XLON, XLON);
         ELFKS (IDN, ALPHA, BETA);
         SUMATB := ALPHA*BINC + SUMATB;
         SUMBB := BETA*BINC + SUMBB;
      End Loop;
      EVPBK := XNORMB*EXP(-AMIN1(50.0, SUMATB));
      ABAK := SUMATT/PLBAK*DBONEP;
      BBAK := 2.0E6*PI*FREQ*PLBAK/(C*SUMBB);
--
--COMBINE THE FORWARD AND REVERSE SIGNALS.
      SIGTOT := EVPFWD + EVPBK*PHACTR*COS(SUMBB - SUMBF);
--
--CONVERT TO DB/MICROVOLT/METER.
      SIGNAL := 20.0*LOG10(ABS(SIGTOT)) + 120.0;
--
      RETURN;
--
      End ELF_HANDLER;
--
--
      Procedure ELFKS (JDN: in DAY_OR_NIGHT;
                       ALPHA: out float;
                       BETA: out float) is
--
--#PURPOSE: ELFKS computes precalculated values of the complex
--          coefficient of propagation at ELF frequencies.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--IN        JDN    = Flag for day or night conditions (DAY or NIGHT)
--OUT       ALPHA  = Attenuation rate, Nepers/Megameter
--OUT       BETA   = Phase shift of the ELF signal.
--
--#CALLED BY:
--          ELF_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          Curve fits to data presented in  Fields,1968 are assessed
--          to compute the amplitude attenuation and the phase shift
--          of the ELF signal.
--
      AD0: array (integer range 1..3) of float
      :=(+4.023E+00, -2.290E+00, +3.824E-01);
      BD0: array (integer range 1..3) of float
      :=(+1.219E+00, +5.289E-02, -1.283E-02);
      AN0: array (integer range 1..3) of float
      :=(+3.234E+00, -1.804E+00, +3.311E-01);
      BN0: array (integer range 1..3) of float
      :=(+1.404E+00, -3.372E-02, -5.125E-03);
      X: float;
      DBONEP:float := 8.686;
      TOPIOC:float := 0.02097;
--
      Begin
--
      X := LOG(FREQ);
      If JDN = DAY Then
         ALPHA := AD0(1) + AD0(2)*X + AD0(3)*(X**2);
         BETA := BD0(1) + BD0(2)*X + BD0(3)*(X**2);
      Else
         ALPHA := AN0(1) + AN0(2)*X + AN0(3)*(X**2);
         BETA := BN0(1) + BN0(2)*X + BN0(3)*(X**2);
      End If;
--
       ALPHA := ALPHA/DBONEP;
       BETA := TOPIOC*FREQ*BETA;
--
      Return;
--
      End ELFKS;
--
--
End ELF_PROPAGATION;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--NOISE
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Debugger2; Use Debugger2;
With Mathlib; Use Mathlib, numeric_primitives, trig_functions, core_functions;
With Text_io; Use Text_io, Integer_io, Float_io;
With Types; Use Types;
With Constants; Use Constants;
With Propagation_Constants; Use Propagation_Constants;
With RFUtil; Use RFUtil;

Package NOISE is

      Procedure NOISE_HANDLER;
      ANA: array (integer range 1..1050) of float;
      FAM: array (integer range 1..14, integer range 1..12) of float;

End NOISE;

Package body NOISE is

-- NOISE Package of PROP_LINK
-- Version 1.0,  April 23, 1985.

-- This NOISE Package contains all of the procedures that
-- are used to compute atmospheric and man-made noise.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
      Pragma Source_info (on);
--
      Procedure VLF_LF_MF_HF_NOISE (T: in float) is
--
--#PURPOSE: VLF_LF_MF_HF_NOISE performs the ambient VLF/LF/MF/HF noise
--          calculations.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#PARAMETER DESCRIPTIONS:
--          T       = Local time in hours.
--
--#CALLED BY:
--          NOISE_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--    This routine calculates the maximum of atmospheric, galactic, and
--    man-made noise at a location for a given time, frequency, and type
--    of area at the location. Galactic noise is computed by:
--               NG = 165 + 9.555 ln (F/3)
--    where F is the wave frequency in MHz. Man-made noise is computed as
--               NM = XNO + BCO ln (F/3)
--    where XNO and BCO have the following frequency dependency:
--               F (MHz)        XNO       BCO
--               F < 10       -148.6    -12.768
--               F >= 10 and
--               F < 20       -167.5     -2.866
--               F <= 20      -142.2    -10.423
--    The values of atmospheric radio noise are taken from worldwide
--    1 MHz noise maps found in CCIR Report No. 322.  The numerical
--    coefficients, which represent the worldwide distribution of atmos-
--    pheric noise as a function of geographic location, were generated
--    by means of a least squares fit using Fourier analysis.  The
--    frequency dependence is computed using a power series least squares
--    fit.
--
      C: array (integer range 1..13) of float;
      S: array (integer range 1..13) of float;
      TL: array (integer range 1..27, integer range 1..5) of float;
      TIME: array (integer range 1..5) of float;
      XNOA: array (integer range 1..3) of float := (-148.6, -167.5, -142.2);
      BCOA: array (integer range 1..3) of float := (-12.768, -2.866, -10.423);
      IUNIT: FILE_TYPE;
      CLT, GMT, XLON, CLG, GSIN, GCOS, CLGS, QGCI, G, QANA, F, R: float;
      TX, ANOS, ATMNO, TM, ABCT, X, PZ, PX, CZ, ATNO, ATNX, F3LOG: float;
      GNOS, XNO, BCO, XNOISE, FREQMH: float;
      I, J, K, M, ICI, ITT, JL, JT, IT, NTB, NTX, ITIME, ITB, NFR: integer;
--
      Begin
--
      FREQMH := FREQ*1.0E-6;
--
--ATMOSPHERIC NOISE AT RECEIVER FOR 1 MHZ FREQ. ,WRECS XNOISE.
      CLT := RLAT*RADIANS_PER_DEGREE;
      GMT := T - RLON/15.0;
      If GMT < 0.0 Then
         GMT := GMT + 24.0;
      End If;
      If GMT > 24.0 Then
         GMT := GMT - 24.0;
      End If;
      NSEAS := (MONTH - 1)/3;
      If NSEAS <= 0 Then
         NSEAS := 4;
      End If;
      If NSEAS /= CURRENT_NOISE_SEASON Then
         Case NSEAS is
            when 1 => OPEN (IUNIT, in_file, "SPRING.DAT");
            when 2 => OPEN (IUNIT, in_file, "SUMMER.DAT");
            when 3 => OPEN (IUNIT, in_file, "FALL.DAT");
            when 4 => OPEN (IUNIT, in_file, "WINTER.DAT");
            when others => null;
         End case;
         SET_INPUT(IUNIT);
         For I in 1..1050 Loop
            Get (ANA(I), 11);
            If I rem 5 = 0 Then
               Skip_Line;
            End If;
         End Loop;
         For J in 1..12 Loop
            For I in 1..14 Loop
               Get (FAM(I,J), 11);
               If (14*(J-1)+I) rem 5 = 0 Then
                  Skip_Line;
               End If;
            End Loop;
         End Loop;
         Close (IUNIT);
         SET_INPUT(STANDARD_INPUT);
         CURRENT_NOISE_SEASON := NSEAS;
      End If;
--
      XLON := -RLON;
      CLG := (360.0 - XLON)*RADIANS_PER_DEGREE;
      GSIN := SIN(CLT);
      GCOS := COS(CLT);
      CLGS := CLG - RADIANS_PER_DEGREE*2.143;
      If CLGS < 0.0 Then
         CLGS := CLGS + TWOPI;
      End If;
      For K in 1..5 Loop
         QGCI := 1.0;
         For I in 1..21 Loop
            G := 0.0;
            M := I;
            If M mod 2 = 0 Then
               QGCI := QGCI*GCOS;
            End If;
            For J in 1..10 Loop
               ICI := I + 21*(10 - J + 10*(K - 1));
               QANA := ANA(ICI);
               If QANA /= 0.0 Then
                  If J /= 10 Then
                     G := (G + QANA)*GSIN;
                  End If;
               End If;
            End Loop;
            TL(I,K) := (G + QANA) * QGCI;
         End Loop;
      End Loop;
      C(1) := COS(CLGS);
      S(1) := SIN(CLGS);
      For M in 2..10 Loop
         C(M) := C(1)*C(M - 1) - S(1)*S(M - 1);
         S(M) := C(1)*S(M - 1) + S(1)*C(M - 1);
      End Loop;
      For ITT in 1..5 Loop
         F := TL(1,ITT);
         For JL in 1..10 Loop
            F := F + TL(2*JL,ITT)*S(JL) + TL(2*JL + 1,ITT)*C(JL);
         End Loop;
         TIME(ITT) := F;
      End Loop;
      IT := INTEGER(GMT);
      R := (15.0*GMT - 180.0)*RADIANS_PER_DEGREE;
      C(1) := COS(R);
      S(1) := SIN(R);
      C(2) := COS(R + R);
      S(2) := SIN(R + R);
      TX := TIME(1);
      For JT in 1..2 Loop
         TX := TX + TIME(2*JT)*S(JT) + TIME(2*JT + 1)*C(JT);
      End Loop;
      ANOS := TX;
      ATMNO := ANOS - 204.0;
      If ABS(FREQMH - 1.0) < 0.01 Then
         Goto GALACTIC_NOISE;
      End If;
--
--Routine GENFAM from WRECS.
      F := LOG10(FREQMH);
      NTB := Integer(T/4.0 + 1.0);
      If NTB > 6 Then
         NTB := 6;
      End If;
      TM := FLOAT(4*NTB - 2);
      ABCT := ABS(T - TM)/4.0;
      NTX := NTB - 1;
      If T > TM Then
         NTX := NTB + 1;
      End If;
      If NTX > 6 Then
         NTX := 1;
      End If;
      If NTX < 1 Then
         NTX := 6;
      End If;
      For ITIME in 1..2 Loop
         ITB := NTB;
         If ITIME = 2 Then
            ITB := NTX;
         End If;
         If RLAT < 0.0 Then
            ITB := ITB + 6;
         End If;
         X := -0.75;
         loop
            PZ := 0.0;
            PX := 0.0;
            For I in 1..7 Loop
               PZ := X*PZ + FAM(I,ITB);
               PX := X*PX + FAM(I+ 7,ITB);
            End Loop;
            If X /= -0.75 Then exit; end if;
            CZ := ANOS*(2.0 - PZ) - PX;
            X := (8.0*2.0**F - 11.0)/4.0;
         End loop;
         If ITIME = 1 Then
            ATNO := CZ*PZ + PX;
         End If;
         If ITIME = 2 Then
            ATNX := CZ*PZ + PX;
         End If;
      End Loop;
      ATMNO := (ATNO + (ATNX - ATNO)*ABCT) - 204.0;
--
<<GALACTIC_NOISE>>
      F3LOG := LOG(FREQMH/3.0);
      GNOS := -(165.0 + 9.555*F3LOG);
--
--MAN MADE NOISE.
      NFR := 1;
      If FREQMH > 10.0 Then
         NFR := 2;
      End If;
      If FREQMH >= 20.0 Then
         NFR := 3;
      End If;
      XNO := XNOA(NFR);
      BCO := BCOA(NFR);
      XNOISE := XNO + BCO*F3LOG;
      SIGNOS := AMAX1(ATMNO, AMAX1(GNOS, XNOISE));
      Return;
--
      End VLF_LF_MF_HF_NOISE;
--
--
      Procedure ELF_NOISE is
--
--#PURPOSE: ELF_NOISE computes the effective atmospheric noise levels,
--          on a world-wide basis, at ELF frequencies.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Numerical Analysis
--
--#CALLED BY:
--          NOISE_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          A limited amount of ELF wideband noise data has been
--          collected at Saipan, Malta, and Norway.  Based on these
--          three known noise levels and the fact that ELF noise is
--          predominantly generated by equatorial thunderstorms, three
--          equivalent equatorial ELF noise sources can be postulated
--          with appropriate power to yield these three known values
--          of noise.  It is this technique that has been employed
--          in ELF_NOISE to generate world-wide ELF noise.
--
--          A noise adjustment factor as a function of
--          frequency is also included in ELF_NOISE based on the data
--          presented in the "SANGUINE System Design Study (SSDS)"
--          (U), December 1970, (SRD).
--
      P1: constant float := 1.094475E3;
      P2: constant float := 2.783973E3;
      P3: constant float := 9.114757E2;
      FACTR, D1, D2, D3, DELF: float;
--
      Begin
--
--  FIRST CALCULATE THE EFFECTIVE NOISE AT 45 HZ. AS A FUNCTION OF
--  DISTANCE FROM EACH OF THE 3 ASSUMED EQUATORIAL NOISE SOURCES.
--
      FACTR := COS(RLAT*RADIANS_PER_DEGREE);
      D1 := RADIUS_OF_EARTH_IN_KM*ACOS(FACTR*
            COS(ABS(110.0 - RLON)*RADIANS_PER_DEGREE));
      D2 := RADIUS_OF_EARTH_IN_KM*ACOS(FACTR*
            COS(ABS(-60.0 - RLON)*RADIANS_PER_DEGREE));
      D3 := RADIUS_OF_EARTH_IN_KM*ACOS(FACTR*
            COS(ABS( 15.0 - RLON)*RADIANS_PER_DEGREE));
      D1 := AMAX1(D1, 1.0E-4);
      D2 := AMAX1(D2, 1.0E-4);
      D3 := AMAX1(D3, 1.0E-4);
--
      SIGNOS := P1/(D1*D1) + P2/(D2*D2) + P3/(D3*D3);
      SIGNOS := 20.0*LOG10(SIGNOS) + 120.0;
      SIGNOS := AMIN1(50.0, SIGNOS);
--
--NOW APPLY THE FREQUENCY ADJUSTMENT FACTOR AS PER SSDS FIG. 5-7
--
      DELF := FREQ - 45.0;
      SIGNOS := SIGNOS + DELF*2.666667E-2;
--
      Return;
--
      End ELF_NOISE;
--
      Procedure NOISE_HANDLER is
--
--#PURPOSE: NOISE_HANDLER computes the signal-strength of the background noise.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Handler subroutine.
--
--#CALLED BY:
--          RF_PROPAGATION_HANDLER
--
--#CALLS TO:
--          ELF_NOISE
--          VLF_LF_MF_HF_NOISE
--          ZENITH
--
--#TECHNICAL DESCRIPTION:
--          This is the handler routine for all of the atmospheric/
--          man-made noise models. The procedure employed is to first
--          determine the frequency and location of the receiver and
--          then to access the appropriate noise model.
--
      BOLTZ: constant float := -228.6;
      TIMSEC, FREQMH, HR, TREFSE, CHI, TOD: float;
      NITDAY: DAY_OR_NIGHT;
      NHR: integer;
--
      Begin
--
--SET VALUES OF TIME TO SECONDS AND FREQUENCY TO MEGAHERTZ
      TIMSEC := CURRENT_TIME*60.0;
      FREQMH := FREQ*1.0E-6;
--
--ELF NOISE HANDLER
      If FREQ < 3.0E3 Then
         ELF_NOISE;
         Return;
      End If;
--
-- VLF/LF/MF/HF NOISE HANDLER
      If FREQ < 3.0E7 Then
         HR := REFERENCE_TIME*0.01;
         NHR := INTEGER(HR);
         TREFSE := (REFERENCE_TIME - FLOAT(NHR)*40.0)*60.0;
         ZENITH (RLAT, RLON, CHI, TOD, NITDAY);
         VLF_LF_MF_HF_NOISE (TOD);
         If FREQ < 3.0E5 Then -- (VLF/LF units conversion)
            SIGNOS := SIGNOS + 20.0*LOG10(FREQ) - 11.5;
         End If;
         Return;
      End If;
--
--VHF/UHF/SHF/EHF NOISE HANDLER
--
--  IN AN AMBIENT ENVIRONMENT, THE NOISE IS CONTAINED IN THE G/T TERM
--  SO SET THE SIGNOS VALUE TO -G/T PLUS BOLTZMANNS CONSTANT.
      SIGNOS := BOLTZ - GOT;
      Return;
--
      End NOISE_HANDLER;
--
End NOISE;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--TRANSMIT
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Text_IO; use Text_io, float_io, integer_io;
With Entityuti; use Entityuti;
With Types; use Types;
With Constants; use Constants;
With Constant2; use Constant2;
With Constant3; use Constant3;
With Helps; Use Helps;
With Debugger; use Debugger;
Package TRANSMIT is
--
      Procedure TRANSMITTER_ADD (IXMT: in integer;
                                 IFLG: in out integer;
                                 IERR: out integer);
      Procedure TRANSMITTER_DATA (INUMBR: in integer;
                                  FREQ: in float;
                                  IFLG: in out integer;
                                  INOADD: out integer);
      Procedure TRANSMITTER_DISPLAY (IBUFF: in L_ARRAY;
                                     NV: in out integer);
      Procedure TRANSMITTER_FETCH (KNAME: out string;
                                   INAME: out long_integer;
                                   INUMBR: out integer;
                                   ISTOP: out integer);
      Procedure TRANSMITTER_FIND (INAME: in long_integer;
                                  INUMBR: out integer);
      Procedure TRANSMITTER_HANDLER;
      Procedure TRANSMITTER_HELP (IWHO: in integer);
      Procedure TRANSMITTER_REMOVE (IBUFF: in out L_ARRAY;
                                    NUMBR: in integer);
--
End TRANSMIT;
--
Package body TRANSMIT is
--
-- TRANSMIT Package of PROP_LINK Version 1.0, February 16, 1985
--
-- This TRANSMIT Package contains all of the procedures that manipulate
-- transmitter data.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
--
      Procedure TRANSMITTER_ADD (IXMT: in integer;
                                 IFLG: in out integer;
                                 IERR: out integer) is
--
--#PURPOSE: TRANSMITTER_ADD processes the addition of one or more transmitter
--          classes.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    I/O Processing
--
--#PARAMETER DESCRIPTIONS:
--IN        IXMT  = The position of the transmitter class to be added,
--                  if 0 on entry, then additions will be allowed
--                  until a = is entered.
--IO        IFLG  = Flag indicating,
--                   0...Addition
--                   1...Modify or Like
--OUT       IERR   = The error code where,
--                   0 means no errors encountered,
--                   1 means an attempt to add too many
--                     transmitter classes has been made.
--
--#CALLED BY:
--          NODE_HANDLER
--          TRANSMITTER_HANDLER
--
--#CALLS TO:
--          BLANK_CHECK
--          HELP_CHECK
--          INTEGER_TO_ALPHA
--          PARSE
--          TRANSMITTER_DATA
--
--#TECHNICAL DESCRIPTION:
--          TRANSMITTER_ADD processes the addition of transmitter classes as
--          well as the replacement of transmitter class data when the
--          modify command has been used.  Echo checking is used
--          so that the operator may inspect the current value for
--          each data element.  The "LIKE" command is also supported
--          so that a transmitter class may be specified as being like
--          some other previously described transmitter class.
--
      KNAME: string(1..6);
      INUMBR, INOADD: integer;
--
      Begin
--
--INITIALIZE.
      IERR := 0;
--
--GET TRANSMITTER CLASS FREQUENCY.
<<FREQUENCY>>
      New_line;
      Put("Frequency: ");
      Put(FREXMT(IXMT));
      Put(" Hz."); New_line;
      Get_line(INPUT_BUFFER, MAX);
--
--IF A <N>  ENTERED SET TRANSMITTER CLASS FREQUENCY TO ZERO AND BRANCH TO
--TRANSMITTER_DATA_CALL.
      If INPUT_BUFFER(1) = 'N' or INPUT_BUFFER(1) = 'n' Then
         NEW_TITLE_CHECK;
         XARRAY(1) := 0.0;
         Goto TRANSMITTER_DATA_CALL;
      End If;
--
--IF A <CR> ENTERED SAVE THIS DATA ELEMENT AS IS AND GET NEXT ONE.
      XARRAY(1) := FREXMT(IXMT);
      If BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
         Goto TRANSMITTER_DATA_CALL;
      End If;
--
--IF A = ENTERED TERMINATE WITH ALL VALUES AS THEY ARE RIGHT NOW.
      If INPUT_BUFFER(1) = '=' Then
         New_line;
         Put("No transmitter data was added or changed in this ");
         Put("transmitter class");
         IERR := 1;
         Return;
      End If;
--
--IF AN <H> ENTERED THEN PRINT A HELP MESSAGE AND RE-PROMPT.
      If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
         TRANSMITTER_HELP (1);
         Goto FREQUENCY;
      End If;
--
--IF A <L> ENTERED THEN THIS TRANSMITTER CLASS IS LIKE SOME OTHER,
--NOW GET THE OTHER TRANSMITTER CLASS FOR THIS ASSIGNMENT.
      If INPUT_BUFFER(1) = 'L' or INPUT_BUFFER(1) = 'l' Then
         IFLG := 1;
<<LIKE>>
         New_line;
         Put("Which transmitter class? ");
         Get_line(INPUT_BUFFER, MAX);
         If INPUT_BUFFER(1) = '=' Then
            New_line;
            Put("No transmitter data was added or changed in this ");
            Put("transmitter class");
            IERR := 1;
            Return;
         End If;
         If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
            TRANSMITTER_HELP(2);
            Goto LIKE;
         End If;
         NUMBER_OF_VARIABLES_TO_EXTRACT := -1;
         PARSE (INPUT_BUFFER(1..MAX));
         If NUMBER_OF_VARIABLES_EXTRACTED /= 1 Then
            Goto LIKE;
         End If;
         TRANSMITTER_FIND(IARRAY(1), INUMBR);
         If INUMBR <= 0 Then
            INTEGER_TO_ALPHA (IARRAY(1), KNAME);
            New_line;
            Put("Transmitter class ");
            Put(KNAME);
            Put(" was not found.");
            Goto LIKE;
         End If;
         NEW_TITLE_CHECK;
         ITPXMT(IXMT) := ITPXMT(INUMBR);
         IATXMT(IXMT) := IATXMT(INUMBR);
         FREXMT(IXMT) := FREXMT(INUMBR);
         TRPXMT(IXMT) := TRPXMT(INUMBR);
         ANTGNX(IXMT) := ANTGNX(INUMBR);
         ANTHTX(IXMT) := ANTHTX(INUMBR);
         ANTLNX(IXMT) := ANTLNX(INUMBR);
         ANTTAX(IXMT) := ANTTAX(INUMBR);
         Goto FREQUENCY;
      End If;
--
      NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
      PARSE(INPUT_BUFFER(1..MAX));
--
<<TRANSMITTER_DATA_CALL>>
      If XARRAY(1) > 3.0E+11 Then
         New_line;
         Put(XARRAY(1));
         Put(" is not an acceptable frequency.");
         Goto FREQUENCY;
      End If;
--
      If FREXMT(IXMT) /= XARRAY(1) Then
         NEW_TITLE_CHECK;
      End If;
--
      FREXMT(IXMT) := XARRAY(1);
      TRANSMITTER_DATA(IXMT, FREXMT(IXMT), IFLG, INOADD);
      If IFLG = 1 Then
         Return;
      End If;
      If INOADD /= 0 Then
         New_line;
         Put("No transmitter data was added or changed in this ");
         Put("transmitter class");
         IERR := 1;
         Return;
      End If;
--
      Return;
--
      End TRANSMITTER_ADD;
--
--
      Procedure TRANSMITTER_DATA (INUMBR: in integer;
                                  FREQ: in float;
                                  IFLG: in out integer;
                                  INOADD: out integer) is
--
--#PURPOSE: TRANSMITTER_DATA is responsible for accepting and checking any
--          data entered for a given transmitter class.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    I/O Processing
--
--#PARAMETER DESCRIPTIONS:
--IN        INUMBR = The index number of the transmitter class being
--                   added.
--IN        FREQ   = The frequency of the transmitter class.
--IO        IFLG   = Flag indicating,
--                   0...Addition
--                   1...Modify or like
--OUT       INOADD = The stop flag where,
--                      0 means that all additions were
--                        normal,
--                      1 means that an addition was terminated
--                        before completion.
--
--#CALLED BY:
--          TRANSMITTER_ADD
--
--#CALLS TO:
--          ANTENNA_CHECK
--          BLANK_CHECK
--          HELP_CHECK
--          PARSE
--          TRANSMITTER_HELP
--
--#TECHNICAL DESCRIPTION:
--          TRANSMITTER_DATA is responsible for accepting and checking any
--          data entered for a given transmitter class.  Straightforward
--          branching on transmitter class type and comparison testing
--          is employed to select only the data that is appropriate
--          for each type of transmitter class.
--
      I: integer;
      LCTYP: BAND_TYPES;
      IATYP: integer;
      TRP: float;
      GNX: float;
      HTX: float;
      LNX: float;
      TAX: float;
      IERR: integer;
--
      Begin
--
--INITIALIZE.
      INOADD := 0;
      LCTYP := ITPXMT(INUMBR);
      IATYP := IATXMT(INUMBR);
      TRP   := TRPXMT(INUMBR);
      GNX   := ANTGNX(INUMBR);
      HTX   := ANTHTX(INUMBR);
      LNX   := ANTLNX(INUMBR);
      TAX   := ANTTAX(INUMBR);
--
--ASSIGN TRANSMITTER CLASS TYPE.
      If FREQ < 3.0 Then
         LCTYP := HARD_WIRED;
         New_line;
         Put("HARD_WIRED type of link assigned to transmitter.");
         Goto ACCEPT_DATA;
      End If;
      If FREQ <= 3.0E+03 Then
         LCTYP := ELF;
      Elsif FREQ > 3.0E+03 and FREQ <= 3.0E+04 Then
         LCTYP := VLF;
      Elsif FREQ > 3.0E+04 and FREQ <= 3.0E+05 Then
         LCTYP := LF;
      Elsif FREQ > 3.0E+05 and FREQ <= 3.0E+06 Then
         LCTYP := MF;
      Elsif FREQ > 3.0E+06 and FREQ <= 3.0E+07 Then
         LCTYP := HF;
      Elsif FREQ > 3.0E+07 and FREQ <= 3.0E+08 Then
         LCTYP := VHF;
      Elsif FREQ > 3.0E+08 and FREQ <= 3.0E+09 Then
         LCTYP := UHF;
      Elsif FREQ > 3.0E+09 and FREQ <= 3.0E+10 Then
         LCTYP := SHF;
      Elsif FREQ > 3.0E+10 and FREQ <= 3.0E+11 Then
         LCTYP := EHF;
      End If;
      New_line;
      Put(Band_types'image(LCTYP));
      Put(" frequency class assigned.");
--
<<TRANSMITTER_POWER>>
      New_line;
      Put("Transmitter power: ");
      Put(TRP);
      Case LCTYP is
         When ELF => Put(" Amp-Meters"); New_line;
         When VLF|LF => Put(" kW"); New_line;
         When Others => Put(" dBW"); New_line;
      End Case;
      Get_line(INPUT_BUFFER, MAX);
      If INPUT_BUFFER(1) = '=' Then
         Goto FLAG_CHECK;
      End If;
      If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
         TRANSMITTER_HELP(6);
         Goto TRANSMITTER_POWER;
      End If;
      If not BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
         NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
         PARSE(INPUT_BUFFER(1..MAX));
         If NUMBER_OF_VARIABLES_EXTRACTED /= 1 Then
            Goto TRANSMITTER_POWER;
         End If;
         NEW_TITLE_CHECK;
         TRP := XARRAY(1);
      End If;
--
<<ANTENNA_TYPE>>
      If LCTYP = HARD_WIRED or LCTYP = ELF or LCTYP = VLF Then
         IATYP := 0;
      Else
         If IATYP=0 then        -- Set some default antenna types
            If LCTYP = LF Then
               IATYP := 1;
            Elsif LCTYP in MF..HF Then
               IATYP := 5;
            Elsif LCTYP in VHF..EHF Then
               IATYP := 3;
            End if;
         End If;
         New_line;
         Put(Band_types'image(LCTYP));
         Put(" Antenna type: ");
         Put(IATYP); New_line;
         Get_line(INPUT_BUFFER, MAX);
         If INPUT_BUFFER(1) = '=' Then
            Goto FLAG_CHECK;
         End If;
         If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
            TRANSMITTER_HELP(7);
            Goto ANTENNA_TYPE;
         End If;
         If not BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
            NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
            PARSE(INPUT_BUFFER(1..MAX));
            If NUMBER_OF_VARIABLES_EXTRACTED /= 1 or XARRAY(1) < 1.0 or
               XARRAY(1) > 8.0 Then
               Goto ANTENNA_TYPE;
            End If;
            NEW_TITLE_CHECK;
            IATYP := INTEGER(XARRAY(1));
         End If;
         ANTENNA_CHECK (IATYP, LCTYP, GNX, HTX, LNX, TAX, IERR);
         If IERR > 1 Then
            Goto ANTENNA_TYPE;
         End If;
         If IERR = 1 Then
            Goto FLAG_CHECK;
         End If;
      End If;
--
<<ACCEPT_DATA>>
      ITPXMT(INUMBR) := LCTYP;
      IATXMT(INUMBR) := IATYP;
      FREXMT(INUMBR) := FREQ;
      TRPXMT(INUMBR) := TRP;
      ANTGNX(INUMBR) := GNX;
      ANTHTX(INUMBR) := HTX;
      ANTLNX(INUMBR) := LNX;
      ANTTAX(INUMBR) := TAX;
      Return;
--
<<FLAG_CHECK>>
      If IFLG /= 1 Then
         INOADD := 1;
      End If;
      Return;
--
      End TRANSMITTER_DATA;
--
--
      Procedure TRANSMITTER_DISPLAY (IBUFF: in L_ARRAY;
                                     NV: in out integer) is
--
--#PURPOSE: TRANSMITTER_DISPLAY displays the requested transmitter classes to
--          either the printer or the terminal depending on the value of
--          CURRENT_COMMAND.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Output module
--
--#PARAMETER DESCRIPTIONS:
--IN        IBUFF  = The array containing the transmitter class numbers to
--                   be displayed.
--IN        NV     = The number of elements in IBUFF.
--
--#CALLED BY:
--          TRANSMITTER_HANDLER
--
--#CALLS TO:
--          INTEGER_TO_ALPHA
--          TRANSMITTER_FIND
--
--#TECHNICAL DESCRIPTION:
--          TRANSMITTER_DISPLAY displays only the transmitter classes listed
--          in IBUFF as long as NV is not 0 on entry.  When NV is 0 this
--          signals that all transmitters should be displayed, therefore if
--          many transmitters exist, and the specified device is the terminal,
--          this can cause data to scroll off the screen.
--
--
      ICOMPL: boolean;
      I,INUM: integer;
      KNREC: string(1..6);
--
      Begin
--
--
--SET THE OUTPUT DEVICE.
      If CURRENT_COMMAND = PRINT Then
         SET_OUTPUT(PRINTER_OUTPUT_FILE);
      End If;
--
--GET THE NUMBER OF TRANSMITTER CLASSES TO DISPLAY AND THE DEVICE NUMBER.
      ICOMPL := FALSE;
      If NV = 0 or NV = NUMXMT Then
         ICOMPL := TRUE;
      End If;
--
--PRINT OUT REPORT HEADER.
      If ICOMPL Then
         New_line;
         Put(TITLE);
         New_line;New_line;
         Put("                    TRANSMITTER SUMMARY");
         New_line;
         Put("               There are currently ");
         Put(NUMXMT);
         Put(" transmitter classes");
         New_line;
         NV := NUMXMT;
      End If;
--
--LOOP ON NUMBER OF TRANSMITTER CLASSES TO PRINT.
      If NV < 1 Then
         Return;
      End If;
      For I in 1..NV Loop
         If I /= 1 Then
            Put("====================================");
            Put("====================================");
         End If;
         TRANSMITTER_FIND(IBUFF(I), INUM);
         If INUM < 1 Then
            --RESET THE OUTPUT DEVICE.
            If CURRENT_COMMAND = PRINT Then
               SET_OUTPUT(STANDARD_OUTPUT);
            End If;
            INTEGER_TO_ALPHA (IBUFF(I), KNREC);
            New_line;
            Put("Transmitter class ");
            Put(KNREC);
            Put(" does not yet exist.");
            --SET THE OUTPUT DEVICE.
            If CURRENT_COMMAND = PRINT Then
               SET_OUTPUT(PRINTER_OUTPUT_FILE);
            End If;
            Goto END_OF_LOOP;
         End If;
         INTEGER_TO_ALPHA(NAMXMT(INUM), KNREC);
         If ITPXMT(INUM) = HARD_WIRED Then
            New_line;
            Put("Transmitter ");
            Put(KNREC);
            Put(" is a HARD_WIRED class.");
            Goto END_OF_LOOP;
         End If;
         New_line;
         Put("Transmitter name.........");
         Put(KNREC);
         Put("          Frequency class...");
         Put(band_types'image(ITPXMT(INUM)));
         New_line;
         Put("Frequency (Hz)..........");
         Put(FREXMT(INUM),2,5,3);
         Put("     Power.............");
         Put(TRPXMT(INUM),2,5,3);
         Case ITPXMT(INUM) is
            When ELF => Put(" Amp-Meters");
            When VLF|LF => Put(" kW");
            When Others => Put(" dBW");
         End Case;
         New_line;
         If ITPXMT(INUM) > VLF Then
            New_line;
            Put("Antenna type..........");
            If IATXMT(INUM) = 1 Then
               Put("Loop");
            Elsif IATXMT(INUM) = 2 Then
               Put("Whip");
            Elsif IATXMT(INUM) = 3 Then
               Put("Dish with tapered side lobe");
            Elsif IATXMT(INUM) = 4 Then
               Put("Dish with constant side lobe");
            Elsif IATXMT(INUM) = 5 Then
               Put("Constant gain");
            Elsif IATXMT(INUM) = 6 Then
               Put("Rhombic");
            Elsif IATXMT(INUM) = 7 Then
               Put("Vertical");
            Elsif IATXMT(INUM) = 8 Then
               Put("Horizontal half-wave dipole");
            End If;
         End If;
         If IATXMT(INUM) = 5 Then
            New_line;
            Put("Antenna gain (dB).....");
            Put(ANTGNX(INUM),2,5,3);
         Elsif IATXMT(INUM) = 6 Then
            New_line;
            Put("Ant tilt angle (deg)..");
            Put(ANTTAX(INUM),2,1,0);
            New_line;
            Put("Antenna height (m)....");
            Put(ANTHTX(INUM),2,5,3);
            New_line;
            Put("Ant leg length (m)....");
            Put(ANTLNX(INUM),2,5,3);
         Elsif IATXMT(INUM) = 7 Then
            New_line;
            Put("Ant leg length (m)....");
            Put(ANTLNX(INUM),2,5,3);
         Elsif IATXMT(INUM) = 8 Then
            New_line;
            Put("Antenna height (m)....");
            Put(ANTHTX(INUM),2,5,3);
         End If;
<<END_OF_LOOP>>
         Null;
         New_line;
      End Loop;
--
--RESET THE OUTPUT DEVICE.
      If CURRENT_COMMAND = PRINT Then
         SET_OUTPUT(STANDARD_OUTPUT);
      End If;
--
      Return;
--
      End TRANSMITTER_DISPLAY;
--
--
      Procedure TRANSMITTER_FETCH (KNAME: out string;
                                   INAME: out long_integer;
                                   INUMBR: out integer;
                                   ISTOP: out integer) is
--
--#PURPOSE: TRANSMITTER_FETCH obtains a transmitter class from the
--          transmitter data structure.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Table Look-up
--
--#PARAMETER DESCRIPTIONS:
--OUT       KNAME  = The transmitter class name string.
--OUT       INAME  = The coded transmitter class name.
--OUT       INUMBR = The location of INAME in the transmitter
--                   data structure.
--                   A value of zero (0) is returned if INAME
--                   cannot be located.
--OUT       ISTOP  = Flag to tell if = is encountered
--                   0...No = encountered
--                   1...A terminator = was encountered
--
--#CALLED BY:
--          TRANSMITTER_HANDLER
--
--#CALLS TO:
--          BLANK_CHECK
--          INTEGER_TO_ALPHA
--          PARSE
--          TRANSMITTER_FIND
--
--#TECHNICAL DESCRIPTION:
--          TRANSMITTER_FETCH queries the operator for a transmitter class
--          name then does a table lookup in the transmitter data structure
--          for the specified transmitter class.  When the transmitter class
--          is located, its position in the structure is returned in the
--          variable INUMBR.  If the transmitter cannot be located, a value
--          of zero is returned in INUMBR.
--
      Begin
--
      ISTOP := 0;
--
<<GET_TRANSMITTER_CLASS_NAME>>
      New_line;
      Put("Enter the transmitter class name: ");
      Get_line(INPUT_BUFFER, MAX);
      KNAME := INPUT_BUFFER(1..6);
      If BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
         Goto GET_TRANSMITTER_CLASS_NAME;
      End If;
      If INPUT_BUFFER(1) = '=' Then
         ISTOP := 1;
         Return;
      End If;
      NUMBER_OF_VARIABLES_TO_EXTRACT := -1;
      PARSE (INPUT_BUFFER(1..MAX));
      If NUMBER_OF_VARIABLES_EXTRACTED /= 1 Then
         Goto GET_TRANSMITTER_CLASS_NAME;
      End If;
      INAME:=IARRAY(1);
      INTEGER_TO_ALPHA(IARRAY(1), KNAME);
      TRANSMITTER_FIND (IARRAY(1), INUMBR);
--
      Return;
--
      End TRANSMITTER_FETCH;
--
--
      Procedure TRANSMITTER_FIND (INAME: in long_integer;
                                  INUMBR: out integer) is
--
--#PURPOSE: TRANSMITTER_FIND locates a transmitter class in the transmitter
--          data structure.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Table Look-up
--
--#PARAMETER DESCRIPTIONS:
--IN        INAME  = The coded transmitter class name.
--OUT       INUMBR = The location of INAME in the transmitter data structure.
--                   A value of zero (0) is returned if INAME cannot be
--                   located.
--
--#CALLED BY:
--          TRANSMITTER_HANDLER
--          TRANSMITTER_ADD
--          TRANSMITTER_DISPLAY
--          TRANSMITTER_FETCH
--          TRANSMITTER_REMOVE
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          TRANSMITTER_FIND does a table lookup in the transmitter data
--          structure the specified transmitter class.  When the transmitter
--          class is located, its position in the structure is returned in
--          the variable INUMBR.  If the transmitter class cannot be located,
--          a value of zero is returned in INUMBR.
--
      KNAME: string(1..6);
      I: integer;
--
      Begin
--
      INUMBR := 0;
      If NUMXMT < 1 Then
         Return;
      End If;
--
--SEARCH THE DATA STRUCTURE FOR THE TRANSMITTER CLASS.
      For I in 1..NUMXMT Loop
         If INAME = NAMXMT(I) Then
            INUMBR := I;
            Return;
         End If;
      End Loop;
      Return;
--
      End TRANSMITTER_FIND;
--
--
      Procedure TRANSMITTER_HANDLER is
--
--#PURPOSE: TRANSMITTER_HANDLER drives the transmitter class processing
--          routines.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    I/O PROCESSING
--
--#PARAMETER DESCRIPTIONS:
--          'NONE'
--
--#CALLED BY:
--          MAIN
--          PRINT_HANDLER
--
--#CALLS TO:
--          BLANK_CHECK
--          INTEGER_TO_ALPHA
--          PARSE
--          TRANSMITTER_ADD
--          TRANSMITTER_DISPLAY
--          TRANSMITTER_FETCH
--          TRANSMITTER_FIND
--          TRANSMITTER_REMOVE
--
--#TECHNICAL DESCRIPTION:
--          TRANSMITTER_HANDLER serves as the driver for the routines which
--          add, delete, and modify transmitter classes.  Trickle down logic
--          is used to select the desired command.
--
      INAME: L_ARRAY(1..MAXRNT);
      IFLG,NV,I,K: integer;
      KNAME:string(1..6);
      JNAME: long_integer;
      JNUMBR, ISTOP, IERR, INUMBR: integer;
--
      Begin
--
--INITIALIZE.
      IFLG := 0;
      NV := 0;
--
      Case CURRENT_COMMAND is
      When ADD =>
<<ADD_TRANSMITTER>>
         TRANSMITTER_FETCH (KNAME, JNAME, JNUMBR, ISTOP);
         If ISTOP = 1 Then
            Return;
         End If;
         If JNUMBR >= 1 Then
            New_line;
            Put("Transmitter class ");
            Put(KNAME);
            Put(" already exists.");
            Goto ADD_TRANSMITTER;
         End If;
         If NUMXMT >= MAXRNT Then
            New_line;
            Put("No more transmitter classes may be added.");
            Put("  Redimension transmitter arrays.");
            Return;
         End If;
         NUMXMT := NUMXMT + 1;
         JNUMBR := NUMXMT;
         NAMXMT (JNUMBR) := JNAME;
         ITPXMT (JNUMBR) := ELF;
         IATXMT (JNUMBR) := 0;
         FREXMT (JNUMBR) := 3.0;
         TRPXMT (JNUMBR) := 0.0;
         ANTGNX (JNUMBR) := 0.0;
         ANTHTX (JNUMBR) := 0.0;
         ANTLNX (JNUMBR) := 0.0;
         ANTTAX (JNUMBR) := 0.0;
         TRANSMITTER_ADD (JNUMBR, IFLG, IERR);
         If IERR = 0 Then
            Goto ADD_TRANSMITTER;
         End If;
--
--TRANSMITTER CLASS ADDITION WAS TERMINATED.
         NUMXMT := NUMXMT - 1;
         Return;
--
--PROCESS THE VIEW OR PRINT COMMANDS.
      When VIEW | PRINT =>
         NV := NUMXMT;
         If NV >= 1 Then
            For K in 1..NUMXMT Loop
               INAME(K) := NAMXMT(K);
            End Loop;
            If not BLANK_CHECK(ARGUMENT_BUFFER) Then
               NUMBER_OF_VARIABLES_TO_EXTRACT := -40;
               PARSE(ARGUMENT_BUFFER);
               NV := NUMBER_OF_VARIABLES_EXTRACTED;
               For K in 1..NV Loop
                  INAME(K) := IARRAY(K);
               End Loop;
            End If;
         End If;
         TRANSMITTER_DISPLAY (INAME, NV);
         Return;
--
--PROCESS THE DELETION COMMAND.
      When DEL =>
         Loop
            Exit When not BLANK_CHECK(ARGUMENT_BUFFER);
            New_line;
            Put("Enter the transmitter class names to be deleted,");
            Put(" separated by spaces.");
            New_line;
            Get_line(ARGUMENT_BUFFER, MAX);
         End Loop;
         If ARGUMENT_BUFFER(1) = '=' Then
            Return;
         End If;
         NUMBER_OF_VARIABLES_TO_EXTRACT := -40;
         PARSE(ARGUMENT_BUFFER);
         NV := NUMBER_OF_VARIABLES_EXTRACTED;
         If NV <= 0 Then
            NV := 1;
         End If;
         TRANSMITTER_REMOVE(IARRAY, NV);
         Return;
--
--PROCESS THE MODIFY COMMAND.
      When MODIFY =>
         IFLG := 1;
         Loop
            Exit When not BLANK_CHECK(ARGUMENT_BUFFER);
            New_line;
            Put("Enter the name of the transmitter class to be modified: ");
            Get_line(ARGUMENT_BUFFER, MAX);
         End Loop;
         If ARGUMENT_BUFFER(1) = '=' Then
            Return;
         End If;
         NUMBER_OF_VARIABLES_TO_EXTRACT := -1;
         PARSE(ARGUMENT_BUFFER);
         If NUMBER_OF_VARIABLES_EXTRACTED > 0 Then
            TRANSMITTER_FIND (IARRAY(1), INUMBR);
            INTEGER_TO_ALPHA (IARRAY(1), KNAME);
            If INUMBR <= 0 Then
               New_line;
               Put("Transmitter class name ");
               Put(KNAME);
               Put(" does not exist.");
               Return;
            End If;
            TRANSMITTER_ADD (INUMBR, IFLG, IERR);
         End If;
--
--ILLEGAL COMMAND WARNING.
      When others =>
         New_line;
         Put("The command code is not valid for transmitter class processing.");
         Return;
      End case;
--
      End TRANSMITTER_HANDLER;
--
--
      Procedure TRANSMITTER_HELP (IWHO: in integer) is
--
--#PURPOSE: TRANSMITTER_HELP prints the various help messages as requested
--          by the operator for the different levels of transmitter class
--          processing.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Operator assistance
--
--#PARAMETER DESCRIPTIONS:
--IN        IWHO   := The indicator flag for which help message to print.
--
--#CALLED BY:
--          TRANSMITTER_ADD
--          TRANSMITTER_DATA
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          TRANSMITTER_HELP prints the various help messages as requested
--          by the operator for the different levels of transmitter class
--          processing.  The value of IWHO determines the message to
--          display.
--
      Begin
--
--SELECT THE HELP MESSAGE TO DISPLAY.
      If IWHO = 1 Then
         New_line;
         Put("At this point you can enter the frequency in Hz of the ");
         Put("transmitter. The range");
         New_line;
         Put("of frequency is from 3Hz to 3.0E+11 Hz.  If the transmitter ");
         Put("frequency that was");
         New_line;
         Put("just echoed is satisfactory, then simply enter a carriage");
         Put("return.  You may also");
         New_line;
         Put("enter  L  or  LIKE  to set this transmitter up exactly like ");
         Put("some other transmitter.");
         New_line;
         Put("Finally, you may enter  N  or  NONE  to signify that a ");
         Put("HARD_WIRED link is");
         New_line;
         Put("desired.");
         New_line;
         Put("An = (equal sign) terminates the addition of this transmitter ");
         Put("with the current");
         New_line;
         Put("information to this point and the transmitter lost, unless ");
         Put("this addition is");
         New_line;
         Put("-like- some other transmitter, then it is saved.");
         New_line;
         Return;
      End If;
--
      If IWHO = 2 Then
         New_line;
         Put("Since you have specified that this transmitter should be ");
         Put("like some other");
         New_line;
         Put("transmitter, you must now enter the name of the transmitter ");
         Put("that has already");
         New_line;
         Put("been entered which has the data that should be used to define ");
         Put("this transmitter.");
         New_line;
         Put("If you made a mistake and don't want this feature, then enter ");
         Put("an = to take you");
         New_line;
         Put("back to the executive for another command.");
         New_line;
         Return;
      End If;
--
      If IWHO = 3 Then
         New_line;
         Put("Enter a class name (maximum of 6 characters). ");
         New_line;
         Put("An = (equal sign) terminates the addition of this transmitter ");
         Put("with the current");
         New_line;
         Put("information to this point and the transmitter lost, unless ");
         Put("this addition is");
         New_line;
         Put("-like- some other transmitter, then it is saved.");
         New_line;
         Return;
      End If;
--
      If IWHO = 6 Then
         New_line;
         Put("If the transmitter radiating power just echoed is ");
         Put("satisfactory then enter a");
         New_line;
         Put("carriage return.  Otherwise, enter the transmitter ");
         Put("radiating power.");
         New_line;
         Put("The units are Amp-Meters for ELF, kW for VLF or LF, or");
         Put("dBW for all");
         New_line;
         Put("other frequency classes.");
         New_line;
         Put("An = (equal sign) terminates the addition of this transmitter ");
         Put("with the current");
         New_line;
         Put("information to this point and the transmitter lost, unless ");
         Put("this addition is");
         New_line;
         Put("-like- some other transmitter, then it is saved.");
         New_line;
         Return;
      End If;
--
      If IWHO = 7 Then
         New_line;
         Put("If the antenna type just echoed is satisfactory then enter ");
         Put("a carriage return.");
         New_line;
         Put("Otherwise, enter the value of the transmitter antenna type.  ");
         Put("The value must be:");
         New_line;
         Put("   1 - loop type (LF only);");
         New_line;
         Put("   2 - whip type (LF only);");
         New_line;
         Put("   3 - dish with tapered side lobe (VHF and above only);");
         New_line;
         Put("   4 - dish with constant side lobe (VHF and above only);");
         New_line;
         Put("   5 - constant gain (MF and HF only);");
         New_line;
         Put("   6 - rhombic (MF and HF only);");
         New_line;
         Put("   7 - vertical (MF and HF only); or,");
         New_line;
         Put("   8 - horizontal half-wave dipole (MF and HF only).");
         New_line;
         Put("An = (equal sign) terminates the addition of this transmitter ");
         Put("with the current");
         New_line;
         Put("information to this point and the transmitter lost, unless ");
         Put("this addition is");
         New_line;
         Put("-like- some other transmitter, then it is saved.");
         New_line;
         Return;
      End If;
--
      End TRANSMITTER_HELP;
--
--
      Procedure TRANSMITTER_REMOVE (IBUFF: in out L_ARRAY;
                                    NUMBR: in integer) is
--
--#PURPOSE: TRANSMITTER_REMOVE removes a specified transmitter class from the
--          data base.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    I/O Processing
--
--#PARAMETER DESCRIPTIONS:
--IN        IBUFF  = The array containing the transmitter class names
--                   to be deleted.
--IN        NUMBR  = The number of transmitter class names in IBUFF.
--
--#CALLED BY:
--          TRANSMITTER_HANDLER
--
--#CALLS TO:
--          INTEGER_TO_ALPHA
--          TRANSMITTER_FIND
--
--#TECHNICAL DESCRIPTION:
--          TRANSMITTER_REMOVE removes a specified transmitter class from the
--          data base.  Before a transmitter class is removed, a check
--          is first made to be sure that some node does not use
--          the transmitter class.  If such a node is found, a message
--          indicating the problem is issued to the operator.  If
--          no node conflict is found, the transmitter class is effectively
--          removed by shifting each transmitter class with an index value
--          higher than the one being removed down by one.
--
      KNAM: string(1..6);
      KNAME2: string(1..6);
      I,J,L,N: integer;
      JNUM: integer;
--
      Begin
--
--CHECK IBUFF FOR USE AT A NODE.
      If NUMNOD > 0 Then
         For I in 1..NUMNOD Loop
            If NXSND(I) > 0 Then
               For J in 1..NXSND(I) Loop
                  For L in 1..NUMBR Loop
                     If IBUFF(L) /= 0 and IBUFF(L) = IXTSND(2,J,I) Then
                        INTEGER_TO_ALPHA (IBUFF(L), KNAM);
                        INTEGER_TO_ALPHA (NAMNOD(I), KNAME2);
                        New_line;
                        Put("Transmitter ");
                        Put(KNAM);
                        Put(" is used at node ");
                        Put(KNAME2);
                        Put(".  Modify it first.");
                        IBUFF(L) := 0;
                        Exit;
                     End If;
                  End Loop;
               End Loop;
            End If;
         End Loop;
      End If;
--
--LOOP ON ALL ELEMENTS TO BE REMOVED.
      For I in 1..NUMBR Loop
         If IBUFF(I) /= 0 Then
            TRANSMITTER_FIND (IBUFF(I), JNUM);
            If JNUM = 0 Then
               --
               --TRYING TO REMOVE A TRANSMITTER CLASS NOT YET ADDED.
               INTEGER_TO_ALPHA (IBUFF(I), KNAM);
               New_line;
               Put("Transmitter class ");
               Put(KNAM);
               Put(" not in database...no action taken.");
            Else
               --
               --REMOVE TRANSMITTER CLASS AT LOCATION J
               NEW_TITLE_CHECK;
               N := NUMXMT - 1;
               If N >= JNUM Then
                  For L in JNUM..N Loop
                     NAMXMT(L) := NAMXMT(L+1);
                     ITPXMT(L) := ITPXMT(L+1);
                     IATXMT(L) := IATXMT(L+1);
                     FREXMT(L) := FREXMT(L+1);
                     TRPXMT(L) := TRPXMT(L+1);
                     ANTGNX(L) := ANTGNX(L+1);
                     ANTHTX(L) := ANTHTX(L+1);
                     ANTLNX(L) := ANTLNX(L+1);
                     ANTTAX(L) := ANTTAX(L+1);
                  End Loop;
               End If;
               NUMXMT := N;
            End If;
         End If;
      End Loop;
--
      End TRANSMITTER_REMOVE;
--
--
End TRANSMIT;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--RECEIVERS
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Text_IO; use Text_io, float_io, integer_io;
With Entityuti; use entityuti;
With types; use Types;
With Constants; use Constants; with Constant2; use Constant2;
With Constant3; use Constant3;
With Helps; use Helps;
With Debugger; use Debugger;
Package RECEIVERS is
--
      Procedure RECEIVER_ADD (IREC: in integer;
                              IFLG: in out integer;
                              IERR: out integer);
      Procedure RECEIVER_DATA (INUMBR: in integer;
                               FREQ: in float;
                               IFLG: in out integer;
                               INOADD: out integer);
      Procedure RECEIVER_DISPLAY (IBUFF: in L_ARRAY;
                                  NV: in out integer);
      Procedure RECEIVER_FETCH (KNAME: out string;
                                INAME: out long_integer;
                                INUMBR: out integer;
                                ISTOP: out integer);
      Procedure RECEIVER_FIND (INAME: in long_integer;
                               INUMBR: out integer);
      Procedure RECEIVER_HANDLER;
      Procedure RECEIVER_HELP (IWHO: in integer);
      Procedure RECEIVER_REMOVE (IBUFF: in out L_ARRAY;
                                 NUMBR: in integer);
--
End RECEIVERS;
--
Package body RECEIVERS is
--
-- RECEIVERS Package of PROP_LINK Version 1.0, February 12, 1985
--
-- This RECEIVERS Package contains all of the procedures that manipulate
-- receiver data.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
--
--
      Procedure RECEIVER_ADD (IREC: in integer;
                              IFLG: in out integer;
                              IERR: out integer) is
--
--#PURPOSE: RECEIVER_ADD processes the addition of one or more receiver
--          classes.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    I/O Processing
--
--#PARAMETER DESCRIPTIONS:
--IN        IREC  = The position of the receiver class to be added,
--                  if 0 on entry, then additions will be allowed
--                  until a = is entered.
--IO        IFLG  = Flag indicating,
--                   0...Addition
--                   1...Modify or Like
--OUT       IERR   = The error code where,
--                   0 means no errors encountered,
--                   1 means an attempt to add too many
--                     receiver classes has been made.
--
--#CALLED BY:
--          NODE_HANDLER
--          RECEIVER_HANDLER
--
--#CALLS TO:
--          BLANK_CHECK
--          HELP_CHECK
--          INTEGER_TO_ALPHA
--          PARSE
--          RECEIVER_DATA
--
--#TECHNICAL DESCRIPTION:
--          RECEIVER_ADD processes the addition of receiver classes as
--          well as the replacement of receiver class data when the
--          modify command has been used.  Echo checking is used
--          so that the operator may inspect the current value for
--          each data element.  The "LIKE" command is also supported
--          so that a receiver class may be specified as being like
--          some other previously described receiver class.
--
      KNAME: string(1..6);
      INUMBR: integer;
      INOADD: integer;
--
      Begin
--
--INITIALIZE.
      IERR := 0;
--
--GET RECEIVER CLASS FREQUENCY.
<<FREQUENCY>>
      New_line;
      Put("Frequency: ");
      Put(FREREC(IREC));
      Put(" Hz."); New_line;
      Get_line(INPUT_BUFFER, MAX);
--
--IF A <N>  ENTERED SET RECEIVER CLASS FREQUENCY TO ZERO AND BRANCH TO
--RECEIVER_DATA_CALL.
      If INPUT_BUFFER(1) = 'N' or INPUT_BUFFER(1) = 'n' Then
         NEW_TITLE_CHECK;
         XARRAY(1) := 0.0;
         Goto RECEIVER_DATA_CALL;
      End If;
--
--IF A <CR> ENTERED SAVE THIS DATA ELEMENT AS IS AND GET NEXT ONE.
      XARRAY(1) := FREREC(IREC);
      If BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
         Goto RECEIVER_DATA_CALL;
      End If;
--
--IF A = ENTERED TERMINATE WITH ALL VALUES AS THEY ARE RIGHT NOW.
      If INPUT_BUFFER(1) = '=' Then
         New_line;
         Put("No receiver data was added or changed in this receiver class");
         IERR := 1;
         Return;
      End If;
--
--IF AN <H> ENTERED THEN PRINT A HELP MESSAGE AND RE-PROMPT.
      If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
         RECEIVER_HELP (1);
         Goto FREQUENCY;
      End If;
--
--IF A <L> ENTERED THEN THIS RECEIVER CLASS IS LIKE SOME OTHER,
--NOW GET THE OTHER RECEIVER CLASS FOR THIS ASSIGNMENT.
      If INPUT_BUFFER(1) = 'L' or INPUT_BUFFER(1) = 'l' Then
         IFLG := 1;
<<LIKE>>
         New_line;
         Put("Which receiver class? ");
         Get_line(INPUT_BUFFER, MAX);
         If INPUT_BUFFER(1) = '=' Then
            New_line;
            Put("No receiver data was added or changed in this ");
            Put("receiver class");
            IERR := 1;
            Return;
         End If;
         If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
            RECEIVER_HELP(2);
            Goto LIKE;
         End If;
         NUMBER_OF_VARIABLES_TO_EXTRACT := -1;
         PARSE (INPUT_BUFFER(1..MAX));
         If NUMBER_OF_VARIABLES_EXTRACTED /= 1 Then
            Goto LIKE;
         End If;
         RECEIVER_FIND(IARRAY(1), INUMBR);
         If INUMBR <= 0 Then
            INTEGER_TO_ALPHA (IARRAY(1), KNAME);
            New_line;
            Put("Receiver class ");
            Put(KNAME);
            Put(" was not found.");
            Goto LIKE;
         End If;
         NEW_TITLE_CHECK;
         ITPREC(IREC) := ITPREC(INUMBR);
         IATREC(IREC) := IATREC(INUMBR);
         FREREC(IREC) := FREREC(INUMBR);
         GTREC(IREC)  := GTREC(INUMBR);
         BWREC(IREC)  := BWREC(INUMBR);
         RLLREC(IREC) := RLLREC(INUMBR);
         ANTGNR(IREC) := ANTGNR(INUMBR);
         ANTHTR(IREC) := ANTHTR(INUMBR);
         ANTLNR(IREC) := ANTLNR(INUMBR);
         ANTTAR(IREC) := ANTTAR(INUMBR);
         Goto FREQUENCY;
      End If;
--
      NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
      PARSE(INPUT_BUFFER(1..MAX));
--
<<RECEIVER_DATA_CALL>>
      If XARRAY(1) > 3.0E+11 Then
         New_line;
         Put(XARRAY(1));
         Put(" is not an acceptable frequency.");
         Goto FREQUENCY;
      End If;
--
      If FREREC(IREC) /= XARRAY(1) Then
         NEW_TITLE_CHECK;
      End If;
--
      FREREC(IREC) := XARRAY(1);
      RECEIVER_DATA(IREC, FREREC(IREC), IFLG, INOADD);
      If IFLG = 1 Then
         Return;
      End If;
      If INOADD /= 0 Then
         New_line;
         Put("No receiver data was added or changed in this receiver class");
         IERR := 1;
         Return;
      End If;
--
      Return;
--
      End RECEIVER_ADD;
--
--
      Procedure RECEIVER_DATA (INUMBR: in integer;
                               FREQ: in float;
                               IFLG: in out integer;
                               INOADD: out integer) is
--
--#PURPOSE: RECEIVER_DATA is responsible for accepting and checking any
--          data entered for a given receiver class.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    I/O Processing
--
--#PARAMETER DESCRIPTIONS:
--IN        INUMBR = The index number of the receiver class being
--                   added.
--IN        FREQ   = The frequency of the receiver class.
--IO        IFLG   = Flag indicating,
--                   0...Addition
--                   1...Modify or like
--OUT       INOADD = The stop flag where,
--                      0 means that all additions were
--                        normal,
--                      1 means that an addition was terminated
--                        before completion.
--
--#CALLED BY:
--          RECEIVER_ADD
--
--#CALLS TO:
--          ANTENNA_CHECK
--          BLANK_CHECK
--          HELP_CHECK
--          PARSE
--          RECEIVER_HELP
--
--#TECHNICAL DESCRIPTION:
--          RECEIVER_DATA is responsible for accepting and checking any
--          data entered for a given receiver class.  Straightforward
--          branching on receiver class type and comparison testing
--          is employed to select only the data that is appropriate
--          for each type of receiver class.
--
      I: integer;
      LCTYP: BAND_TYPES;
      IATYP: integer;
      GT: float;
      BW: float;
      RLL: float;
      GNR: float;
      HTR: float;
      LNR: float;
      TAR: float;
      IERR: integer;
--
      Begin
--
--INITIALIZE.
      INOADD := 0;
      LCTYP := ITPREC(INUMBR);
      IATYP := IATREC(INUMBR);
      GT    := GTREC(INUMBR);
      BW    := BWREC(INUMBR);
      RLL   := RLLREC(INUMBR);
      GNR   := ANTGNR(INUMBR);
      HTR   := ANTHTR(INUMBR);
      LNR   := ANTLNR(INUMBR);
      TAR   := ANTTAR(INUMBR);
--
--ASSIGN RECEIVER CLASS TYPE.
      If FREQ < 3.0 Then
         LCTYP := HARD_WIRED;
         New_line;
         Put("HARD_WIRED type of link assigned to receiver.");
         Goto ACCEPT_DATA;
      End If;
      If FREQ <= 3.0E+03 Then
         LCTYP := ELF;
      Elsif FREQ > 3.0E+03 and FREQ <= 3.0E+04 Then
         LCTYP := VLF;
      Elsif FREQ > 3.0E+04 and FREQ <= 3.0E+05 Then
         LCTYP := LF;
      Elsif FREQ > 3.0E+05 and FREQ <= 3.0E+06 Then
         LCTYP := MF;
      Elsif FREQ > 3.0E+06 and FREQ <= 3.0E+07 Then
         LCTYP := HF;
      Elsif FREQ > 3.0E+07 and FREQ <= 3.0E+08 Then
         LCTYP := VHF;
      Elsif FREQ > 3.0E+08 and FREQ <= 3.0E+09 Then
         LCTYP := UHF;
      Elsif FREQ > 3.0E+09 and FREQ <= 3.0E+10 Then
         LCTYP := SHF;
      Elsif FREQ > 3.0E+10 and FREQ <= 3.0E+11 Then
         LCTYP := EHF;
      End If;
      New_line;
      Put(BAND_TYPES'IMAGE(LCTYP));
      Put(" frequency class assigned.");
--
      If LCTYP >= VHF Then
<<GAINER>>
         New_line;
         Put("Antenna G/T: ");
         Put(GT);
         Put(" (dB/K)"); New_line;
         Get_line(INPUT_BUFFER, MAX);
         If INPUT_BUFFER(1) = '=' Then
            Goto FLAG_CHECK;
         End If;
         If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
            RECEIVER_HELP(6);
            Goto GAINER;
         End If;
         If not BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
            NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
            PARSE(INPUT_BUFFER(1..MAX));
            If NUMBER_OF_VARIABLES_EXTRACTED /= 1 Then
               Goto GAINER;
            End If;
            NEW_TITLE_CHECK;
            GT := XARRAY(1);
         End If;
--
<<RECEIVER_LINE_LOSS>>
         New_line;
         Put("Receiver line loss: ");
         Put(RLL);
         Put(" dB"); New_line;
         Get_line(INPUT_BUFFER, MAX);
         If INPUT_BUFFER(1) = '=' Then
            Goto FLAG_CHECK;
         End If;
         If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
            RECEIVER_HELP(12);
            Goto RECEIVER_LINE_LOSS;
         End If;
         If not BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
            NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
            PARSE(INPUT_BUFFER(1..MAX));
            If NUMBER_OF_VARIABLES_EXTRACTED /= 1 Then
               Goto RECEIVER_LINE_LOSS;
            End If;
            NEW_TITLE_CHECK;
            RLL := XARRAY(1);
         End If;
      End If;
--
<<BANDWIDTH>>
      New_line;
      Put("Receiver noise bandwidth: ");
      Put(BW);
      Put(" (Hz)"); New_line;
      Get_line(INPUT_BUFFER, MAX);
      If INPUT_BUFFER(1) = '=' Then
         Goto FLAG_CHECK;
      End If;
      If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
         RECEIVER_HELP(9);
         Goto BANDWIDTH;
      End If;
      If not BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
         NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
         PARSE(INPUT_BUFFER(1..MAX));
         If NUMBER_OF_VARIABLES_EXTRACTED /= 1 or XARRAY(1) <= 0.0 Then
            Goto BANDWIDTH;
         End If;
         NEW_TITLE_CHECK;
         BW := XARRAY(1);
      End If;
--
<<ANTENNA_TYPE>>
      If LCTYP = HARD_WIRED or LCTYP = ELF or LCTYP = VLF Then
         IATYP := 0;
      Else
         If IATYP = 0 then              -- Set some default antenna values
            If LCTYP = LF Then
               IATYP := 1;
            Elsif LCTYP in MF..HF Then
               IATYP := 5;
            Elsif LCTYP in VHF..EHF Then
               IATYP := 3;
            End If;
         End If;
         New_line;
         Put(BAND_TYPES'IMAGE(LCTYP));
         Put(" Antenna type: ");
         Put(IATYP); New_line;
         Get_line(INPUT_BUFFER, MAX);
         If INPUT_BUFFER(1) = '=' Then
            Goto FLAG_CHECK;
         End If;
         If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
            RECEIVER_HELP(11);
            Goto ANTENNA_TYPE;
         End If;
         If not BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
            NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
            PARSE(INPUT_BUFFER(1..MAX));
            If NUMBER_OF_VARIABLES_EXTRACTED /= 1 or XARRAY(1) < 1.0 or
               XARRAY(1) > 8.0 Then
               Goto ANTENNA_TYPE;
            End If;
            NEW_TITLE_CHECK;
            IATYP := INTEGER(XARRAY(1));
            ANTENNA_CHECK (IATYP, LCTYP, GNR, HTR, LNR, TAR, IERR);
            If IERR > 1 Then
               Goto ANTENNA_TYPE;
            End If;
            If IERR = 1 Then
               Goto FLAG_CHECK;
            End If;
         End If;
      End If;
--
<<ACCEPT_DATA>>
      ITPREC(INUMBR) := LCTYP;
      IATREC(INUMBR) := IATYP;
      FREREC(INUMBR) := FREQ;
      GTREC(INUMBR) := GT;
      BWREC(INUMBR) := BW;
      RLLREC(INUMBR) := RLL;
      ANTGNR(INUMBR) := GNR;
      ANTHTR(INUMBR) := HTR;
      ANTLNR(INUMBR) := LNR;
      ANTTAR(INUMBR) := TAR;
      Return;
--
<<FLAG_CHECK>>
      If IFLG /= 1 Then
         INOADD := 1;
      End If;
      Return;
--
      End RECEIVER_DATA;
--
--
      Procedure RECEIVER_DISPLAY (IBUFF: in L_ARRAY;
                                     NV: in out integer) is
--
--#PURPOSE: RECEIVER_DISPLAY displays the requested receiver classes to
--          either the printer or the terminal depending on the value of
--          CURRENT_COMMAND.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Output module
--
--#PARAMETER DESCRIPTIONS:
--IN        IBUFF  = The array containing the receiver class numbers to
--                   be displayed.
--IN        NV     = The number of elements in IBUFF.
--
--#CALLED BY:
--          RECEIVER_HANDLER
--
--#CALLS TO:
--          INTEGER_TO_ALPHA
--          RECEIVER_FIND
--
--#TECHNICAL DESCRIPTION:
--          RECEIVER_DISPLAY displays only the receiver classes listed in
--          IBUFF as long as NV is not 0 on entry.  When NV is 0 this
--          signals that all receivers should be displayed, therefore if
--          many receivers exist, and the specified device is the terminal,
--          this can cause data to scroll off the screen.
--
--
      ICOMPL: boolean;
      I,INUM: integer;
      KNREC: string(1..6);
--
      Begin
--
--SET THE OUTPUT DEVICE.
      If CURRENT_COMMAND = PRINT Then
         SET_OUTPUT(PRINTER_OUTPUT_FILE);
      End If;
--
--GET THE NUMBER OF RECEIVER CLASSES TO DISPLAY AND THE DEVICE NUMBER.
      ICOMPL := FALSE;
      If NV = 0 or NV = NUMREC Then
         ICOMPL := TRUE;
      End If;
--
--PRINT OUT REPORT HEADER.
      If ICOMPL Then
         New_line;
         Put(TITLE);
         New_line;New_line;
         Put("                    RECEIVER SUMMARY");
         New_line;
         Put("               There are currently ");
         Put(NUMREC);
         Put(" receiver classes");
         New_line;
         NV := NUMREC;
      End If;
--
--LOOP ON NUMBER OF RECEIVER CLASSES TO PRINT.
      If NV < 1 Then
         Return;
      End If;
      For I in 1..NV Loop
         If I /= 1 Then
            Put("====================================");
            Put("====================================");
         End If;
         RECEIVER_FIND(IBUFF(I), INUM);
         If INUM < 1 Then
            --RESET THE OUTPUT DEVICE.
            If CURRENT_COMMAND = PRINT Then
               SET_OUTPUT(STANDARD_OUTPUT);
            End If;
            INTEGER_TO_ALPHA (IBUFF(I), KNREC);
            New_line;
            Put("Receiver class ");
            Put(KNREC);
            Put(" does not yet exist.");
            --SET THE OUTPUT DEVICE.
            If CURRENT_COMMAND = PRINT Then
               SET_OUTPUT(PRINTER_OUTPUT_FILE);
            End If;
            Goto END_OF_LOOP;
         End If;
         INTEGER_TO_ALPHA(NAMREC(INUM), KNREC);
         If ITPREC(INUM) = HARD_WIRED Then
            New_line;
            Put("Receiver ");
            Put(KNREC);
            Put(" is a HARD_WIRED class.");
            Goto END_OF_LOOP;
         End If;
         New_line;
         Put("Receiver name.........");
         Put(KNREC);
         Put("          Frequency class...");
         Put(Band_types'IMAGE(ITPREC(INUM)));
         New_line;
         Put("Frequency (Hz)..........");
         Put(FREREC(INUM),2,5,3);
         Put("    Bandwidth (Hz)........");
         Put(BWREC(INUM),2,5,3);
         New_line;
         If ITPREC(INUM) > VLF Then
            New_line;
            Put("Antenna type..........");
            If IATREC(INUM) = 1 Then
               Put("Loop");
            Elsif IATREC(INUM) = 2 Then
               Put("Whip");
            Elsif IATREC(INUM) = 3 Then
               Put("Dish with tapered side lobe");
            Elsif IATREC(INUM) = 4 Then
               Put("Dish with constant side lobe");
            Elsif IATREC(INUM) = 5 Then
               Put("Constant gain");
            Elsif IATREC(INUM) = 6 Then
               Put("Rhombic");
            Elsif IATREC(INUM) = 7 Then
               Put("Vertical");
            Elsif IATREC(INUM) = 8 Then
               Put("Horizontal half-wave dipole");
            End If;
         End If;
         If ITPREC(INUM) >= VHF Then
            New_line;
            Put("Antenna G/T (dB/K)....");
            Put(GTREC(INUM),2,5,3);
            New_line;
            Put("Rec. line loss (dB)....");
            Put(RLLREC(INUM),2,5,3);
         End If;
         If IATREC(INUM) = 5 Then
            New_line;
            Put("Antenna gain (dB).....");
            Put(ANTGNR(INUM),2,5,3);
         Elsif IATREC(INUM) = 6 Then
            New_line;
            Put("Ant tilt angle (deg)..");
            Put(ANTTAR(INUM),3,1,0);
            New_line;
            Put("Antenna height (m)....");
            Put(ANTHTR(INUM),2,5,3);
            New_line;
            Put("Ant leg length (m)....");
            Put(ANTLNR(INUM),2,5,3);
         Elsif IATREC(INUM) = 7 Then
            New_line;
            Put("Ant leg length (m)....");
            Put(ANTLNR(INUM),2,5,3);
         Elsif IATREC(INUM) = 8 Then
            New_line;
            Put("Antenna height (m)....");
            Put(ANTHTR(INUM),2,5,3);
         End If;
<<END_OF_LOOP>>
         Null;
         New_line;
      End Loop;
--
--RESET THE OUTPUT DEVICE.
      If CURRENT_COMMAND = PRINT Then
         SET_OUTPUT(STANDARD_OUTPUT);
      End If;
--
      Return;
--
      End RECEIVER_DISPLAY;
--
--
      Procedure RECEIVER_FETCH (KNAME: out string;
                                INAME: out long_integer;
                                INUMBR: out integer;
                                ISTOP: out integer) is
--
--#PURPOSE: RECEIVER_FETCH obtains a receiver class from the receiver data
--          structure.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Table Look-up
--
--#PARAMETER DESCRIPTIONS:
--OUT       KNAME  = The receiver class name string.
--OUT       INAME  = The coded receiver class name.
--OUT       INUMBR = The location of INAME in the receiver
--                   data structure.
--                   A value of zero (0) is returned if INAME
--                   cannot be located.
--OUT       ISTOP  = Flag to tell if = is encountered
--                   0...No = encountered
--                   1...A terminator = was encountered
--
--#CALLED BY:
--          RECEIVER_HANDLER
--
--#CALLS TO:
--          BLANK_CHECK
--          INTEGER_TO_ALPHA
--          PARSE
--          RECEIVER_FIND
--
--#TECHNICAL DESCRIPTION:
--          RECEIVER_FETCH queries the operator for a receiver class name
--          then does a table lookup in the receiver data structure for
--          the specified receiver class.  When the receiver class is
--          located, its position in the structure is returned in the
--          variable INUMBR.  If the receiver cannot be located, a value
--          of zero is returned in INUMBR.
--
      Begin
--
      ISTOP := 0;
--
<<GET_RECEIVER_CLASS_NAME>>
      New_line;
      Put("Enter the receiver class name: ");
      Get_line(INPUT_BUFFER, MAX);
      KNAME := INPUT_BUFFER(1..6);
      If BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
         Goto GET_RECEIVER_CLASS_NAME;
      End If;
      If INPUT_BUFFER(1) = '=' Then
         ISTOP := 1;
         Return;
      End If;
      NUMBER_OF_VARIABLES_TO_EXTRACT := -1;
      PARSE (INPUT_BUFFER(1..MAX));
      If NUMBER_OF_VARIABLES_EXTRACTED /= 1 Then
         Goto GET_RECEIVER_CLASS_NAME;
      End If;
      INAME:=IARRAY(1);
      INTEGER_TO_ALPHA(IARRAY(1), KNAME);
      RECEIVER_FIND (IARRAY(1), INUMBR);
--
      Return;
--
      End RECEIVER_FETCH;
--
--
      Procedure RECEIVER_FIND (INAME: in long_integer; INUMBR: out integer) is
--
--#PURPOSE: RECEIVER_FIND locates a receiver class in the receiver data
--          structure.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Table Look-up
--
--#PARAMETER DESCRIPTIONS:
--IN        INAME  = The coded receiver class name.
--OUT       INUMBR = The location of INAME in the receiver data structure.
--                   A value of zero (0) is returned if INAME cannot be
--                   located.
--
--#CALLED BY:
--          RECEIVER_HANDLER
--          RECEIVER_ADD
--          RECEIVER_DISPLAY
--          RECEIVER_FETCH
--          RECEIVER_REMOVE
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          RECEIVER_FIND does a table lookup in the receiver data
--          structure the specified receiver class.  When the receiver
--          class is located, its position in the structure is returned in
--          the variable INUMBR.  If the receiver class cannot be located, a
--          value of zero is returned in INUMBR.
--
      KNAME: string(1..6);
      I: integer;
--
      Begin
--
      INUMBR := 0;
      If NUMREC < 1 Then
         Return;
      End If;
--
--SEARCH THE DATA STRUCTURE FOR THE RECEIVER CLASS.
      For I in 1..NUMREC Loop
         If INAME = NAMREC(I) Then
            INUMBR := I;
            Return;
         End If;
      End Loop;
      Return;
--
      End RECEIVER_FIND;
--
--
      Procedure RECEIVER_HANDLER is
--
--#PURPOSE: RECEIVER_HANDLER drives the receiver class processing routines.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    I/O PROCESSING
--
--#PARAMETER DESCRIPTIONS:
--          'NONE'
--
--#CALLED BY:
--          MAIN
--          PRINT_HANDLER
--
--#CALLS TO:
--          BLANK_CHECK
--          INTEGER_TO_ALPHA
--          PARSE
--          RECEIVER_ADD
--          RECEIVER_DISPLAY
--          RECEIVER_FETCH
--          RECEIVER_FIND
--          RECEIVER_REMOVE
--
--#TECHNICAL DESCRIPTION:
--          RECEIVER_HANDLER serves as the driver for the routines which
--          add, delete, and modify receiver classes.  Trickle down logic
--          is used to select the desired command.
--
      INAME: L_ARRAY(1..MAXRNT);
      IFLG,NV,I,K: integer;
      KNAME: string(1..6);
      JNAME: long_integer;
      JNUMBR: integer;
      ISTOP: integer;
      IERR: integer;
      INUMBR: integer;
--
      Begin
--
--INITIALIZE.
      IFLG := 0;
      NV := 0;
--
      Case CURRENT_COMMAND is
      When ADD =>
<<ADD_RECEIVER>>
         RECEIVER_FETCH (KNAME, JNAME, JNUMBR, ISTOP);
         If ISTOP = 1 Then
            Return;
         End If;
         If JNUMBR >= 1 Then
            New_line;
            Put("Receiver class ");
            Put(KNAME);
            Put(" already exists.");
            Goto ADD_RECEIVER;
         End If;
         If NUMREC >= MAXRNT Then
            New_line;
            Put("No more receiver classes may be added.");
            Put("  Redimension receiver arrays.");
            Return;
         End If;
         NUMREC := NUMREC + 1;
         JNUMBR := NUMREC;
         NAMREC (JNUMBR) := JNAME;
         ITPREC (JNUMBR) := ELF;
         IATREC (JNUMBR) := 0;
         FREREC (JNUMBR) := 3.0;
         GTREC  (JNUMBR) := -30.0;
         BWREC  (JNUMBR) := 1.0;
         RLLREC (JNUMBR) := 0.0;
         ANTGNR (JNUMBR) := 0.0;
         ANTHTR (JNUMBR) := 0.0;
         ANTLNR (JNUMBR) := 0.0;
         ANTTAR (JNUMBR) := 0.0;
         RECEIVER_ADD (JNUMBR, IFLG, IERR);
         If IERR = 0 Then
            Goto ADD_RECEIVER;
         End If;
--
--RECEIVER CLASS ADDITION WAS TERMINATED.
         NUMREC := NUMREC - 1;
         Return;
--
--PROCESS THE VIEW OR PRINT COMMANDS.
      When VIEW | PRINT =>
         NV := NUMREC;
         If NV >= 1 Then
            For K in 1..NUMREC Loop
               INAME(K) := NAMREC(K);
            End Loop;
            If not BLANK_CHECK(ARGUMENT_BUFFER) Then
               NUMBER_OF_VARIABLES_TO_EXTRACT := -40;
               PARSE(ARGUMENT_BUFFER);
               NV := NUMBER_OF_VARIABLES_EXTRACTED;
               For K in 1..NV Loop
                  INAME(K) := IARRAY(K);
               End Loop;
            End If;
         End If;
         RECEIVER_DISPLAY (INAME, NV);
         Return;
--
--PROCESS THE DELETION COMMAND.
      When DEL =>
         Loop
            Exit When not BLANK_CHECK(ARGUMENT_BUFFER);
            New_line;
            Put("Enter the receiver class names to be deleted,");
            Put(" separated by spaces.");
            New_line;
            Get_line(ARGUMENT_BUFFER, MAX);
         End Loop;
         If ARGUMENT_BUFFER(1) = '=' Then
            Return;
         End If;
         NUMBER_OF_VARIABLES_TO_EXTRACT := -40;
         PARSE(ARGUMENT_BUFFER);
         NV := NUMBER_OF_VARIABLES_EXTRACTED;
         If NV <= 0 Then
            NV := 1;
         End If;
         RECEIVER_REMOVE(IARRAY, NV);
         Return;
--
--PROCESS THE MODIFY COMMAND.
      When MODIFY =>
         IFLG := 1;
         Loop
            Exit When not BLANK_CHECK(ARGUMENT_BUFFER);
            New_line;
            Put("Enter the name of the receiver class to be modified: ");
            Get_line(ARGUMENT_BUFFER, MAX);
         End Loop;
         If ARGUMENT_BUFFER(1) = '=' Then
            Return;
         End If;
         NUMBER_OF_VARIABLES_TO_EXTRACT := -1;
         PARSE(ARGUMENT_BUFFER);
         If NUMBER_OF_VARIABLES_EXTRACTED > 0 Then
            RECEIVER_FIND (IARRAY(1), INUMBR);
            INTEGER_TO_ALPHA (IARRAY(1), KNAME);
            If INUMBR <= 0 Then
               New_line;
               Put("Receiver class name ");
               Put(KNAME);
               Put(" does not exist.");
               Return;
            End If;
            RECEIVER_ADD (INUMBR, IFLG, IERR);
         End If;
--
--ILLEGAL COMMAND WARNING.
      When others =>
         New_line;
         Put("The command code is not valid for receiver class processing.");
         Return;
      End Case;
--
      End RECEIVER_HANDLER;
--
--
      Procedure RECEIVER_HELP (IWHO: in integer) is
--
--#PURPOSE: RECEIVER_HELP prints the various help messages as requested
--          by the operator for the different levels of receiver class
--          processing.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Operator assistance
--
--#PARAMETER DESCRIPTIONS:
--IN        IWHO   := The indicator flag for which help message to print.
--
--#CALLED BY:
--          RECEIVER_ADD
--          RECEIVER_DATA
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          RECEIVER_HELP prints the various help messages as requested
--          by the operator for the different levels of receiver class
--          processing.  The value of IWHO determines the message to
--          display.
--
      Begin
--
--SELECT THE HELP MESSAGE TO DISPLAY.
      If IWHO = 1 Then
         New_line;
         Put("At this point you can enter the frequency in Hz of the ");
         Put("receiver. The range of");
         New_line;
         Put("frequency is from 3Hz to 3.0E+11 Hz.  If the receiver ");
         Put("frequency that was just");
         New_line;
         Put("echoed is satisfactory, then simply enter a carriage return.");
         Put("  You may also");
         New_line;
         Put("enter  L  or  LIKE  to set this receiver up exactly like ");
         Put("some other receiver.");
         New_line;
         Put("Finally, you may enter  N  or  NONE  to signify that a ");
         Put("HARD_WIRED link is");
         New_line;
         Put("desired.");
         New_line;
         Put("An = (equal sign) terminates the addition of this receiver ");
         Put("with the current");
         New_line;
         Put("information to this point and the receiver lost, unless this ");
         Put("addition is");
         New_line;
         Put("-like- some other receiver, then it is saved.");
         New_line;
      Return;
      End If;
--
      If IWHO = 2 Then
         New_line;
         Put("Since you have specified that this receiver should be like ");
         Put("some other");
         New_line;
         Put("receiver, you must now enter the name of the receiver that ");
         Put("has already been");
         New_line;
         Put("entered which has the data that should be used to define ");
         Put("this receiver. If");
         New_line;
         Put("you made a mistake and don't want this feature, then enter ");
         Put("an = to take you");
         New_line;
         Put("back to the executive for another command.");
         New_line;
         Return;
      End If;
--
      If IWHO = 5 Then
         New_line;
         Put("Enter a class name (maximum of 6 characters). ");
         New_line;
         Put("An = (equal sign) terminates the addition of this receiver ");
         Put("with the current");
         New_line;
         Put("information to this point and the receiver lost, unless this ");
         Put("addition is");
         New_line;
         Put("-like- some other receiver, then it is saved.");
         New_line;
         Return;
      End If;
--
      If IWHO = 6 Then
         New_line;
         Put("If the antenna G/T just echoed is satisfactory then enter");
         Put(" a carriage return.");
         New_line;
         Put("Otherwise, enter the value of the receiving antenna ");
         Put("in (dB/k).");
         New_line;
         Put("G/T is a figure of merit for a VHF/UHF/SHF/EHF satellite ");
         Put("receiver.  G refers");
         New_line;
         Put("to the gain of the antenna in the receive mode, and T is ");
         Put("the equivalent noise");
         New_line;
         Put("temperature of the receiving system.  The equivalent noise ");
         Put("temperature is");
         New_line;
         Put("based on the total amount of noise in the received signal.  ");
         Put("The units of G/T");
         New_line;
         Put("are dB/k which may be computed as:");
         New_line;
         Put("      10.0 * alog10 (gain / temp)");
         New_line;
         Put("   where:");
         New_line;
         Put("      gain = gain of the antenna as a multiplier..not dB; and,");
         New_line;
         Put("      temp = noise temperature in degrees kelvin.");
         New_line;
         Put("An = (equal sign) terminates the addition of this receiver ");
         Put("with the current");
         New_line;
         Put("information to this point and the receiver lost, unless this ");
         Put("addition is");
         New_line;
         Put("-like- some other receiver, then it is saved.");
         New_line;
         Return;
      End If;
--
      If IWHO = 9 Then
         New_line;
         Put("If the bandwidth just echoed is satisfactory then enter a ");
         Put("carriage return.");
         New_line;
         Put("Otherwise, enter the value of the receiver bandwidth in Hz.");
         New_line;
         Put("An = (equal sign) terminates the addition of this receiver ");
         Put("with the current");
         New_line;
         Put("information to this point and the receiver lost, unless this ");
         Put("addition is");
         New_line;
         Put("-like- some other receiver, then it is saved.");
         New_line;
         Return;
      End If;
--
      If IWHO = 11 Then
         New_line;
         Put("If the antenna type just echoed is satisfactory then enter ");
         Put("a carriage return.");
         New_line;
         Put("Otherwise, enter the value of the receiver antenna type.  ");
         Put("The value must be:");
         New_line;
         Put("   1 - loop type (LF only);");
         New_line;
         Put("   2 - whip type (LF only);");
         New_line;
         Put("   3 - dish with tapered side lobe (VHF and above only);");
         New_line;
         Put("   4 - dish with constant side lobe (VHF and above only);");
         New_line;
         Put("   5 - constant gain (MF and HF only);");
         New_line;
         Put("   6 - rhombic (MF and HF only);");
         New_line;
         Put("   7 - vertical (MF and HF only); or,");
         New_line;
         Put("   8 - horizontal half-wave dipole (MF and HF only).");
         New_line;
         Put("An = (equal sign) terminates the addition of this receiver ");
         Put("with the current");
         New_line;
         Put("information to this point and the receiver lost, unless this ");
         Put("addition is");
         New_line;
         Put("-like- some other receiver, then it is saved.");
         New_line;
         Return;
      End If;
--
      If IWHO = 12 Then
         New_line;
         Put("If the receiver line loss just echoed is satisfactory then ");
         Put("enter a carriage");
         Put("return.  Otherwise, enter the value of the receiver line ");
         Put("loss in dB.");
         New_line;
         Put("An = (equal sign) terminates the addition of this receiver ");
         Put("with the current");
         New_line;
         Put("information to this point and the receiver lost, unless this ");
         Put("addition is");
         New_line;
         Put("-like- some other receiver, then it is saved.");
         New_line;
         Return;
      End If;
--
      End RECEIVER_HELP;
--
--
      Procedure RECEIVER_REMOVE (IBUFF: in out L_ARRAY;
                                 NUMBR: in integer) is
--
--#PURPOSE: RECEIVER_REMOVE removes a specified receiver class from the
--          data base.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    I/O Processing
--
--#PARAMETER DESCRIPTIONS:
--IN        IBUFF  = The array containing the receiver class names
--                   to be deleted.
--IN        NUMBR  = The number of receiver class names in IBUFF.
--
--#CALLED BY:
--          RECEIVER_HANDLER
--
--#CALLS TO:
--          INTEGER_TO_ALPHA
--          RECEIVER_FIND
--
--#TECHNICAL DESCRIPTION:
--          RECEIVER_REMOVE removes a specified receiver class from the
--          data base.  Before a receiver class is removed, a check
--          is first made to be sure that some node does not use
--          the receiver class.  If such a node is found, a message
--          indicating the problem is issued to the operator.  If
--          no node conflict is found, the receiver class is effectively
--          removed by shifting each receiver class with an index value
--          higher than the one being removed down by one.
--
      KNAM: string(1..6);
      KNAME2: string(1..6);
      I,J,L,N: integer;
      JNUM: integer;
--
      Begin
--
--CHECK IBUFF FOR USE AT A NODE.
      If NUMNOD > 0 Then
         For I in 1..NUMNOD Loop
            If NRSND(I) > 0 Then
               For J in 1..NRSND(I) Loop
                  For L in 1..NUMBR Loop
                     If IBUFF(L) /= 0 and IBUFF(L) = IRCSND(2,J,I) Then
                        INTEGER_TO_ALPHA (IBUFF(L), KNAM);
                        INTEGER_TO_ALPHA (NAMNOD(I), KNAME2);
                        New_line;
                        Put("Receiver ");
                        Put(KNAM);
                        Put(" is used at node ");
                        Put(KNAME2);
                        Put(".  Modify it first.");
                        IBUFF(L) := 0;
                        Exit;
                     End If;
                  End Loop;
               End Loop;
            End If;
         End Loop;
      End If;
--
--LOOP ON ALL ELEMENTS TO BE REMOVED.
      For I in 1..NUMBR Loop
         If IBUFF(I) /= 0 Then
            RECEIVER_FIND (IBUFF(I), JNUM);
            If JNUM = 0 Then
               --
               --TRYING TO REMOVE A RECEIVER CLASS NOT YET ADDED.
               INTEGER_TO_ALPHA (IBUFF(I), KNAM);
               New_line;
               Put("Receiver class ");
               Put(KNAM);
               Put(" not in database...no action taken.");
            Else
               --
               --REMOVE RECEIVER CLASS AT LOCATION J
               NEW_TITLE_CHECK;
               N := NUMREC - 1;
               If N >= JNUM Then
                  For L in JNUM..N Loop
                     NAMREC(L) := NAMREC(L+1);
                     ITPREC(L) := ITPREC(L+1);
                     IATREC(L) := IATREC(L+1);
                     FREREC(L) := FREREC(L+1);
                     GTREC(L) := GTREC(L+1);
                     BWREC(L) := BWREC(L+1);
                     RLLREC(L) := RLLREC(L+1);
                     ANTGNR(L) := ANTGNR(L+1);
                     ANTHTR(L) := ANTHTR(L+1);
                     ANTLNR(L) := ANTLNR(L+1);
                     ANTTAR(L) := ANTTAR(L+1);
                  End Loop;
               End If;
               NUMREC := N;
            End If;
         End If;
      End Loop;
--
      End RECEIVER_REMOVE;
--
--
End RECEIVERS;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--NODES
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Debugger; Use Debugger;
With Text_io, system;   use Text_io,float_io,integer_io,LONG_INTEGER_IO;
With Types;     use Types;
With Constants; use Constants;
With Constant2; use constant2;
With Constant3; use Constant3;
With Helps;     use Helps;
With Entityuti; use Entityuti;
Package NODES is
--
      Procedure ENTITY_DATA (ITYPE: in integer;
                             IENT: in out integer;
                             NENT: in out integer;
                             LENT: in out SND3;
                             NUMCL: in out integer;
                             NAMCL: in out L_ARRAY;
                             ITPCL: out BAND_ARRAY;
                             INUMBR: in integer;
                             IERR: out integer);
      Procedure INITIALIZE_NODES;
      Procedure NODE_ADD (INUMBR: in integer;
                          IERRCD: out integer);
      Procedure NODE_DATA (INUMBR: in integer;
                           ISTOP: out integer);
      Procedure NODE_DISPLAY (IBUFF: in L_ARRAY; NV: in out integer);
      Procedure NODE_FETCH (KNAME: out string;
                            INAME: out long_integer;
                            INUMBR: out integer;
                            IERRCD: out integer);
      Procedure NODE_FIND (KNAME: out string;
                           INAME: in long_integer;
                           INUMBR: out integer;
                           IERRCD: out integer);
      Procedure NODE_HANDLER;
      Procedure NODE_HELP (IWHO: in integer);
      Procedure NODE_REMOVE (INAME: L_ARRAY;
                             NUMBR: in integer);
      Procedure LOCATION_DATA ( INUMBR: in integer;
                                LOCERR: out integer );
--
End NODES;
--
Package body NODES is
--
-- NODES Package of PROP_LINK Version 1.0, February 8, 1985
--
-- This NODES Package contains all of the procedures that manipulate node data.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
--
--
      Procedure ENTITY_DATA (ITYPE: in integer;
                             IENT: in out integer;
                             NENT: in out integer;
                             LENT: in out SND3;
                             NUMCL: in out integer;
                             NAMCL: in out L_ARRAY;
                             ITPCL: out BAND_ARRAY;
                             INUMBR: in integer;
                             IERR: out integer) is
--
--PURPOSE: ENTITY_DATA enters entity data (receiver and transmitter
--         classes) for nodes.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Input module.
--
--PARAMETER DESCRIPTIONS:
--IN        ITYPE  = entity type code,
--                  1, receiver,
--                  2, transmitter.
--IN        IENT   = entity location in entity array (1 -> 15).
--IN        NENT   = number of entities in entity array.
--IO        LENT   = entity array.
--                  LENT(1,IENT,INUMBR) entity name.
--                  LENT(2,IENT,INUMBR) entity class.
--IN        NUMCL  = number of entity classes.
--IO        NAMCL  = entity class names.
--OUT       ITPCL  = entity class types.
--IN        INUMBR = node number of entity.
--OUT       IERR   = error code,
--                  0, data correctly entered.
--                  1, end of data indication (=),
--
--CALLED BY:
--         NODE_DATA
--
--CALLS TO:
--         BLANK_CHECK
--         HELP_CHECK
--         INTEGER_TO_ALPHA
--         NEW_TITLE_CHECK
--         NODE_HELP
--         PARSE
--
--TECHNICAL DESCRIPTION:
--         ENTITY_DATA enters entity data (receiver and transmitter
--         classes) for nodes.  It does all error checking internally.
--
      TYPE KNSTRING IS array (integer range 1..2) of string(1..6);
      TYPE KTSTRING IS array (integer range 1..2) of string(1..11);
      KNAME: KNSTRING;
      KTYPE: KTSTRING;
      QREC: integer := 99;
      QXMT: integer := 99;
      IWHO: integer;
      I,J: integer;
      FLG: integer;
--
      Begin
--
      KTYPE(1):="   RECEIVER";
      KTYPE(2):="TRANSMITTER";
      IWHO := ITYPE + 6;
      IERR := 0;
--
<<CONVERT_NAMES>>
       INTEGER_TO_ALPHA (LENT(1,IENT,INUMBR), KNAME(1));
       INTEGER_TO_ALPHA (LENT(2,IENT,INUMBR), KNAME(2));
<<OUTPUT_NAMES>>
       New_line;
       Put(KTYPE(ITYPE));
       Put("-");
       Put(KNAME(1));
       Put(" CLASS-");
       Put(KNAME(2));
       New_line;
       INPUT_BUFFER(1..10):="          ";
       Get_line(INPUT_BUFFER,MAX);
       If INPUT_BUFFER(1) = '=' Then
         If NENT /= (IENT - 1) Then
            NEW_TITLE_CHECK;
         End If;
         NENT := IENT - 1;
         IERR := 1;
         Return;
      End If;
      If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
         NODE_HELP (IWHO);
         Goto OUTPUT_NAMES;
      End If;
--
      If LENT(1,IENT,INUMBR) /= 0  Then
         If BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
            Goto CHECK_FOR_DUPLICATE;
         End If;
      End If;
--
      NUMBER_OF_VARIABLES_TO_EXTRACT := -2;
      PARSE (INPUT_BUFFER(1..MAX));
      If NUMBER_OF_VARIABLES_EXTRACTED < 2 Then
         New_line;
         Put("Invalid format...re-enter data.");
         Goto CONVERT_NAMES;
      End If;
      LENT(1,IENT,INUMBR) := IARRAY(1);
      FLG:=0;
      For J in 1..NUMCL Loop
         If IARRAY(2) = NAMCL(J) Then
            NEW_TITLE_CHECK;
            LENT(2,IENT,INUMBR) := IARRAY(2);
            FLG:=1;
            exit;
         End If;
      End Loop;
      If FLG=1 then
         goto CHECK_FOR_DUPLICATE;
      end if;
      If (NUMCL > QREC and ITYPE = 1) or
         (NUMCL > QXMT and ITYPE = 2) Then
         INTEGER_TO_ALPHA (IARRAY(2), KNAME(1));
         New_line;
         Put("No room to add ");
         Put(KTYPE(ITYPE));
         Put(" class ");
         Put(KNAME(1));
         Put("  Redimension arrays.");
            Goto CONVERT_NAMES;
      End If;
--
      NUMCL := NUMCL + 1;
      NAMCL(NUMCL) := IARRAY(2);
      ITPCL(NUMCL) := UNDEFINED;
      NEW_TITLE_CHECK;
      LENT(2,IENT,INUMBR) := IARRAY(2);
--
--NEW ENTITY ADDED, CHECK FOR DUPLICATE
<<CHECK_FOR_DUPLICATE>>
      If IENT <= 1 Then
         NENT := IENT;
         Return;
      End If;
      For I in 1..IENT Loop
         If I = IENT Then
            NENT := IENT;
            Return;
         End If;
         If LENT(1,I,INUMBR) = LENT(1,IENT,INUMBR) Then
            Exit;
         End If;
      End Loop;
--
--FOUND A DUPLICATE ENTITY.
      New_line;
      Put("Duplicate names are not allowed...");
      Goto CONVERT_NAMES;
--
      Exception
          When others => Put_line("handling exception");
                         system.report_error;
                         raise;
      End ENTITY_DATA;
--
--
      Procedure INITIALIZE_NODES is
--
--PURPOSE: INITIALIZE_NODES initializes the node data structure.
--
--AUTHOR: J. Conrad
--
--TYPE:    Initialization
--
--PARAMETER DESCRIPTIONS:
--         'NONE'
--
--CALLED BY:
--         MAIN
--         READ_NODE
--
--CALLS TO:
--         'NONE'
--
--TECHNICAL DESCRIPTION:
--         INITIALIZE_NODES initializes the node data structure by setting the
--         node names to null and creating the node pointers.
--
      I: integer;
--
      Begin
      NUMNOD := 0;
      For I in 1..100 Loop
         NAMNOD(I) := 0;
      End Loop;
--
      End INITIALIZE_NODES;
--
--
      Procedure NODE_ADD (INUMBR: in integer; IERRCD: out integer) is
--
--PURPOSE: NODE_ADD processes the addition of one or more nodes.
--
--AUTHOR:  J. Conrad
--
--TYPE:    I/O Processing
--
--PARAMETER DESCRIPTIONS:
--IN        INUMBR  = The number of the node to add.
--OUT       IERRCD  = The error code where,
--                  =0, means no errors encountered,
--                  =1, means no data was created.
--                  >1, indicates an error with disc I/O.
--
--CALLED BY:
--         NODE_HANDLER
--
--CALLS TO:
--         BLANK_CHECK
--         HELP_CHECK
--         NEW_TITLE_CHECK
--         NODE_DATA
--         NODE_FETCH
--         NODE_HELP
--
--TECHNICAL DESCRIPTION:
--         NODE_ADD processes the addition of nodes as
--         well as the replacement of node data when the modify
--         command has been used.  The "LIKE" command is also
--         supported so that nodes may be specified as being like
--         another node that has been previously defined.
--
      KTYPE: array (integer range 1..2, integer range 1..4) of character;
      ITYPE: integer;
      KNAME: string (1..6);
      JNAME: long_integer;
      JNUMBR: integer;
      IERR: integer;
      ISTOP: integer;
      I,J: integer;
      FLG: integer;
--
      Begin
      KTYPE:=(('L','F','M','S'),
         ('l','f','m','s'));
<<GET_NODE_TYPE>>
      Case ITYSND(INUMBR) is
         When FIXED => ITYPE := 2;
            New_line;
            Put("Type is Fixed");
         When MOVING => ITYPE := 3;
            New_line;
            Put("Type is Moving");
         When SATELLITE => ITYPE := 4;
            New_line;
            Put("Type is Satellite");
         When Others => ITYPE := 0;
            New_line;
            Put("Enter type: ");
      End Case;
      new_line;
      Get_line(INPUT_BUFFER, MAX);
      If BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
         Goto GOOD_NODE_TYPE;
      End If;
      If INPUT_BUFFER(1) = '=' Then
         Goto CHECK_FOR_ERROR;
      End If;
      If HELP_CHECK(INPUT_BUFFER(1..MAX)) THEN
         NODE_HELP (1);
         Goto GET_NODE_TYPE;
      End If;
--
--PROCESS THE TYPE CODE.
      FLG:=0;
      For I in 1..4 Loop
         ITYPE := I;
         If INPUT_BUFFER(1) = KTYPE(1,I) or
            INPUT_BUFFER(1) = KTYPE(2,I) Then
            FLG:=1;
            Exit;
         End If;
      End Loop;
      If FLG=0 then
         New_line;
         Put("Type is not valid...");
         Goto GET_NODE_TYPE;
      end if;
--
--GOOD NODE TYPE.  GET THE DATA FOR THIS NODE.
      NEW_TITLE_CHECK;
<<GOOD_NODE_TYPE>>
      If ITYPE < 1 Then
         Goto GET_NODE_TYPE;
      End If;
      If ITYPE = 1 Then  --NODE LIKE ANOTHER NODE.  GET NODE NAME.
         Loop
            New_line;
            Put("Like which node?");
            New_line;
            NODE_FETCH (KNAME, JNAME, JNUMBR, IERR);
            If IERR /= 0 Then
               New_line;
               Put("Node fetch error...No data created.");
               Goto CHECK_FOR_ERROR;
            End If;
            If JNUMBR > 0  Then
               NEW_TITLE_CHECK;
-- COPY DATA FROM NODE JNUMBR TO INUMBR
               ITYSND(INUMBR) := ITYSND(JNUMBR);
               NLSND(INUMBR) := NLSND(JNUMBR);
               NRSND(INUMBR) := NRSND(JNUMBR);
               NXSND(INUMBR) := NXSND(JNUMBR);
               for I in 1..4 loop
                  for J in 1..10 loop
                     XPSSND(I,J,INUMBR) := XPSSND(I,J,JNUMBR);
                  end loop;
               end loop;
               for I in 1..6 loop
               EPHSND(I,INUMBR) := EPHSND(I,JNUMBR);
               end loop;
               for I in 1..2 loop
                  for J in 1..15 loop
                     IRCSND(I,J,INUMBR) := IRCSND(I,J,JNUMBR);
                     IXTSND(I,J,INUMBR) := IXTSND(I,J,JNUMBR);
                  end loop;
               end loop;
               New_line;
               Put("Do you wish to modify this node? (Y/N): ");
               Get_LINE(INPUT_BUFFER, MAX);
               If (INPUT_BUFFER(1) = 'N') or (INPUT_BUFFER(1) = 'n') Then
                  Goto CHECK_FOR_ERROR;
               Else
                  Goto GET_NODE_TYPE;
               End If;
               New_line;
               Put("Node does not exist.");
            End If;
         End Loop;
      End If;
--
--ENTER NODE DATA.
      ITYSND(INUMBR) := NODE_TYPES'VAL(ITYPE - 1);
      NODE_DATA (INUMBR, ISTOP);
      If ISTOP = 0 Then
          IERRCD := 0;
      End If;
--
<<CHECK_FOR_ERROR>>
      If ITYPE = 0 Then
         IERRCD := 1;
      End If;
      If IERRCD = 0 Then
         Return;
      Else
         New_line;
         Put("Node data not saved.  Error code = ");
         Put(IERRCD);
      End If;
--
      End NODE_ADD;
--
--
      Procedure NODE_DATA (INUMBR: in integer; ISTOP: out integer) is
--
--PURPOSE: NODE_DATA is responsible for accepting and checking any data
--         entered for a given node.  It acquires all data which
--         depends on the type of node.
--
--AUTHOR:  J. Conrad
--
--TYPE:    I/O Processing
--
--PARAMETER DESCRIPTIONS:
--IN        INUMBR = The index number of the node being added.
--OUT       ISTOP  = The stop flag where,
--                      0 means that all additions were
--                        normal,
--                      1 means that an addition was terminated
--                        before completion.
--
--CALLED BY:
--         NODE_ADD
--
--CALLS TO:
--         BLANK_CHECK
--         ENTITY_DATA
--         HELP_CHECK
--         INTEGER_TO_ALPHA
--         LOCATION_DATA
--         NODE_HELP
--         PARSE
--
--TECHNICAL DESCRIPTION:
--         NODE_DATA accepts all data needed for each specific type of
--         node.  Any name of alphanumeric data is accepted as such
--         and converted to integer format before storing in NODNAM.
--         The operator may terminate an addition at any time simply
--         by entering an =.
--
      I,J: integer;
      LOCERR,IERR: integer;
--
      Begin
--
--LOCATION.
      ISTOP := 1;
      LOCATION_DATA(INUMBR, LOCERR);
      IF LOCERR /= 0 Then
         Return;
      End If;
--
--RECEIVERS.
      For I in 1..15 Loop
         J := I;
         ENTITY_DATA(1,J, NRSND(INUMBR), IRCSND, NUMREC, NAMREC,
                      ITPREC, INUMBR, IERR);
         Exit When IERR = 1;
      End Loop;
--
--TRANSMITTERS.
      For I in 1..15 Loop
         J := I;
         ENTITY_DATA(2,J, NXSND(INUMBR), IXTSND, NUMXMT, NAMXMT,
                      ITPXMT, INUMBR, IERR);
         Exit When IERR = 1;
      End Loop;
--
--ALL DATA ADDED.");
      ISTOP := 0;
      Return;
--
      End NODE_DATA;
--
--
      Procedure NODE_DISPLAY (IBUFF: in L_ARRAY; NV: in out integer) is
--
--PURPOSE: NODE_DISPLAY displays the requested nodes to either the print
--         or the monitor depending on the value of CURRENT_COMMAND.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Output module
--
--PARAMETER DESCRIPTIONS:
--IN        IBUFF  = The array containing the node numbers to be displayed.
--IN        NV     = The number of elements in IBUFF.
--
--CALLED BY:
--         NODE_HANDLER
--
--CALLS TO:
--         INTEGER_TO_ALPHA
--         NODE_FIND
--
--TECHNICAL DESCRIPTION:
--         NODE_DISPLAY displays only the nodes listed in the array IBUFF
--         as long as NV is not 0 on entry.  When NV is 0 this signals
--         that all nodes should be displayed, therefore if many nodes
--         exist, and the specified device is the monitor, this can cause
--         data to scroll off the screen.  Note that the standard output
--         device is switched from the monitor to the printer depending
--         on CURRENT_COMMAND.
--
      ICOMPL: boolean;
      I,II,J: integer;
      IERRCD: integer;
      KNAME: string(1..6);
      INUMBR: integer;
--
      Begin
--
--SET THE OUTPUT DEVICE.
      If CURRENT_COMMAND = PRINT Then
         SET_OUTPUT(PRINTER_OUTPUT_FILE);
      End If;
--
--GET THE NUMBER OF NODES TO DISPLAY AND THE DEVICE NUMBER.
      ICOMPL := FALSE;
      If NV = 0 or NV = NUMNOD Then
         ICOMPL := TRUE;
      End If;
--
--PRINT OUT REPORT HEADER.
      If ICOMPL Then
         New_line;
         Put(TITLE);
         New_line;New_line;
         Put("                    NODE SUMMARY");
         New_line;
         Put("               There are currently ");
         Put(NUMNOD);
         Put(" nodes.");
         New_line;
         NV := NUMNOD;
      End If;
--
--LOOP ON NUMBER OF NODES TO PRINT.
      If NV < 1 Then
         Return;
      End If;
--
      For II in 1..NV Loop
         NODE_FIND (KNAME, IBUFF(II), INUMBR, IERRCD);
         If IERRCD /= 0 Then
            --RESET THE OUTPUT DEVICE.
            If CURRENT_COMMAND = PRINT Then
                SET_OUTPUT(STANDARD_OUTPUT);
            End If;
            New_line;
            Put("Unable to access node ");
            Put(KNAME);
            Put("  Error = ");
            Put(IERRCD);
            --SET THE OUTPUT DEVICE.
            If CURRENT_COMMAND = PRINT Then
               SET_OUTPUT(PRINTER_OUTPUT_FILE);
            End If;
            Goto END_OF_LOOP;
         End If;
         If INUMBR < 1 Then
            --RESET THE OUTPUT DEVICE.
            If CURRENT_COMMAND = PRINT Then
                SET_OUTPUT(STANDARD_OUTPUT);
            End If;
            New_line;
            Put("Cannot find node ");
            Put(KNAME);
            --SET THE OUTPUT DEVICE.
            If CURRENT_COMMAND = PRINT Then
               SET_OUTPUT(PRINTER_OUTPUT_FILE);
            End If;
            Goto END_OF_LOOP;
         End If;
--
--PRINT HEADING
--NODE NAME.
--
--GET THE LOCATION DATA BASED ON TYPE.
         If ITYSND(INUMBR) = FIXED Then
            I := 1;
            New_line;New_line;New_line;New_line;New_line;
            Put(KNAME);
            Put(" is a fixed node.");
            New_line;New_line;
            Put("  North      East");
            New_line;
            Put("Latitude   Longitude   Altitude");
            New_line;
            Put("  (deg)      (deg)       (km)");
            New_line;
            For J in 2..4 Loop
               Put(XPSSND(J,I,INUMBR),5,1,0);
               Put("   ");
            End Loop;
         End If;
--
         If ITYSND(INUMBR) = MOVING Then
            New_line;New_line;New_line;New_line;New_line;
            Put(KNAME);
            Put(" is a moving node.");
            New_line;New_line;
            Put("               North      East");
            New_line;
            Put("Time (min)   Latitude   Longitude   Altitude");
            New_line;
            Put("               (deg)      (deg)       (km)");
            New_line;
            For I in 1..NLSND(INUMBR) Loop
               For J in 1..4 Loop
                  Put (XPSSND(J,I,INUMBR),5,2,0);
                  Put("   ");
               End Loop;
               New_line;
            End Loop;
         End If;
--
         If ITYSND(INUMBR) = SATELLITE Then
            New_line;New_line;New_line;New_line;New_line;
            Put(KNAME);
            Put(" is a satellite.");
            New_line;
            Put_line("                          Arg.of    East Long.");
            Put("SM-Axis   Eccen   Incln   Perigee   of Ascnd   ");
            Put_line("Time since Perigee");
            Put("  (km)            (deg)     (deg)   node (deg) ");
            Put_line(" (min)");
               Put(EPHSND(1,INUMBR),5,0,0);
               Put(EPHSND(2,INUMBR),3,3,0);
               Put("   ");
            For J in 3..6 Loop
               Put(EPHSND(J,INUMBR),5,0,0);
               Put("   ");
            End Loop;
            New_line;
         End If;
--
--RECEIVERS.
         If NRSND(INUMBR) >= 1 Then
            New_line;
            Put("Receiver   Class");
            For I in 1..NRSND(INUMBR) Loop
               INTEGER_TO_ALPHA (IRCSND(1,I,INUMBR), KNAME);
               New_line;
               Put(KNAME);
               INTEGER_TO_ALPHA (IRCSND(2,I,INUMBR), KNAME);
               Put("     ");
               Put(KNAME);
            End Loop;
         End If;
--
--TRANSMITTERS.
         If NXSND(INUMBR) >= 1 Then
            New_line;
            Put("Transmitter   Class");
            For I in 1..NXSND(INUMBR) Loop
               INTEGER_TO_ALPHA (IXTSND(1,I,INUMBR), KNAME);
               New_line;
               Put(KNAME);
               INTEGER_TO_ALPHA (IXTSND(2,I,INUMBR), KNAME);
               Put("        ");
               Put(KNAME);
            End Loop;
         End If;
--
<<END_OF_LOOP>>
         Null;
         New_line;
--
      End Loop;
--
--RESET THE OUTPUT DEVICE.
      If CURRENT_COMMAND = PRINT Then
         SET_OUTPUT(STANDARD_OUTPUT);
      End If;
--
      Return;
--
      End NODE_DISPLAY;
--
--
      Procedure NODE_FETCH (KNAME: out string;
                            INAME: out long_integer;
                            INUMBR: out integer;
                            IERRCD: out integer) is
--
--PURPOSE: NODE_FETCH obtains a node from the node data structure.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Table Look-up
--
--PARAMETER DESCRIPTIONS:
--OUT       KNAME  = Node name string.
--OUT       INAME  = The coded node name.
--OUT       INUMBR = The location of INAME in the node data structure.
--                   A value of zero (0) is returned if INAME
--                   cannot be located.
--OUT       IERRCD = The error code where 0 is normal or it is set to 1
--                   if the user types a =.
--
--CALLED BY:
--         NODE_ADD
--         NODE_HANDLER
--
--CALLS TO:
--         HELP_CHECK
--         NODE_FIND
--         NODE_HELP
--         PARSE
--
--TECHNICAL DESCRIPTION:
--         NODE_FETCH queries the operator for a node name, and then
--         does a table lookup in the node data structure for
--         the specified node.  When the node is located, its
--         position in the structure is returned in the variable
--         INUMBR.  If the node cannot be located, a value of zero
--         is returned in INUMBR.
--
--
      Begin
--
      IERRCD := 1;
<<GET_NODE_NAME>>
      New_line;
      Put("Enter node name: ");
      Get_LINE(INPUT_BUFFER, MAX);
      KNAME := INPUT_BUFFER(1..6);
      If INPUT_BUFFER(1) = '=' Then
         Return;
      End If;
      If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
         NODE_HELP (9);
         Goto GET_NODE_NAME;
      End If;
      NUMBER_OF_VARIABLES_TO_EXTRACT := -1;
      PARSE (INPUT_BUFFER(1..MAX));
      If NUMBER_OF_VARIABLES_EXTRACTED < 1 Then
         Goto GET_NODE_NAME;
      End If;
--
--FOUND NAME STRING.
      IERRCD := 0;
      INAME:=IARRAY(1);
      NODE_FIND (KNAME, IARRAY(1), INUMBR, IERRCD);
--
      Return;
--
      End NODE_FETCH;
--
--
      Procedure NODE_FIND (KNAME: out string;
                           INAME: in long_integer;
                           INUMBR: out integer;
                           IERRCD: out integer) is
--
--PURPOSE: NODE_FIND locates a node in the node data structure.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Table Look-up
--
--PARAMETER DESCRIPTIONS:
--OUT       KNAME  = Alphanumeric node name string.
--IN        INAME  = Coded node name.
--OUT       INUMBR = Location of INAME in the node data structure.
--                   A value of zero (0) is returned if INAME
--                   cannot be located.
--OUT       IERRCD = Error flag, any value greater than zero indicates
--                   an error has occured.
--
--CALLED BY:
--         NODE_DISPLAY
--         NODE_FETCH
--         NODE_HANDLER
--         NODE_REMOVE
--
--CALLS TO:
--         INTEGER_TO_ALPHA
--
--TECHNICAL DESCRIPTION:
--         NODE_FIND does a table lookup in the node data structure for
--         the specified node.  When the node is located, its
--         position in the structure is returned in the variable
--         INUMBR.  If the node cannot be located, a value of zero
--         is returned in INUMBR.
--
      I: integer;
--
      Begin
--
      IERRCD := 0;
--
--CONVERT NAME TO ALPHA.
      INTEGER_TO_ALPHA (INAME, KNAME);
--
      INUMBR := 0;
      IF NUMNOD < 1 Then
         INUMBR := 0;
         Return;
      End If;
--
--SEARCH THE DATA STRUCTURE FOR THE NODE.
      For I in 1..NUMNOD Loop
         INUMBR := I;
         If INAME = NAMNOD(I) Then
            Return;
         End If;
      End Loop;
      INUMBR := 0;
      Return;
--
      End NODE_FIND;
--
--
      Procedure NODE_HANDLER is
--
--PURPOSE: NODHND drives the node processing routines.
--
--AUTHOR:  J. Conrad
--
--TYPE:    I/O PROCESSING
--
--PARAMETER DESCRIPTIONS:
--         'NONE'
--
--CALLED BY:
--          MAIN
--          PRINT_HANDLER
--
--CALLS TO:
--         BLANK_CHECK
--         INTEGER_TO_ALPHA
--         NODE_ADD
--         NODE_DISPLAY
--         NODE_FETCH
--         NODE_FIND
--         NODE_REMOVE
--         PARSE
--
--TECHNICAL DESCRIPTION:
--         NODE_HANDLER serves as the driver for the routines which add,
--         delete, and modify nodes.
--
      INAME: L_ARRAY(1..MAXNOD);
      K,NV,IFLG: integer;
      KNAME: string(1..6);
      JNAME: long_integer;
      JNUMBR: integer;
      IERR: integer;
      IERRCD: integer;
      INUMBR: integer;
--
      Begin
--
      IFLG := 0;
--
      Case CURRENT_COMMAND is
       When ADD =>
<<ADD_NODE>>
         NODE_FETCH (KNAME, JNAME, JNUMBR, IERRCD);
         If KNAME(1) = '=' or IERRCD /= 0 Then return; End if;
         If JNUMBR >= 1 Then
            New_line;
            Put("Node ");
            Put(KNAME);
            Put(" already exists.");
            GoTo ADD_NODE;
          End If;
          If NUMNOD >= MAXNOD Then
             New_line;
             Put("No more nodes may be added.  Redimension node arrays.");
             Return;
          End If;
          NUMNOD := NUMNOD + 1;
          JNUMBR := NUMNOD;
          NAMNOD(JNUMBR) := JNAME;
--CLEARS NODE FOR INPUT
          ITYSND(JNUMBR):=NOTDEFINED;
          for I in 1..10 loop
             for J in 2..4 loop
                XPSSND(J,I,JNUMBR) := 0.0;
             end loop;
          end loop;
          for I in 1..6 loop
             EPHSND(I,JNUMBR) := 0.0;
          end loop;
          for I in 1..2 loop
             for J in 1..15 loop
                IRCSND(I,J,JNUMBR):=0;
                IXTSND(I,J,JNUMBR):=0;
             end loop;
          end loop;
          NLSND(JNUMBR) := 0;
          NRSND(JNUMBR) := 0;
          NXSND(JNUMBR) := 0;
--
          NODE_ADD (JNUMBR, IERRCD);
          If IERRCD = 0 Then
             Goto ADD_NODE;
          Else
             NUMNOD := NUMNOD - 1;
          End If;
--
--PROCESS THE VIEW OR PRINT COMMANDS.
     When VIEW | PRINT =>
         NV := NUMNOD;
         If NV >= 1 Then
            For K in 1..NV Loop
               INAME(K) := NAMNOD(K);
            End Loop;
            If not BLANK_CHECK(ARGUMENT_BUFFER) Then
               NUMBER_OF_VARIABLES_TO_EXTRACT := -40;
               PARSE (ARGUMENT_BUFFER);
               NV := NUMBER_OF_VARIABLES_EXTRACTED;
               For K in 1..NV Loop
                   INAME(K) := IARRAY(K);
               End Loop;
            End If;
         End If;
         NODE_DISPLAY (INAME, NV);
--
--PROCESS THE DELETION COMMAND.
      When DEL  =>
         Loop
            Exit When not BLANK_CHECK(ARGUMENT_BUFFER);
            New_line;
            Put("Enter the node names to be deleted, separated by spaces.");
            New_line;
            Get_Line(ARGUMENT_BUFFER, MAX);
         End Loop;
         If ARGUMENT_BUFFER(1) = '=' Then Return; End if;
         NUMBER_OF_VARIABLES_TO_EXTRACT := -40;
         PARSE (ARGUMENT_BUFFER);
         NV := NUMBER_OF_VARIABLES_EXTRACTED;
         If NV <= 0 Then
            NV := 1;
         End If;
         NODE_REMOVE (IARRAY, NV);
--
--PROCESS THE MODIFY COMMAND.
      When MODIFY =>
         Loop
            Exit When not BLANK_CHECK(ARGUMENT_BUFFER);
            New_line;
            Put("Enter the name of the node to be modified: ");
            Get_LINE(ARGUMENT_BUFFER,MAX);
         End Loop;
         If ARGUMENT_BUFFER(1) = '=' Then Return; end if;
         NUMBER_OF_VARIABLES_TO_EXTRACT := -1;
         PARSE (ARGUMENT_BUFFER);
         If NUMBER_OF_VARIABLES_EXTRACTED > 0 Then
            NODE_FIND (KNAME, IARRAY(1), INUMBR, IERRCD);
            If IERRCD /= 0 Then return; end if;
            If INUMBR <= 0 Then
               New_line;
               Put("Node name ");
               Put(KNAME);
               Put(" does not exist.");
               Return;
            End If;
            NODE_ADD (INUMBR, IERRCD);
          End If;
--
--INVALID COMMAND WARNING.
      When others => New_line;
      Put("The command code is not valid for node processing.");
      Return;
   end Case;
--
   end NODE_HANDLER;
--
--
      Procedure NODE_HELP (IWHO: in integer) is
--
--PURPOSE: NODE_HELP prints the various help messages as requested by
--         the operator for the different levels of node processing.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Operator assistance
--
--PARAMETER DESCRIPTIONS:
--IN        IWHO   = The indicator flag for which help message to print.
--
--CALLED BY:
--         ENTITY_DATA
--         LOCATION_DATA
--         NODE_ADD
--         NODE_DATA
--         NODE_FETCH
--
--CALLS TO:
--         'NONE'
--
--TECHNICAL DESCRIPTION:
--         NODE_HELP prints the various help messages as requested by
--         the operator for the different levels of node processing.
--         The particular help message printed depends on the value
--         of IWHO input.
--
      Begin
--
--SELECT THE HELP MESSAGE TO DISPLAY.
      If IWHO = 1 Then
         New_line;
         Put("Select the node type as one of the following:");
         New_line;
         Put("    Fixed;");
         New_line;
         Put("    Moving; or,");
         New_line;
         Put("    Satellite.");
         New_line; New_line;
         Put("Or, you may also enter L or LIKE to set this node up exactly");
         New_line;
         Put("like some other node.");
         New_line;New_line;
      End If;
--
      If IWHO = 2 Then
         New_line;
         Put("Enter the latitude (degrees -90 to 90, positive north),");
         Put(" longitude (degrees");
         New_line;
         Put("-180 to 180, positive east), and altitude (kilometers),");
         Put(" separated by blanks.");
         New_line;New_line;
      End If;
--
      If IWHO = 3 Then
         New_line;
         Put("Enter the time (minutes), latitude (degrees -90 to 90,");
         Put(" positive north),");
         New_line;
         Put("longitude (degrees -180 to 180, positive, east), and");
         Put(" altitude (kilometers),");
         New_line;
         Put("separated by blanks.");
         New_line;New_line;
      End If;
--
      If IWHO = 4 Then
         New_line;
         Put("The ephemeride data consist of six items:");
         New_line;
         Put(" 1 - the semi-major axis of the elliptical orbit");
         Put(" (0 - 200,000 km);");
         New_line;
         Put(" 2 - the eccentricity of the orbital ellipse (0 - 1);");
         New_line;
         Put(" 3 - the inclination of the orbital plane to the equitorial");
         New_line;
         Put("     plane(0 to 180 degrees);");
         New_line;
         Put(" 4 - the argument of perigee (-180 to 180 degrees);");
         New_line;
         Put(" 5 - the longitude of the ascending node");
         Put(" (-180 to 180 degrees);");
         New_line;
         Put(" 6 - the time since perigee (minutes).");
         New_line;New_line;
      End If;
--
      If IWHO = 7 Then
         New_line;
         Put("Enter the name of the receiver (up to six characters,");
         Put(" it should be unique for");
         New_line;
         Put("this node), and the receiver class name (up to six");
         Put(" characters).  If the");
         New_line;
         Put("receiver class does not already exist, a null receiver");
         Put(" class record will be");
         New_line;
         Put("created.");
         New_line;New_line;
      End If;
--
      If IWHO = 8 Then
         New_line;
         Put("Enter the name of the transmitter (up to six characters)");
         Put(" and the transmitter");
         New_line;
         Put("class name (up to six characters).  If the transmitter");
         Put(" class does not already");
         New_line;
         Put("exist, a null transmitter class record will be created.");
         New_line;New_line;
      End If;
--
      If IWHO = 9 then
         NEW_LINE;
         Put("Enter a six character, alpha-numeric node name. ");
         Put("If an = is entered, control is "); NEW_LINE;
         Put("returned to the executive and no data for this node");
         Put(" is entered.  If a carriage"); NEW_LINE;
         Put("return is entered, the node name prompt will be repeated.");
         NEW_LINE;
         Return;
      End if;
--
      If IWHO = 1 or IWHO = 2 or IWHO = 4 then
         Put("If the value displayed is satisfactory, then enter a");
         Put(" carriage return.  An =");
         New_line;
         Put("terminates the entry of this node with the information");
         Put(" entered to this point");
         New_line;
         Put("lost, unless this addition is -like- some other node or");
         Put(" if the node is being");
         New_line;
         Put("modified, then it is saved.");
         New_line;
         Return;
      end if;
      If IWHO = 3 or IWHO = 7 or IWHO = 8 then
         Put("If the data displayed are satisfactory, then enter a");
         Put(" carriage return.  An =");
         New_line;
         Put("terminates the entry for this sequence with the information");
         Put(" entered to this");
         New_line;
         Put("point saved.");
         New_line;
         Return;
      end if;
      Put("No help"); New_line;
      Return;
--
      End NODE_HELP;
--
--
      Procedure NODE_REMOVE (INAME: in L_ARRAY;
                             NUMBR: in integer) is
--
--PURPOSE: NODE_REMOVE removes nodes from the network.
--
--AUTHOR:  J. Conrad
--
--TYPE:    I/O Processing
--
--PARAMETER DESCRIPTIONS:
--IN        INAME  = The array containing the node names to be deleted.
--IN        NUMBR  = The number of node names in INAME.
--
--CALLED BY:
--         NODE_HANDLER
--
--CALLS TO:
--         NEW_TITLE_CHECK
--         NODE_FIND
--
--TECHNICAL DESCRIPTION:
--         NODE_REMOVE removes nodes from the database.  The pointer into
--         the node data array is adjusted for all nodes with an index
--         greater than the node being deleted; thereby effectively
--         overwriting the node data of the node to be deleted.
--
      I,N,IPT,L: integer;
      J, IERR: integer;
      KNAME: string(1..6);
--
      Begin
--
--LOOP ON ALL ELEMENTS TO BE REMOVED.
      For I in 1..NUMBR Loop
         NODE_FIND (KNAME, INAME(I), J, IERR);
         If J <= 0 Then
            New_line;
            Put("Node ");
            Put(KNAME);
            Put(" not found...no action taken.");
            Return;
         End If;
         NEW_TITLE_CHECK;
         N := NUMNOD - 1;
         If N >= J Then
            IPT := IPTNOD(J);
            For L in J..N Loop
               NAMNOD(L) := NAMNOD(L+1);
               IPTNOD(L) := IPTNOD(L+1);
            End Loop;
            IPTNOD(NUMNOD) := IPT;
            NAMNOD(NUMNOD) := 0;
         End If;
         NUMNOD := N;
      End Loop;
--
      Return;
--
      End NODE_REMOVE;
--
--
      Procedure LOCATION_DATA ( INUMBR: in integer; LOCERR: out integer ) is
--
--PURPOSE: LOCATION_DATA acquires the data for a single node location.
--
--AUTHOR:  J. Conrad
--
--TYPE:    I/O Processing
--
--PARAMETER DESCRIPTIONS:
--IN        INUMBR = The index number of the node being addressed.
--OUT       LOCERR = Flag set to 1 if = is read for a fixed
--                   location or node type is invalid.
--
--CALLED BY:
--         NODE_DATA
--
--CALLS TO:
--         BLANK_CHECK
--         HELP_CHECK
--         NEW_TITLE_CHECK
--         NODE_HELP
--         PARSE
--
--TECHNICAL DESCRIPTION:
--         LOCATION_DATA is responsible for accepting and checking the
--         location data for a single node.  It acquires
--         latitude, longitude and altitude for fixed and moving
--         locations and acquires ephemeride data for satellites.
--
      I,J: integer;
      NLOC: integer;
--
      Begin
--
      LOCERR := 1;
--
--GET THE LOCATION DATA BASED ON TYPE.
--
      If ITYSND(INUMBR) = FIXED Then
         NLSND(INUMBR) := 1;
<<FIXED_NODE>>
         New_line;
         Put("  Latitude   Longitude   Altitude");
         New_line;
         Put(XPSSND(2,1,INUMBR),5,1,0);
         Put("   ");
         Put(XPSSND(3,1,INUMBR),5,1,0);
         Put("  ");
         Put(XPSSND(4,1,INUMBR),5,1,0);
         New_line;
         Get_LINE(INPUT_BUFFER,MAX);
         If INPUT_BUFFER(1) = '=' Then
            Return;
         End If;
         IF HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
            NODE_HELP (2);
            Goto FIXED_NODE;
         End If;
         If BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
            LOCERR := 0;
            Return;
         End If;
         NUMBER_OF_VARIABLES_TO_EXTRACT := 3;
         PARSE (INPUT_BUFFER(1..MAX));
         If NUMBER_OF_VARIABLES_EXTRACTED /= 3 or
            XARRAY(1) < -90.0 or XARRAY(1) > 90.0 or
            XARRAY(2) < -180.0 or XARRAY(2) > 180.0 or
            XARRAY(3) < 0.0 Then
            New_line;
            Put("Format error...re-enter data.");
            Goto FIXED_NODE;
         End If;
         For J in 2..4 Loop
            XPSSND(J,1,INUMBR) := XARRAY(J-1);
         End Loop;
         NEW_TITLE_CHECK;
         LOCERR := 0;
         Return;
      End If;
--
      If ITYSND(INUMBR) = MOVING Then
<<MOVING_NODE>>
         New_line;
         Put("  Time   Latitude   Longitude   Altitude");
         For I in 1..10 Loop
<<TOP>>
            New_line;
            Put(XPSSND(1,I,INUMBR),5,0,0);
            Put("   ");
            Put(XPSSND(2,I,INUMBR),5,1,0);
            Put("   ");
            Put(XPSSND(3,I,INUMBR),5,1,0);
            Put("  ");
            Put(XPSSND(4,I,INUMBR),5,1,0);
            New_line;
            Get_LINE(INPUT_BUFFER,MAX);
            If INPUT_BUFFER(1) = '=' Then
               NLSND(INUMBR) := I - 1;
               LOCERR := 0;
               Return;
            End If;
            If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
               NODE_HELP (3);
               Goto TOP;
            End If;
            If BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
               Goto BOTTOM;
            End If;
            NUMBER_OF_VARIABLES_TO_EXTRACT := 4;
            PARSE (INPUT_BUFFER(1..MAX));
            If NUMBER_OF_VARIABLES_EXTRACTED /= 4 or
               XARRAY(2) < -90.0 or XARRAY(2) > 90.0 or
               XARRAY(3) < -180.0 or XARRAY(3) > 180.0 or
               XARRAY(4) < 0.0  Then
               New_line;
               Put("Format error...re-enter data.");
               Goto TOP;
            End If;
            For J in 1..4 Loop
               XPSSND(J,I,INUMBR) := XARRAY(J);
            End Loop;
            NEW_TITLE_CHECK;
<<BOTTOM>>
            Null;
         End Loop;
         NLSND(INUMBR) := 10;
         LOCERR := 0;
         Return;
      End If;
--
      If ITYSND(INUMBR) = SATELLITE Then
         New_line;
         Put("SM-Axis   Eccen   Incln   Perigee   Ascnd   Time");
<<SATELLITE_NODE>>
         New_line;
         Put(EPHSND(1,INUMBR),5,0,0);
         Put(EPHSND(2,INUMBR),5,3,0);
         Put(" ");
         For J in 3..6 Loop
            Put(EPHSND(J,INUMBR),6,0,0);
         End Loop;
         New_line;
         Get_LINE(INPUT_BUFFER,MAX);
         If INPUT_BUFFER(1) = '=' Then
            Return;
         End If;
         If HELP_CHECK(INPUT_BUFFER(1..MAX)) Then
           NODE_HELP (4);
            Goto SATELLITE_NODE;
         End If;
         IF BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
            LOCERR := 0;
            Return;
         End If;
         NUMBER_OF_VARIABLES_TO_EXTRACT := 6;
         PARSE (INPUT_BUFFER(1..MAX));
         If NUMBER_OF_VARIABLES_EXTRACTED /= 6 or
            XARRAY(1) < 0.0 or XARRAY(1) > 200000.0 or
            XARRAY(2) < 0.0 or XARRAY(2) > 1.0 or
            XARRAY(3) < 0.0 or XARRAY(3) > 180.0 or
            XARRAY(4) < -180.0 or XARRAY(4) > 180.0 or
            XARRAY(5) < -180.0 or XARRAY(5) > 180.0 Then
            New_line;
            Put("Format error...re-enter data.");
            Goto SATELLITE_NODE;
         End If;
         For J in 1..6 Loop
            EPHSND(J,INUMBR) := XARRAY(J);
         End Loop;
         NEW_TITLE_CHECK;
         NLSND(INUMBR) := 0;
         LOCERR := 0;
         Return;
      End If;
--
      Return;
--
      End LOCATION_DATA;
--
--
End NODES;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--EXECUTIVE
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Text_IO; use Text_io;
With Helps; use Helps;
With Types; use Types;
With Constants; use Constants;
--
Package EXECUTIVE is
      Procedure COMMAND_LINE_PROCESSOR;
      Procedure INTERPRET_ENTITY;
End EXECUTIVE;
--
Package body EXECUTIVE is
--
-- EXECUTIVE Package of PROP_LINK Version 1.0,  February 16, 1985.
--
-- This EXECUTIVE Package contains the MAIN program as well as all
-- command line interpretation procedures.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
Procedure COMMAND_LINE_PROCESSOR is
--
--PURPOSE:COMMAND_LINE_PROCESSOR is the Command Line Processor.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Input Conversion
--
--PARAMETER DESCRIPTIONS:
--          'NONE'
--
--CALLED BY:
--          MAIN
--
--CALLS TO:
--          INTERPRET_ENTITY
--          HELP_CHECK
--          SHIFT_LEFT
--
--TECHNICAL DESCRIPTION:
--         This procedure decodes the command line in terms of commands and
--         entities.  If an entity is associated with the command, a call to
--         INTERPRET_ENTITY is made to decode the entity as well.
--
      I,J,K,FLG: integer;
      KOMAND: array (integer range 1..2, integer range 0..8) of character;
--
Begin
      KOMAND :=(('R','W','P','V','S','G','A','D','M'),
               ('r','w','p','v','s','g','a','d','m'));

<<ACCEPT_INPUT>>
      New_line;
      Put("Type H for help or enter command: ");
      for I in INPUT_BUFFER'RANGE loop
         INPUT_BUFFER(I):=' ';
      end loop;
      Get_line(INPUT_BUFFER, MAX);
      If INPUT_BUFFER(1)='H' or INPUT_BUFFER(1)='h' Then
         New_line;
         Put("The proper format is:"); New_line;
         Put("<Command> <Entity> <Argument>"); New_line; New_line;
         Put("The valid commands are:"); New_line; New_line;
         Put("Read   -- recovers an existing data base;"); New_line;
         Put("Write  -- saves the current data base;"); New_line;
         Put("Print  -- outputs the current data base"); New_line;
         Put("          (one or all entities) to a print file;"); New_line;
         Put("View   -- displays the current data base"); New_line;
         Put("          (one or all entities) on the monitor;"); New_line;
         Put("Stop   -- halts program execution;"); New_line;
         Put("Go     -- begins RF propagation calculations;"); New_line;
         Put("Add    -- adds an entity to the current data base;"); New_line;
         Put("Delete -- removes an entity from the current data base; and,");
         New_line;
         Put("Modify -- modifies an entity in the current data base.");
         New_line;
         Goto ACCEPT_INPUT;
      End If;
--CHECK FOR TYPE OF COMMAND
      FLG:=0;
      SEARCH:
      For I in KOMAND'RANGE(1) Loop
         For J in KOMAND'RANGE(2) Loop
            IF INPUT_BUFFER(1) = KOMAND(I,J) Then
               K:=J;
               FLG := 1;
               EXIT SEARCH;
            End If;
         End Loop;
      End Loop SEARCH;
      If FLG=0 then
         Put_line(" That command is not valid...");
         Goto ACCEPT_INPUT;
      End if;
--
<<FOUND_COMMAND>>
      CURRENT_COMMAND := COMMAND'VAL(K);
      If (CURRENT_COMMAND = STOP) or (CURRENT_COMMAND = GO) Then
         Return;
      End If;
--SEARCH FOR END OF COMMAND
      FLG:=0;
      For I in INPUT_BUFFER'RANGE Loop
         If INPUT_BUFFER(1) = ' ' Then
            FLG:=1;
            Exit;
         End If;
         SHIFT_LEFT(INPUT_BUFFER);
      End Loop;
      If FLG=0 then
         New_line;
         Put("No blank found after command...");
         Goto ACCEPT_INPUT;
      End if;
--
<<CHECK_ENTITY>>
      INTERPRET_ENTITY;
      If (CURRENT_COMMAND = READ) or (CURRENT_COMMAND = WRITE) Then
         Return;
      End If;
      If CURRENT_ENTITY = ENTITY_ERROR and CURRENT_COMMAND /= PRINT Then
        Goto ACCEPT_INPUT;
      End If;
--
      End COMMAND_LINE_PROCESSOR;
--
Procedure INTERPRET_ENTITY is
--
--PURPOSE: INTERPRET_ENTITY searches for the command line entity and
--         decodes it.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Conversion Module
--
--PARAMETER DESCRIPTIONS:
--          'NONE'
--
--CALLED BY:
--          COMMAND_LINE_PROCESSOR
--CALLS TO:
--         BLANK_CHECK
--         HELP_CHECK
--         SHIFT_LEFT
--
--TECHNICAL DESCRIPTION:
--         This procedure searches for valid entities based on the first
--         letter of the entity.  A simple LOOP type search and compare
--         over the possible entity types is used.
--
      I,J,K,FLG: integer;
      KNT: array (integer range 1..2, integer range 0..2) of character;
--
      Begin
      KNT := (('R','T','N'),
             ('r','t','n'));
      CURRENT_ENTITY := ENTITY_ERROR;
      For I in ENTITY_BUFFER'RANGE Loop
         ENTITY_BUFFER(I) := ' ';
      End Loop;
--SEARCH FOR ENTITY
      FLG:=0;
      For I in INPUT_BUFFER'RANGE Loop
         If INPUT_BUFFER(1) /= ' ' Then
            FLG:=1;
            Exit;
         End If;
         SHIFT_LEFT(INPUT_BUFFER);
      End Loop;
      If FLG=1 then
         Goto DECODE_ENTITY;
      End if;
--NO ENTITY FOUND SO GET THE ENTITY, UNLESS A PRINT COMMAND.
      IF CURRENT_COMMAND = PRINT Then
         Return;
      End If;
--
<<GET_ENTITY>>
      If (CURRENT_COMMAND = READ) or (CURRENT_COMMAND = WRITE) Then
         New_line;
         Put(" Enter the filename: ");
      Else
         New_line;
         Put(" Enter the entity: ");
      End If;
      Get_LINE(INPUT_BUFFER,MAX);
      IF INPUT_BUFFER(1)='H' or INPUT_BUFFER(1)='h' Then
         New_line;
         Put("The valid entities are:"); New_line;New_line;
         Put("Node;"); New_line;
         Put("Receiver; and,"); New_line;
         Put("Transmitter."); New_line;
         Goto GET_ENTITY;
      End If;
--
<<DECODE_ENTITY>>
      IF (CURRENT_COMMAND = READ) or (CURRENT_COMMAND = WRITE) Then
         Goto BLANK_BUFFER_TEST;
      End If;
      FLG:=0;
      SEARCH:
      For I in KNT'RANGE(1) Loop
          For J in KNT'RANGE(2) Loop
            If INPUT_BUFFER(1) = KNT(I,J) Then
               K:=J;
               FLG:=1;
               Exit SEARCH;
            End If;
          End Loop;
      End Loop SEARCH;
      If FLG=1 then
         Goto FOUND_ENTITY;
      End if;
      If (CURRENT_COMMAND = READ) or (CURRENT_COMMAND = WRITE) or
         (CURRENT_COMMAND = PRINT) Then
         Return;
      End If;
--A VALID ENTITY WAS NOT FOUND.
      New_line;
      Put(" There is an entity error...");
      Goto GET_ENTITY;
--
<<FOUND_ENTITY>>
--REMOVE THE REST OF THE ENTITY.
      CURRENT_ENTITY := ENTITY'VAL(K);
      For I in INPUT_BUFFER'RANGE Loop
         If INPUT_BUFFER(1) = ' ' Then
            Exit;
         Else
         SHIFT_LEFT(INPUT_BUFFER);
         End If;
      End Loop;
--FIND THE START OF THE ARGUMENT BUFFER.
      For I in INPUT_BUFFER'RANGE Loop
         If INPUT_BUFFER(1) /= ' ' Then
            exit;
         Else
            SHIFT_LEFT(INPUT_BUFFER);
         End If;
      End Loop;
      Goto BUFFER_COPY;
--
<<BLANK_BUFFER_TEST>>
      If BLANK_CHECK(INPUT_BUFFER(1..MAX)) Then
         Goto GET_ENTITY;
      End If;
--
<<BUFFER_COPY>>
--COPY OVER THE ARGUMENT BUFFER FOR USE IN THE HANDLERS.
      For I in INPUT_BUFFER'RANGE Loop
         ARGUMENT_BUFFER(I) := INPUT_BUFFER(I);
      End Loop;
--
      End INTERPRET_ENTITY;
--
End EXECUTIVE;
--

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--IOANDFILE
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With debugger2; Use debugger2;
With Text_IO; Use Text_io, Float_io, Integer_io, Long_integer_io;
with Types; Use Types;
with Constants; use Constants;
with Constant2; use Constant2;
with Constant3; use Constant3;
with Nodes;
with Entityuti; use Entityuti;
Package IOANDFILE is
--
--    Type REAL is digits 6;
--
      Procedure READ_HANDLER;
      Procedure WRITE_HANDLER;
--
--
End IOANDFILE;
--
Package body IOANDFILE is
--
-- IO_AND_FILE_HANDLERS Package of PROP_LINK Version 1.0,  February 21, 1985.
--
-- This IO_AND_FILE_HANDLERS Package contains all of the procedures that
-- are used to perform file input and output.
--
-- PROP_LINK is the Ada version of STRATLINK, a FORTRAN stand-alone
-- radio frequency propagation prediction code.
--
-- PROP_LINK has been developed for the Department of Defense under
-- contract N66001-85-C-0042 by IWG Corp. (Bruce Perry) and StratCom
-- Systems Inc. (Jim Conrad).
--
-- Instantiate integer and floating point IO.
--    Package IO_INTEGER is new INTEGER_IO(INTEGER);
--    Package IO_FLOAT is new FLOAT_IO(FLOAT);
--    Use IO_INTEGER,IO_FLOAT;
--
--
--  VARIABLES:
      IUNIT: FILE_TYPE;
--
--
      Procedure ENSORT (NUMENT: in integer;
                        NAMENT: in L_ARRAY;
                        INDEX: out I_ARRAY) is
--
--#PURPOSE: ENSORT performs an alphabetical sort of entities.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Input
--
--#PARAMETER DESCRIPTIONS:
--IN        NUMENT := number of enties to be sorted.
--IN        NAMENT := array of entities to be sorted.
--OUT       INDEX  := pointer array of sorted names.
--
--#CALLED BY:
--          WRTNOD
--          WRTREC
--          WRTXMT
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          ENSORT sorts the array of entities into alphabetical order.
--          The algorithm employed is a shell sort technique that has
--          been adapted from D. Knuth's "Art of Computer Programming".
--
      INCR,INCR1,INDX, I: integer;
      NAME: long_integer;
--
      Begin
--
      For I in 1..NUMENT Loop
         INDEX(I) := I;
      End Loop;
      If NUMENT <= 1  Then
         Return;
      End If;
      INCR := 13;
--
      Loop
         Exit When INCR >= NUMENT;
         INCR := 3*INCR + 1;
      End Loop;
--
      INCR := INCR/3;
--
-- MAJOR SORT LOOP
      Loop
         INCR := INCR/3;
         If INCR < 1 Then
            Return;
         End If;
         INCR1 := INCR + 1;
         For J in INCR1..NUMENT Loop
            I := J - INCR;
            INDX := INDEX(J);
            NAME := NAMENT(INDX);
            Loop
               Exit When NAME >= NAMENT(INDEX(I));
               INDEX(I+INCR) := INDEX(I);
               I := I - INCR;
               Exit When I <= 0;
            End Loop;
            INDEX(I+INCR) := INDX;
         End Loop;
      End Loop;
--
      End ENSORT;
--
--
      Procedure REDNOD is
--
--#PURPOSE: REDNOD reads the node data from the disk file.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Input
--
--#PARAMETER DESCRIPTIONS:
--IN        'NONE'
--
--#CALLED BY:
--          READ_HANDLER
--
--#CALLS TO:
--          INITIALIZE_NODES
--
--#TECHNICAL DESCRIPTION:
--          REDNOD reads the node data from the disk file using a
--          series of Get statements.
--
--          Note that NKSND, TPKSND, TTRNOD, NPSND IPRSND and PROSND
--          are only read to be compatible with SIMSTAR/StratSim/StratLink
--          data bases.  Also note that both the old (IFORM /= 1) and
--          new SIMSTAR database formats may be read.
--
      J,K: Integer;
      IFORM, INODE, NKSND, NPSND, IPRSND, ITYPE: Integer;
      TPKSND, TTRNOD, PROSND: float;
      NAME1, NAME2: string(1..6);
      DUMMY: string(1..4);
--
     Begin
--
--BEGIN THE INPUT OPERATION.
      NODES.INITIALIZE_NODES;
--
      Get(NUMNOD, 5);
      Get(IFORM, 5);
      If NUMNOD <= 0 Then
         Return;
      End If;
--
      For INODE in 1..NUMNOD Loop
         If IFORM /= 1 Then
            Skip_line;
            Get(NAMNOD(INODE), 15);
         Else
            Skip_Line;
            Get(NAME1);
            ALPHA_TO_INTEGERIZED_ALPHA(NAME1, NAMNOD(INODE));
         End If;
--
         Skip_Line;
         Get(ITYPE, 5);
         Case ITYPE is
            When 1 => ITYSND(INODE) := FIXED;
            When 2 => ITYSND(INODE) := MOVING;
            When 3 => ITYSND(INODE) := SATELLITE;
            When Others => New_Line;
               Put("ERROR in REDNOD...unknown node type.");
         End Case;
         Get(NLSND(INODE), 7);
         Get(NKSND, 7);
         Get(NRSND(INODE), 7);
         Get(NXSND(INODE), 7);
         Get(NPSND, 7);
         If ITYSND(INODE) = SATELLITE Then
            Skip_line;
            For J in 1..5 Loop
               Get(EPHSND(J,INODE), 15);
            End Loop;
            Skip_line;
            Get(EPHSND(6,INODE), 15);
         End If;
         If NLSND(INODE) > 0 Then
            For K in 1..NLSND(INODE) Loop
               For J in 1..4 Loop
                  If (4*(K-1)+J) rem 5 = 1 Then
                     Skip_Line;
                  End If;
                  Get(XPSSND(J,K,INODE), 15);
               End Loop;
            End Loop;
         End if;
         If NKSND > 0 Then
            For K in 1..NKSND Loop
               For J in 1..2 Loop
                  If (2*(K-1)+J) rem 5 = 1 Then
                     Skip_Line;
                  End If;
                  Get(TPKSND, 15);
               End Loop;
            End Loop;
            Skip_Line;
            Get(TTRNOD, 15);
         End If;
         If IFORM /= 1 Then
            If NRSND(INODE) > 0 Then
               For K in 1..NRSND(INODE) Loop
                  Skip_Line;
                  Get(IRCSND(1,K,INODE), 15);
                  Get(IRCSND(2,K,INODE), 17);
               End Loop;
            End If;
            If NXSND(INODE) > 0 Then
               For K in 1..NXSND(INODE) Loop
                  Skip_Line;
                  Get(IXTSND(1,K,INODE), 15);
                  Get(IXTSND(2,K,INODE), 17);
               End Loop;
            End If;
            If NPSND > 0 Then
               For K in 1..NPSND Loop
                  For J in 1..5 Loop
                     If J = 1 Then
                        Skip_Line;
                        Get(IPRSND, 15);
                     Else
                        Get(IPRSND, 16);
                     End If;
                  End Loop;
               End Loop;
            End If;
         Else
-- IFORM = 1 so read the names and convert them to integer.
            If NRSND(INODE) > 0 Then
               For K in 1..NRSND(INODE) Loop
                  Skip_Line;
                  Get(NAME1);
                  Get(DUMMY); -- Skip four spaces;
                  Get(NAME2);
                  ALPHA_TO_INTEGERIZED_ALPHA(NAME1,IRCSND(1,K,INODE));
                  ALPHA_TO_INTEGERIZED_ALPHA(NAME2,IRCSND(2,K,INODE));
               End Loop;
            End If;
            If NXSND(INODE) > 0 Then
               For K in 1..NXSND(INODE) Loop
                  Skip_Line;
                  Get(NAME1);
                  Get(DUMMY); -- Skip four spaces;
                  Get(NAME2);
                  ALPHA_TO_INTEGERIZED_ALPHA(NAME1,IXTSND(1,K,INODE));
                  ALPHA_TO_INTEGERIZED_ALPHA(NAME2,IXTSND(2,K,INODE));
               End Loop;
            End If;
            If NPSND > 0 Then
               For K in 1..NPSND Loop
                  Skip_Line;
               End Loop;
               For K in 1..NPSND Loop
                  For J in 1..4 Loop
                     If (4*(K-1)+J) rem 5 = 1 Then
                        Skip_Line;
                     End If;
                     Get(PROSND);
                  End Loop;
               End Loop;
            End If;
         End If;
--
      End Loop;
--
      Return;
--
      End REDNOD;
--
--
      Procedure REDREC is
--
--#PURPOSE: REDREC reads the receiver class data from the disk file.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Input
--
--#PARAMETER DESCRIPTIONS:
--IN        'NONE'
--
--#CALLED BY:
--          READ_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          REDREC reads the receiver class data from the disk file
--          using a series of Get statements.
--
--          Note that MODREC, SLBREC, BEMREC, NPHREC, ICRREC, FNDREC,
--          KBFREC, LRCREC, NSLREC, PFTIME, PFVAL, TTRREC, and NRPF
--          are only read to be compatible with SIMSTAR/StratSim/StratLink
--          data bases.  Also note that both the old (IFORM /= 1) and
--          new SIMSTAR database formats may be read.
--
      NAME: string(1..6);
      I, J, IFLAG, ICRREC, ITYPE, MODREC, NPHREC, KBFREC: Integer;
      LRCREC, NSLREC: Integer;
      SLBREC, BEMREC, FMDREC, PFTIME, PFVAL, TTRREC: Float;
      NRPF: array (integer range 1..99) of integer;
      DUMMY: string(1..4);
--
      Begin
--
--BEGIN THE INPUT OPERATION.
      Get(NUMREC, 5);
      Get(IFLAG, 5);
      If NUMREC <= 0 Then
         Return;
      End If;
--
      If IFLAG /= 1 Then
         For I in 1..NUMREC Loop
            If I rem 4 = 1 Then
               Skip_Line;
               Get(NAMREC(I), 15);
            Else
               Get(NAMREC(I), 17);
            End If;
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 10 = 1 Then
               Skip_Line;
               Get(ITYPE, 5);
            Else
               Get(ITYPE, 7);
            End If;
            begin
               ITPREC(I) := BAND_TYPES'VAL(ITYPE+1);
            exception
               when CONSTRAINT_ERROR =>
                  Put_line("ERROR in REDREC...unknown receiver type.");
            End;
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 10 = 1 Then
               Skip_Line;
               Get(MODREC, 5);
            Else
               Get(MODREC, 7);
            End If;
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 10 = 1 Then
               Skip_Line;
               Get(IATREC(I), 5);
            Else
               Get(IATREC(I), 7);
            End If;
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(FREREC(I), 15);
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(GTREC(I), 15);
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(BWREC(I), 15);
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(RLLREC(I), 15);
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(BEMREC, 15);
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 10 = 1 Then
               Skip_Line;
               Get(NPHREC, 5);
            Else
               Get(NPHREC, 7);
            End If;
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 10 = 1 Then
               Skip_Line;
               Get(ICRREC, 5);
            Else
               Get(ICRREC, 7);
            End If;
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(FMDREC, 15);
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 10 = 1 Then
               Skip_Line;
               Get(KBFREC, 5);
            Else
               Get(KBFREC, 7);
            End If;
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 10 = 1 Then
               Skip_Line;
               Get(LRCREC, 5);
            Else
               Get(LRCREC, 7);
            End If;
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 10 = 1 Then
               Skip_Line;
               Get(NSLREC, 5);
            Else
               Get(NSLREC, 7);
            End If;
         End Loop;
--
--INPUT THE ADDITIONAL ANTENNA CHARACTERISTICS NEEDED FOR
--CONSTANT GAIN (5), RHOMBIC (6), VERTICAL (7) AND
--HORIZONTAL HALF WAVE DIPOLE (8) ANTENNA TYPES.
         For I in 1..NUMREC Loop
            If IATREC(I) > 4 and IATREC(I) < 9 Then
               Skip_Line;
               If IATREC(I) = 5 Then
                  Get(ANTGNR(I), 15);
               Elsif IATREC(I) = 6 Then
                  Get(ANTTAR(I), 15);
                  Get(ANTHTR(I), 15);
                  Get(ANTLNR(I), 15);
               Elsif IATREC(I) = 7 Then
                  Get(ANTLNR(I), 15);
               Elsif IATREC(I) = 8 Then
                  Get(ANTHTR(I), 15);
               End If;
            End If;
         End Loop;
--
         For I in 1..NUMREC Loop
            If I rem 10 = 1 Then
               Skip_Line;
               Get(NRPF(I), 5);
            Else
               Get(NRPF(I), 7);
            End If;
         End Loop;
         For I in 1..NUMREC Loop
            If NRPF(I) > 0 Then
               For J in 1..2*NRPF(I) Loop
                  If J rem 5 = 1 Then
                     Skip_Line;
                  End If;
                  Get(PFTIME, 15);  --PFVAL is actually every other Get.
               End Loop;
            End If;
         End Loop;
         For I in 1..NUMREC Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(TTRREC, 15);
         End Loop;
      Else
--
-- INPUT FILE IS IN "NEW" FORMAT, EACH RECEIVER HAS ALPHA NAME AND ALL
-- DATA TOGETHER
--
         For I in 1..NUMREC Loop
            Skip_Line;
            Get(NAME);
            ALPHA_TO_INTEGERIZED_ALPHA(NAME,NAMREC(I));
            Get(DUMMY);      -- Skip 4 spaces.
            Get(ITYPE, 5);
            begin
               ITPREC(I) := BAND_TYPES'VAL(ITYPE+1);
            exception
               When CONSTRAINT_ERROR =>
                  Put_line("ERROR in REDREC...unknown receiver type.");
            End;
            Get(MODREC, 5);
            Get(IATREC(I), 5);
            Get(LRCREC, 5);
            Get(NSLREC, 5);
            Get(FREREC(I), 15);
            Get(GTREC(I), 15);
            Get(BWREC(I), 15);
            Skip_line;
            Get(NPHREC, 5);
            Get(ICRREC, 5);
            Get(KBFREC, 5);
            Get(NRPF(I), 5);
            Get(FMDREC, 15);
            Get(SLBREC, 15);
            Get(BEMREC, 15);
            Get(RLLREC(I), 15);
            If IATREC(I) >= 5 and IATREC(I) <= 8 Then
               Skip_Line;
               Get(ANTGNR(I), 15);
               Get(ANTTAR(I), 15);
               Get(ANTHTR(I), 15);
               Get(ANTLNR(I), 15);
            End If;
            If NRPF(I) > 0 Then
               For J in 1..2*NRPF(I) Loop
                  If J rem 5 = 1 Then
                     Skip_Line;
                  End If;
                  Get(PFTIME, 15);  --PFVAL is actually every other Get.
               End Loop;
            End If;
         End Loop;
--
      End If;
      Return;
--
      End REDREC;
--
--
      Procedure REDXMT is
--
--#PURPOSE: REDXMT reads the transmitter class data from the disk file.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Input
--
--#PARAMETER DESCRIPTIONS:
--IN        'NONE'
--
--#CALLED BY:
--          READ_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          REDXMT reads the transmitter class data from the disk file
--          using a series of Get statements.
--
--          Note that DRTXMT, CHUXMT, PFTIMX, PFVALX, TTRXMT and NXPF
--          are only read to be compatible with SIMSTAR/StratSim/StratLink
--          data bases.  Also note that both the old (IFORM /= 1) and
--          new SIMSTAR database formats may be read.
--
      NAME: string(1..6);
      I, J, IFORM, ITYPE: Integer;
      DRTXMT, CHUXMT, PFTIMX, PFVALX, TTRXMT: Float;
      NXPF: array (integer range 1..99) of integer;
      DUMMY: string(1..4);
--
      Begin
--
--BEGIN THE INPUT OPERATION.
      Skip_line;
      Get(NUMXMT, 5);
      Get(IFORM, 5);
      If NUMXMT <= 0 Then
         Return;
      End If;
--
      If IFORM /= 1 Then
         For I in 1..NUMXMT Loop
            If I rem 4 = 1 Then
               Skip_Line;
               Get(NAMXMT(I), 15);
            Else
               Get(NAMXMT(I), 17);
            End If;
         End Loop;
         For I in 1..NUMXMT Loop
            If I rem 10 = 1 Then
               Skip_Line;
               Get(ITYPE, 5);
            Else
               Get(ITYPE, 7);
            End If;
            begin
               ITPXMT(I) := BAND_TYPES'VAL(ITYPE+1);
            exception
               When CONSTRAINT_ERROR =>
                  Put("ERROR in REDXMT...unknown transmitter type.");
            End;
         End Loop;
         For I in 1..NUMXMT Loop
            If I rem 10 = 1 Then
               Skip_Line;
               Get(IATXMT(I), 5);
            Else
               Get(IATXMT(I), 7);
            End If;
         End Loop;
         For I in 1..NUMXMT Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(BWXMT(I), 15);
         End Loop;
         For I in 1..NUMXMT Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(TRPXMT(I), 15);
         End Loop;
         For I in 1..NUMXMT Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(FREXMT(I), 15);
         End Loop;
         For I in 1..NUMXMT Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(DRTXMT, 15);
         End Loop;
         For I in 1..NUMXMT Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(CHUXMT, 15);
         End Loop;
--
--INPUT THE ADDITIONAL ANTENNA CHARACTERISTICS NEEDED FOR
--  CONSTANT GAIN (5),RHOMBIC (6),VERTICAL (7) AND
--  HORIZONTAL HALF WAVE DIPOLE (8) ANTENNA TYPES.
         For I in 1..NUMXMT Loop
            If IATXMT(I) > 4 and IATXMT(I) < 9 Then
               Skip_Line;
               If IATXMT(I) = 5 Then
                  Get(ANTGNX(I), 15);
               Elsif IATXMT(I) = 6 Then
                  Get(ANTTAX(I), 15);
                  Get(ANTHTX(I), 15);
                  Get(ANTLNX(I), 15);
               Elsif IATXMT(I) = 7 Then
                  Get(ANTLNX(I), 15);
               Elsif IATXMT(I) = 8 Then
                  Get(ANTHTX(I), 15);
               End If;
            End If;
         End Loop;
--
         For I in 1..NUMXMT Loop
            If I rem 10 = 1 Then
               Skip_Line;
               Get(NXPF(I), 5);
            Else
               Get(NXPF(I), 7);
            End If;
         End Loop;
         For I in 1..NUMXMT Loop
            If NXPF(I) > 0 Then
               For J in 1..2*NXPF(I) Loop
                  If J rem 5 = 1 Then
                     Skip_Line;
                  End If;
                  Get(PFTIMX, 15);  --PFVALX is actually every other Get.
               End Loop;
            End If;
         End Loop;
         For I in 1..NUMXMT Loop
            If I rem 5 = 1 Then
               Skip_Line;
            End If;
            Get(TTRXMT, 15);
         End Loop;
      Else
--
-- INPUT FILE IS IN "NEW" FORMAT, EACH TRANSMITTER HAS ALPHA NAME AND ALL
-- DATA TOGETHER
--
         For I in 1..NUMXMT Loop
            Skip_Line;
            Get(NAME);
            ALPHA_TO_INTEGERIZED_ALPHA(NAME,NAMXMT(I));
            Get(DUMMY);      -- Skip 4 spaces.
            Get(ITYPE, 5);
            begin
               ITPXMT(I) := BAND_TYPES'VAL(ITYPE+1);
            exception
               When CONSTRAINT_ERROR =>
                  Put("ERROR in REDXMT...unknown transmitter type.");
            End;
            Get(IATXMT(I), 5);
            Get(NXPF(I), 5);
            Skip_Line;
            Get(BWXMT(I), 15);
            Get(TRPXMT(I), 15);
            Get(FREXMT(I), 15);
            Get(DRTXMT, 15);
            Get(CHUXMT, 15);
            If IATXMT(I) >= 5 and IATXMT(I) <= 8 Then
               Skip_Line;
               Get(ANTGNX(I), 15);
               Get(ANTTAX(I), 15);
               Get(ANTHTX(I), 15);
               Get(ANTLNX(I), 15);
            End If;
            If NXPF(I) > 0 Then
               For J in 1..2*NXPF(I) Loop
                  If J rem 5 = 1 Then
                     Skip_Line;
                  End If;
                  Get(PFTIMX, 15);  --PFVALX is actually every other Get.
               End Loop;
            End If;
         End Loop;
--
      End If;
      Return;
--
      End REDXMT;
--
      Procedure READ_HANDLER is
--
--#PURPOSE: READ_HANDLER is the driver for the file reading routines.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Input
--
--#PARAMETER DESCRIPTIONS:
--          'NONE'
--
--#CALLED BY:
--          MAIN
--
--#CALLS TO:
--          REDNOD
--          REDREC
--          REDXMT
--
--#TECHNICAL DESCRIPTION:
--          READ_HANDLER drives the various routines which read the
--          data stored in the file as specified by ARGUMENT_BUFFER.
--          The number of each entity read is output to the
--          operator after each individual read operation.
--
--
      Begin
--
--OPEN FILE.
      Open (IUNIT, in_file, ARGUMENT_BUFFER);
--
--SET THE INPUT DEVICE.
      SET_INPUT(IUNIT);
--
--READ ALL DATA.
      Get(TITLE);
      Skip_line;
      New_line;
      Put(TITLE);
      DATABASE_HAS_BEEN_MODIFIED := FALSE;
      REDNOD;
      New_line;
      Put(NUMNOD);
      Put(" nodes read.");
--
--SKIP THE NEXT LINE OF INPUT.
      Skip_line;
      Skip_line;
      REDREC;
      New_line;
      Put(NUMREC);
      Put(" receiver classes read.");
--
--SKIP THE NEXT LINE OF INPUT.
      Skip_line;
      Skip_line;
      REDXMT;
      New_line;
      Put(NUMXMT);
      Put(" transmitter classes read.");
      New_line;
--
--CLOSE READ FILE.
      Close(IUNIT);
--
--RESET INPUT DEVICE.
      SET_INPUT(STANDARD_INPUT);
--
      Return;
--
      Exception
         When Status_Error =>
            New_line;
            Put("File handling error in READ_HANDLER.");
            Return;
         When Others =>
            New_line;
            Put("File handling error in READ_HANDLER.");
            Return;
--
      End READ_HANDLER;
--
--
      Procedure WRTNOD is
--
--#PURPOSE: WRTNOD writes the node data to the disk file.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Input
--
--#PARAMETER DESCRIPTIONS:
--IN        'NONE'
--
--#CALLED BY:
--          WRITE_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          WRTNOD writes the node data to the disk file using a
--          series of Put statements.
--
--          Note that NKSND, NPSND are only written to be compatible
--          with SIMSTAR/StratSim/StratLink data bases.
--
      I,J,K: Integer;
      IFORM: Integer := 1;
      INODE, NKSND, NPSND, ITYPE: Integer := 0;
      NAME1, NAME2: string(1..6);
      INDEX: I_ARRAY(1..NUMNOD);
--
     Begin
--
--BEGIN THE OUTPUT OPERATION.
      New_line;
      Put(NUMNOD, 5);
      Put(IFORM, 5);
      If NUMNOD <= 0 Then
         Return;
      End If;
--
      ENSORT (NUMNOD, NAMNOD, INDEX);
      For I in 1..NUMNOD Loop
         INODE := INDEX(I);
         INTEGER_TO_ALPHA (NAMNOD(INODE), NAME1);
         New_line;
         Put(NAME1);
         ITYPE := NODE_TYPES'POS(ITYSND(INODE));
         New_line;
         Put(ITYPE, 5);
         Put(NLSND(INODE), 7);
         Put(NKSND, 7);
         Put(NRSND(INODE), 7);
         Put(NXSND(INODE), 7);
         Put(NPSND, 7);
         If ITYPE = 3 Then
            New_line;
            For J in 1..5 Loop
               Put(EPHSND(J,INODE),3,7,3);
            End Loop;
            New_line;
            Put(EPHSND(6,INODE),3,7,3);
         End If;
         If NLSND(INODE) > 0 Then
            For K in 1..NLSND(INODE) Loop
               For J in 1..4 Loop
                  If (4*(K-1)+J) rem 5 = 1 Then
                     New_Line;
                  End If;
                  Put(XPSSND(J,K,INODE),3,7,3);
               End Loop;
            End Loop;
         End If;
         If NRSND(INODE) > 0 Then
            For K in 1..NRSND(INODE) Loop
               INTEGER_TO_ALPHA(IRCSND(1,K,INODE), NAME1);
               INTEGER_TO_ALPHA(IRCSND(2,K,INODE), NAME2);
               New_Line;
               Put(NAME1);
               Put("    "); -- Skip four spaces;
               Put(NAME2);
            End Loop;
         End If;
         If NXSND(INODE) > 0 Then
            For K in 1..NXSND(INODE) Loop
               INTEGER_TO_ALPHA(IXTSND(1,K,INODE), NAME1);
               INTEGER_TO_ALPHA(IXTSND(2,K,INODE), NAME2);
               New_Line;
               Put(NAME1);
               Put("    "); -- Skip four spaces;
               Put(NAME2);
            End Loop;
         End If;
--
      End Loop;
--
      Return;
--
      End WRTNOD;
--
--
      Procedure WRTREC is
--
--#PURPOSE: WRTREC writes the receiver class data to the disk file.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Input
--
--#PARAMETER DESCRIPTIONS:
--IN        'NONE'
--
--#CALLED BY:
--          WRITE_HANDLER
--
--#CALLS TO:
--          'NONE'
--
--#TECHNICAL DESCRIPTION:
--          WRTREC writes the receiver class data to the disk file
--          using a series of Put statements.
--
--          Note that MODREC, SLBREC, BEMREC, NPHREC, ICRREC, FNDREC,
--          KBFREC, LRCREC, NSLREC and NRPF are only written to be
--          compatible with SIMSTAR/StratSim/StratLink data bases.
--
      NAME: string(1..6);
      I, J, ITYPE: Integer;
      IFORM: Integer := 1;
      MODREC, NPHREC, ICRREC, KBFREC, LRCREC, NSLREC, NRPF: Integer := 0;
      SLBREC, BEMREC, FMDREC: Float := 0.0;
      INDEX:I_ARRAY(1..NUMREC);
--
      Begin
--
--BEGIN THE OUTPUT OPERATION.
      New_Line;
      Put(NUMREC, 5);
      Put(IFORM, 5);
      If NUMREC <= 0 Then
         Return;
      End If;
--
      ENSORT (NUMREC, NAMREC, INDEX);
      For I in 1..NUMREC Loop
         J := INDEX(I);
         INTEGER_TO_ALPHA(NAMREC(J), NAME);
         New_Line;
         Put(NAME);
         Put("    ");      -- Skip 4 spaces.
         ITYPE := BAND_TYPES'POS(ITPREC(J))-1;
         Put(ITYPE, 5);
         Put(MODREC, 5);
         Put(IATREC(J), 5);
         Put(LRCREC, 5);
         Put(NSLREC, 5);
         Put(FREREC(J),3,7,3);
         Put(GTREC(J),3,7,3);
         Put(BWREC(J),3,7,3);
         New_line;
         Put(NPHREC, 5);
         Put(ICRREC, 5);
         Put(KBFREC, 5);
         Put(NRPF, 5);
         Put(FMDREC,3,7,3);
         Put(SLBREC,3,7,3);
         Put(BEMREC,3,7,3);
         Put(RLLREC(J),3,7,3);
         If IATREC(J) >= 5 and IATREC(J) <= 8 Then
            New_Line;
            Put(ANTGNR(J),3,7,3);
            Put(ANTTAR(J),3,7,3);
            Put(ANTHTR(J),3,7,3);
            Put(ANTLNR(J),3,7,3);
         End If;
         New_line;
      End Loop;
--
      Return;
--
      End WRTREC;
--
--
      Procedure WRTXMT is
--
--#PURPOSE: WRTXMT writes the transmitter class data to the disk file.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Input
--
--#PARAMETER DESCRIPTIONS:
--IN        'NONE'
--
--#CALLED BY:
--          WRITE_HANDLER
--
--#CALLS TO:
--          ENSORT
--          INTEGER_TO_ALPHA
--
--#TECHNICAL DESCRIPTION:
--          WRTXMT writes the transmitter class data to the disk file
--          using a series of Put statements.
--
--          Note that DRTXMT, CHUXMT and NXPF are only written to
--          be compatible with SIMSTAR/StratSim/StratLink data bases.
--
      NAME: string(1..6);
      I, J: Integer;
      IFORM: Integer := 1;
      ITYPE: Integer;
      DRTXMT, CHUXMT, TTRXMT: Float := 0.0;
      NXPF: Integer := 0;
      INDEX: I_ARRAY(1..NUMXMT);
--
      Begin
--
--BEGIN THE OUTPUT OPERATION.
      New_Line;
      Put(NUMXMT, 5);
      Put(IFORM, 5);
      If NUMXMT <= 0 Then
         Return;
      End If;
--
      ENSORT (NUMXMT, NAMXMT, INDEX);
      For I in 1..NUMXMT Loop
         J := INDEX(I);
         INTEGER_TO_ALPHA(NAMXMT(J), NAME);
         New_Line;
         Put(NAME);
         Put("    ");      -- Skip 4 spaces.
         ITYPE := BAND_TYPES'POS(ITPXMT(J))-1;
         Put(ITYPE, 5);
         Put(IATXMT(J), 5);
         Put(NXPF, 5);
         New_line;
         Put(BWXMT(J),3,7,3);
         Put(TRPXMT(J),3,7,3);
         Put(FREXMT(J),3,7,3);
         Put(DRTXMT,3,7,3);
         Put(CHUXMT,3,7,3);
         If IATXMT(J) >= 5 and IATXMT(J) <= 8 Then
            New_Line;
            Put(ANTGNX(J),3,7,3);
            Put(ANTTAX(J),3,7,3);
            Put(ANTHTX(J),3,7,3);
            Put(ANTLNX(J),3,7,3);
         End If;
      End Loop;
--
      Return;
--
      End WRTXMT;
--
--
      Procedure WRITE_HANDLER is
--
--#PURPOSE: WRITE_HANDLER is the driver for the file writing routines.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Input
--
--#PARAMETER DESCRIPTIONS:
--          'NONE'
--
--#CALLED BY:
--          MAIN
--
--#CALLS TO:
--          WRTNOD
--          WRTREC
--          WRTXMT
--
--#TECHNICAL DESCRIPTION:
--          WRITE_HANDLER drives the various routines which write the
--          data stored in the file as specified by ARGUMENT_BUFFER.
--
      Begin
--
--OPEN FILE.
      CREATE(IUNIT, out_file, ARGUMENT_BUFFER(1..MAX));
--
--
--SET THE OUTPUT DEVICE.
      SET_OUTPUT(IUNIT);
--
--WRITE ALL DATA.
      Put(TITLE);
      DATA_HAS_NOT_YET_BEEN_WRITTEN := FALSE;
      WRTNOD;
      New_line;
      Put("RECEIVER CLASS DATA");
      WRTREC;
      New_line;
      Put("TRANSMITTER CLASS DATA");
      WRTXMT;
--
--RESET OUTPUT DEVICE.
      SET_OUTPUT(STANDARD_OUTPUT);
--
--CLOSE FILE.
      Close(IUNIT);
--
      Return;
--
      Exception
         When Status_Error =>
            New_line;
            Put("File handling error in WRITE_HANDLER.");
            Return;
         When Others =>
            New_line;
            Put("File handling error in WRITE_HANDLER.");
            Return;
--
      End WRITE_HANDLER;
--
--
End IOANDFILE;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--PROPLINK
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
With Text_io, system; Use Text_io, Float_io, Integer_io;
With Types; Use Types;
With Constants; Use Constants;
With Constant2; Use Constant2;
With Constant3; Use Constant3;
With Propagation_Constants; Use Propagation_constants;
With Helps; use Helps;
With Entityuti; Use Entityuti;
With Executive; Use Executive;
With Nodes; Use Nodes;
With Receivers; Use Receivers;
With transmit; Use Transmit;
With RFUTIL; use RFUTIL;
With NODELOC;
With IOandFILE;
With ELF_PROPAGATION;
With VLF_PROPAGATION;
With LF_PROPAGATION;
With MF_HF_PROPAGATION;
With VHF_UHF_SHF_EHF_PROPAGATION;
With Noise;
With Debugger2; Use Debugger2;
Procedure PROPLINK is
--
pragma SOURCE_INFO (on);
--
Noise_file: file_type;
type STATE is (GOOD,BAD);
OPERATION: STATE:=GOOD;
--
      Procedure PRINT_HANDLER is
--
--PURPOSE: PRTHND drives the master print of all data.
--
--AUTHOR:  J. Conrad
--
--TYPE:    Output
--
--PARAMETER DESCRIPTIONS:
--         'NONE'
--
--CALLED BY:
--         MAIN
--
--CALLS TO:
--         NODE_HANDLER
--         RECEIVER_HANDLER
--         TRANSMITTER_HANDLER
--
--TECHNICAL DESCRIPTION:
--         PRINT_HANDLER sets up and calls all the individual entity
--         handlers so that all data currently held are printed
--         on the selected output device.
--
      Begin
      Pragma Source_info(on);
--
--ZERO THE ARGUMENT_BUFFER SO ALL ELEMENTS WILL BE PRINTED.
      For I in ARGUMENT_BUFFER'RANGE Loop
         ARGUMENT_BUFFER(I) := ' ';
      End Loop;
--
--CALL ALL THE INDIVIDUAL ENTITY HANDLERS.
      NODES.NODE_HANDLER;
      RECEIVERS.RECEIVER_HANDLER;
      TRANSMIT.TRANSMITTER_HANDLER;
--
      Return;
--
      End PRINT_HANDLER;
--
      Procedure CHECK_FOR_MISSING_ENTITYS is
--
--PURPOSE: This procedure checks the node array
--         for any receiver and transmitter classes that have not
--         been added.
--
--AUTHOR:  B. Perry
--
--CALLED BY: MAIN
--
--CALLS TO :
--           INTEGER_TO_ALPHA
--           RECEIVER_ADD
--           TRANSMITTER_ADD
--
       KNAME: string(1..6);
       K, IFLG, IERR: integer;
       begin
--
--CHECK_FOR_UNDEFINED_RECEIVERS
--
      If NUMREC >= 1 Then
         For K in 1..NUMREC Loop
            If ITPREC (K) = UNDEFINED Then
               Loop
                  INTEGER_TO_ALPHA (NAMREC(K), KNAME);
                  New_line;
                  Put("Receiver class ");
                  Put(KNAME);
                  Put(" must be added.");
                  ITPREC(K) := ELF;
                  IATREC(K) := 0;
                  FREREC(K) := 3.0;
                  GTREC(K)  := -30.0;
                  BWREC(K)  := 1.0;
                  RLLREC(K) := 0.0;
                  ANTGNR(K) := 0.0;
                  ANTHTR(K) := 0.0;
                  ANTLNR(K) := 0.0;
                  ANTTAR(K) := 0.0;
                  RECEIVER_ADD (K, IFLG, IERR);
                  Exit When IERR = 0;
               End Loop;
            End If;
         End Loop;
      End If;
--
--CHECK FOR UNDEFINED TRANSMITTERS.
--
      If NUMXMT >= 1 Then
         For K in 1..NUMXMT Loop
            If ITPXMT(K) = UNDEFINED Then
               Loop
                  INTEGER_TO_ALPHA (NAMXMT(K), KNAME);
                  New_line;
                  Put("Transmitter class ");
                  Put(KNAME);
                  Put(" must be added.");
                  ITPXMT(K) := ELF;
                  BWXMT (K) := 1.0;
                  TRPXMT(K) := 0.0;
                  FREXMT(K) := 3.0;
                  IATXMT(K) := 0;
                  ANTGNX(K) := 0.0;
                  ANTHTX(K) := 0.0;
                  ANTLNX(K) := 0.0;
                  ANTTAX(K) := 0.0;
                  TRANSMITTER_ADD (K, IFLG, IERR);
                  Exit When IERR = 0;
               End Loop;
            End If;
         End Loop;
      End If;
--
      Return;
--
      End CHECK_FOR_MISSING_ENTITYS;

      Procedure RF_PROPAGATION_HANDLER is
--
--#PURPOSE: RF_PROPAGATION_HANDLER is the RF propagation prediction driver.
--
--#AUTHOR:  J. Conrad
--
--#TYPE:    Driver routine.
--
--#PARAMETER DESCRIPTIONS:
--
--          'NONE'
--
--#CALLED BY:
--          MAIN
--
--#CALLS TO:
--          ADJBW
--          ELF_HANDLER
--          INTEGER_TO_ALPHA
--          LF_HANDLER
--          LOCGRB
--          LOCUPD
--          LOS
--          MF_HF_HANDLER
--          NOISE_HANDLER
--          VHF_UHF_SHF_EHF_HANDLER
--          VLF_HANDLER
--
--
--#TECHNICAL DESCRIPTION:
--          RF_PROPAGATION_HANDLER loops over all transmitters at each node
--          and matches the frequency with each receiver at each node.
--          RF_PROPAGATION_HANDLER then determines the link frequency
--          type and calls SIGLNK and NOISE_HANDLER to obtain the XMTR-RECVR
--          link signal strength and noise level.
--
      NAME1, NAME2: string(1..6);
      SENDER, RECEIVER, IXMT, IREC, I: integer;
--
      Begin
--
      If NUMNOD < 1 Then
         Return;
      End If;
      TIMSEC := CURRENT_TIME*60.0;
--
--LOOP OVER ALL NODES, TRANSMITTERS & RECEIVERS.
      For SENDER in 1..NUMNOD Loop
         If NXSND(SENDER) >= 1 Then
            NODELOC.LOCUPD (SENDER, TLAT, TLON, TALT);
            For IX in 1..NXSND(SENDER) Loop
               For I in 1..NUMXMT Loop
                  If IXTSND(2, IX, SENDER) = NAMXMT(I) then
                     IXMT := I;
                     Exit;
                  End if;
               End loop;
               If FREXMT(IXMT) >= 3.0 and ITPXMT(IXMT) /= HARD_WIRED Then
                  TERP := TRPXMT(IXMT);
                  FREQ := FREXMT(IXMT);
                  FREQKC := FREQ*0.001;
                  FREQMC := FREQKC*0.001;
                  IATYPT := IATXMT(IXMT);
                  TAX := ANTTAX(IXMT);
                  GNX := ANTGNX(IXMT);
                  HTX := ANTHTX(IXMT);
                  LNX := ANTLNX(IXMT);
                  ENTITYUTI.INTEGER_TO_ALPHA (IXTSND(1,IX,SENDER), NAME1);
                  ENTITYUTI.INTEGER_TO_ALPHA (IXTSND(2,IX,SENDER), NAME2);
                  SET_OUTPUT(STANDARD_OUTPUT);
                  For I in 1..2 Loop
                     If I = 2 Then
                        SET_OUTPUT(PRINTER_OUTPUT_FILE);
                     End If;
                     New_Line;
                     Put("Transmitter ");
                     Put(NAME1);
                     New_line;
                     Put("Class       ");
                     Put(NAME2);
                     Put("   at ");
                     Put(TLAT,3,2,0);
                     Put(" deg. N., ");
                     Put(TLON,4,2,0);
                     Put(" deg. E., ");
                     Put(TALT,7,0,0);
                     Put(" km. alt.");
                     If I = 2 Then
                        SET_OUTPUT(STANDARD_OUTPUT);
                     End If;
                  End Loop;
--
                  For RECEIVER in 1..NUMNOD Loop
                     If NRSND(RECEIVER) >= 1 Then
                        NODELOC.LOCUPD (RECEIVER, RLAT, RLON, RALT);
                        For IR in 1..NRSND(RECEIVER) Loop
                           For I in 1..NUMREC Loop
                              If IRCSND(2, IR, RECEIVER) = NAMREC(I) then
                                 IREC := I;
                                 Exit;
                              End if;
                           End loop;
                           NLTYP := ITPREC(IREC);
                           BW := BWREC(IREC);
                           GOT := GTREC(IREC);
                           RLL := RLLREC(IREC);
                           IATYPR := IATREC(IREC);
                           TAR := ANTTAR(IREC);
                           GNR := ANTGNR(IREC);
                           HTR := ANTHTR(IREC);
                           LNR := ANTLNR(IREC);
                           If FREREC(IREC) >= 3.0 and
                              ITPREC(IREC) /= HARD_WIRED and
                              ADJBW (FREQ, BW, FREREC(IREC), BW) > 0.0 Then
                              ENTITYUTI.INTEGER_TO_ALPHA (IRCSND(1,IR,
                                           RECEIVER), NAME1);
                              ENTITYUTI.INTEGER_TO_ALPHA (IRCSND(2,IR,
                                           RECEIVER), NAME2);
                              For I in 1..2 Loop
                                 If I = 2 Then
                                    SET_OUTPUT(PRINTER_OUTPUT_FILE);
                                 End If;
                                 New_Line;
                                 Put("     Receiver ");
                                 Put(NAME1);
                                 New_line;
                                 Put("     Class    ");
                                 Put(NAME2);
                                 Put("   at ");
                                 Put(RLAT,3,2,0);
                                 Put(" deg. N., ");
                                 Put(RLON,4,2,0);
                                 Put(" deg. E., ");
                                 Put(RALT,7,0,0);
                                 Put(" km. alt.");
                                 If I = 2 Then
                                    SET_OUTPUT(STANDARD_OUTPUT);
                                 End If;
                              End Loop;
--
--IF LINK IS VHF OR ABOVE, SEE IF LINE-OF-SIGHT EXISTS AND IF NOT,
--  RETURN A SIGNAL OF -99999.9.
                              SIGNAL := -99999.9;
                              SIGNOS := -99999.9;
                              If (FREQ >= 3.0E7 and
                                  LOS (TLAT*RADIANS_PER_DEGREE,
                                       TLON*RADIANS_PER_DEGREE,  TALT,
                                       RLAT*RADIANS_PER_DEGREE,
                                       RLON*RADIANS_PER_DEGREE, RALT)) or
                                      (FREQ < 3.0E7) Then
--
--COMPUTE THE BEARING AND RANGE
                                 NODELOC.LOCGRB (TLAT, TLON, RLAT, RLON,
                                         BRNG1, BRNG2, DPATH);
--
--USE THE APPROPRIATE RF PREDICTION MODULE
                                 Case NLTYP is
                                    when ELF =>ELF_PROPAGATION.ELF_HANDLER;
                                    when VLF =>VLF_PROPAGATION.VLF_HANDLER;
                                    when LF  =>LF_PROPAGATION.LF_HANDLER;
                                    when MF|HF =>
                                       MF_HF_PROPAGATION.MF_HF_HANDLER;
                                    when VHF|UHF|SHF|EHF =>
                         VHF_UHF_SHF_EHF_PROPAGATION.VHF_UHF_SHF_EHF_HANDLER;
                                    when others => null;
                                 End Case;
--
--COMPUTE THE NOISE LEVEL
                                 NOISE.NOISE_HANDLER;
--
                              End If;
                              For I in 1..2 Loop
                                 If I = 2 Then
                                    SET_OUTPUT(PRINTER_OUTPUT_FILE);
                                 End If;
                                 New_Line;
                                 Put("           Signal Strength = ");
                                 Put(SIGNAL,3,7,3);
                                 If FREQ <= 3.0E5 Then
                                    Put(" dB/uV/m");
                                 Else
                                    Put(" dBW");
                                 End If;
                                 New_Line;
                                 Put("           Noise Strength = ");
                                 Put(SIGNOS,3,7,3);
                                 If FREQ <= 3.0E5 Then
                                    Put(" dB/uV/m/Hz");
                                 Else
                                    Put(" dBW/HZ");
                                 End If;
                                 If I = 2 Then
                                    SET_OUTPUT(STANDARD_OUTPUT);
                                 End If;
                              End Loop;
                           End If;
                        End Loop;
                     End If;
                  End Loop;
               End If;
            End Loop;
         End If;
      End Loop;
--
      Return;
--
      End RF_PROPAGATION_HANDLER;
--
--
--
Begin -- MAIN PROGRAM.
--
--PURPOSE: PROPLINK is the main routine for the stand-alone RF
--         propagation prediction code -- PROP_LINK.
--
--AUTHOR:  J. Conrad, StratCom Systems, Inc.
--
--TYPE:   Executive
--
--PARAMETER DESCRIPTIONS:
--         'NONE'
--
--CALLED BY:
--         'NONE'
--
--CALLS TO:
--         COMMAND_LINE_PROCESSOR
--         CHECK_FOR_MISSING_ENTITYS
--         INITIALIZE_NODES
--         BLANK_CHECK
--         NODE_HANDLER
--         PARSE
--         PRINT_HANDLER
--         READ_HANDLER
--         RECEIVER_HANDLER
--         RF_PROPAGATION_HANDLER
--         TRANSMITTER_HANDLER
--         WRITE_HANDLER
--
--TECHNICAL DESCRIPTION:
--
--  This is the main program for the stand-alone RF propagation
--  prediction code -- PROP_LINK.  This software is based on the
--  FORTRAN algorithms contained in SIMSTAR, the U.S. Air Force's
--  Dynamic Multi-Message Simulator.
--
--
--INITIALIZE NODE DATA.
      INITIALIZE_NODES;
--CLEAR SCREEN AND ANNOUNCE PROGRAM.
      For I in 1..12 loop
         New_line;
      end loop;
      Put("                                    PROP_LINK");
      New_line;New_line;New_line;
      Put("                       --- Ada RF Propagation Predictor ---");
      New_line;New_line;
      Put("                                   Version 1.0");
      New_line;New_line;New_line;
      Put("                                  Developed by:");
      New_line;New_line;
      Put("                             IWG Corp. (Bruce Perry)");
      New_line;New_line;
      Put("                    Under Government Contract N66001-85-C-0042");
      New_line;New_line;New_line;New_line;
--
--    INITIALIZE TITLE
   for I in 1..80 loop
      TITLE(I):=' ';
   end loop;
--
--    MAIN COMMAND LOOP
   loop
<<COMMANDER>>
      COMMAND_LINE_PROCESSOR;
--      Exception
--         when CONSTRAINT_ERROR =>
--            Goto COMMANDER;
--      End;
--
      Case CURRENT_COMMAND is
--
         When READ => IOANDFILE.READ_HANDLER;
         When WRITE =>IOANDFILE.WRITE_HANDLER;
         When PRINT => New_line;
            Put("Enter the filename of the printer output file: ");
            Get_line(FILE_NAME, MAX);
            Create(PRINTER_OUTPUT_FILE, out_file, FILE_NAME(1..MAX));
            Case CURRENT_ENTITY is
               When RECEIVER => RECEIVER_HANDLER;
               When TRANSMITTER => TRANSMITTER_HANDLER;
               When NODE => NODE_HANDLER;
               When others => PRINT_HANDLER;
            End Case;
            Close(PRINTER_OUTPUT_FILE);
         When STOP => If DATABASE_HAS_BEEN_MODIFIED and
                         DATA_HAS_NOT_YET_BEEN_WRITTEN Then
                            New_line;
                            Put("WARNING...Data has been added/modified");
                            Put(" but not yet saved.");
                            DATA_HAS_NOT_YET_BEEN_WRITTEN := FALSE;
                            Goto COMMANDER;
                      End If;
                      exit;
         When GO => New_line;
            Put("Enter the filename of the printer output file: ");
            Get_line(FILE_NAME, MAX);
            Create(PRINTER_OUTPUT_FILE, out_file,
                   FILE_NAME(1..MAX));
            New_line;
            Put("Enter the GMT reference time as would be");
            Put(" specified on a 24 hour clock");
            New_line;
            Put("(e.g., 6:30 PM as 1830) or type ENTER key");
            Put(" to accept default value of: ");
            Put(INTEGER(REFERENCE_TIME));
            New_line;
            Get_LINE(ARGUMENT_BUFFER, MAX);
            If not BLANK_CHECK(ARGUMENT_BUFFER(1..MAX)) Then
               NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
               PARSE (ARGUMENT_BUFFER(1..MAX));
               If NUMBER_OF_VARIABLES_TO_EXTRACT =
                  NUMBER_OF_VARIABLES_EXTRACTED Then
                  REFERENCE_TIME:= XARRAY(1);
               End if;
            End If;
            New_line;
            Put("Enter the minutes since GMT reference time or");
            Put(" type ENTER key to accept the");
            New_line;
            Put(" default value of: ");
            Put(INTEGER(CURRENT_TIME));
            New_line;
            Get_line(ARGUMENT_BUFFER, MAX);
            If not BLANK_CHECK(ARGUMENT_BUFFER(1..MAX)) Then
               NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
               PARSE (ARGUMENT_BUFFER(1..MAX));
               If NUMBER_OF_VARIABLES_TO_EXTRACT =
                  NUMBER_OF_VARIABLES_EXTRACTED Then
                  CURRENT_TIME:= XARRAY(1);
               End if;
            End If;
            New_line;
            Put("Enter the month as a digit between 1 and 12");
            Put("(e.g., June = 6) or type ENTER");
            New_line;
            Put("to accept the default value of: ");
            Put(MONTH);
            New_line;
            Get_line(ARGUMENT_BUFFER,MAX);
            If not BLANK_CHECK(ARGUMENT_BUFFER(1..MAX)) Then
               NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
               PARSE (ARGUMENT_BUFFER(1..MAX));
               If (NUMBER_OF_VARIABLES_TO_EXTRACT =
                   NUMBER_OF_VARIABLES_EXTRACTED) and
                   (INTEGER(XARRAY(1)) >= 1) and (INTEGER(XARRAY(1)) <= 12) Then
                   MONTH:= INTEGER(XARRAY(1));
               End if;
            End If;
            NSEAS := (MONTH - 1) / 3;
            If NSEAS <= 0 Then
               NSEAS := 4;
            End If;
            Case NSEAS is
                When 1 => FILE_NAME(1..10):="SPRING.DAT";
                When 2 => FILE_NAME(1..10):="SUMMER.DAT";
                When 3 => FILE_NAME(1..10):="FALL.DAT  ";
                When 4 => FILE_NAME(1..10):="WINTER.DAT";
                When others => Put("BAD MONTH");NEW_LINE; goto COMMANDER;
            End Case;

            begin
               Open (NOISE_FILE, IN_FILE, FILE_NAME);
               Close (NOISE_FILE);
            Exception
               when NAME_ERROR =>
                  New_line;
                  Put("WARNING...The noise data file for this month");
                  Put_line(" (season) cannot be found.");
                  OPERATION := BAD;
            End;
            If OPERATION=BAD then
               Goto COMMANDER;
               OPERATION := GOOD;
            end if;
            New_line;
            Put("Enter the sunspot activity index (Wolf number)");
            Put_line(" or type the ENTER key to");
            Put(" accept the default value of: ");
            Put(AVERAGE_SUN_SPOT_NUMBER);
            New_line;
            Get_line(ARGUMENT_BUFFER,MAX);
            If not BLANK_CHECK(ARGUMENT_BUFFER(1..MAX)) Then
               NUMBER_OF_VARIABLES_TO_EXTRACT := 1;
               PARSE (ARGUMENT_BUFFER(1..MAX));
               If NUMBER_OF_VARIABLES_TO_EXTRACT =
                  NUMBER_OF_VARIABLES_EXTRACTED Then
                  AVERAGE_SUN_SPOT_NUMBER := INTEGER(XARRAY(1));
               End if;
            End If;
--COMPUTE LINK SIGNAL AND NOISE LEVELS.
            New_line;
            Put("GMT = ");
            Put(INTEGER(REFERENCE_TIME),4);
            Put(", Minutes since GMT = ");
            Put(INTEGER(CURRENT_TIME),4);
            Put(", Month = ");
            Put(MONTH,2);
            Put(", Sun Spot Activity Index = ");
            Put(AVERAGE_SUN_SPOT_NUMBER,3);
--
            SET_OUTPUT(PRINTER_OUTPUT_FILE);
            New_line;
            Put("GMT = ");
            Put(INTEGER(REFERENCE_TIME),4);
            Put(", Minutes since GMT = ");
            Put(INTEGER(CURRENT_TIME),4);
            Put(", Month = ");
            Put(MONTH,2);
            Put(", Sun Spot Activity Index = ");
            Put(AVERAGE_SUN_SPOT_NUMBER,3);
--
            begin
               RF_PROPAGATION_HANDLER;
            exception
               when use_error =>
                  New_line;
                  put_line("Cannot write output file - check storage space");
               when others =>
                  set_output(STANDARD_OUTPUT);
                  New_line;
                  put_line("Error in RF propagation - check data");
            end;
            Close(PRINTER_OUTPUT_FILE);
            SET_OUTPUT(STANDARD_OUTPUT);
--
         When VIEW|ADD|DEL|MODIFY=> New_line;
            Case CURRENT_ENTITY is
               When RECEIVER => RECEIVER_HANDLER;
               When TRANSMITTER => TRANSMITTER_HANDLER;
               When NODE => NODE_HANDLER;
                  CHECK_FOR_MISSING_ENTITYS;
               When ENTITY_ERROR  => Null;
               When others => Null;
            End Case;
      End Case;
--
   End loop;
   Exception
      when use_error =>
         New_line;
         put_line("Cannot write output file - check storage space");
      when others => system.report_error;
End PROPLINK;