FCC VAX VMS Fortran program AMDIST

[rfengineer55]

By popular demand, here is one of my FCC programs that Is
generating Gfortran errors, two to be exact.

Incompatible type in DATA statement at <1>: Attempted conversion of
type integer to type character.
<during initialiation>

The second error is just like this one, except for the <during
initialization> thing. No line number, no variable name, no
nothing.This tells me that the error is likely being generated on the
compiler's second runthrough of the source code.

I did a search of all the DATA statements thinking there could have
been some conflicting declarations, but I could not find any.

I have about six FCC programs that fail to compile for strange
problems similar to this one. BTW one of the respondents here asked if
I was working from a photocopied DEC VMS Fortrann manual. I wish. I
have no DEC documentatio at all. The best I have been able to do is to
find two or three generic college VAX texdtbooks from ABEbooks.com
which WERE helpful in helping me unravel a syntax error I was running
into with the OPEN statement; VMS OPEN is very different from Fortran
77 OPEN :-)

I'm wanting to compile these programs so my computer does all the FCC
Engineering calculations that I would otherwise have to do by hand,
and to better understand how the FCC formulas are solved by studying
the source code.With all of the time and money i've pissed away trying
to teach my computer to run these programs, I'm close to simply
relying on using the CPU nature gave me and running the numbers that
way :-) This project is certainly pegging the frustration meter. I
have to continually remind myself that someday, computers will save
someone alot of time.

Sorry for the long post, but it could not be avoided; with the obvious
exception of my hyperbole and jesting :-) Thanks for your help.

