FCC VAX VMS Fortran program AMDIST

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

"rfengineer55" <rfengineer55@aol.com> wrote in message news:53e77e08-f59d-478f-b673-b0b216d8e702@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

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.

rfengineer55 <rfengineer55@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

"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] > > > 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 [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.]

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

e p chandler <epc8@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

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

"Richard Maine" <nospam@see.signature> wrote in message news:1jjue01.1hqn9cj5zesgmN%nospam@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.

On 6/10/2010 1: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') > 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. > 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

"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.

In article <4C10A4DA.4030103@net-b.de>, Tobias Burnus <burnus@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

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=A0pm, rfengineer55 <rfenginee...@aol.com> wrote: > =A0 =A0 =A0By popular demand, here is one of my =A0FCC 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

On Jun 10, 11:41=A0am, 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. =A0VMS extensions are clearly > indicated along with their standard-conforming > replacements. =A0Again, 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

Similiar Articles:

Intel Visual Fortran Error Message - comp.lang.fortran
Hello, I' working on another of a large collection of FCC Fortran programs compiled in VAX VMS Fortran. There are variables in this program nam...

Intel Visual Fortran Error Message [Fortran]
Hello, I' working on another of a large collection of FCC Fortran programs compiled in VAX VMS Fortran. There are variables in this program named Class4 , Class3 ...

Intel Visual Fortran Error Message - comp.lang.fortran | Computer ...
Hello, I' working on another of a large collection of FCC Fortran programs compiled in VAX VMS Fortran. There are variables in this program nam...

7/22/2012 5:00:44 PM