program rpatgs
c
c-----------------------------------------------------------------------
c-----------------------------------------------------------------------
c
      byte icx
c
      integer*4 kode, modblk(8)
c
      external close_maf1  !$pragma C( close_maf1 )
c
c-------------------------------------------------------------------
c     *** initialization data collection parameters ***
c-------------------------------------------------------------------
c
      call initialize (kode, modblk, icx)
      if (kode .eq. -1) go to 500
c
c---------------------------------------------------------------------
c     *** process the data  ***
c---------------------------------------------------------------------
c
      call proces (modblk, iret, kflag, icx)
c
c---------------------------------------------------------------------
c     *** end of file logic ***
c---------------------------------------------------------------------
c
      if (iret .eq. -10) write (*,'('' end of file'')')
      if (iret .eq. 1) write (*,'('' no more subperiods'')')
c
c---------------------------------------------------------------------
c     *** normal exit ***
c---------------------------------------------------------------------
c
  500 continue
      call close_maf1
      stop
      end

      subroutine initialize (kode, modblk, icx)
c
c-----------------------------------------------------------------------
c-----------------------------------------------------------------------
c
      byte      icx, text(4)
c
      character cyorn
c
      integer*2 intp
c
      integer*4 ieof, modblk(8)
c
      common    /interpolate/intp
c
      external open_maf1  !$pragma C( open_maf1 )
c
c-----------------------------------------------------------------------
c     *** open the input data file ***
c-----------------------------------------------------------------------
c
      call open_maf1 (ieof)
c
c-----------------------------------------------------------------------
c     *** get start and stop times ***
c-----------------------------------------------------------------------
c
      call lmssetr (kode)
      if (kode .eq. -1) go to 99
c
c-----------------------------------------------------------------------
c     *** get duration of each frame ***
c-----------------------------------------------------------------------
c
      call frasetr (kode)
c
c-----------------------------------------------------------------------
c     *** define which head ***
c-----------------------------------------------------------------------
c
      call hedset (modblk(1))
      if (modblk(1) .eq. 4) go to 10
c
c-----------------------------------------------------------------------
c     *** define mass setting range ***
c-----------------------------------------------------------------------
c
      call masset (jm1,jm2)
c
c-----------------------------------------------------------------------
c     *** single mass det define ilohi lo/hi flag ***
c-----------------------------------------------------------------------
c
      call mastxt (jm1,jm2,modblk(2),text,text)
      modblk(3)=jm1
      modblk(4)=jm2
      call mascnv (modblk(3),modblk(4))
   10 continue
c
c-----------------------------------------------------------------------
c     *** define angle range ***
c-----------------------------------------------------------------------
c
  200 continue
      write (*,'('' Enter start and stop phase angles (deg): '', $)')
      read (*,*) iang1, iang2
      if (iabs(iang1) .gt. 180) then
         write (*, '('' ERROR: start angle out of range (+,- 180)'')')
         go to 200
      end if
      if (iabs(iang2) .gt. 180) then
         write (*, '('' ERROR: start angle out of range (+,- 180)'')')
         go to 200
      end if
      if (iang2 .lt. iang1) then
         write (*, '('' ERROR: stop angle less than start angle'')')
         go to 200
      end if
      modblk(7) = iang1
      modblk(8) = iang2
c
c-----------------------------------------------------------------------
c     *** define aperture bias ***
c-----------------------------------------------------------------------
c
      call apset (icx)
c
c-----------------------------------------------------------------------
c     *** see if wish to interpolate ***
c-----------------------------------------------------------------------
c
   25 continue
      type '('' do you wish to interpolate the data (y/n)? '',$)'
      accept '(a1)', cyorn
      if (cyorn .eq. 'y'  .or.  cyorn .eq. 'y') then
         intp = 1
      else if (cyorn .eq. 'n'  .or.  cyorn .eq. 'n') then
         intp = 0
      else
         go to 25
      end if
