C Program reads ASCII CRS file and generates full PDS label character*6 body !name of body character*1 comma !ASCII comma integer*4 crdate(3) !file creation date (mm,dd,yy) integer*4 crec !card record number (1-90) character*1 dquote !ASCII quote character*1 dot !ASCII period double precision etmutc !ET minue UTC (sec) integer*4 et_yyyy !ET year of data record integer*4 et_dd !ET day-of-month of data record integer*4 et_ddd !ET day-of-year of data record integer*4 et_hh !ET hour of data record integer*4 et_mm !ET minute of data record integer*4 et_mon !ET month of data record double precision et_ss !ET seconds of first data record double precision etsp50 !ET seconds past 0h 1 January 1950 integer*4 file_recs !number of card images in file character*12 filename !CRS file name (8.3 naming convention) integer*4 filename_len !length of filename string character*12 fmt !variable format statement double precision gm !GM of body integer*4 i !miscellaneous index integer*4 ierr !status return from stat integer*4 istat !status return from get_string double precision j2 !gravity field coefficient double precision j4 !gravity field coefficient double precision j6 !gravity field coefficient double precision j8 !gravity field coefficient integer*4 jstat !status return from doy_mmdd character*38 label !text defn of coordinate system character*1 lparen !ASCII left parenthesis integer*4 m !miscellaneous index integer*4 mode !mode for calling doy_mmdd integer*4 mrec !number of card images returned integer*4 n !miscellaneous index character*8 navid !NAV Team ID for this file integer*4 navid_len !length of navid string integer*4 nbodis !number of bodies in file double precision npole(3) !unit vector to north pole integer*4 nrecs !number of data records in file character*8 pfid !NAV Team ID for source P-file integer*4 pgm_status !program exit status double precision pos(3) !body position character*80 producer !producer of file character*80 producer_id !producer ID integer*4 producer_id_len !length of producer_id string character*80 prod_inst_name !producer institution name integer*4 prod_inst_name_len !length of prod_inst_name string integer*4 producer_len !length of producer string double precision req !mean equatorial radius (km) character*1 rparen !ASCII right parenthesis double precision rpol !polar radius (km) double precision rref !reference radius for gravity field character*20 sc_name !spacecraft name for label integer*4 sc_name_len !length of spacecraft name integer*4 scid !spacecraft ID number character*80 software_name !program which created the file integer*4 software_name_len !length of software_name string character*1 space !ASCII space character*19 start_time !start time string integer*4 statb(13) !file status array character*19 stop_time !stop time string character*328 string !miscellaneous string integer*4 table1_start !start record for table 1 integer*4 table1_len !records in table 1 integer*4 table1_rows !rows in table 1 integer*4 table2_start !start record for table 2 integer*4 table2_len !records in table 2 integer*4 table2_rows !rows in table 2 integer*4 table3_start !start record for table 3 integer*4 table3_len !records in table 3 integer*4 table3_rows !rows in table 3 integer*4 table4_cols !number of columns in table 4 integer*4 table4_start !start record for table 4 integer*4 table4_len !records in table 4 integer*4 table4_rows !rows in table 4 integer*4 trec !tape record number (1,2,3...) double precision vel(3) !body velocity integer*4 iargc !library function integer*4 ndigits !function integer*4 stat !library function C Initializations if (iargc() .ne. 1) then write(*,'("USAGE: crs2lbl filename")') pgm_status = 1 go to 99 end if pgm_status = 0 trec = 1 crec = 1 mrec = 1 mode = 1 space = char(32) dquote = char(34) lparen = char(40) rparen = char(41) comma = char(44) dot = char(46) write(*,'("CRS2LBL - Creates LBLGN *.dat for ASCII CRS File", * /, "Program by Dick Simpson - Version of 24 July 1998")') C Get and process arguments; open input file call getarg(1,filename) ierr = stat (filename,statb) if (ierr .gt. 0) then write(*,'("CRS2LBL: Error return from call to STATB", * " ierr = ",i10,/, * "Check that CRS file is in PWD and that it has ", * "an 8.3 filename")') ierr pgm_status = 1 go to 99 end if open ( unit = 30, * file = filename, * access = 'direct', * recl = 7380, * status = 'old') C Output data file will have name crs2lbl.dat; open it. open (unit = 31, * file = 'crs2lbl.dat', * status = 'unknown') C Banner info to the terminal write(*,'("Input file: ",(a),10x, * "Output file: crs2lbl.dat")') filename C Determine file size, find number of card image records file_recs = statb(8)/82 if (file_recs*82 .ne. statb(8)) then write(*,'("Input file size not multiple of 82 bytes")') pgm_status = 1 go to 99 end if C Find length of filename i = 0 10 continue i = i + 1 if ((filename(i:i) .ne. space) .and. (i .lt. 12)) then go to 10 else if (filename(i:i) .ne. space) then filename_len = i else filename_len = i - 1 end if C Get Logical Record 1 call get_string(trec,crec,mrec,string,istat) if (istat .ne. 0) then write(*,'("Unexpected EOF")') pgm_status = 1 go to 99 end if read(string,'(3i10,1x,3(1x,i2))') nrecs,scid,nbodis, * crdate navid = string(43:50) pfid = string(53:60) i = 0 20 continue i = i + 1 if ((navid(i:i) .ne. space) .and. (i .lt. 8)) then go to 20 else if (navid(i:i) .ne. space) then navid_len = i else navid_len = i - 1 end if write(*,'("Number of data records (NRECS) = ",i8,/, * "Spacecraft Number (SCID) = ",i8,/, * "Number of bodies (NBODIS) = ",i8,/, * "File creation date (CRDATE) = ",2(i2.2,"-"),i2.2,/, * "NAV Team file ID (NAVID) = ",a8,/, * "Source P-File ID (PFID) = ",a8)') * nrecs,scid,nbodis,crdate(3),crdate(1),crdate(2), * navid,pfid table1_start = 1 table1_len = 1 table1_rows = 1 C Get Logical Record 2 call get_string(trec,crec,mrec,string,istat) if (istat .ne. 0) then write(*,'("Unexpected EOF")') pgm_status = 1 go to 99 end if label = string(01:38) read(string(39:64),'(e26.18)') etmutc write(*,'("Coordinates (LABEL) = ",a38,/, * "ETMUTC = ",1p1e25.18)') * label,etmutc table2_start = table1_start + table1_len table2_len = 1 table2_rows = 1 C Get Logical Records 3 through 2+NBODIS do n = 1,nbodis mrec = 3 call get_string(trec,crec,mrec,string,istat) if (istat .ne. 0) then write(*,'("Unexpected EOF")') pgm_status = 1 go to 99 end if body = string(17:22) read(string(23:238),'(e26.18,2e16.8,2x,5e16.8,2x,3e26.18)') * gm,req,rpol,rref,j2,j4,j6,j8,npole write(*,'(a6," GM =",1p1e20.12, * " J2 =",1p1e13.6, * " NPOL =",0p1f9.6,/, * 15x," REQ =",0p1f11.3, * " J4 =",1p1e13.6,8x,0p1f9.6,/, * 16x,"RPOL =",0p1f11.3,2x,"J6 =",1p1e13.6,8x,0p1f9.6,/, * 16x,"RREF =",0p1f11.3," J8 =",1p1e13.6)') * body,gm,j2,npole(1),req,j4,npole(2),rpol,j6, * npole(3),rref,j8 end do table3_start = table2_start + table2_len table3_len = 3*nbodis table3_rows = nbodis C Get Logical Records 4+NBODIS to end write(*,'("Reading data records ...")') do m = 1,nrecs mrec = 1 call get_string(trec,crec,mrec,string,istat) if (istat .ne. 0) then write(*,'("Unexpected EOF")') pgm_status = 1 go to 99 end if read(string(01:80),'(2i4,2i3,f8.4,e26.18)') * et_yyyy,et_ddd,et_hh,et_mm,et_ss,etsp50 C write(*,'(i4.4,"-",i3.3,"T",2(i2.2,":"),f7.4,f26.13)') C * et_yyyy,et_ddd,et_hh,et_mm,et_ss,etsp50 if (m .eq. 1) then call doy_mmdd(mode,et_yyyy,et_ddd,et_mon,et_dd,jstat) if (jstat .ne. 0) then write(*,'("Error return ",i3," from doy_mmdd")') jstat pgm_status = 1 go to 99 end if write(start_time, * '(i4.4,2("-",i2.2),"T",i2.2,2(":",i2.2))') * et_yyyy,et_mon,et_dd,et_hh,et_mm,int(et_ss) end if do n = 1,nbodis call get_string(trec,crec,mrec,string,istat) if (istat .ne. 0) then write(*,'("Unexpected EOF")') pgm_status = 1 go to 99 end if read(string(01:80),'(3e26.18)') pos call get_string(trec,crec,mrec,string,istat) if (istat .ne. 0) then write(*,'("Unexpected EOF")') pgm_status = 1 go to 99 end if read(string(01:80),'(3e26.18)') vel C write(*,'("POS",i1," =",1p3e26.18,/, C * "VEL",i1," =",1p3e26.18)') C * n,pos,n,vel end do end do table4_start = table3_start + table3_len table4_len = (2*nbodis+1)*nrecs table4_rows = nrecs table4_cols = 6 C Build the label components if (scid .eq. 25 ) then sc_name(01:16) = "LUNAR PROSPECTOR" sc_name_len = 16 producer(01:32) = "LUNAR PROSPECTOR NAVIGATION TEAM" producer_len = 32 prod_inst_name(01:24) = "LUNAR RESEARCH INSTITUTE" prod_inst_name_len = 24 producer_id(01:07) = "LPX NAV" producer_id_len = 7 software_name(01:03) = "UNK" software_name_len = 3 else if (scid .eq. 31 ) then sc_name(01:09) = "VOYAGER 1" sc_name_len = 9 producer(01:32) = "VOYAGER NAVIGATION TEAM" producer_len = 23 prod_inst_name(01:25) = "JET PROPULSION LABORATORY" prod_inst_name_len = 25 producer_id(01:07) = "VGR NAV" producer_id_len = 7 software_name(01:03) = "UNK" software_name_len = 3 else if (scid .eq. 32 ) then sc_name(01:09) = "VOYAGER 2" sc_name_len = 9 producer(01:32) = "VOYAGER NAVIGATION TEAM" producer_len = 23 prod_inst_name(01:25) = "JET PROPULSION LABORATORY" prod_inst_name_len = 25 producer_id(01:07) = "VGR NAV" producer_id_len = 7 software_name(01:03) = "UNK" software_name_len = 3 else if (scid .eq. 77 ) then sc_name(01:15) = "GALILEO ORBITER" sc_name_len = 15 producer(01:32) = "GALILEO NAVIGATION TEAM" producer_len = 23 prod_inst_name(01:25) = "JET PROPULSION LABORATORY" prod_inst_name_len = 25 producer_id(01:07) = "GLL NAV" producer_id_len = 7 software_name(01:03) = "UNK" software_name_len = 3 else write(*,'("Unknown spacecraft id ",i3)') scid pgm_status = 1 go to 99 end if call doy_mmdd(mode,et_yyyy,et_ddd,et_mon,et_dd,jstat) if (jstat .ne. 0) then write(*,'("Error return ",i3," from doy_mmdd")') jstat pgm_status = 1 go to 99 end if write(stop_time, * '(i4.4,2("-",i2.2),"T",i2.2,2(":",i2.2))') * et_yyyy,et_mon,et_dd,et_hh,et_mm,int(et_ss) C Write values to the output file in order they will be needed by lblgn write(fmt,'(a1,"i",i2.2,a1,7x)') * lparen,ndigits(file_recs),rparen write(31,fmt) file_recs write(31,'(a1,(a),a1)') dquote,sc_name(01:sc_name_len), * dquote write(31,'(a1,(a),a1)') dquote,navid(01:navid_len),dquote write(31,'(a1,(a),a1)') dquote, * filename(01:filename_len),dquote write(31,'(a19)') start_time(01:19) write(31,'(a19)') stop_time write(31,'(i4.4,2("-",i2.2),"T00:00:00")') * crdate(3)+1900,crdate(1),crdate(2) write(31,'(a1,(a),a1)') dquote,producer(01:producer_len), * dquote write(31,'(a1,(a),a1)') dquote, * prod_inst_name(01:prod_inst_name_len),dquote write(31,'(a1,"FINAL",a1)') dquote,dquote write(31,'(a1,(a),a1)') dquote, * producer_id(01:producer_id_len),dquote write(31,'(a1,(a),a1)') dquote, * software_name(01:software_name_len),dquote write(fmt,'(a1,"i",i2.2,a1,7x)') * lparen,ndigits(table1_rows),rparen write(31,fmt) table1_rows write(fmt,'(a1,"i",i2.2,a1,7x)') * lparen,ndigits(table2_rows),rparen write(31,fmt) table2_rows write(fmt,'(a1,"i",i2.2,a1,7x)') * lparen,ndigits(table3_rows),rparen write(31,fmt) table3_rows write(fmt,'(a1,"i",i2.2,a1,7x)') * lparen,ndigits(table4_rows),rparen write(31,fmt) table4_rows write(fmt,'(a1,"i",i2.2,a1,7x)') * lparen,ndigits(80+160*nbodis),rparen write(31,fmt) 82+164*nbodis write(fmt,'(a1,"i",i2.2,a1,7x)') * lparen,ndigits(160*nbodis),rparen write(31,fmt) 164*nbodis write(fmt,'(a1,"i",i2.2,a1,7x)') * lparen,ndigits(nbodis),rparen write(31,fmt) nbodis C Add lengths of each table in numbers of records write(fmt,'(a1,"i",i2.2,a1,7x)') * lparen,ndigits(table1_len),rparen write(31,fmt) table1_len write(fmt,'(a1,"i",i2.2,a1,7x)') * lparen,ndigits(table2_len),rparen write(31,fmt) table2_len write(fmt,'(a1,"i",i2.2,a1,7x)') * lparen,ndigits(table3_len),rparen write(31,fmt) table3_len write(fmt,'(a1,"i",i2.2,a1,7x)') * lparen,ndigits(table4_len),rparen write(31,fmt) table4_len go to 99 99 continue if (pgm_status .eq. 0) write(*,'("Done ... ", * "Values file for lblgn is crs2lbl.dat")') call exit(pgm_status) stop end C ----------------------------------------------------------------- subroutine get_string(trec,crec,mrec,string,istat) C Subroutine returns mrec card images in string. Data begin at C tape record trec (1,2,3,...) and card image crec (1,2,...90). C Data are read from logical unit 30, opened in the main program. C trec and crec are updated by this routine. Card images are C assumed to have 80 characters plus an ASCII carriage-return line- C feed pair. integer*2 ia(3690) !input array integer*4 i !miscellaneous index integer*4 istat !status return integer*4 m !card image counter integer*4 mrec !number of card images to transfer character*(*) string !string of returned values integer*4 crec !card record number integer*4 trec !tape record number C Initializations istat = 0 m = 1 read(30,rec=trec,end=90) ia C Enter loop for transfer to string 20 continue write(string(82*m-81:82*m),'(41a2)') * (ia(i),i=41*crec-40,41*crec) crec = crec + 1 if (crec .eq. 91) then trec = trec + 1 crec = 1 read(30,rec=trec,end=90) ia end if m = m + 1 if (m .le. mrec ) go to 20 go to 99 C Exits 90 continue istat = 1 99 continue return end C ---------------------------------------------------------------- function ndigits(i) C Function returns the number of digits in integer i integer*4 i,ii integer*4 ndigits ndigits = 0 ii = i 10 continue ndigits = ndigits + 1 ii = ii/10 if (ii .ne. 0) go to 10 return end