FCC VAX VMS Fortran program AMDIST
in [Fortran]
|
Prev: Intel Fortran compiler
Next: Intel Fortran etc.
From: rfengineer55 on 10 Jun 2010 01:27 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
From: e p chandler on 10 Jun 2010 02:17 "rfengineer55" <rfengineer55(a)aol.com> wrote in message news:53e77e08-f59d-478f-b673-b0b216d8e702(a)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
From: Craig Powers on 10 Jun 2010 02:26 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.
From: Richard Maine on 10 Jun 2010 02:31 rfengineer55 <rfengineer55(a)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
From: e p chandler on 10 Jun 2010 02:41
"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.] |