c
c-----------------------------------------------------------------------
c-----------------------------------------------------------------------
c
   99 return
      end

      subroutine proces (modblk,kode,lflag,icx)
c
c-----------------------------------------------------------------------
c-----------------------------------------------------------------------
c
      logical   ifirst1
c
      byte      icx
c
      integer*2 intp
c
      integer*4 ctn(32), iicx, modblk(8)
      integer*4 ftms1(4),ieof,ifirst(2),iorboft,iorbtime,iorbyd,
     *          iwindow,istrip_times(180,2),itime(2,13)
      integer*4 doy_date, immddyy, iyyddd
c
      real      cts(32),orbs(4,13),rpa_data(180,32)
c
      real*8    stms(4),ftms(4)
c
      common    /comlim/stms,
     *          /deluns/lundat,lunti,lunto,
     *          /fratms/ftms,ndiv,
     *          /interpolate/intp,
     *          /orbdat/itime,orbs,
     *          /orbit/iorboft,iwindow,iorbyd,iorbtime,inum,ifirst
c
      data      ifirst1/.true./
c
      external open_maf1  !$pragma C( open_maf1 )
c
c-----------------------------------------------------------------------
c     *** initialize ***
c-----------------------------------------------------------------------
c
      lflag=0
      do i=1,180
         do j=1,32
            rpa_data(i,j) = -1.0
         end do
         istrip_times(i,1) = 0
         istrip_times(i,2) = 0
      end do
c
c-----------------------------------------------------------------------
c     *** initialize the orbit parameters and ***
c     ***    initialize save information      ***
c-----------------------------------------------------------------------
c
      call orboftr
      do i=1,13
         itime(1,i)=-1
         itime(2,i)=-1
         do j=1,4
            orbs(j,i)=0.0
         end do
      end do
c
c-----------------------------------------------------------------------
c     *** if first time in routine read first record ***
c-----------------------------------------------------------------------
c
      if (ifirst1) then
         call getmf1 (kode)
c         if (kode .eq. -10) go to 3000
         if (kode .eq. -10) then
            call open_maf1 (ieof)
            if (ieof .eq. 1) go to 3000
         end if
         ifirst1=.false.
      end if
c
c-----------------------------------------------------------------------
c     *** loop through the number of divisions for this time span ***
c-----------------------------------------------------------------------
c
      indiv=0
      do 1800 idiv=1,ndiv
         indiv=indiv+1
c
c-----------------------------------------------------------------------
c        *** initialize working arrays ***
c-----------------------------------------------------------------------
c
         jflag=0
         do i=1,32
            cts(i)=0.0
            ctn(i)=0
         end do
c
c-----------------------------------------------------------------------
c        *** record within time limits ? ***
c-----------------------------------------------------------------------
c
  200    call lmstssr (kode,i1,i2)
         if (kode) 400,600,1600     ! before,during,after
c
c-----------------------------------------------------------------------
c        *** get next record ***
c-----------------------------------------------------------------------
c
  400    call getmf1 (kode)
c         if (kode .eq. -10) go to 3000      ! end of file
         if (kode .eq. -10) then
            call open_maf1 (ieof)
            if (ieof .eq. 1) go to 3000
         end if
         go to 200
c
c-----------------------------------------------------------------------
c        *** this record in current limits so process ***
c-----------------------------------------------------------------------
c
  600    continue
c
c-----------------------------------------------------------------------
c        *** see if time to save orbit parameters ***
c-----------------------------------------------------------------------
c
         call orb_save
c
c-----------------------------------------------------------------------
c        *** test if required aperture bias ***
c-----------------------------------------------------------------------
c
         call aptst (icx,kode)
         if (kode .eq. -1) go to 800     ! no
c
c-----------------------------------------------------------------------
c        *** proper aperature bias - continue processing ***
c-----------------------------------------------------------------------
c
         call deffgs     ! define flags
         call getmd1     ! and instrument mode
