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