Program AMDIST
c
c Program by John Boursy, April 1983
c
c Federal Communications Commission,
c Washington, D. C.
c
c This program will print all records in the AM Engineering Data
c Base which are a given distance from a given set of coordinates.
c
include 'amkeys.inc'
c
character*2400 amrec
c
integer out/6/
integer out2
data in/5/
integer amdb
c
logical dbms/.false./
logical print/.false./
character*9 today
character*11 amkey
character*12 header_key /'000000000000'/
character*1 dunits
character*2 cdunits
character*1 lat,lon
character*1 listing
double precision bear
double precision dmstdc,x
double precision radian/0.017453292519943d0/ ! degrees to
radians
double precision degree/57.2957795131d0/ ! radians to degrees
double precision rlat,rlon,xlat,xlon,tlat,tlon
double precision alat,alon
integer format_version
c
logical testing /.false./
c
character*80 amdbname /'bam:amdb.dat'/
character*80 new_db_name
character*6 db_update
character*1 lat_ns
character*1 lon_ew
c
c
******************************************************************
c
c Following is the section with statement functions.
c
c
******************************************************************
c
dmstdc(x)=dint(x)+sign(dint(mod(x,1d0)*100d0)/
60+mod(x*100d0,1d0)
2 /36d0,x)
c The above statement function converts a latitude or longitude in
c the form D.MMSS to double precision floating point degrees.
c
c
******************************************************************
c
c The next statement is the first executable statement.
c
c
******************************************************************
c
call amdist_handle_options
c
c call date (today) Jeff Glass
c
write (out,801) today
801 format (//,' Welcome to AMDIST',t60,'Today is ',a9)
c
if (testing) then ! solicit name of different data base
c
write (out,817) amdbname(1:length(amdbname)),
2 amdbname(1:length(amdbname))
817 format ('0Normally, AMDIST uses ',a,/,
2 ' Enter alternative file name (or return to use ',a,')',
3 /,'$Alternative file name: ')
c
read (in,816) new_db_name
816 format (a)
c
if (new_db_name.ne.' ') amdbname=new_db_name
c
endif
c
840 write ( out, 841 )
841 format ( /, '$Output to a print file [Y or N] --> ' )
call yesno ( *842, *840, *900, in )
print = .true.
call getnextlu ( out2 )
open ( unit = out2,
& status = 'new',
& access = 'sequential',
& form = 'formatted',
& file = 'am_dist.lis',
& recl = 132,
& iostat = iostat,
& err = 2002 )

write ( out2, 801 ) today
c
c
842 call getnextlu ( amdb )
c
c open (unit=amdb,status='old',access='keyed',
open (unit=amdb,status='old',
2 file=amdbname,form='formatted',iostat=iostat,err=200)
c
c
c read (amdb,810,key=header_key,iostat=iostat,err=2000) amrec
read (amdb,810,iostat=iostat,err=2000) amrec

read (amrec,830) ivol,db_update,format_version
830 format (t19,i5,t29,a6,i6)
c
write (out,831) ivol, db_update
if(print) write (out2,831) ivol, db_update
831 format (/'0AMDIST prints all stations within a given distance ',
2 ' from given coordinates',//,
3 ' We are using AM Volume',i5, '; Last updated: ', a6)
c
10 continue
write (out,802)
802 format (/,'0Select units for distances:',//,
2 ' Enter K for kilometers',/,
3 7x,'M for miles',/,'$Selection? ')
read (in,803) dunits
803 format (a1)
call upper (dunits)
if (dunits.eq.'K') then
cdunits='km'
else if (dunits.eq.'M') then
cdunits='mi'
else if (dunits.eq.' ') then
stop
else
go to 10
endif
c
300 continue
write (out,815)
815 format ('0Enter S for short listings',/,7x,
2 'M for medium listings',/,7x,'L for long listings',//,
3 '$Selection? ')
read (in,803) listing
call upper (listing)
if (listing.ne.'S'.and.listing.ne.'M'.and.listing.ne.'L')
2 go to 300
c
20 continue
write (out,804)
804 format ('0Select range of frequencies:',//,
2 '$Starting frequency, ending frequency? ')
read (in,*,err=20) ichans,ichane
if (ichans.lt.540) then
write (out,805)
805 format (' *** Starting frequency below 540 not acceptable; ',
2 'try again ***')
go to 20
else if (ichane.gt.1700) then
write (out,806)
806 format (' *** Ending frequency above 1700 not acceptable; ',
2 'try again ***')
go to 20
else if (ichane.lt.ichans) then
write (out,807)
807 format (' *** Ending frequency cannot be below starting ',
2 'frequency; try again ***')
go to 20
endif
c
30 continue
write (out,808) cdunits
808 format (//,'$Distance(',a2,'), Lat (D.MMSS), Lon (D.MMSS)? ')
read (in,*,err=30) dist,xlat,xlon
xlat=dmstdc(xlat+0.000001d0)
xlon=dmstdc(xlon+0.000001d0)
c
call degint (xlat,latd1,latm1,lats1)
call degint (xlon,lond1,lonm1,lons1)
c
lat_ns = 'N'
lon_ew = 'W'
if ( xlat .lt. 0.0d0 ) lat_ns = 'S'
if ( xlon .lt. 0.0d0 ) lon_ew = 'E'
c
if ( print ) then
write ( out2, 844 ) ichans,ichane,dist,cdunits,lat_ns,latd1,
& latm1,lats1,lon_ew,lond1,lonm1,lons1
844 format ( '0 Search Parameters are:' /
& ' Start Freq = ', i4 /
& ' End Freq = ', i4 /
& ' Distance = ', f7.1, 1x, a2 /
& ' Latitude = ', a1,1x,i2.2,'-',i2.2,'-',i2.2 /
& ' Longitude = ', a1,1x,i3.3,'-',i2.2,'-',i2.2 )
end if
c
rlat=xlat*radian
rlon=xlon*radian
c
latmax=xlat
latmin=xlat
lonmax=xlon
lonmin=xlon
distmi=dist
if (dunits.eq.'K') distmi=dist/1.609344
c
do 40 loop=1,4,1
az=float(loop-1)*90.
call dsprong (rlat,rlon,distmi,az,tlat,tlon)
latt=tlat*degree
lont=tlon*degree
if (latt.lt.latmin) latmin=latt
if (latt.gt.latmax) latmax=latt
if (lont.lt.lonmin) lonmin=lont
if (lont.gt.lonmax) lonmax=lont
40 continue
c
latmin=latmin+90 ! bias for use with alternate key
latmax=latmax+90
lonmin=lonmin+180
lonmax=lonmax+180
c
latkey=latmin
lonkey=lonmin
ichankey=ichans
icount=0
c
c call program_timer ( 0, .true., icount, 2, 'AMDIST ' )
c
45 continue
write (amkey,809) ichankey,latkey,lonkey
809 format (i4.4,i3.3,i4.4)
c read (amdb,810,keyid=3,keyge=amkey,err=150,iostat=iostat) amrec
read (amdb,810,err=150,iostat=iostat) amrec
810 format (a2400)
c
50 continue
read (amrec,811) ichan,lat,latd,latm,lats,lon,lond,lonm,lons
811 format (i4,t46,a1,3i2,a1,i3,2i2)
c
if (ichan.le.ichane) then
c
if (ichan.gt.ichankey) then ! jump to starting lat/lon
ichankey=ichan
latkey=latmin
lonkey=lonmin
go to 45
endif
c
if (lat.eq.'S') latd=-latd
if (lon.eq.'E') lond=-lond
c
if (latd+90.le.latmax.and.lond+180.le.lonmax) then
if (latd+90.gt.latkey) latkey=latd+90 ! adjust if needed
alat=dble(abs(latd))+dble(latm)/60.d0+dble(lats)/3600.d0
alon=dble(abs(lond))+dble(lonm)/60.d0+dble(lons)/3600.d0
if (lat.eq.'S') alat=-alat
if (lon.eq.'E') alon=-alon
alat=alat*radian
alon=alon*radian
call btween (rlat,rlon,alat,alon,distax,az1,az2,dummy)
if (cdunits.eq.'km') distax=distax*1.609344
if (distax.le.dist) then
icount=icount+1
c
if (listing.eq.'S') then
call shamdisp (amrec,dbms,out)
if(print)call shamdisp (amrec,dbms,out2)
else if (listing.eq.'M') then
call medamdisp (amrec,dbms,format_version,out)
if(print)call medamdisp (amrec,dbms,format_version,
& out2)
else
call lngamdisp (amrec,dbms,format_version,out)
if(print)call lngamdisp (amrec,dbms,format_version,
& out2)
endif
c
write (out,812) lat_ns,latd1,latm1,lats1,lon_ew,
2 lond1,lonm1,lons1,distax,cdunits
if(print)write (out2,812) lat_ns,latd1,latm1,lats1,
2 lon_ew,lond1,lonm1,lons1,distax,cdunits
812 format('0 Distance from ',a1,' Lat',3i3.2,1x,a1,' Lon',
2 i4,2i3.2,' is',f7.1,1x,a2)
write (out,813) lat_ns,latd1,latm1,lats1,
2 lon_ew,lond1,lonm1,lons1,az1
if(print)write (out2,813) lat_ns,latd1,latm1,lats1,
2 lon_ew,lond1,lonm1,lons1,az1
813 format(' Azimuth from ',a1,' Lat',3i3.2,1x,a1,' Lon',
2 i4,2i3.2,' is',f7.1,' degrees')
write (out,814) lat_ns,latd1,latm1,lats1,
2 lon_ew,lond1,lonm1,lons1,az2
if(print)write (out2,814) lat_ns,latd1,latm1,lats1,
2 lon_ew,lond1,lonm1,lons1,az2
814 format(' Azimuth to ',a1,' Lat',3i3.2,1x,a1,' Lon',
2 i4,2i3.2,' is',f7.1,' degrees'/)
endif
read (amdb,810,err=150,iostat=iostat,end=75) amrec
go to 50
else
lonkey=lonmin
latkey=latkey+1
if (latkey.gt.latmax) then
latkey=latmin
next_10_khz=(ichankey/10+1)*10
next_9_khz=(ichankey/9+1)*9
ichankey=min(next_10_khz,next_9_khz)
endif
if (ichankey.le.ichane) go to 45
endif
endif
75 continue
c
if (icount.eq.0) then
write (out,820)
if(print) write ( out2, 820 )
820 format ('0*** Nothing in the search range ***')
else
write ( out, 846 ) icount
if ( print ) write ( out2, 846 ) icount
846 format ( '0 Number of records in the search range = ', i8 )
end if
c
c if ( icount .le. 999 ) then
c call program_timer ( 1, .true., icount, 2, 'AMDIST ' )
c else
c call program_timer ( 1, .true., 999, 2, 'AMDIST ' )
c end if
c
100 continue
write (out,823)
823 format (/'$More? ')
call yesno (*125,*100,*100,in)
go to 20
c
125 continue
c We are here for a normal stop
if ( print ) then
write ( out2, 848 )
848 format ( '0 This is the end of the list.' )
close ( out2 )
end if
stop
c call exit Jeff Glass
c
150 continue
c We are here if we encountered an error in reading a record.
c
if (iostat.eq.22) then ! input record too long
write (out,824)
if(print) write ( out2, 824 )
824 format ('0*** Input record is too long ***',/,
2 '0*** Ask the System Manager to increase BYTLM for ',
3 'your Username; then, try again')
else
write (out,821) iostat
if(print) write (out2,821) iostat
821 format (' *** Error in reading record; status is',i4,' ***')
endif
go to 100
c
200 continue
c we are here if we encountered an error in opening the file.
write (out,822) iostat
if(print) write(out2,822) iostat
822 format (' *** Error in trying to access AM data base is',i4)
go to 125
c
2000 continue
c We come through here if we cannot read the header record
c
write (out,825) iostat,amdbname
if(print)write (out2,825) iostat,amdbname
825 format ('0*** AM Engineering Data Base is corrupted ***',/,
2 '0*** iostat trying to read header record is',i4,/,
3 '0*** File Name of data base is ',a)
go to 125
c
2002 continue
write ( out, 2004 ) iostat
2004 format ( '0*** Error in trying to open print file is ', i4 )
c 900 call exit Jeff Glass
900 stop
end
c
c
c
c
c
c
c
c
******************************************************************
c
subroutine amdist_handle_options
c
c Subroutine by John Boursy, April 1986.
c
c This subroutine should be called at the beginning of AMDIST to
c handle any options that may have been specified on the command
c line. For example, if AMDIST was initiated by typing AMDIST/
TEST,
c then this routine starts testing.
c
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
implicit none
c
c include '($ssdef)' Jeff Glass
c
integer max_options
parameter (max_options=6)
character*132 options
character*20 options_list(max_options)
integer num_options
c integer lib$get_foreign Jeff Glass
integer istat
integer out_len
logical overflow
integer loop
integer max_valid_options
parameter (max_valid_options=1)
character*20 valid_options(max_valid_options)

integer loop2
integer leng_option
integer leng_valid_option
integer length
logical l_dummy
logical start_testing
logical valid

data valid_options(1) /'/TESTING'/
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
c istat=lib$get_foreign (options,,out_len,) Jeff
Glass
c
c if (istat.ne. 1 ) call lib$stop (istat) Jeff
Glass
c
call break_out_options (options,options_list,max_options,
2 num_options,overflow)
c
if (num_options.eq.0) return
c
do 1000 loop=1,num_options,1
c
leng_option=length(options_list(loop))
valid=.false. ! set valid to true if find match
c
do 500 loop2=1,max_valid_options,1
c
leng_valid_option=length(valid_options(loop2))
c
if (leng_option.gt.leng_valid_option) go to 500
c
if (options_list(loop)(1:leng_option).eq.
2 valid_options(loop2)(1:leng_option)) then
c
valid=.true.
c
if (loop2.eq.1) then ! we have the /TESTING option
c
c Jeff Glass
c
c l_dummy=start_testing()
c
endif
c
endif
c
500 continue
c
if (.not.valid) then
c
c We are here if we have an option specified that does not
c match any of our valid options
c
write (*,801) options_list(loop)(1:leng_option)
801 format (' Invalid option ',a,' is ignored')
c
endif
c
1000 continue
c
return
end

subroutine degint (x,ideg,min,isec)
c
c Subroutine by John Boursy, October 1982.
c
c This subroutine takes a latitude or longitude in double
precision
c floating point degrees, and converts it to degrees, minutes, and
c seconds.
c
c Only the absolute value of 'x', the input argument, is used.
The
c calling routine must take account of any conventions used
c that involved negative numbers.
c
double precision x
double precision xabs
c
xabs=abs(x)
ideg=xabs
xlatm1=(xabs-ideg)*60.
min=xlatm1
xlats1=(xabs-ideg-float(min)/60.)*3600.
isec=xlats1+0.5
c
if (isec.eq.60) then
isec=0
min=min+1
endif
c
if (min.eq.60) then
min=0
ideg=ideg+1
endif
c
return
end

C BEARING, DISTANCE, AND MIDPOINT LATITUDE
C
C
C BBBB TTTTT W W EEEEE EEEEE N N
C B B T W W E E NN N
C BBBBB T W W EEEE EEEE N N N
C B B T W WW W E E N N N
C B B T WW WW E E N NN
C BBBBB T W W EEEEEE EEEEEE N N
C
C
C
******************************************************************
C
SUBROUTINE BTWEEN ( ALAT, ALONG, BLAT, BLONG, DIST, AZ1, AZ2,
& AMDLAT )
C
C
******************************************************************
C
C GIVEN POINT1 AND POINT2 -- FIND DISTANCE BETWEEN 1 AND 2,
C AZIMUTH FROM 1 TO 2, AZIMUTH FROM 2 TO 1, AND MIDPOINT
C LATITUDE OF THE PATH BETWEEN 1 AND 2.
C INPUT ARGUMENTS ARE THE COORDINATES OF POINT1 (ALAT,ALONG)
C AND POINT2 (BLAT,BLONG) IN DOUBLE PRECISION FORMAT IN
C RADIANS.
C OUTPUT ARGUMENTS ARE DISTANCE BETWEEN 1 AND 2, AZIMUTH FROM 1
C TO 2 (AZ1), AZIMUTH FROM 2 TO 1 (AZ2), AND MIDPOINT
C LATITUDE (AMDLAT), ALL IN FLOATING POINT DEGREES EXCEPT
C THE DISTANCE WHICH IS IN MILES.
C SIGN CONVENTIONS -- NORTH LATITUDES AND WEST LONGITUDES ARE
C POSITIVE, SOUTH LATITUDES AND EAST LONGITUDES ARE
NEGATIVE
C THIS SUBROUTINE USES THE GREAT CIRCLE METHOD OF CALCULATION,
C AND IS BASED ON SPHERICAL TRIGONOMETRY. ASSUME A
C SPHERICAL TRIANGLE WITH VERTICES AT THE NORTH POLE AND
AT
C POINTS 1 AND 2. ASSUME ANGLE C TO BE THE ONE WITH A
C VERTEX AT THE NORTH POLE - SIDE CC TO BE OPPOSITE ANGLE
C.
C CC IS THE DISTANCE BETWEEN POINTS 1 AND 2. ASSUME
ANGLES
C A AND B AND SIDES AA AND BB TO BE THE OTHER ANGLES AND
C SIDES OF THE SPHERICAL TRIANGLE. SIDE AA IS OPPOSITE
C ANGLE A, AND SIDE BB IS OPPOSITE ANGLE B. FOR MIDPOINT
C LATITUDE CALCULATIONS ASSUME DD TO EXTEND FROM THE NORTH
C POLE TO THE MIDPOINT OF CC. THE PERTINENT TRIG
C IDENTITIES ARE --
C COS(CC) = COS(AA)*COS(BB) + SIN(AA)*SIN(BB)*COS(C)
C SOLVE FOR CC
C COS(AA) = COS(BB)*COS(CC) + SIN(BB)*SIN(CC)*COS(A)
C SOLVE FOR A
C COS(BB) = COS(CC)*COS(AA) + SIN(CC)*SIN(AA)*COS(B)
C SOLVE FOR B
C COS(DD) = COS(BB)*COS(CC/2) + SIN(BB)*SIN(CC/
2)*COS(A)
C SOLVE FOR DD
C***********************************************************************
C
DOUBLE PRECISION ALAT, ALONG, BLAT, BLONG
DOUBLE PRECISION AA, BB, C, CC, COSCC, COSA, COSB, CCHALF, COSDD
DOUBLE PRECISION COSAA, COSBB, SINAA, SINBB, DCOSCC, SINCC
C
DOUBLE PRECISION PIHALF / 1.570796326794896D0 /
DOUBLE PRECISION PI / 3.141592653589793D0 /
C
DOUBLE PRECISION DMC / 69.08404915D0 /
C
*************************************************************************
C Note: The value for DMC is determined as follows:
C
C 111.18 km/degree
C ---------------- = 69.08404915 miles/degree
C 1.609344 km/mile
C
C 111.18 km/degree comes from our international agreements,
and
C is the value which is used in the skywave curves formula
C adopted in MM Docket 88-508.
C
C If a spherical earth of equal area is assumed, (radius of
C 3958.7 miles) then the value would be:
C
C (3958.7 miles)(2pi)
C -------------------- = 69.09234911 miles/degree
C 360 degrees
C
C Which is the more common number. To be consistant with
C our international agreements, we are using the 69.08
value.
C This is in agreement with Tom Lucy, Larry Olson,
C Gary Kalagian and Bill Ball, all of Mass Media Bureau,
C January 1992.
C***********************************************************************
C
DATA TOL / 4.0E-6 / ! TOL < 1 SECOND IN RADIANS
DATA DEGREE / 57.2957795 /
C
ISIG = 0 ! ISIG = 0 MEANS POINT 2 WEST OF POINT1
JSIG = 0 ! JSIG = 0 MEANS 1ST ATTEMPT AT C IS < 180
DEGREES
C
AA = PIHALF - BLAT ! AA IN RADIANS
BB = PIHALF - ALAT ! BB IN RADIANS
C = ALONG - BLONG ! C IN RADIANS
C
IF ( ABS( C ) .LT. TOL ) GO TO 40
IF ( C .GT. 0. ) GO TO 10
C
ISIG = 1 ! MEANS POINT1 WEST OF POINT2
C = ABS(C)
C
10 CONTINUE
IF ( C .LT. PI ) GO TO 20 ! C < 180 DEGREES
JSIG = 1 ! MEANS 1ST ATTEMPT AT C IS > 180
DEGREES
C = PI * 2.D0 - C ! MAKING C < 180 DEGREES
C
20 CONTINUE
COSAA = DCOS(AA)
COSBB = DCOS(BB)
SINAA = DSIN(AA)
SINBB = DSIN(BB)
DCOSCC = COSAA * COSBB + SINAA * SINBB * DCOS(C)
COSCC = DCOSCC
IF ( COSCC .LT. -1.0D0 ) COSCC = -1.0D0
IF ( COSCC .GT. 1.0D0 ) COSCC = 1.0D0
CC = DACOS( COSCC ) ! DISTANCE IN RADIANS
DIST = CC * DEGREE * DMC ! RADIANS TO DEGREES TO MILES
SINCC = DSIN(CC)
COSA = ( COSAA - COSBB * DCOSCC ) / ( SINBB * SINCC )
IF ( COSA .LT. -1.0D0 ) COSA = -1.0D0
IF ( COSA .GT. 1.0D0 ) COSA = 1.0D0
A = DEGREE * DACOS( COSA ) ! A IN DEGREES
COSB = ( COSBB - DCOSCC * COSAA ) / ( SINCC * SINAA )
IF ( COSB .LT. -1.0D0 ) COSB = -1.0D0
IF ( COSB .GT. 1.0D0 ) COSB = 1.0D0
B = DEGREE * ACOS( COSB ) ! B IN DEGREES
CCHALF = CC / 2.D0
C
C DIST FROM PT1 TO MIDLAT IN RADIANS
C
COSDD = COSBB * DCOS( CCHALF ) + SINBB * DSIN( CCHALF ) * COSA
IF ( COSDD .LT. -1.0D0 ) COSDD = -1.0D0
IF ( COSDD .GT. 1.0D0 ) COSDD = 1.0D0
DD = DEGREE * DACOS( COSDD )
AMDLAT = 90. - DD ! MIDPOINT LATITUDE IN DEGREES
IF ( ISIG .NE. JSIG ) GO TO 30
AZ1 = A
C
C CONVERTING TO DEGREES EAST OF TRUE NORTH
C
AZ2 = 360. - B
C
C CONVERTING TO DEGREES EAST OF TRUE NORTH
C
RETURN
C
30 CONTINUE
AZ1 = 360. - A
C
C CONVERTING TO DEGREES EAST OF TRUE NORTH
C
AZ2 = B
C
C CONVERTING TO DEGREES EAST OF TRUE NORTH
C
RETURN
C
40 CONTINUE
AMDLAT = ( ALAT + BLAT ) / 2. * DEGREE
C
C IF SAME LONG, MIDLAT = AVELAT
C
IF ( ABS( ALAT - BLAT ) .LT. TOL ) GO TO 60
C
C PT1 < 1 SEC FROM PT2
C
CC = ABS( AA - BB )
C
C CC IN RADIANS - BOTH POINTS HAVE SAME LONG
C
DIST = CC * DEGREE * DMC ! RADIANS TO DEGREES TO MILES
IF ( AA .GT. BB ) GO TO 50
AZ1 = 0.
AZ2 = 180.
C
C POINT2 IS STRAIGHT NORTH OF POINT1
C
RETURN
C
50 CONTINUE
AZ1 = 180.
AZ2 = 0.
C
C POINT1 IS STRAIGHT NORTH OF POINT2
C
RETURN
C
60 CONTINUE
C
C POINT1 LESS THAN 1 SECOND FROM POINT2
C
DIST = 0.
AZ1 = 0.
AZ2 = 0.
RETURN
C
END

SUBROUTINE YESNO (*,*,*,IN)
c
c Subroutine by John Boursy.
C
C THIS SUBROUTINE READS A 84-CHARACTER (OR LESS) INPUT FROM
C FILE CODE 'IN', AND DETERMINES WHETHER IT IS A 'YES' OR
C 'NO' ANSWER. IN ADDITION, OTHER RESPONSES ARE ACCEPTABLE.
C IN PARTICULAR, VARIOUS HONEYWELL 6000 SUBSYSTEMS CAN BE
ACCESSED.
C
C THE ACCEPTABLE RESPONSES ARE --
C
C YES MEANS 'YES'
C Y MEANS 'YES'
C NO MEANS 'NO'
C N MEANS 'NO'
C (BLANK) MEANS 'NO'
C STOP STOPS THE RUN
c EXIT same as STOP
c QUIT same as STOP
c DONE same as STOP
C <Ctrl>Z ACTS AS IF AN END-OF-FILE HAS BEEN READ ON UNIT IN
c
c The acceptable responses may be either lower or upper case.
C
C THERE IS THE ONE NORMAL RETURN FROM THIS SUBROUTINE. THERE ARE
C ALSO THREE ABNORMAL RETURNS. THEY ARE USED AS FOLLOWS --
C
C NORMAL RETURN -- WHEN THE ANSWER IS 'YES'
C 1ST ABNORMAL RETURN -- WHEN THE ANSWER IS 'NO'
C 2ND ABNORMAL RETURN -- WHEN THE ANSWER IS NOT YES/NO AND THE
C SUBSYSTEM HAS BEEN CALLED, AND WE HAVE RETURNED
C FROM IT.
C 3RD ABNORMAL RETURN -- WHEN THE ANSWER IS <Ctrl>Z
C
C
******************************************************************
C
C THE NEXT STATEMENT IS THE FIRST STATEMENT
C
C
******************************************************************
C
CHARACTER*84 CBUFF
C
C
******************************************************************
C
C THE FOLLOWING STATEMENT IS THE FIRST EXECUTABLE STATEMENT
C
C
******************************************************************
C
READ ( IN, 800, END=805 ) CBUFF
800 FORMAT (A84)
call upper (cbuff) ! puts cbuff all in upper case
c
if (cbuff.eq.'Y'.or.cbuff.eq.'YES') then
return
else if (cbuff.eq.'N'.or.cbuff.eq.' '.or.cbuff.eq.'NO') then
return 1
else if (cbuff.eq.'STOP'.or.cbuff.eq.'EXIT'.or.cbuff.eq.'QUIT'
3 .or.cbuff.eq.'DONE') then
stop
else
return 2
endif
C
805 RETURN 3
c
end

subroutine getnextlu (lu)
c
c Subroutine by John Boursy, February 1985.
c
c This subroutine is designed to return the next available
c FORTRAN logical unit number, in the range from 20 to 99,
c inclusive. The lowest, unused number in this range is
c returned. If the logical unit has previously been used, and
c has subsequently been CLOSEd, it is again available for
c consideration by this routine.
c
c We begin at 20 to allow those logical units below 20 to be
c explicitly assigned by the user.
c
c Here is a description of the argument:
c
c lu -- output; integer; the next available logical unit
c number in the range from 20 to 99; if all of the
c numbers in the range from 20 to 99 are in use (an
c impossible occurance since who has 80 files open
c at one time?), a value of 0 is returned.
c
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
implicit none
integer lu
logical opened
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
do 100 lu=20,99,1
c
inquire (unit=lu,opened=opened)
c
if (.not.opened) return ! We found it!!!!
c
100 continue
c
c We should finish the DO loop only if all logical units from 20
c through 99 are in use, an extremely unlikely occurance. But,
c just in case, we set lu to 0 to cover this possibility.
c
lu=0
c
return
end

SUBROUTINE dSPRONG (ALAT,ALONG,DIST,AZ,BLAT,BLONG)
c
c Subroutine by John Boursy.
C
C GIVEN A STARTING SET OF COORDINATES, AND A DISTANCE AND AZIMUTH,
C THE COORDINATES OF A TERMINAL POINT (LOCATED AT THAT DISTANCE
C AND AZIMUTH FROM THE STARTING POINT) ARE FOUND.
C
C COORDINATES ARE GIVEN IN RADIANS, BUT THE AZIMUTH IS IN DEGREES.
C THE DISTANCE IS IN MILES.
c
c The coordinates are double precision.
C
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
double precision alat,along,blat,blong
double precision aa,bb,cc,c
double precision cosaa,sinbb,cosbb,coscc,cosc
double precision radian /0.017453292519943d0/
double precision pihalf /1.570796326794896d0/ ! pi/2
double precision pi /3.141592653589793d0/
double precision twopi /6.283185307179586d0/ ! 2*pi
C
DOUBLE PRECISION DMC / 69.08404915D0 /
C
*************************************************************************
C Note: The value for DMC is determined as follows:
C
C 111.18 km/degree
C ---------------- = 69.08404915 miles/degree
C 1.609344 km/mile
C
C 111.18 km/degree comes from our international agreements,
and
C is the value which is used in the skywave curves formula
C adopted in MM Docket 88-508.
C
C If a spherical earth of equal area is assumed, (radius of
C 3958.7 miles) then the value would be:
C
C (3958.7 miles)(2pi)
C -------------------- = 69.09234911 miles/degree
C 360 degrees
C
C Which is the more common number. To be consistant with
C our international agreements, we are using the 69.08
value.
C This is in agreement with Tom Lucy, Larry Olson,
C Gary Kalagian and Bill Ball, all of Mass Media Bureau,
C January 1992.
C***********************************************************************
C
DATA TOL/0.05/ ! TOL IS 0.05 MILES
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
C
IF (DIST.LT.TOL) GO TO 20 ! SMALL DIST, THEN POINT1=POINT2
C
ISIG=0 ! MEANS AZIMUTH < 180 DEGREES
A=AMOD(AZ,360.0)
IF (A.LT.0.0) A=360.0+A
IF (A.GT.180.0) THEN
A=360.0-A
ISIG=1 ! MEANS AZIMUTH > 180 DEGREES
ENDIF
C
A=A*RADIAN
BB=PIHALF-ALAT
CC=DIST*RADIAN/DMC
SINBB=SIN(BB)
COSBB=COS(BB)
COSCC=COS(CC)
COSAA=COSBB*COSCC+SINBB*SIN(CC)*COS(A)
IF (COSAA.LE.-1.0d0) COSAA=-1.0d0
IF (COSAA.GE.1.0d0) COSAA=1.0d0
AA=ACOS(COSAA)
COSC=(COSCC-COSAA*COSBB)/(SIN(AA)*SINBB)
IF (COSC.LE.-1.0d0) COSC=-1.0d0
IF (COSC.GE.1.0d0) COSC=1.0d0
C=ACOS(COSC)
BLAT=PIHALF-AA
BLONG=ALONG-C
IF (ISIG.EQ.1) BLONG=ALONG+C
IF (BLONG.GT.PI) BLONG=BLONG-TWOPI
IF (BLONG.LT.-PI) BLONG=BLONG+TWOPI
RETURN
C
20 CONTINUE
C WE ARE HERE WHEN THE DISTANCE IS VERY SMALL
BLAT=ALAT
BLONG=ALONG
RETURN
END

subroutine medamdisp (amrec,dbms,format_version,out)
c
c Subroutine by John Boursy, April 1983.
c Modified by Gary Kalagian, May 1995.
c
c This subroutine prints a medium display of the data in the
record
c which is supplied. If dbms is true, the Sequence and ID numbers
c are also printed.
c
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
implicit none
c
integer maxtower
integer maxaug
parameter (maxtower=20)
parameter (maxaug=28)
logical dbms
integer format_version
character*2400 amrec
integer ifreq
character*6 control
character*6 id
character*7 call
character*27 city
character*2 state
character*2 country
character*4 prefix
character*8 arn
character*1 domstatus
character*1 schedule
character*1 hours
character*4 dstatus
character*1 lat,lon
integer latd
integer latm
integer lats
integer lond
integer lonm
integer lons
character*3 chours
character*76 comment
character*3 antmode
character*1 r2class
character*1 dompat
character*4 pattern
character*2 class
character*5 clnum
character*6 cldate
character*1 ifrb_list
character*6 ifrb_plan_date
character*9 ifrb_serial
character*6 e_sub_u
character*6 updater
character*6 update
character*1 nstatus
character*1 notpat
character*13 notstatus
integer out
integer lu_term/6/
real q
character*13 q_ascii
character*1 can_coord_status
character*1 mex_coord_status
character*1 r2_coord_status
character*6 cutoff
integer length
character*13 can_coord_status_l ! long version of
can_coord_status
character*13 mex_coord_status_l ! long version of
mex_coord_status
character*13 r2_coord_status_l ! long version of
r2_coord_status
character*13 am_coord_status
character*1 cc /' '/ ! Single spacing for bad/dummy data msg
c
real f(maxtower)
real phase(maxtower)
real g(maxtower)
double precision space(maxtower)
double precision orien(maxtower)
integer nda(maxtower)
integer itlsec(maxtower)
real f1d(maxtower)
real f2d(maxtower)
real f3d(maxtower)
real f4d(maxtower)
double precision space_r(maxtower) ! in radians
double precision orien_r(maxtower) ! in radians
real azaug(maxaug)
real span(maxaug)
real rad(maxaug)
c
character*4 amdstatus
character*3 amhours
character*4 ampattern
character*13 amnstatus
character*1 bad_data
character*1 dummy_data
real power
real rms
integer ntower
integer naug
integer result
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
call amdb_decode (amrec,format_version,maxtower,maxaug,ifreq,
2
control,id,country,state,city,call,prefix,arn,domstatus,hours,
3 r2class,dompat,class,lat,latd,latm,lats,lon,lond,lonm,lons,
4
power,ntower,q,antmode,schedule,naug,rms,clnum,cldate,nstatus,
5 notpat,comment,update,cutoff,dummy_data,bad_data,
6 can_coord_status,mex_coord_status,r2_coord_status,
7 ifrb_plan_date,ifrb_list,ifrb_serial,e_sub_u,updater,f,g,
8 phase,space,orien,nda,itlsec,f1d,f2d,f3d,f4d,azaug,span,
9 rad,result)
c
if (result.ne.0) go to 1000 ! error in reading record
c
dstatus=amdstatus(domstatus)
c
chours=amhours(hours)
c
if (country.eq.'US') then ! use domestic pattern
pattern=ampattern(dompat)
else ! use notified pattern
pattern=ampattern(notpat)
endif
c
c Display the q value as the characters actually stored in the
c record without conversion to floating point decimal.
c
if (q.lt.0.0) then ! no Q specified in data base
q_ascii=' '
else
q_ascii(1:4) = amrec(368:371)
q_ascii(5:5) = '.'
q_ascii(6:13) = amrec(372:379)
endif
c
notstatus=amnstatus(nstatus)
c
can_coord_status_l=am_coord_status(can_coord_status)
mex_coord_status_l=am_coord_status(mex_coord_status)
r2_coord_status_l=am_coord_status(r2_coord_status)
c
if (updater.ne.'IFRB') updater='FCC'
c
write (out,805) call,city,state,country,ifreq,prefix,arn,
2 dstatus,chours,antmode(1:2),antmode(3:3),schedule
805 format ('0',a7,2x,a27,1x,a2,1x,a2,i5,' kHz ',a4,a8,1x,a4,1x,
2 a3,1x,a2,'-',a1,'-',a1)
c
if (dbms) write (out,803) control,id,updater
803 format (' Sequence No. ',a6,5x,'ID No. ',a6,5x,'Updated by ',a)
c
write (out,806) lat,latd,latm,lats,lon,lond,lonm,lons,class,
2 r2class,rms
806 format (1x,a1,' Lat',3i3.2,1x,a1,' Lon',i4,2i3.2,' Class ',a2,
2 ' Region 2 Class ',a1,' RMS:',f9.2,' mV/m')
c
write (out,807) power,notstatus,clnum,cldate,update
807 format (1x,f10.5,' kW',5x,a13,' CL# ',a5,
2 ' (',a6,') Last Updated ',a6)
c
if (country.eq.'US'.and.domstatus.eq.'C') then
c
write (out,819) ntower,pattern,naug,q_ascii,cutoff
819 format (i3,' Towers; ',a4,' Pattern;',i3,' Augmentations; Q: ',
2 a13'; Expire: ',a6)
c
else
c
write (out,818) ntower,pattern,naug,q_ascii,cutoff
818 format (i3,' Towers; ',a4,' Pattern;',i3,' Augmentations; Q: ',
2 a13'; Cutoff: ',a6)
c
end if
c
write (out,809) ifrb_serial,ifrb_list,ifrb_plan_date
809 format (' IFRB Serial # ',a,'; Entered into List ',a,' on ',a)
c
write (out,831)
can_coord_status_l(1:length(can_coord_status_l)),
2 mex_coord_status_l(1:length(mex_coord_status_l)),
3 r2_coord_status_l(1:length(r2_coord_status_l))
831 format (' Coordination Status: Canada: ',a,'; Mexico: ',a,
2 '; Region 2: ',a)
c
if (comment.ne.' ') write (out,804) comment
804 format (3x,a76)
c
if (bad_data.ne.' ') call am_bad_data (bad_data,out,lu_term,cc)
c
if (dummy_data.ne.' ') call am_dummy_data (dummy_data,out,
& lu_term,cc)
c
return
c
1000 continue
c We come through here when we have an error in the reading of the
c input record.
c
if (result.ge.1.and.result.le.4) then
c
write (out,801) result,'7'x,'7'x,amrec(1:79),'7'x,'7'x
801 format ('0*** Error in trying to read Item',i2,
2 ' in following record ***',
3 2a1,/,'0',a79,/,'0*** Non-numeric data where numeric data
',
4 'should be *** Record ignored ***',/,'0*** Please inform
',
5 'the Data Base Management Staff *** Thank you ***',2a1)
c
else if (result.eq.5) then
c
write (out,802) '7'x,'7'x,amrec(1:79),'7'x,'7'x,naug
802 format ('0*** Error in trying to read following record ***',
2 2a1,/,'0',a79,/,'0***',i3,' augmentations specified, but
',
3 'only 1 was supplied *** Record ignored ***',/,
4 '0*** Please inform the Data Base Management Staff *** ',
5 'Thank you ***',2a1)
endif
c
return
end

subroutine shamdisp (amrec,dbms,out)
c
c Subroutine by John Boursy, April 1983.
c
c This subroutine prints a short display of the data in the record
c which is supplied. If dbms is true, the Sequence and ID numbers
c are also printed.
c
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
logical dbms
c
character*2400 amrec
character*7 call
character*27 city
character*2 state
character*2 country
character*12 filenum
character*1 domstatus
character*1 hours
character*4 dstatus
character*3 chours
character*76 comment
character*4 antmode
c
integer out
c
character*4 amdstatus
character*3 amhours
character*6 updater
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
read (amrec,801,err=1000)
ifreq,iseq,id,country,filenum,domstatus,
2 hours,updater,city,state,call,antmode,comment
801 format (i4,i6,t13,i6,a2,t27,a12,2a1,t110,a6,t323,a27,a2,a7,
2 t380,a4,t387,a76)
c
dstatus=amdstatus(domstatus)
c
chours=amhours(hours)
c
if (updater.ne.'IFRB') updater='FCC'
c
write (out,802) call,city,state,country,ifreq,filenum,dstatus,
2 chours,antmode(1:2),antmode(3:3),antmode(4:4)
802 format ('0',a7,2x,a27,1x,a2,1x,a2,i5,' kHz ',a12,1x,a4,1x,a3,1x,
2 a2,'-',a1,'-',a1)
c
if (dbms) write (out,803) iseq,id,updater
803 format (' Sequence No.',i7,5x,'ID No.',i7,5x,'Updated by ',a)
c
if (comment.ne.' ') write (out,804) comment
804 format (3x,a76)
c
return
c
1000 continue
c We come through here when we have an error in the reading of the
c input record.
c
write (out,805) '7'x,'7'x,amrec(1:79),'7'x,'7'x
805 format ('0*** Error in trying to read following record ***',2a1,
2 /,'0',a79,/,'0*** Non-numeric data where numeric data ',
3 'should be *** Record ignored ***',/,'0*** Please inform ',
4 'the Data Base Management Staff *** Thank you ***',2a1)
return
end

subroutine lngamdisp (amrec,dbms,format_version,out)
c
c Subroutine by John Boursy, April 1983.
c Modified by Gary Kalagian, May 1995.
c
c This subroutine prints a long display of the data in the record
c which is supplied. If dbms is true, the Sequence and ID numbers
c are also printed.
c
c In displaying the tower information, if there is a spacing and
c orientation with respect to the immediately preceeding tower,
c the adjusted spacing and orientation is also printed. However,
c this is not printed if all spacings and orientations are with
c respect to the common origin.
c
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
implicit none
c
integer maxtower
integer maxaug
parameter (maxtower=20)
parameter (maxaug=28)
logical dbms
integer format_version
logical tlsec
character*2400 amrec
character*600 ambuff
integer ifreq
character*6 control
character*6 id
character*7 call
character*27 city
character*2 state
character*2 country
character*4 prefix
character*8 arn
character*1 domstatus
character*1 schedule
character*1 hours
character*4 dstatus
character*1 lat,lon
integer latd
integer latm
integer lats
integer lond
integer lonm
integer lons
character*3 chours
character*76 comment
character*3 antmode
character*1 r2class
character*1 dompat
character*4 pattern
character*2 class
character*5 clnum
character*6 cldate
character*1 ifrb_list
character*6 ifrb_plan_date
character*9 ifrb_serial
character*6 e_sub_u
character*6 updater
character*6 update
character*1 nstatus
character*1 notpat
character*13 notstatus
integer out
integer lu_term/6/
real q
character*13 q_ascii
character*1 can_coord_status
character*1 mex_coord_status
character*1 r2_coord_status
character*6 cutoff
integer length
character*13 can_coord_status_l ! long version of
can_coord_status
character*13 mex_coord_status_l ! long version of
mex_coord_status
character*13 r2_coord_status_l ! long version of
r2_coord_status
character*13 am_coord_status
character*1 cc /' '/ ! Single spacing for bad/dummy data msg
c
real f(maxtower)
real phase(maxtower)
real g(maxtower)
double precision space(maxtower)
double precision orien(maxtower)
integer nda(maxtower)
integer itlsec(maxtower)
real f1d(maxtower)
real f2d(maxtower)
real f3d(maxtower)
real f4d(maxtower)
double precision adjspace(maxtower)
double precision adjorien(maxtower)
double precision space_r(maxtower) ! in radians
double precision orien_r(maxtower) ! in radians
real azaug(maxaug)
real span(maxaug)
real rad(maxaug)
c
character*4 amdstatus
character*3 amhours
character*4 ampattern
character*13 amnstatus
character*1 bad_data
character*1 dummy_data
real power
real rms
integer ntower
integer naug
integer result
integer loop
integer klm
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
call amdb_decode (amrec,format_version,maxtower,maxaug,ifreq,
2
control,id,country,state,city,call,prefix,arn,domstatus,hours,
3 r2class,dompat,class,lat,latd,latm,lats,lon,lond,lonm,lons,
4
power,ntower,q,antmode,schedule,naug,rms,clnum,cldate,nstatus,
5 notpat,comment,update,cutoff,dummy_data,bad_data,
6 can_coord_status,mex_coord_status,r2_coord_status,
7 ifrb_plan_date,ifrb_list,ifrb_serial,e_sub_u,updater,f,g,
8 phase,space,orien,nda,itlsec,f1d,f2d,f3d,f4d,azaug,span,
9 rad,result)
c
if (result.ne.0) go to 1000 ! error in reading record
c
dstatus=amdstatus(domstatus)
c
chours=amhours(hours)
c
if (country.eq.'US') then ! use domestic pattern
pattern=ampattern(dompat)
else ! use notified pattern
pattern=ampattern(notpat)
endif
c
c Display the q value as the character value stored in the record
c without converting to a real number.
c
if (q.lt.0.0) then ! no Q specified in data base
q_ascii=' '
else
q_ascii(1:4) = amrec(368:371)
q_ascii(5:5) = '.'
q_ascii(6:13) = amrec(372:379)
endif
c
notstatus=amnstatus(nstatus)
c
can_coord_status_l=am_coord_status(can_coord_status)
mex_coord_status_l=am_coord_status(mex_coord_status)
r2_coord_status_l=am_coord_status(r2_coord_status)
c
if (updater.ne.'IFRB') updater='FCC'
c
write (out,805) call,city,state,country,ifreq,prefix,arn,
2 dstatus,chours,antmode(1:2),antmode(3:3),schedule
805 format ('0',a7,2x,a27,1x,a2,1x,a2,i5,' kHz ',a4,a8,1x,a4,1x,
2 a3,1x,a2,'-',a1,'-',a1)
c
if (dbms) write (out,803) control,id,updater
803 format (' Sequence No. ',a6,5x,'ID No. ',a6,5x,'Updated by ',a)
c
write (out,806) lat,latd,latm,lats,lon,lond,lonm,lons,class,
2 r2class,rms
806 format (1x,a1,' Lat',3i3.2,1x,a1,' Lon',i4,2i3.2,' Class ',a2,
2 ' Region 2 Class ',a1,' RMS:',f9.2,' mV/m')
c
write (out,807) power,notstatus,clnum,cldate,update
807 format (1x,f10.5,' kW',5x,a13,' CL# ',a5,
2 ' (',a6,') Last Updated ',a6)
c
if (country.eq.'US'.and.domstatus.eq.'C') then
write (out,819) ntower,pattern,naug,q_ascii,cutoff
819 format (i3,' Towers; ',a4,' Pattern;',i3,' Augmentations; Q: ',
2 a13'; Expire: ',a6)
c
else
c
write (out,818) ntower,pattern,naug,q_ascii,cutoff
818 format (i3,' Towers; ',a4,' Pattern;',i3,' Augmentations; Q: ',
2 a13'; Cutoff: ',a6)
c
end if
c
write (out,809) ifrb_serial,ifrb_list,ifrb_plan_date
809 format (' IFRB Serial # ',a,'; Entered into List ',a,' on ',a)
c
write (out,831)
can_coord_status_l(1:length(can_coord_status_l)),
2 mex_coord_status_l(1:length(mex_coord_status_l)),
3 r2_coord_status_l(1:length(r2_coord_status_l))
831 format (' Coordination Status: Canada: ',a,'; Mexico: ',a,
2 '; Region 2: ',a)
c
if (comment.ne.' ') write (out,804) comment
804 format (3x,a76)
c
if (bad_data.ne.' ') call am_bad_data (bad_data,out,lu_term,cc)
c
if (dummy_data.ne.' ') call am_dummy_data (dummy_data,out,
& lu_term,cc)
c
100 continue
tlsec=.false. ! initialize; are any towers tl or sec?
c
do 200 loop=1,ntower,1
if (itlsec(loop).ne.0) tlsec=.true.
200 continue
c
if (ntower.gt.1) then
call am_tower_ref (ntower,space,adjspace,orien,adjorien,
2 orien_r,space_r,nda,klm)
else
klm=0
endif
c
if (klm.eq.0) then ! all spacings/orientations to common origin
write (out,812)
812 format (/,4x,'Field',t43,'Tow Ref',/,4x,'Ratio',5x,'Phasing',
2 3x,'Spacing',3x,'Orient',3x,'Switch',3x,'Height',/)
c
write (out,813) (f(loop),phase(loop),space(loop),orien(loop),
2 nda(loop),g(loop),loop=1,ntower,1)
813 format (f11.4,2f10.3,f9.3,i6,f12.1)
else ! adjusted spacings and orientations to be printed
write (out,840)
840 format (/,4x,'Field',t43,'Tow Ref',t65,'Adj',t76,'Adj',/,
2 4x,'Ratio',5x,'Phasing',3x,'Spacing',3x,'Orient',3x,'Switch',
3 3x,'Height',t63,'Spacing',5x,'Orient',/)
c
write (out,841) (f(loop),phase(loop),space(loop),orien(loop),
2 nda(loop),g(loop),adjspace(loop),adjorien(loop),
3 loop=1,ntower,1)
841 format (f11.4,2f10.3,f9.3,i6,f12.1,2f11.3)
endif
c
if (tlsec) then ! we have top-loaded and/or sectionalized
towers
write (out,816)
816 format ('0 TL/Sec',5x,'A',7x,'B',7x,'C',7x,'D',/)
write (out,817) (itlsec(loop),f1d(loop),f2d(loop),f3d(loop),
2 f4d(loop),loop=1,ntower,1)
817 format (i6,2x,4f8.1)
endif
c
if (naug.ge.1) then
write (out,814)
814 format ('0',9x,'Augmentation Parameters',/,'0',9x,'Azimuth',
2 3x,'Span',6x,'Aug',/)
write (out,815)
(loop,azaug(loop),span(loop),rad(loop),loop=1,
2 naug,1)
815 format (i5,'.',f10.1,f8.1,f10.2)
endif
c
return
c
1000 continue
c We come through here when we have an error in the reading of the
c input record.
c
if (result.ge.1.and.result.le.4) then
c
write (out,801) result,'7'x,'7'x,amrec(1:79),'7'x,'7'x
801 format ('0*** Error in trying to read Item',i2,
2 ' in following record ***',
3 2a1,/,'0',a79,/,'0*** Non-numeric data where numeric data
',
4 'should be *** Record ignored ***',/,'0*** Please inform
',
5 'the Data Base Management Staff *** Thank you ***',2a1)
c
else if (result.eq.5) then
c
write (out,802) '7'x,'7'x,amrec(1:79),naug,'7'x,'7'x
802 format ('0*** Error in trying to read following record ***',
2 2a1,/,'0',a79,/,'0***',i3,' augmentations specified, but
',
3 'only 1 was supplied *** Record ignored ***',/,
4 '0*** Please inform the Data Base Management Staff *** ',
5 'Thank you ***',2a1)
endif
c
return
end

subroutine am_bad_data (bad_data,lu_out,lu_term,cc)
c
c Subroutine by John Boursy, July 1986.
c
c This subroutine prints out a warning message that we have known
c bad data. If we are using an ANSI terminal, the message is done
c in bold, flashing. The warning message will vary, depending on
c what data is known to be bad.
c
c Note that a lack of a message does not necessarily mean that the
c data is good; it might simply mean that we haven't yet
discovered
c that it is bad.
c
c Here is a description of the arguments:
c
c bad_data -- input; character; indicates whether or not we
have
c bad data; possible values are:
c
c blank -- no data is known to be bad; this routine
c does nothing.
c B -- Some (undefined) data is known to be
bad.
c V -- Antenna parameters affecting
calculations
c in the vertical plane are known to be
bad;
c antenna parameters affecting
calculations
c in the horizontal plane are not known to
c be bad.
c 1 -- Coordinates are known to be bad.
c 2 -- Antenna parameters are known to be bad
c for both horizontal and vertical plane
c calculations.
c 3 -- Both coordinates and antenna parameters
c are known to be bad.
c
c lu_out -- input; integer; the FORTRAN logical unit number
c for output of the results.
c
c lu_term -- input; integer; the FORTRAN logical unit number
c for output to a terminal.
c
c cc -- input; character; the FORTRAN carriage control
c character that will be used in printing the
c message; the most likely values are "0" for
c double spacing and blank for single spacing.
c
c Note that lu_out and lu_term will be equal if we are running
c interactively with output of the results to the terminal.
c Otherwise, lu_out and lu_term will be different. This is used
c to determine whether we want to make the output bold and
flashing
c when we print the message about bad data; we want to print it
c bold and flashing only when the output is going to an ANSI
c terminal, not if it is going to a printing terminal, printer, or
c file.
c
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
integer lu_out
integer lu_term
character*1 bad_data
character*1 cc
character*2 escape /'1B'x/
logical ansi_crt
logical its_ansi
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
if (bad_data.ne.' ') then
c
if (ansi_crt().and.lu_out.eq.lu_term) then
its_ansi=.true.
else
its_ansi=.false.
endif
c
if (its_ansi) write (lu_out,801) escape,'[1;5m' ! bold,
flashing
801 format ('+',a1,a)
c
if (bad_data.eq.'1') then
write (lu_out,802) cc
802 format (a,'*** Warning *** Coordinates known to be bad
***')
else if (bad_data.eq.'2') then
write (lu_out,803) cc
803 format (a,'*** Warning *** Antenna Parameters affecting ',
2 'both horizontal and vertical',/,17x,
3 'radiation are known to be bad ***')
else if (bad_data.eq.'3') then
write (lu_out,804) cc
804 format (a,'*** Warning *** Coordinates and Antenna ',
2 'Parameters known to be bad ***')
else if (bad_data.eq.'V') then
write (lu_out,805) cc
805 format (a,'*** Warning *** Antenna Parameters affecting ',
2 'vertical radiation known',/,17x,'to be bad ***')
else if (bad_data.eq.'B') then
write (lu_out,806) cc
806 format (a,'*** Warning *** Some (undefined) data is known
',
2 'to be bad ***')
else ! unknown value for bad_data
write (lu_out,807) cc,bad_data
807 format (a,'*** Warning *** Unknown Value of Bad Data is ',
2 a1,' ***',/,' *** Please report this to Data ',
3 'Management Staff ***')
endif
c
if (its_ansi) write (lu_out,801) escape,'[0m' ! normal
display
c
endif
c
return
end

subroutine am_dummy_data (dummy_data,lu_out,lu_term,cc)
c
c Subroutine by John Boursy, July 1986.
c
c This subroutine prints out a warning message that we have known
c assumed data. If we are using an ANSI terminal, the message is
c done in bold, flashing. The warning message will vary,
depending
c what data is assumed.
c
c Note that a lack of a message does not necessarily mean that the
c data is not assumed; it might simply mean that we haven't yet
c discovered that it is assumed.
c
c Here is a description of the arguments:
c
c dummy_data -- input; character; indicates whether or not we
have
c assumed data; possible values are:
c
c blank -- no data is known to be assumed; this
c routine does nothing.
c D -- Some (undefined) data is assumed.
c V -- Antenna parameters affecting
calculations
c in the vertical plane are assumed;
c antenna parameters affecting
calculations
c in the horizontal plane are not known to
c be assumed.
c 1 -- Antenna Parameters affecting
calculations
c in both the horizontal and vertical
plane
c are assumed.
c 2 -- Coordinates are assumed.
c 3 -- Both coordinates and antenna parameters
c are assumed.
c
c lu_out -- input; integer; the FORTRAN logical unit number
c for output of the results.
c
c lu_term -- input; integer; the FORTRAN logical unit number
c for output to a terminal.
c
c cc -- input; character; the FORTRAN carriage control
c character that will be used in printing the
c message; the most likely values are "0" for
c double spacing and blank for single spacing.
c
c Note that lu_out and lu_term will be equal if we are running
c interactively with output of the results to the terminal.
c Otherwise, lu_out and lu_term will be different. This is used
c to determine whether we want to make the output bold and
flashing
c when we print the message about assumed data; we want to print
it
c bold and flashing only when the output is going to an ANSI
c terminal, not if it is going to a printing terminal, printer, or
c file.
c
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
integer lu_out
integer lu_term
character*1 dummy_data
character*1 cc
character*2 escape /'1B'x/
logical ansi_crt
logical its_ansi
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
if (dummy_data.ne.' ') then
c
if (ansi_crt().and.lu_out.eq.lu_term) then
its_ansi=.true.
else
its_ansi=.false.
endif
c
if (its_ansi) write (lu_out,801) escape,'[1;5m' ! bold,
flashing
801 format ('+',a1,a)
c
if (dummy_data.eq.'1') then
write (lu_out,802) cc
802 format (a,'*** Warning *** Antenna Parameters affecting ',
2 'both horizontal and vertical',/,17x,
3 'radiation are assumed ***')
else if (dummy_data.eq.'2') then
write (lu_out,803) cc
803 format (a,'*** Warning *** Coordinates are assumed ***')
else if (dummy_data.eq.'3') then
write (lu_out,804) cc
804 format (a,'*** Warning *** Coordinates and Antenna ',
2 'Parameters are assumed ***')
else if (dummy_data.eq.'V') then
write (lu_out,805) cc
805 format (a,'*** Warning *** Antenna Parameters affecting ',
2 'vertical radiation are assumed ***')
else if (dummy_data.eq.'D') then
write (lu_out,806) cc
806 format (a,'*** Warning *** Something (undefined) is ',
2 'assumed ***')
else ! unknown value of dummy_data
write (lu_out,807) cc,dummy_data
807 format (a,'*** Warning *** Unknown Value of Dummy Data is
',
2 a1,' ***',/,' *** Please report this to the Data ',
3 'Management Staff ***')
endif
c
if (its_ansi) write (lu_out,801) escape,'[0m' ! normal
display
c
endif
c
return
end

subroutine upper (string)
c
c Subroutine by John Boursy, December 1982.
c
c This subroutine takes a character string and converts all lower
c case letters to upper case letters. That is, letters in the
range
c from a to z, inclusive, are converted to letters in the range
c from A to Z. Characters outside of this range are not touched.
c
c string, the input argument, must be a character variable; it can
c be any length.
c
c
******************************************************************
c
character string*(*)
c
do 100 i=1,len(string),1
if (string(i:i).ge.'a'.and.string(i:i).le.'z')
2 string(i:i)=char(ichar(string(i:i))-32)
100 continue
c
return
end

subroutine am_tower_ref (num_towers,spacing_in,spacing_out_deg,
2 orien_in,orien_out_deg,orien_out_rad,spacing_out_rad,
3 tow_ref,adjusted)
c
c This subroutine computes the adjusted spacing and orientation
c for the towers, so that we have a spacing and orientation for
c all towers with respect to a common origin. The results are
c returned both in double precision degrees and double precision
c radians.
c
c Following is a description of the arguments:
c
c num_towers -- input; integer; the number of towers
c
c spacing_in -- input; double precision array; the specified
c distances for each tower as entered; degrees.
c
c spacing_out_deg -- output; double precision array; the distances
c for each tower from the common origin (after
c adjustments); degrees.
c
c orien_in -- input; double precision array; the specified
c orientations for each tower as entered;
degrees.
c
c orien_out_deg -- output; double precision array; the
orientations
c for each tower with respect to the common
origin
c (after adjustments); the orientation will
always
c be in the range from 0 through 360 degrees,
even
c if orien_in was negative.
c
c orien_out_rad -- output; double precision array; the
orientations
c for each tower with respect to the common
origin
c (after adjustments); radians.
c
c spacing_out_rad -- output; double precision array; the distances
c for each tower from the common origin (after
c adjustments); radians.
c
c tow_ref -- input; integer array; contains the indicator
c for each tower to specify whether orien_in
c and spacing_in are with respect to a common
c origin or with respect to the immediately
c preceeding tower:
c
c 0 -- orien_in and spacing_in for this
tower
c are with respect to the common
origin.
c
c 1 -- orien_in and spacing_in for this
tower
c are with respect to the immediately
c preceeding tower; for example, if
c tow_ref(4)=1, then orien_in(4) and
c spacing_in(4) are the spacing and
c orientation of tower 4 with respect
c to tower 3.
c
c adjusted -- output; integer; specifies whether any
c adjustments to spacing and orientation were
c made in this routine:
c
c 0 -- no adjustments were made; tow_ref was
c equal to 0 for all towers.
c
c 1 -- at least one adjustment was made;
c tow_ref was equal to 1 for at least 1
c tower.
c
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
implicit none
c
integer num_towers
double precision radian /0.017453292519943d0/
double precision degree /57.2957795131d0/
double precision spacing_in(num_towers)
double precision spacing_out_deg(num_towers)
double precision orien_in(num_towers)
double precision orien_out_deg(num_towers)
integer tow_ref(num_towers)
double precision orien_out_rad(num_towers)
double precision spacing_out_rad(num_towers)
integer adjusted
double precision temp1
double precision temp2
integer loop
integer loop1
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
adjusted=0
c
do 100 loop=1,num_towers,1
c
orien_out_rad(loop)=orien_in(loop)*radian
spacing_out_rad(loop)=spacing_in(loop)*radian
c
if (loop.gt.1.and.tow_ref(loop).eq.1) then
c
adjusted=1
loop1=loop-1
temp1=spacing_out_rad(loop)*cos(orien_out_rad(loop))
2 +spacing_out_rad(loop1)*cos(orien_out_rad(loop1))
temp2=spacing_out_rad(loop)*sin(orien_out_rad(loop))
2 +spacing_out_rad(loop1)*sin(orien_out_rad(loop1))
spacing_out_rad(loop)=sqrt(temp1*temp1+temp2*temp2)
c
if (temp1.eq.0.0d0.and.temp2.eq.0.0d0) then
orien_out_rad(loop)=0.0
else
orien_out_rad(loop)=atan2(temp2,temp1)
endif
c
endif
c
orien_out_deg(loop)=orien_out_rad(loop)*degree
if (orien_out_deg(loop).lt.0.0) orien_out_deg(loop)=
2 orien_out_deg(loop)+360.0
spacing_out_deg(loop)=spacing_out_rad(loop)*degree
c
100 continue
c
return
end

character*13 function amnstatus (nstatus)
c
c Function by John Boursy, April 1983
c
c This function is given a 1-character notified status and returns
c a 13-character expanded notified status.
c
character*1 nstatus
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
if (nstatus.eq.'A') then
amnstatus='Priority'
else if (nstatus.eq.'O') then
amnstatus='Operating'
else if (nstatus.eq.'P') then
amnstatus='Proposal'
else if (nstatus.eq.'T') then
amnstatus='Inf Proposal'
else if (nstatus.eq.'U') then
amnstatus='Not Notified'
else if (nstatus.eq.'Z') then
amnstatus='Test'
else
amnstatus='Invalid: '//nstatus
endif
c
return
end

character*4 function amdstatus (dstatus)
c
c Function by John Boursy, April 1983
c
c This character function returns a 4-character long expansion of
c the supplied 1-character domestic status for the AM Engineering
c Data Base.
c
character*1 dstatus
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
if (dstatus.eq.'A') then
amdstatus='App'
else if (dstatus.eq.'C') then
amdstatus='CP'
else if (dstatus.eq.'L') then
amdstatus='Lic'
else if (dstatus.eq.'D') then
amdstatus='Del'
else if (dstatus.eq.'M') then
amdstatus='Move' ! A petition to move to expanded band
else if (dstatus.eq.'P') then
amdstatus='Plan'
else if (dstatus.eq.'S') then
amdstatus='SMov' ! A petition to move to expanded band
c with a stereo preference
else if (dstatus.eq.'T') then
amdstatus='Test'
else if (dstatus.eq.' ') then
amdstatus=' '
else
amdstatus='?'//dstatus//'?'
endif
c
return
end

character*13 function am_coord_status (coord_status)
c
c Function by John Boursy, November 1985.
c
c This function receives a 1-character indication of the
c coordination status, and returns a long version of the
c status.
c
c Here is a description of the argument:
c
c coord_status -- input; character; 1-character indication of
c the coordination status.
c
c Here is the correspondence between input and output:
c
c Input Output
c
c A Accepted
c B Cond Accepted
c O Objection
c P Pending
c U Unstudied
c Space or blank Unknown
c
c Any other value on input will result in the output being
"Unknown".
c
c Modified by Kalagian 9-5-90, to output ***** for any other value
c instead of unknown; change spaces to unknown. Will help us
locate
c records with data errors in these fields.
c
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
implicit none
c
character*(*) coord_status
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
if (coord_status.eq.'A') then
am_coord_status='Accepted'
else if (coord_status.eq.'B') then
am_coord_status='Cond Accepted'
else if (coord_status.eq.'O') then
am_coord_status='Objection'
else if (coord_status.eq.'P') then
am_coord_status='Pending'
else if (coord_status.eq.'U') then
am_coord_status='Unstudied'
else if (coord_status.eq.' ') then
am_coord_status='Unknown'
else
am_coord_status='*****'
endif
c
return
end

character*3 function amhours (hours)
c
c Function by John Boursy, April 1983
c
c This function returns a 3-character value that has expanded the
c supplied 1-character value of the hours of operation.
c
character*1 hours
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
if (hours.eq.'D') then
amhours='Day'
else if (hours.eq.'N') then
amhours='Nit'
else if (hours.eq.'U') then
amhours='Unl'
else if (hours.eq.'C') then
amhours='CH'
else if (hours.eq.'R') then
amhours='CR'
else if (hours.eq.'P') then
amhours='PSA'
else
amhours='?'//hours//'?'
endif
c
return
end

function length (string)
c
c Function by John Boursy, January 1984.
c
c This function receives a character string, and returns its
length
c as an integer. Note: this is different from the intrinsic LEN
c function in FORTRAN. This function LENGTH returns the length of
c the string out to the last non-blank character, while LEN
returns
c the entire length of the string (including blanks).
c
character*(*) string
c
length=len(string)
c
do 100 loop=length,1,-1 ! move back from end of string
if (string (loop:loop).ne.' ') go to 200
100 continue
length=0 ! completely blank string
return
c
200 continue
length=loop
return
end

subroutine amdb_decode (amrec,format_version,max_towers,
2 max_aug,freq,control,id,country,state,city,call,prefix,
3 arn,dom_status,hours,r2class,dom_pat,class,lat,latdeg,
4 latmin,latsec,lon,londeg,lonmin,lonsec,power,num_towers,
5 q,ant_mode,schedule,num_aug,rms,cl_num,cl_date,not_status,
6 not_pat,comment,last_update,cutoff,dummy_data,bad_data,
7 can_coord_status,mex_coord_status,r2_coord_status,
8 ifrb_plan_date,ifrb_list,ifrb_serial,e_sub_u,updater,
9 field,height,phasing,spacing,orientation,tow_ref,tl_sec,
X a,b,c,d,cen_az,span,rad_at_cen_az,result)
c
c Subroutine by John Boursy, January 1986.
c
c Modified by Gary Kalagian, August 1990, to change the way the
c tl_sec switch is decoded. The tl_sec switch is a one character
c field that used to contain the characters 0 to 9, and therefore
c was decoded as an integer. The need arose for more than 10
values
c so letters are starting to be used. A = 10, B=11, C=12 etc.
c The argument tl_sec is still output as an integer with the range
c 0 to 35 now.
c
c This subroutine takes a record from the AM Engineering Data Base
c and breaks it up into its individual fields.
c
c No adjustments are made, except that 360 is subtracted from the
c phasing. This is because the phasing has 360 added to it before
c it is stored in the data base.
c
c The argument result shows how successful we were in decoding
c this record. Possible values are:
c
c 0 -- successful.
c 1 -- cannot decode everything since there
c are non-numeric values where numeric
c data should be in item 1.
c 2 -- cannot decode everything since there
c are non-numeric values where numeric
c data should be in item 2.
c 3 -- cannot decode everything since there
c are non-numeric values where numeric
c data should be in item 3.
c 4 -- cannot decode everything since there
c are non-numeric values where numeric
c data should be in item 4.
c 5 -- missing augmentation data (missing
c item 4 when # of augs > 1).
c
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
implicit none
c
character*(*) amrec
integer format_version
integer max_towers
integer max_aug
character*600 ambuff
integer freq
character*6 control
character*6 id
character*(*) call
character*(*) city
character*2 state
character*2 country
character*4 prefix
character*8 arn
character*1 dom_status
character*1 hours
character*1 lat,lon
character*76 comment
character*3 antmode
character*1 r2class
character*1 dom_pat
character*2 class
character*5 cl_num
character*6 cl_date
character*6 last_update
character*1 not_status
character*1 not_pat
character*12 q_db
character*1 can_coord_status
character*1 mex_coord_status
character*1 r2_coord_status
character*6 cutoff
character*1 bad_data
character*1 dummy_data
integer latdeg
integer latmin
integer latsec
integer londeg
integer lonmin
integer lonsec
real power
integer num_towers
real q
character*3 ant_mode
character*1 schedule
integer num_aug
real rms
character*6 ifrb_plan_date
character*1 ifrb_list
character*9 ifrb_serial
character*6 e_sub_u
character*6 updater
integer result
integer loop
integer item
integer iostat
c
real field (max_towers)
real phasing (max_towers)
real height (max_towers)
double precision spacing (max_towers)
double precision orientation (max_towers)
integer tow_ref (max_towers)
integer tl_sec (max_towers)
character*1 ctl_sec (17)
integer error
real a (max_towers)
real b (max_towers)
real c (max_towers)
real d (max_towers)
c
real cen_az (max_aug)
real span (max_aug)
real rad_at_cen_az (max_aug)
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
c First, we handle all of the character stuff, and then get into
c dealing with integers and reals.
c
control=amrec(5:10)
id=amrec(13:18)
country=amrec(19:20)
cutoff=amrec(21:26)
prefix=amrec(27:30)
arn=amrec(31:38)
dom_status=amrec(39:39)
hours=amrec(40:40)
r2class=amrec(41:41)
dom_pat=amrec(42:42)
class=amrec(43:44)
dummy_data=amrec(45:45)
lat=amrec(46:46)
lon=amrec(53:53)
bad_data=amrec(61:61)
updater=amrec(110:115)
can_coord_status=amrec(116:116)
mex_coord_status=amrec(117:117)
r2_coord_status=amrec(118:118)
city=amrec(323:349)
state=amrec(350:351)
call=amrec(352:358)
ifrb_plan_date=amrec(362:367)
q_db=amrec(368:379)
ant_mode=amrec(380:382)
schedule=amrec(383:383)
ifrb_list=amrec(384:384)
comment=amrec(387:462)
e_sub_u=amrec(504:509)
cl_num=amrec(516:520)
cl_date=amrec(521:526)
not_status=amrec(537:537)
ifrb_serial=amrec(547:555)
last_update=amrec(556:561)
not_pat=amrec(589:589)
c
if (q_db.ne.' ') then
read (q_db,819,err=1000) q
819 format (f12.8)
else
q=-10.0 ! negative Q means we calculate it, not from data
base
endif
c
item=1 ! going to read Item 1
c
read (amrec,808,iostat=iostat,err=1000) freq,latdeg,latmin,
2 latsec,londeg,lonmin,lonsec,power,num_towers,(field(loop),
3 height(loop),phasing(loop),spacing(loop),orientation(loop),
4 tow_ref(loop),ctl_sec(loop),a(loop),b(loop),c(loop),d(loop),
5 loop=1,3,1),num_aug,cen_az(1),span(1),rad_at_cen_az(1)
808 format (i4,t47,3i2,1x,i3,2i2,t62,f9.5,t72,i2,t119,
2 3(f9.7,f5.2,2f8.4,f7.4,i1,a1,f4.1,3f5.2,10x),t385,i2,t463,
3 2f7.4,f7.2)
c
c Convert the ctl_sec switch from character to integer
c
do loop = 1,3,1
call convert_tl_sec ( ctl_sec(loop), tl_sec(loop), error )
if ( error .ne. 0 ) go to 1000
end do
c
if (format_version.eq.100) then
read (amrec,850) rms
850 format (t484,f6.2)
else if (format_version.eq.101) then
read (amrec,851) rms
851 format (t484,f7.2)
else ! Format Version we're not prepared for
write (*,852) format_version
852 format ('0*** We have a Format Version of',i1,/,
2 '0*** We cannot handle this Format Version')
c call lib$stop(%val(0))
endif
c
if (num_towers.gt.3) then
ambuff=amrec(601:1200)
item=2 ! going to read Item 2
read (ambuff,809,err=1000) (field(loop),height(loop),
2 phasing(loop),spacing(loop),orientation(loop),
3 tow_ref(loop),ctl_sec(loop),a(loop),b(loop),c(loop),
4 d(loop),loop=4,10,1)
809 format (t31,7(f9.7,f5.2,2f8.4,f7.4,i1,a1,f4.1,3f5.2,10x))
c
c Convert the ctl_sec switch from character to integer
c
do loop = 4,10,1
call convert_tl_sec ( ctl_sec(loop), tl_sec(loop), error )
if ( error .ne. 0 ) go to 1000
end do
c
if (num_towers.gt.10) then
ambuff=amrec(1201:1800)
item=3 ! going to read item 3
read (ambuff,809,err=1000) (field(loop),height(loop),
2 phasing(loop),spacing(loop),orientation(loop),
3 tow_ref(loop),ctl_sec(loop),a(loop),b(loop),c(loop),
4 d(loop),loop=11,17,1)
c
c Convert the ctl_sec switch from character to integer
c
do loop = 11,17,1
call convert_tl_sec ( ctl_sec(loop), tl_sec(loop), error )
if ( error .ne. 0 ) go to 1000
end do
c
endif
endif
c
if (num_aug.gt.1) then
c
if (amrec(611:612).eq.'04') then
ambuff=amrec(601:1200)
else if (amrec(1211:1212).eq.'04') then
ambuff=amrec(1201:1800)
else if (amrec(1811:1812).eq.'04') then
ambuff=amrec(1801:2400)
else
result=5
return
endif
c
item=4 ! going to read item 4
c
read (ambuff,811,err=1000) (cen_az(loop),span(loop),
2 rad_at_cen_az(loop),loop=2,num_aug,1)
811 format (t31,27(2f7.4,f7.2))
endif
c
100 continue
c
do 200 loop=1,num_towers,1
phasing(loop)=phasing(loop)-360.0 ! get rid of 360 deg bias
200 continue
c
result=0
return
c
1000 continue
c We come through here when we have an error in the reading of the
c input record.
c
result=item
return
end

character*4 function ampattern (pattern)
c
c Function by John Boursy, April 1983.
c
c This function receives a 1-character value for the type of
c directional antenna pattern, and returns a 4-character value.
c
character*1 pattern
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
if (pattern.eq.'T') then
ampattern='Theo'
else if (pattern.eq.'S') then
ampattern=' Std'
else if (pattern.eq.'A') then
ampattern=' Aug'
else if (pattern.eq.' ') then
ampattern=' '
else
ampattern='?'//pattern//'?'
endif
c
return
end

*
************************************************************************
*
subroutine convert_tl_sec ( tl_in, tl_out, error )
*
************************************************************************
* This subroutine will convert the top-loaded sectional switch in
* the AM data base tower record to the proper integer value. The
* tl_sec switch is a one character field that used to have values
* in the range 0 to 9. These values were read as integers and then
* converted to a value for nfork by adding 1 to the tl_sec switch.
* NFORK is a switch for subroutine GETFTH to determine which
* formula to use to calculate f of theta for the vertical
radiation
* pattern. Canada submitted a proposal on 6/10/90 for station CBF
* which used a new equation for the sectionalized antenna. This
* required another value for the tl_sec switch. So we tested the
* update system with letters in the field and it allowed letters
* but gave an error message. So we now can have the characters
* 0 to 9 and the letters A to Z in the field for tl_sec. So this
* routine will convert the character tl_in to the interger tl_out.
* Characters 0 to 9 will of course be converted to integers 0 to
* 9, while letter A = 10, B = 11, C = 12, etc.
* The argument error = 0 if the conversion is ok; 1 otherwise.
c
* Please note: this routine does not give the value for nfork.
c
* .....Kalagian...8/22/90....
************************************************************************
*
implicit none
c
character*1 tl_in
c
integer tl_out
integer error
integer int_char
c
error = 0
c
int_char = ichar ( tl_in ) ! vax function that converts
characters
c ! to their integer equivalents.
c
if ( int_char .eq. 32 ) then ! space character
tl_out = 0
c
else if ( int_char .ge. 48 .and. ! characters 0 to 9
& int_char .le. 57 ) then
tl_out = int_char - 48
c
else if ( int_char .ge. 65 .and. ! characters A to Z
& int_char .le. 90 ) then
tl_out = int_char - 55
else
error = 1
end if
c
return
c
end

subroutine break_out_options (options,options_list,max_options,
2 num_options,overflow)
c
c Subroutine by John Boursy, January 1986.
c
c This subroutine is designed to take a command retrieved from
c LIB$GET_FOREIGN, and break it into its separate options.
c
c Here is a description of the arguments:
c
c options -- input; character; the options as obtained
c from LIB$GET_FOREIGN.
c
c options_list -- output; character array; each element in the
c array contains a separate option that was in
c input argument "options".
c
c max_options -- input; integer; the maximum number of elements
c in options_list.
c
c num_options -- output; integer; the actual number of elements
c in options_list which contain options which
have
c been broken out.
c
c overflow -- output; logical; true if we attempted to break
c out more options than "max_options"; false if
c we broke out all options without exceeding
c "max_options". Note: if we overflow, then
c "num_options" is set equal to "max_options",
c and only the first "max_options" options are
c picked up.
c
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
implicit none
c
character*(*) options
integer max_options
integer num_options
character*(*) options_list(max_options)
logical overflow
c
integer loop
integer length
integer leng_options
integer istart
logical in_option
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
num_options=0 ! initialize
overflow=.false. ! initialize
c
if (options.eq.' ') return ! nothing to break out
c
leng_options=length(options)! length, not counting trailing
spaces
c
loop=0 ! initialize
in_option=.false. ! initialize
c
100 continue
loop=loop+1
c
if (loop.gt.leng_options) go to 500
c
if (options(loop:loop).eq.'/') then ! start of option
c
if (in_option) then ! move out finished option, begin new
one
num_options=num_options+1
c
if (num_options.gt.max_options) then
num_options=num_options-1
overflow=.true.
return
endif
c
options_list(num_options)=options(istart:loop-1)
istart=loop
c
else
c
in_option=.true.
istart=loop
c
endif
c
else if (options(loop:loop).eq.' ') then ! end of option, or
nothing
c
if (in_option) then ! move out finished option, begin new
one
num_options=num_options+1
c
if (num_options.gt.max_options) then
num_options=num_options-1
overflow=.true.
return
endif
c
options_list(num_options)=options(istart:loop-1)
in_option=.false.
endif
c
else ! something within option or at start of option
c
if (.not.in_option) then
in_option=.true.
istart=loop
endif
c
endif
c
go to 100 ! go increment loop to handle next character
c
500 continue
c We are here if we have finished with all characters in "options"
c
c Now, let's check to see if we have an option to finish up.
c
if (in_option) then
num_options=num_options+1
c
if (num_options.gt.max_options) then
num_options=num_options-1
overflow=.true.
return
endif
c
options_list(num_options)=options(istart:leng_options)
endif
c
return
end

logical function ansi_crt ()
c
c Function by John Boursy, July 1985.
c
c This function determines whether the current terminal is defined
c as an ANSI CRT or not. This function is TRUE if it is defined
c as an ANSI CRT and FALSE if it is not defined as an ANSI CRT.
c
c
******************************************************************
c
c The following statement is the first statement.
c
c
******************************************************************
c
implicit none
c
c include '($ssdef)'
c include '($dvidef)'
c
c integer*4 lib$getdvi
integer result

c commented by Jeff Glass
c integer*4 istat

c Jeff Glass
result = 1
c
c
******************************************************************
c
c The following statement is the first executable statement.
c
c
******************************************************************
c
c istat=lib$getdvi (dvi$_tt_ansicrt,,'TT:',result,,)
c
c if (istat.ne.ss$_normal) call lib$stop (%val(istat))
c
if (result.eq.1) then
ansi_crt=.true.
else
ansi_crt=.false.
endif
c
return
end

[e p chandler]

"rfengineer55" <rfengi...@aol.com> wrote in message
news:53e77e08-f59d-478f...@d8g2000yqf.googlegroups.com...

> By popular demand, here is one of my FCC programs that Is
> generating Gfortran errors, two to be exact.

[snip]

> I have about six FCC programs that fail to compile for strange
> problems similar to this one. BTW one of the respondents here asked if
> I was working from a photocopied DEC VMS Fortrann manual. I wish. I
> have no DEC documentatio at all. The best I have been able to do is to
> find two or three generic college VAX texdtbooks from ABEbooks.com
> which WERE helpful in helping me unravel a syntax error I was running
> into with the OPEN statement; VMS OPEN is very different from Fortran
> 77 OPEN :-)

Well, one good place to look for old manuals is in the "BitSavers" archive
collection.

http://www.bitsavers.org/pdf/dec/vax/lang/fortran/

looks like it may have what you want. You may prefer to download from a
mirror of this archive. Sorry I don't have a URL for one of those handy.
Also there may be more general VMS manuals there. Sorry, I don't know the
DEC term for the IBMism "Principles of Operation".

Do you have a pointer to a site from which this source code can be
downloaded directly from "Uncle Charlie" in electronic form?

-- Elliot

[Craig Powers]

rfengineer55 wrote:
> By popular demand, here is one of my FCC programs that Is
> generating Gfortran errors, two to be exact.

Note that the line wrapping settings on your newsreader resulted in a
massive amount of text fixes that are necessary. If you have control of
that setting, if you could bump the wrap point to at least column 73 or
74 (maybe, depending on comments, it would want to be more, I didn't
both to check) and repost it would be much appreciated.

You've also omitted the file amkeys.inc, which is required on line 11 of
the main program.

[Richard Maine]

rfengineer55 <rfengi...@aol.com> wrote:

> Incompatible type in DATA statement at <1>: Attempted conversion of
> type integer to type character.

...

> I did a search of all the DATA statements thinking there could have
> been some conflicting declarations, but I could not find any.

Be aware that the forms like

> integer out/6/

are a nonstandard variant of a DATA statement. It would not be too
surprising if the compiler error message erroneously referred to them as
DATA statements.

> This project is certainly pegging the frustration meter. I
> have to continually remind myself that someday, computers will save
> someone alot of time.

Sometimes. Do note that using nonstandard syntax is a way to signicantly
increase the frustration part. Some of us learned that lesson a long
time ago. (See the quote in my signature). Yes, I realize it wasn't you
who wrote the nonstandard syntax; you just get to pay some of the cost
in frustration.

I did spend a little time looking at this code, but decided it was too
much fuss to look further, at least for tonight. I first took out a
large number of line wraps (mostly from comments) introduced either by
your usenet posting software or my usenet reader (I'm not actually sure
which). Easy, if a bit boring because of the large number. I noticed the
reference to a missing include file, but figured I might be able to
ignore that (though there is at least a possibility that the error is in
the include file or related to it).

But then I hit the zillions of syntax errors from the above-mentioned
nonstandard form. Whiile I am familliar with that form, and it is at
least a moderately common one, neither of the compilers I have handy
would accept it by default. Maybe there is a compiler option to allow
that class of extension, but I decided I had spent enough time on it at
least for tonight.

--
Richard Maine | Good judgment comes from experience;
email: last name at domain . net | experience comes from bad judgment.
domain: summertriangle | -- Mark Twain

[e p chandler]

"rfengineer55" wrote

> By popular demand, here is one of my FCC programs that Is
> generating Gfortran errors, two to be exact.
>
> Incompatible type in DATA statement at <1>: Attempted conversion of
> type integer to type character.
> <during initialiation>
>
> The second error is just like this one, except for the <during
> initialization> thing. No line number, no variable name, no
> nothing.This tells me that the error is likely being generated on the
> compiler's second runthrough of the source code.
>
> I did a search of all the DATA statements thinking there could have
> been some conflicting declarations, but I could not find any.

[snip]

[snip rest of program]

Well, just looking at this section I see something that is not standard at
all. You have what looks like a cross between a type declaration and a DATA
statement. One of the VAX/VMS Fortran "features" listed in Appendix D at the
web site I cited in a message in a different thread is:

Initialize in declarations

Initialization of variables in declaration statements is allowed. Example:

CHARACTER*10 NAME /'Nell'/

It's not that hard to fix these. You can

1. split them into type declaration statements and corresponding data
statements
2. write PARAMETER statements for some of them
3. use the Fortran 90 feature which combines declaration and initialization.
IIRC this gives these vars the SAVE attribute just like DATA

for example

INTEGER, PARAMETER :: nmax = 100 (for a constant)

or

REAL :: foo=99.99, bar = 42.0

Note that you CAN use Fortran 90+ features in fixed format source code!

HTH

-- Elliot

[It's way past my bed time.]

[Tim Prince]

On 6/9/2010 10:27 PM, rfengineer55 wrote:
> By popular demand, here is one of my FCC programs that Is
> generating Gfortran errors, two to be exact.
>

As you've quoted it, there are many broken lines, which have to be fixed
by inspection, not by any magic compiler option "fix my broken source."
You haven't supplied the file amkeys.inc . Other than that, you
haven't shown anything which isn't accepted by default in ifort, however
"dodgy" some of that stuff may be.
The worst of it may be this:

character*2 escape /'1B'x/

presumably intended to mean something like
escape=char(z'1B')
which could easily have been written in a more standard way, even back then,
followed by displaying escape with a1 format, which presumably is
intended to take escape(1:1), provoking an apparent bug in gfortran
error diagnostics.

There are commented out VAX specific library calls, and comments to the
effect that some of the code had been tested at one time on a 36-bit
Honeywell.

--
Tim Prince

[glen herrmannsfeldt]

e p chandler <ep...@juno.com> wrote:
(snip)

> http://www.bitsavers.org/pdf/dec/vax/lang/fortran/

That is where they should be. I write to Al some time ago that
some of the bits are missing. Specifically, the distinction between
blue and black ink. Some DEC manuals marked extensions to the
standard in blue, but that distinction is lost in the scanning.

IBM Fortran manuals mark extensions by shading (gray) over the
words describing the extension. That usually survives the scanning,
though in some cases it covers up the words.

> looks like it may have what you want. You may prefer to download from a
> mirror of this archive. Sorry I don't have a URL for one of those handy.
> Also there may be more general VMS manuals there. Sorry, I don't know the
> DEC term for the IBMism "Principles of Operation".

The "Principles of Operation" manuals describe the hardware.
There are VAX Architecture manuals that do that for VAX.

For compilers, IBM produces two manuals, usually with names
like "Language Reference" and "Programmers Guide." The Language
Reference describes the language, including extensions.
The Programmers Guide gives details on running the compiler,
and things to know about the object code, among others.

> Do you have a pointer to a site from which this source code can be
> downloaded directly from "Uncle Charlie" in electronic form?

-- glen

[Tobias Burnus]

On 06/10/2010 08:47 AM, Tim Prince wrote:
> On 6/9/2010 10:27 PM, rfengineer55 wrote:
>> By popular demand, here is one of my FCC programs that Is
>> generating Gfortran errors, two to be exact.
>>
>
> As you've quoted it, there are many broken lines, which have to be fixed
> by inspection, not by any magic compiler option "fix my broken source."
> You haven't supplied the file amkeys.inc . Other than that, you
> haven't shown anything which isn't accepted by default in ifort, however
> "dodgy" some of that stuff may be.
> The worst of it may be this:
> character*2 escape /'1B'x/
> presumably intended to mean something like
> escape=char(z'1B')

First, gfortran supports as extension which allows to initialize
variables in the form
type variable /initialization/
However, it does not support initializing a CHARACTER variable with an
INTEGER (without )

I think Tim found the line, which causes the error you are seening. You
could try replacing

character*2 escape /'1B'x/

by
character(2) :: escape = achar(z'1B')

Tobias

[robin]

"Richard Maine" <nos...@see.signature> wrote in message news:1jjue01.1hqn9cj5zesgmN%nos...@see.signature...

| Be aware that the forms like
|
| > integer out/6/
|
| are a nonstandard variant of a DATA statement.

Actually, it's a non-standard INTEGER statement.

[mecej4]

To add to what Tim has stated:

I fixed the wrapped lines, provided a blank AMKEYS.INC and got the code
to compile and link with two different compilers. Here are some
observations on making the code run successfully:

i) There are references to keyed-access files, which have been commented
out and replaced by I/O with formatted files. The 'database' file,
'bam:amdb.dat' has a name which may not be acceptable (because of the
DeviceName:FileName format) on some OSes. It is important that this file
be available, correctly formatted and be compatible with the source code.

ii) The program assumes that it is writing to an ANSI/VT-100 terminal.
Specifically, BELL (ASCII 7) and escape sequences are output in WRITE
statements. These will need to be fixed if you do not want to slow down
the program considerably.

iii) The program will not work unless variables are allocated statically
and initialized to zero.

HTH

-- mecej4

[e p chandler]

"mecej4" wrote

> The program assumes that it is writing to an ANSI/VT-100 terminal.
> Specifically, BELL (ASCII 7) and escape sequences are output in WRITE
> statements. These will need to be fixed if you do not want to slow down
> the program considerably.

Bear in mind that ANSI.SYS support no longer exists on Windows. It did work
on XP but only for 16 bit (DOS) programs under COMMAND.COM instead of
CMD.EXE and only if CONFIG.NT (not CONFIG.SYS) was modified. 64 bit Vista
drops 16 bit support (DOS and Win16) entirely.

[Ron Shepard]

In article <4C10A4DA...@net-b.de>,
Tobias Burnus <bur...@net-b.de> wrote:

> I think Tim found the line, which causes the error you are seening. You
> could try replacing
> character*2 escape /'1B'x/
> by
> character(2) :: escape = achar(z'1B')

Why use the confusing hex form for the integer? Why not simply
achar(27) where 27=16+11.

Also, why is the variable escape declared as two characters rather
than one. It is always used in an A1 field, so it seems it should
be one character long rather than two. The fact that is is two
character rather than one prevents the programmer from using
expressions like

escape // '[0m'

to generate the terminal escape sequences.

It is much easier to convert codes like this to standard form when
the programmer still has access to a compiler that accepts the
nonstandard extensions. In this case, sections of code can be
rewritten and tests of all of the internal state, before and after,
can be done. For this code, that should have happened about 30
years ago for the nonstandard declarations, and 20 years ago for the
achar() related stuff. After you no longer have support for all the
nonstandard stuff, then the programmer must try to port the code
without the ability to compare the internal state, which is a much
much harder task. Of course, the OP is stuck with code that was
written that way by someone else, so this comment applies more to
current and future code. The real purpose of compatibility
libraries and compiler flags that allow nonstandard extensions is to
facilitate porting the code to standard form, not necessarily to
allow the nonstandard code to be compiled indefinitely.

$.02 -Ron Shepard

[Ken Fairfield]

Note up front: I have great hesitation in replying to this
thread any more since my previous replies seem to have gone
unheeded like those of many other regulars here. Nevertheless.

On Jun 9, 10:27 pm, rfengineer55 <rfenginee...@aol.com> wrote:
>      By popular demand, here is one of my  FCC programs that Is
> generating Gfortran errors, two to be exact.
>
> Incompatible type in DATA statement at <1>: Attempted conversion of
> type integer to type character.
> <during initialiation>

Edit the lines that have combined declaration and data
initialization into two lines. For example,

integer ibc /42/

would become:

integer ibc
data ibc /42/

Standard F77 form.

[...]

> I have about six FCC programs that fail to compile for strange
> problems similar to this one. BTW one of the respondents here asked if
> I was working from a photocopied DEC VMS Fortrann manual. I wish. I
> have no DEC documentatio at all. The best I have been able to do is to
> find two or three generic college VAX texdtbooks from ABEbooks.com
> which WERE helpful in helping me unravel a syntax error I was running
> into with the OPEN statement; VMS OPEN is very different from Fortran
> 77 OPEN :-)

See: http://h71000.www7.hp.com/doc/fortran.html for the VMS Fortran
online documentation. While that compiler is F95 compliant, it is
also (as I mentioned before) F77 compliant *and* it documents various
VMS Fortran extensions.

[...]

In *quickly* looking at the source you posted, I see three VMS library
routines (which you've commented-out):

LIB$GET_FOREIGN.
This is used to retrieve command-line arguments. Most compilers
have an O/S-specific and/or compiler-specific alternative. You
can often replace it with a simple "READ(*,*) COMMAND" if you are
willing to supply the arguments on a line that follows the
program invocation.

LIB$STOP(status)
This is simply a convenient way to get the error message
associated with "status" written to the output device
while halting the program. If you're not interested in
status, a simple Fortran STOP is good enough. Or you
can WRITE(*,*) STATUS and the STOP.

LIB$GETDVI
The subroutine in which this appears is mostly trying
to determine if there's an actual terminal attached,
as opposed to a batch run with output to a log file
(I presume). You've handled that sort opposite of the
way I would, by hard-coding that you do have a terminal
attached. Your choice.

DATE (Not VMS-specific)
All the compilers you will be using support the
DATE_AND_TIME Fortran intrinsic function. Use it.
Otherwise, having commented-out the call, you
reference the character variable TODAY without ever
having given it a value, which is a program error.

Three other points:
The missing AMKEYS.INC *will* need to be supplied.
You need to determine what reasonable contents it
should have, but you at least need to supply a file,
even if it's empty, to satisfy the compiler.

At least one character variable holds the "path"
to a file, whether input or output I didn't check.
You need to determine how it is used and substitute
a path+file specification appropriate to the platform
you're using.

OPEN statements.
See the VMS Fortran documentation at the link I
supplied above. VMS extensions are clearly
indicated along with their standard-conforming
replacements. Again, I didn't check them carefully,
but I doubt there is anything very VMS-specific
(other than the "spelling") in any of them.

Regards, Ken

[Ken Fairfield]

On Jun 10, 11:41 am, Ken Fairfield <ken.fairfi...@gmail.com> wrote:

[...]

> At least one character variable holds the "path"
> to a file, whether input or output I didn't check.
> You need to determine how it is used and substitute
> a path+file specification appropriate to the platform
> you're using.

amdbname is the variable in question and is using
VMS file specification syntax. It needs to be
changed to Windows and/or Linux syntax.

>
> OPEN statements.
> See the VMS Fortran documentation at the link I
> supplied above.  VMS extensions are clearly
> indicated along with their standard-conforming
> replacements.  Again, I didn't check them carefully,
> but I doubt there is anything very VMS-specific
> (other than the "spelling") in any of them.

In particular, AMDBNAME points to an RMS indexed
files, something *very* VMS-specific. You probably
don't want to go to all the trouble of installing
an "ISAM" package on your computers, so you need
to understand the context of that file, and
provide a different method of reading it.

I.e., you probably will need to read the file
form the beginning and compare the appropriate
field in each line you read to the "key" string
until you get a match.

Reading an indexed file by key is fast, easy
and efficient in VMS, but it is certainly not
necessary: a brute force method will work just
as well.

-Ken