c
c-----------------------------------------------------------------------
c        *** id mass scan mode grt next record ***
c-----------------------------------------------------------------------
c
         call is_mass_scan (isms)
         if (isms .eq. 1) then
            go to 400
         end if
c
c-----------------------------------------------------------------------
c        *** collect the data ***
c-----------------------------------------------------------------------
c
         call srtrpa (modblk,cts,ctn,i1,i2,kflag)
         jflag=max0(jflag,kflag)
         lflag=max0(jflag,lflag)
  800    continue
c
c-----------------------------------------------------------------------
c        *** see if need more data for this division ***
c-----------------------------------------------------------------------
c
         if (i2 .eq. 512) go to 400
c
c-----------------------------------------------------------------------
c        *** average data ***
c-----------------------------------------------------------------------
c
         do i=1,32
             if (ctn(i) .le. 0) then
               cts(i)=-1.0
            else
               cts(i)=cts(i)/float(ctn(i))
            end if
         end do
         if (intp .ne. 0) call intrr1 (cts,32)
c
c-----------------------------------------------------------------------
c        *** put data in storage arrays ***
c-----------------------------------------------------------------------
 1000    continue
         iflag=1
         istrip_times(idiv,1)=stms(2)/1000.0d0
         istrip_times(idiv,2)=stms(4)/1000.0d0
         do irpa=1,32
            rpa_data(idiv,irpa)=cts(irpa)
         end do
c
c-----------------------------------------------------------------------
c        *** get time of next division ***
c-----------------------------------------------------------------------
c
 1600    call lmsnxtr (kode)
         if (kode .ne. 0) go to 3000
 1800 continue
c
c-----------------------------------------------------------------------
c     *** process the last division ***
c-----------------------------------------------------------------------
c
 3000 continue
      do i=1,32
         if (ctn(i) .le. 0) then
            cts(i)=-1.0
         else
            cts(i)=cts(i)/float(ctn(i))
         end if
      end do
      istrip_times(idiv,1)=stms(2)/1000.0d0
      istrip_times(idiv,2)=stms(4)/1000.0d0
      if (intp .ne. 0) call intrr1 (cts,32)
      do irpa=1,32
         rpa_data(idiv,irpa)=cts(irpa)
      end do
c
c-----------------------------------------------------------------------
c     *** output data array to output file ***
c-----------------------------------------------------------------------
c
      open (unit = 2, file = 'rpatgs.dat', access = 'sequential',
     *      form = 'formatted', err = 3100)
      go to 3200
 3100 continue
      type '('' error opening output file'')'
      return
 3200 continue
      ftms1(1)=ftms(1)
      ftms1(2)=ftms(2)/1000.0d0
      ftms1(3)=ftms(3)
      ftms1(4)=ftms(4)/1000.0d0
      if (icx .eq. '0') then
         iicx = 0
      else if (icx .eq. '2') then
         iicx = 2
      else if (icx .eq. '4') then
         iicx = 4
      else if (icx .eq. '8') then
         iicx = 8
      else
         iicx = 10
      end if
      iyyddd = ftms(1)
      immddyy = doy_date (iyyddd)
      immdd = immddyy / 100
      imm = immdd / 100
      idd = immdd - (imm * 100)
      write (2,*) (modblk(i),i=1,8),iicx,(ftms1(i),i=1,4)
      write (2,*) imm, idd
      write (2,*) inum,iorboft,ifirst(1),ifirst(2)
      do i=1,inum
         write (2,*) (itime(j,i),j=1,2),(orbs(j,i),j=1,4)
      end do
      ndif=32
      write (2,*) ndiv,ndif
      do i=1,ndiv
         write (2,*) (rpa_data(i,j),j=1,ndif)
      end do
      close (2)
c
c-----------------------------------------------------------------------
c-----------------------------------------------------------------------
c
      return
      end