C==================== PCCRTW SYSTEM=DOS32=========================
C>>>>>>>>>>>>>>>>>> c:\watcom\cmfdos32\ECPCRTW32.FOR<<<<<<<<<<<<<<<<<<<<<<
c -10s clock adj on startup
C>>> TO RUN PC INTERCFACE BOX FROM ECP PORT RATHER THAN PCL750 ISA CARD
C>>> includes 1st 3 gate special gain set and for025 sig o/p

C>>>>>>>>>>>>>>>>>>>work:[meek]qxcrtw32.for<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
C>>>>>>>>>>>> WATCOM F77 COHRTW program =>32 bit dos<<<<<<<<<<<<<<<<<<<<<<
C>>> 1997 copyright C.E.Meek,ISAS,Physics Dept.,University of Saskatchewan
C>>>>>>>>>>>>>>>This program is Public Domain<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
C>>>>>>>>>>>>>i.e. copy and use but don't sell<<<<<<<<<<<<<<<<<<<<<<<<<<<<
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
C----------upgrade to oxcrtw32.for(maybe)=>try full size matrx      
      implicit real*8 (a-h,o-z)
      SAVE
      character*14 tstamp
      character*80 string
      common/dattim/iyr,idy,ihr,imin,isec,tstamp,itcorr
      common/rdparm/ICLKIN,IDLY,IGSEP,NPTS,NANT,IRAW,ARRAY(6),
     1NINTEG,TSTEP,RWL,FFLMT,PKLMT,ISITE,MINSIG,MAXSIG,
     1PRF,ITSTRT,maxlag,khdr,itest
      Integer*1 ibLk(864),ihdr(96),khdr(32),byte
      integer*2 ii
      equivalence (ii,byte)
      common/outdat/iblk,ihdr
      call display
      call getkey(byte,1) !clear key code
      call update   !want date/time defined right away
C... Read param. fiLe and caLc. derived params
      caLL INIT
C===========PROGRAM ID=====================
      write(string,'(''Program version:16Sep98(wtd <auto>)'')')
      call display3(string)
      call logger(string)
C==========================================
      ifail=0
      icount=1 !indicates 1st record
  10  caLL wfstrt(msg)  !wait for start - key cmds incl. "soft stop"
      if(iraw.eq.1)call display1a(23,15,'SAVING RAW DATA!',16,1)
C......clear gen. purpose msg area(lhs,bottom line)
      call display1(24,0,
     1'                                         ',40)
      write(string,1339)int(tstep*npts),ninteg,prf
 1339 format('RecLen=',i4,'s',',#integ=',i2,',PRF=',f5.1,'Hz')
      call display1(5,2,string,34)
      if(isite.eq.208)then   ! "P"
        write(string,'(''site=PARK'')')
        call display1(6,15,string,9)
      elseif(isite.eq.212)then  ! "T"
        write(string,'(''site=TROMSO'')')
        call display1(6,14,string,11)
      elseif(isite.eq.214)then !"V"
        write(string,'(''site=Platteville'')')
        call display1(6,10,string,16)
      else
        write(string,'(''site id='',i3)' )isite       
        call display1(6,14,string,11)
      endif      
      if(icount.eq.1)call logger(string)
      msg=0
      iend=-1 
c.... message to screen = e.g. "running" or "record in progress"
      caLL sndcmd(icount,msg)
c      call display3('out of sndcmd')
      if(icount.eq.1)goto 200
C....write ANALYSIS date/time and parms to FCA analysis screen
      byte=iblk(1)
      iyr1=(ii/16)*10+mod(ii,16)      
      write(string,1031)iyr1,(iblk(l),l=3,5),
     1(iblk(l),l=7,10),ninteg,npts
 1031 format('ANALYZE:',i2,':',3i1,'/',4i1,' integ#',i2,' #pts=',i3)
      call display3(string)
      write(string,1032)iclkin,igsep,idly
 1032 format('Gate params(clkin,gsep,dly)=',3(1x,z2))
      call display3(string)
      if(ifail.ne.0)then !last rec aborted,so no analy.,but keep readn
        write(string,'('' This record aborted during data input'')')
        call display3(string)
        goto200
      endif        
      do 100 ih=1,32
C....check for new data ready
      caLL rddata(iend,msg) !AlsoCallsUpdateSoNoInterferenceWithTiming
      if(iend.eq.1)caLL update   !screen cLock,IfEndOfInputData
      caLL correL(ih) !does rest of analysis & o/p store
  100 continue    
  200 caLL rddata(iend,msg)
      if(msg.ne.0)goto 210
      if(iend.ne.1)goto 200 !still data to come in
C...write to disc [& tape?]
  210 if(icount.eq.0.and.ifail.eq.0)caLL fiLout
      icount=0
      if(msg.eq.0)then
        ifail=0  !Ok,DataCollectFini,MarkItOkForAnalysis
      else
        ifail=1  
        call incscreen(11,38) !total#fails 
      endif  
C... transfer hdr to bLock
      do k=1,96
        iblk(k)=ihdr(k)
      end do
c...and blank rest
      do k=97,864
        iblk(k)=0
      end do
      goto10
      end

C=============================================

      blockdata
      implicit real*8 (a-h,o-z)
      SAVE
c      integer*2 porta,portb,portc,portctl
C....bitn = CONSTANTS
      integer*1 bit0,bit1,bit2,bit3,bit4,bit5,bit6,bit7
      integer*1 KHDR(32)
      character*1 extdrv
      common/rdparm/ICLKIN,IDLY,IGSEP,NPTS,NANT,IRAW,ARRAY(6),
     1NINTEG,TSTEP,RWL,FFLMT,PKLMT,ISITE,MINSIG,MAXSIG,
     1PRF,ITSTRT,maxlag,khdr,itest
c      common/ports/porta,port,portc,portctl,bit0,bit1,bit2,bit3,bit4,
c     1bit5,bit6,bit7
      integer*2 PortA,PortSTA,PortCTL,PortECR
      common/ports/portA,portSTA,portCTL,portECR,bit0,bit1,bit2,
     1bit3,bit4,bit5,bit6,bit7
      character*3 filnam
      common/zipdrv/extdrv,filnam
C.... initialized parms in rdparm are for test data
      data ICLKIN,IDLY,IGSEP,NPTS,NANT,IRAW,ARRAY/
     199,99,8,512,4,0,156.,156.,156.,90.,210.,330./
      data NINTEG,RWL,FFLMT,PKLMT,ISITE,MINSIG,MAXSIG/
     132,135.,0.4,0.1,99,32,140/
      data PRF,ITSTRT,MAXLAG/60.,300,16/,filnam/'ist'/
      data isite/99/
      data bit0,bit1,bit2,bit3,bit4,bit5,bit6,bit7/
     11,2,4,8,16,32,64,-128/
      end

C================================================

      subroutine init
      implicit real*8 (a-h,o-z)
      SAVE
C... read param fiLe and caL derived quant, DONE ONLY ONCE!
C...aLso set up KHDR (1st 32 of o/p) bytes which are fixed param.
C... by i/p params - and zero rest. This used for reLoading ihdr()
C...and aLso for getting bytes for CMD for rx interface cntL
c      common/ports/porta,portb,portc,portctl,bit0,bit1,bit2,bit3,bit4,
c     1bit5,bit6,bit7
C>>>>!!!!have to change format if using NEW PC-INTERFACE
c      integer*2 pbase,porta,portb,portc,portctl
      integer*2 pbase,PortA,PortSTA,PortCTL,PortECR
      common/ports/portA,portSTA,portCTL,portECR,bit0,bit1,bit2,
     1bit3,bit4,bit5,bit6,bit7
      integer*1 bit0,bit1,bit2,bit3,bit4,bit5,bit6,bit7
      common/rdparm/ICLKIN,IDLY,IGSEP,NPTS,NANT,IRAW,ARRAY(6),
     1NINTEG,TSTEP,RWL,FFLMT,PKLMT,ISITE,MINSIG,MAXSIG,
     1PRF,ITSTRT,maxlag,khdr,itest
      character*14 TSTAMP
      common/dattim/iyr,idy,ihr,imin,isec,tstamp,itcorr
      Integer*1 ibLk(864),KHDR(32),ihdr(96),byte
      integer*2 ii
      equivaLence (ii,byte)
      common/outdat/iblk,ihdr
      character*80 aa,string,strng1
      character*1 bb(80) 
      character*1 extdrv
      character*3 filnam
      logical ex
      integer ios
      common/zipdrv/extdrv,filnam
      equivalence (aa,bb(1))
      isite=0
      extdrv=' ' !NextPrintGoesOnlyToC:...log
      inquire(file='c:\cohrtw\pccrtw32.ini',exist=ex)
      if(.not. ex)then
          print*,
     1    'Can''t Find c:\cohrtw\pccrtw32.ini; paused; return to stop'
          pause
          stop
      endif      
      open(20,fiLe='c:\cohrtw\pccrtw32.ini',status='old')
      iline=0
   20 iflag=0
      read(20,'(a80)',end=900)aa     
      do 30 i=1,80
      if(bb(i).eq.'!')goto40
      if(bb(i).ne.' ')iflag=1 !value line
   30 continue
   40 if(iflag.ne.1)goto20
c...have value line, length=j-1
      iline=iline+1
      bb(i)=','   !want to end #field with comma
      SELECT CASE (iline)
         CASE (1)
           read(aa,*)ii
           extdrv=' '  !dont write to extern drive
           if(ii.eq.1)then
              extdrv=bb(i+1) !=char after '!'
              write(strng1,
     1       '(''Info: Write to extern. Drive='',a1,'':'')')
     1        extdrv
           else
             write(strng1,'('' Info: Do not write to extern drive'')')
           endif
c ......    have to wait until filname ID before writing strng1
         CASE (2)
           read(aa,*,iostat=ios,err=45)isite,filnam
   45      if(ios.ne.0)then !must be old version with no file prefix
             if(isite.ne.0)then
               filnam='rtw'
             else
               isite=1 !mark bad read
               filnam='unk'
             endif
           endif
           isite=mod(isite,256) !stored as 1 byte
           write(string,
     1'('' Info:SystemStart:Init. parms from c:\cohrtw\pccrtw32.ini'')')
           call logger(string)  !=1st line in log
           write(string,
     1     '('' Info: USING SITE ID = '',i3,'' IN O/P DATA'')')
     1      isite
           call logger(strng1)  !o/p saved string; now have filnam ID
         CASE (3)
           read(aa,*)ITEST
           if(itest.eq.1)then
             write(string,1002)
 1002 format('Test run,read from byteampz.dat,o/p to rtwtest.out')
             call logger(string)
             goto 60 !test parms were set in blk comm.
           else
             write(string,
     1     '('' Info: Normal operating mode (not test)'')')
           endif     
         CASE (4)
           read(aa,*)NANT
           write(string,'('' Info:# antennas='',i1)')NANT
         CASE (5)
           read(aa,*)ARRAY(1),ARRAY(2),ARRAY(3)
           write(string,'('' Info:array spacings='',3f6.1,''m'')')
     1     ARRAY(1),ARRAY(2),ARRAY(3)
         CASE (6)
           read(aa,*)ARRAY(4),ARRAY(5),ARRAY(6)
           write(string,'('' Info:array azims='',3f6.1,'' degEofN'')')
     1     ARRAY(4),ARRAY(5),ARRAY(6)
         CASE (7)
           read(aa,*)NPTS
           write(string,'('' Info:# pts/rec='',i4)')NPTS
         CASE (8)
           read(aa,*)PRF
           write(string,'('' Info:PRF(Hz)='',f6.1)')PRF
         CASE (9)
           read(aa,*)NINTEG
           write(string,'('' Info:# to pulses to integrate='',i3)')
     1       NINTEG
         CASE (10)
           read(aa,*)IDLY,ICLKIN,IGSEP
           write(string,'('' Info:ht gate parms='',3i4)')IDLY,
     1     ICLKIN,IGSEP
         CASE (11)
           read(aa,*)ITSTRT
           write(string,'('' Info: start recs every(sec)='',i4)')
     1             ITSTRT
         CASE (12)
           read(aa,*)MAXLAG
           write(string,'('' Info:correl MAXLAG='',i3)')MAXLAG
           if(maxlag.gt.32)then
             write(string,'(''maxlag too large for dims='',i3)')
     1             maxlag
             call logger(string)
             call display(24,1,string,29)
             stop
           endif
         CASE (13)
           read(aa,*)IRAW
           write(string,'('' Info:save raw amps(1)?='',i1)')IRAW
           if(iraw.eq.1)call display1a(23,15,'SAVING RAW DATA!',16,1)
         CASE (14)
           read(aa,*)RWL
           write(string,'('' Info:radio wavelength(m)='',f6.1)')RWL
         CASE (15)
           read(aa,*)PBASE
           write(string,
     1    '('' Info:Hex PortBaseAdr='',z3)') pbase
C...NB with NEW interface there is only 1 base addr
c           porta=pbase
c           portb=pbase+1
c           portc=pbase+2
c           portctl=pbase+3
           PortA=pbase
           PortSTA=pbase+1
           PortCTL=pbase+2
           PortECR=pbase+'402'x
         CASE (16)
           read(aa,*)MINSIG,MAXSIG
           write(string,'('' Info:siglimits for good gain val='',2i4)')
     1     MINSIG,MAXSIG
         CASE (17)
           READ(AA,*)FFLMT,PKLMT
           WRITE(string,
     1   '('' Info:Correl Lmts;1st lag auto>'',f4.2,'', X-Peak>'',F5.2)'
     1    )FFLMT,PKLMT
         case (18)
           read(aa,*)itcorr
           write(string,
     1    '('' Info: clock adjust(added)='',i5,''secs/week'')')
     1     itcorr
         call logger(string)     
         goto60  
         CASE DEFAULT
         call display2(23,1,'TooManyDataLinesInCohrtw.ini:paused',35)
         call display2(24,1,'HitReturnToStop ',16)
         pause
         stop
         END SELECT
         if(iline.ne.1)call logger(string) !line 1 has to wait for filnam
         goto20 !read next line
   60 TSTEP=float(NINTEG)/PRF
      write(string,'('' Calc: TSTEP = '',f6.3,'' sec'')')tstep
      call logger(string)
      close(20)
C...set up permanent part of 32 byte o/p header
      KHDR(14)=NINTEG
      KHDR(15)=mod(NPTS,256)
      KHDR(16)=NPTS/256
      KHDR(17)=IDLY
      ii=ICLKIN
      KHDR(18)=byte
      ii=IGSEP
      KHDR(19)=byte
      ii=186  ! AppLe ":"
      KHDR(2)=byte
      KHDR(11)=byte
      ii=175  ! AppLe "/"
      KHDR(6)=byte            
      KHDR(32)=-1  !$FF, link/data check bytes
      KHDR(31)=0   !        "
      khdr(20)=1
      ii=isite
      khdr(22)=byte  !site id
      do k=1,864
       if(k.le.32)ihdr(k)=KHDR(k)
       iblk(k)=0
      end do
      if(npts.gt.1100)then  ! 3 matrices, 248 pts each
         !NB WATCOM doesn't like calling with string in quotes-
         ! but since we are stopping here anyway, who cares
        call logger('INIT- NPTS too great for dimensions-so stop')
        call display1(24,1,
     1  'NptsTooLargeInInit(max=1100),SoStop',34)      
        stop
      endif    
      msec=-10
      write(string,'(''StartUpClockAdj='',i3,''s'')')msec
      call logger(string)
      call display3(string) !1st 40 char only
      while(msec.ne.0)do
        call timadj(msec) !msec set=0 when success
      endwhile
      call display3('ClockAdj successful')
      return
  900 call logger(':Unexpected end of cohrtw.ini file so stop')
      call display1(24,1,
     1'Unexpected end of cohrtw.ini,hit rtn to stop',44)
      pause
      stop
      end

C==================================================
      subroutine getkey(keycode,icmd)
c.... flush kbd, keep last key; calling routine call again with icmd=1
C... so keycode=0  if it has "used" the key.
C... fn keylook() is kept here as ref. but not used (yet)      
C... The idea is to keep the last pressed key only, so a non-functional
C... key will not block operation.
      
C DOS16 int*1 function kbhit(); rtn -1 if kbhit, 0 if not -doesnt clearstrb
*$pragma aux kbhit = "mov ah,0bh" "int 21h" parm (value) [al] modify [ah]

C DOS16 int*1 getch(); returns 0 if no key (or start of dbl char)
C        or key code (and clears "key pressed" flag)
*$pragma aux getch = "push dx" "mov al,0ffh" "mov dl,al" "mov ah, 06h" \
* "int 21h" "pop dx" parm (value) [al] modify [ah]
            
C DOS16 int*1 keylook(); get last key in kbd buff.,no strob. clr
C  (if no key key, result = 0 .. by test)
*$pragma aux keylook = "mov AH,11h" "int 16h" \ 
* parm (value) [al] modify [ah]

C...there's some bug here ... dont know what, doesnt work very well
C.... but does work (sort of)

      SAVE
      integer*1 getch,keylook,kbhit,keycode,keysav
      if(icmd.eq.1)keysav=0
      keycode=keysav      
      if(kbhit().eq.-1)keysav=getch() !clrs strobe
      return
      end
        
C==================================================

      subroutine update

 
C   DOS32      
*$pragma aux ctick = "push es" "mov ax,0040h" "mov es,ax" \
* "mov eax,es:[006ch]" "pop es" \
* parm (value) [eax]

C DOS32 int*4 getclock() lsb-msb=100ths,secs,mins,hrs(binary)
*$pragma aux getclock = "push cx" "push dx" "mov AH,2ch" "int 21h" \
* "mov ah,ch" "mov al,cl" "shl eax,10h" "mov ax,dx" "pop dx" "pop cx"\
* parm (value) [eax]

C DOS32 int*4 getdate() lsb-msb=DofM,Mon,Yr
*$pragma aux getdate = "push cx" "push dx" "mov AH,2ah" "int 21h" \
* "mov ax,cx" "shl eax,10h" "mov ax,dx" "pop dx" "pop cx" \
* parm (value) [eax]

C DOS32 -- untested !!!
*$pragma aux setdate = "push ecx"  "shld ecx,eax,10h" "mov dx,ax" \
* "shr eax,10h" "mov dx,ax" "mov AH,2bh" "int 21h" "pop ecx" \
* parm (value) [eax]

C DOS32 setclock(int*4) lsb-msb=h100,sec,min,hr=>dl,dh,cl,ch
*$pragma aux setclock = "push ecx" "mov ecx,eax" "shr ecx,10h" \
* "mov dx,ax" "mov AH,2dh" "int 21h" "pop ecx" parm (value) [eax]

      SAVE
      integer*4 clock4,date4,getdate,getclock,imon,idum4
      integer*1 date(4),clock(4),byte,setclock,setdate
      integer*2 ii
      integer*1 keycode
      integer*4 iset,ctick,mset
      character*80 string      !mod for DOS32
      equivalence (clock(1),clock4),(date(1),date4),(ii,byte)
      dimension ndm(12)
      common/dattim/iyr,idy,ihr,imin,isec,tstamp,itcorr
C..day# list for non-Leap year
      character*14 tstamp
      data ndm/0,31,59,90,120,151,181,212,243,
     1273,304,334/,iskip/1/,idyl/0/
      clock4=getclock() !could have a day change between this
      date4=getdate()   ! and this
      byte=date(4)
      iyr=ii
      byte=date(3)
      iyr=mod(iyr*256+ii,100)
      iyr=mod(iyr,100)  !thinkng of the millenium,dont know what PC will do
      imon=date(2)
      idy=ndm(imon)+date(1)
      if(mod(iyr,4).eq.0.and.imon.gt.2)idy=idy+1
      if(idyl.ne.idy)clock4=getclock() !if day# changed,re-read hms!
      idyl=idy
      isec=clock(2)
      imin=clock(3)
      ihr=clock(4)      
      write(tstamp,1234)iyr,idy,ihr,imin,isec
 1234 format(i2.2,':',i3.3,'/',2i2.2,':',i2.2)
      call display1a(3,12,tstamp,14,0)    
      call getkey(keycode,0)  !get last pressed key if any
      if(keycode.eq.2)then  !cntrl-B  BUT getch traps ctl-c too (Ithink)
         call getkey(keycode,1) !clr keycode
         call display1(24,1,
     1   'StopRequested-DoYouReallyWantToStop?',36)     
         while(keycode.eq.0) do  !using sep. function
           call getkey(keycode,0)
         end while
         if(keycode.eq.121.or.keycode.eq.89)stop  !'y' or 'Y'
         call display1(24,1,'                                    ',36)
         call getkey(keycode,1) !clr key
      endif
c.................................................        
      call getkey(keycode,0)
      if(keycode.ne.43.and.keycode.ne.45)return
         if(keycode.eq.43.and.clock(2).lt.58)then !'+'
              clock(2)=clock(2)+'01'x
              idum4=clock4
              iset=ctick()
              x=setclock(idum4)
              itadj=itadj+1
              clock4=getclock()
C...     give clocktic time to be reset,clk change by 1 sec=18 tics
              while (iabs(itimout(iset)).lt.10)do !
              end while
C..           Ok clock tic must have been changed            
              call getkey(keycode,1) !clr key
         endif
         if(keycode.eq.45.and.clock(2).gt.1)then ! '-'
            clock(2)=clock(2)-'01'x
            idum4=clock4
            iset=ctick()
            x=setclock(idum4)
            itadj=itadj-1
            clock4=getclock()
C...give clocktic time to be reset,clk change by 1 sec=18 tics
            while (iabs(itimout(iset)).lt.10)do !
            end while
C... Ok clock tic must have been changed            
            call getkey(keycode,1) !clr key
         endif
      return
      ENTRY timadj(mset)
      if(mset.eq.0)return
      clock4=getclock()
      byte=clock(2)  !get present secs
      ii=ii+mset
      if(ii.lt.2.or.ii.gt.58)then !cant change clock right now
        ii=0 !so high byte stays zero
      else   !ok, can change
        clock(2)=byte      
        idum4=clock4
        iset=ctick()
        x=setclock(idum4)
        clock4=getclock()
C...give clocktic time to be reset,clk change by 1 sec=18 tics
        while (iabs(itimout(iset)).lt.10)do !
        end while
C... Ok clock tic must have been changed            
        mset=0
      endif  
      return
      end

C=============================================================
      function itimout(iset)

C   DOS32
*$pragma aux ctick = "push es" "mov ax,0040h" "mov es,ax" \
* "mov eax,es:[006ch]" "pop es" \
* parm (value) [eax]

      SAVE
      character*14 tstamp
      common/dattim/iyr,idy,ihr,imin,isec,tstamp,itcorr           
      integer*4 iset,itimout,ctick
      itimout= mod(iset- ctick(), '1800b0'x)
      if(itimout.ge.'c0058'x)itimout=itimout-'1800b0'x
      return
      end
      
C========================================================

      
      subroutine wfstrt(msg)      
      implicit real*8 (a-h,o-z)
      SAVE
      character*14 tstamp
      common/dattim/iyr,idy,ihr,imin,isec,tstamp,itcorr
      common/rdparm/ICLKIN,IDLY,IGSEP,NPTS,NANT,IRAW,ARRAY(6),
     1NINTEG,TSTEP,RWL,FFLMT,PKLMT,ISITE,MINSIG,MAXSIG,
     1PRF,ITSTRT,maxlag,khdr,itest
      character*1 key
      character*80 string
      integer*1 keyeqv,khdr(32),keycode
      equivalence (key,keyeqv)
      data iwait/0/,iskip/1/,itlst/0/,ihrsav/-1/,nadj/0/,kskip/1/
c      type*,'Key cmds: W/w=wait,S/s=dont wait,M/m=start rec now'
c      call display3('Wait for start')
      msg=0 !don't know what to use this for yet
      iwait=0
C--------------junk to do with automatic clock correction---------      
      if(kskip.eq.1)idysav=idy  !start off 7d counter
      kskip=0
      if(mod(idy-idysav,7).eq.0.and.nadj.eq.0)then !setup tot#secs
         nadj=28 !four times a day for a week
         msec=itcorr  !=total # secs per week (signed)
         idysav=idy
      endif
      if((ihr.ne.ihrsav).and.(mod(ihr,6).eq.0).and.(nadj.ne.0))then
        if(msec.ne.0)then
            ksec=msec/nadj
            write(string,'('':AutoClockAdjust::'',3i4)')nadj,msec,ksec
            call logger(string)  !temporary test o/p ? or perm?
            call timadj(ksec) !=ENTRY in subr update
            if(ksec.eq.0)then   !note that ihrsav is NOT the prev hr
               ihrsav=ihr  !Ok , did clock adjust                    
               msec=msec-msec/nadj
               nadj=nadj-1
            endif
        endif
      endif              
c-----------------------------------------------------------------
      call display2(3,27,' ',0) !clear 'R' from prev
   10 caLL update
      itnow=(ihr*60+imin)*60+isec
      if(iskip.eq.1)then
          itLst=itnow
          iskip=0
      endif
      itnxt=mod( ((itLst+ITSTRT)/itstrt)*itstrt,86400) ! # secs in day
      if(itnxt.eq.itnow)then
         itLst=itnxt
c...     cLr screen msg
         call display2(3,27,'R',0)
         iskip=1
         return     
      endif     
C....key cmds
   20 call update
      call getkey(keycode,0)
      keyeqv=keycode  !get char representation in "key"
      if(key.eq.'w'.or.key.eq.'W')then
          call getkey(keycode,1)  !clr key
          iwait=1
          call display2(3,27,'W',1)
      elseif (iwait.eq.1.and.(key.eq.'S'.or.key.eq.'s'))then
           call getkey(keycode,1)  !clr key
           call display2(3,27,' ',0)
           iwait=0
           iskip=1
           call display !re-draw screen on rtn from wait
      elseif (iwait.eq.1.and.(key.eq.'m'.or.key.eq.'M'))then
           call getkey(keycode,1)  !clr key
           iwait=0 
           call display
           call display2(3,27,'R',0)
           iskip=1
           return            !start record now
      elseif (iwait.eq.1.and.(key.eq.'h'.or.key.eq.'H'))then
c......... copy c:\rtwdata\hrlymean.dat to a:hmlist      
           call getkey(keycode,1) !clr key
           call dmphms     
      endif
      if(iwait.eq.1)goto20
      goto10
      end

C=============================================================

      subroutine sndcmd(icount,msg)

C  clear printer buff,send nmi, send cmd, change direct. for i/p

C  WATCOM PRAGMAS
C----- int*1 function rdport(int*2 portaddr);
C       returns result of port read
*$pragma aux rdport = "in al,dx" parm (value) [dx] [al]

C--- int*1 function wrport(int*2 portaddr, int*1 byte)
C     write to port, - no address check! so be careful !
*$pragma aux wrport = "out dx,al" parm (value) [dx] [al] 

C----- int*1 function rdmask(int*2 portaddr, int*1 mask)
C       masked read returned (port data AND mask)
*$pragma aux rdmask =  "push bx" "mov bl,al" "in al,dx" "and al,bl" \
* "pop bx" parm (value) [dx] [al]

C---- int*1 function posstrobe(int*2 portaddr,int*1 mask);
C      pos strobe (up-dwn) of mask bits
*$pragma aux posstrobe = "push bx" "mov bl,al" "in al,dx" "or al,bl" \
* "out dx,al" "xor bl,0ffh" "and al,bl" "mov bx,[1234h]" \ !time delay
* "out dx,al" "pop bx" parm (value) [dx] [al]

C DOS32 int*4 function ctick(); rtn clktic( 1800b0h/day ~1500000 ~54ms)     
*$pragma aux ctick = "push es" "mov ax,0040h" "mov es,ax" \
* "mov eax,es:[006ch]" "pop es" \
* parm (value) [eax]

      implicit real*8 (a-h,o-z)
      SAVE
      integer*1 rdport,wrport,rdmask,posstrobe
      integer*4 ctick,iset
c      integer*2 porta,portb,portc,portctl
      integer*1 bit0,bit1,bit2,bit3,bit4,bit5,bit6,bit7
c      common/ports/porta,portb,portc,portctl,bit0,bit1,bit2,
c     1bit3,bit4,bit5,bit6,bit7
      integer*2 PortA,PortSTA,PortCTL,PortECR
      common/ports/portA,portSTA,portCTL,portECR,bit0,bit1,bit2,
     1bit3,bit4,bit5,bit6,bit7
      integer*1 h34,h2b,h29,h0f,h0e,h0d,h07,h00,h09,h0b,h08,h0c 
      data h34,h2b,h29,h0f,h0e,h0d,h07,h00,h09,h0b,h08,h0c/
     1'34'x,'2b'x,'29'x,'0f'x,'0e'x,'0d'x,'07'x,'00'x,
     1'09'x,'0b'x,'08'x,'0c'x/
      logical ex
      Integer*1 CMD(48),ibLk(864),KHDR(32),ihdr(96),byte
      integer*1 iamp1(264,1100),iamp2(264,1100)
      common/indata/iamp1,iamp2,iseL,isig
      dimension isig(32)
      integer*2 ii,ig
      equivaLence (byte,ii)      
      common/outdat/iblk,ihdr 
      character*14 tstamp
      character*80 string
      common/dattim/iyr,idy,ihr,imin,isec,tstamp,itcorr
      common/rdparm/ICLKIN,IDLY,IGSEP,NPTS,NANT,IRAW,ARRAY(6),
     1NINTEG,TSTEP,RWL,FFLMT,PKLMT,ISITE,MINSIG,MAXSIG,
     1PRF,ITSTRT,maxlag,khdr,itest
C      NB 1s show pLaces to be fiLLed in
      data cmd/0,0,0,0,0,1,1,1,1,1,1,0,0,0,32*1,0,-1/!must use signed!

C..... TX on
       msg=0   !no error (yet)
CX: NB at the end of this rec, ihdr(96) contains d/t and gains for 
C  present record being started. When rec ends in rddata,
C... cheap sigs wiLL be stored, and used here to set next gain
      cmd(11)=ihdr(16) !# sends High == rec Length
      cmd(10)=ihdr(15) !# sends Low
      cmd(9)=ihdr(14) !#integr
      cmd(6)=ihdr(19) !gsep 
      cmd(7)=ihdr(18) !ICLKIN
      cmd(8)=ihdr(17) !IDLY
C... update gains from Last signaL
c      print*,'     in sndcmd, icount=',icount
      if(icount.eq.1)then !*INIT GAINS to 77776666....0000
          isel=2
          inquire(file='c:\cohrtw\rtwgains.dat',exist=ex)
          if(ex)then
            open(20,file='c:\cohrtw\rtwgains.dat',form='formatted',
     1      access='direct',recl=80,status='old')
            read(20,'(32i1)',rec=1)(cmd(i),i=15,46)
            close(20)
            maxlow=(32*48)/float(ninteg)
            !maxlow is what you get (empirically tested) with 100% I and Q clip
            !then div-by-2 to get limit for gain change
            maxlow=maxlow/2
            write(string,'('' ECPCRTW32:ht#1-3, gain limits:'',2i3)')
     1        7,maxlow
            call logger(string)
            do i=1,32
              ihdr(64+i)=cmd(14+i)
c                 double check for bad#s,and reset if so           
              if(cmd(14+i).lt.0.or.cmd(14+i).gt.7)then
                 cmd(14+i)=5
                 ihdr(64+i)=5
              endif   
            end do
            isel=2  
          else  
            do i=1,32
              ii=(32-i)/4     !can do with byte?
              cmd(i+14)=byte
              ihdr(64+i)=byte
            end do
            open(20,file='c:\cohrtw\rtwgains.dat',recl=80,
     1      form='formatted',access='direct',status='new')
            write(20,'(32i1)',rec=1)(cmd(i+14),i=1,32)
            close(20)  
            maxlow=(32*48)/float(ninteg)
            !maxlow is what you get (empirically tested) with 100% I and Q clip
            !then div-by-2 to get limit for gain change
            maxlow=maxlow/2
            write(string,'('' ECPCRTW32:ht#1-3, gain limits:'',2i3)')
     1        7,maxlow
            call logger(string)
          endif    
      eLse               !*SET GAINS
          ISEL=MOD(ISEL,2)+1 !REVERSE COLLECT/Analysis flag
C...if isel = 1, data are collected (from cpu#1) in iamp2
C while iamp1 is analysed  and vice versa
          
          do 30 i=1,32
          byte=ihdr(64+i)
          ig=ii
          byte=ihdr(32+i) != cheap sig from end of rddata
          if(byte.ne.0)msg=msg+1 !resuse msg temporarily
          if(i.gt.3)then
            if(ii.Lt.MINSIG)then
              if(ig.Lt.7)ig=ig+1
            eLse
              if(ii.gt.MAXSIG)then  
                 if(ig.gt.0)ig=ig-1
              endif 
            endif
          else !lowest 3 gates
            if(ii.lt.8)then
              if(ig.lt.7)thenig=ig+1
            else
              if(ii.gt.maxlow)then
                if(ig.gt.0)ig=ig-1
              endif  
            endif          
          endif  
c          ii=ig
          ii=mod(ig,8) !to fix a strange bug in qvcrtw32
          ihdr(64+i)=byte
          cmd(14+i)=byte 
   30     continue
          if(msg.ne.0)then   
   !  save new gains so manual restart gets last gains, unless sigs=0
   !     which means last record aborted
            open(20,file='c:\cohrtw\rtwgains.dat',form='formatted',
     1      recl=80,access='direct',status='old')
            write(20,'(32i1)',rec=1)(cmd(14+i),i=1,32)
            close(20)
            msg=0
          endif
      endif
C>..no sense in cLearing out oLd sig .. wiLL just repLace
C  with accur. in correL routine

      if(ITEST.eq.1)return  !test mode
C..punct and everthing const.  was set prev. in init
      do 67 k=1,32
   67 ihdr(k)=KHDR(k)
      ii=mod(iyr,10)+(iyr/10)*16
      ihdr(1)=byte
      ihdr(3)=idy/100
      ihdr(4)=mod(idy/10,10)
      ihdr(5)=mod(idy,10)
      ihdr(7)=ihr/10
      ihdr(8)=mod(ihr,10)
      ihdr(9)=imin/10
      ihdr(10)=mod(imin,10)
      ihdr(12)=isec/10
      ihdr(13)=mod(isec,10)


c--------------- ECP  clr p-buf-------------
      
      x=wrport(portECR,h34) !request bi-directional - just need to do once! 

c        (see Parallel Port Complete by Jan Axelson  to find the reason for 
c            the other set bits; all we should really need is $20      

C      read from CPU#1/PC Box Buffer
c..       portctL (internal) bit 5 sets port= i/p
C    AND   (external) Port Ctl bit 5= sets PCInterfaceBox dir. rx->PC

       x=wrport(portctL,h2b)     !PortA = i/p mode because bit 5 set: $20
                                 !keep bit 0 = high so no strobe to cpu#1
C>>>NOTE doing things brute force instead of posstrobe/negstrobe because those
c    assume that the stored register contents can be got by read - not true for
c      ECP apparently; some active bit(s) are different (e.g. maybe port direction)
c    so read-nomodify-write  can change the state.

c.. preset the PCBox latch, which autosends strobe to p-buffer; -ve strobe bit1
c                                                               (=+ve strobe to box!)
      x=wrport(portctL,h29)

      x=wrport(portctL,h2b) !reSet latch/send strobe to buff


         !always check p-buff *first* (or simul) when timout
         ! for new data
      icnt=0
      iset=ctick()+20  !wait longer for slawcrtw (need during test with gen.for)
      while (itimout(iset).ge.0) do
        i4old=ctick()  !a little more efficient than the outer
        while(i4old.eq.ctick())do
          if(rdmask(portsta,bit7).ne.0)then  !latch o/p=active low =>  S7-bar=high
          
            x=wrport(portctL,h29)
            x=wrport(portctL,h2b) !preset latch/send strobe

            icnt=icnt+1
            if(icnt.eq.1)then
               write(string,'(''PrinterBufferNotEmpty-ClearIt'')')
               call display3(string)
            endif
            if(mod(icnt,500).eq.0)call update !keep the clock running(& key cmds) 
            if(mod(icnt,10000).eq.0)then
            
               write(string,'(''Clrd:'',i5,''K'')')icnt/1000
               call display3(string)  
            elseif(icnt.gt.200000)then
              write(string,'(''Cleared>200K!??? so quit'')')
              call display3(string)             
              msg=-1
              return             
            endif
            iset=ctick()+20  !am I using this ?
          endif
        end while
      end while

c...end of ECP clr p-buf
c      call display3(' after ptr buf clr section')
    5 if(icnt.ne.0)then
        write(string,'('':had to clr p-buf,#='',i6)')icnt
        call logger(string)
      endif
C....send nmi     

C ECP    CTL bit 5 clr = o/p mode, set = i/p 
      x=wrport(portCTL,h07) !bit C5 clr,so ECP PortA is o/p mode
                            ! bit C2 high,so intfce box PC-> RX
                            !and C3 low - to send NMI (edge trig)
      x=wrport(portctl,h0f) ! bring NMI high again

      iset=ctick()+50  !clktics @ 54ms/tic, 1800B0h tics/day
      while (itimout(iset).ge.0) do
c         print*,'test:',iset,itimout(iset)
c        if(rdmask(portc,bit0).eq.0)goto40 !ok got a strobe
         if(rdmask(portSTA,bit7).ne.0)goto 40 !OK got a strobe
      end while
      write(string,'(''No response to NMI'')')
      call logger(string)
      call display1(24,1,'No response to NMI: wait & restart',34)
      msg=1
      iset=ctick()+100 !5 sec wait
      while(itimout(iset).ge.0) do !wait, so it wont try immed. again
      end while
      return
c.. .OK have 1st strobe from cpu#1, so ...send cmd data
   40 i=0
        !could reduce the # of levels of timout below ...
      iset=ctick()+2  ! 0.11 sec (has to be less than shortest delta-T!)
      while(itimout(iset).gt.0) do
         while(rdmask(PortSTA,bit7).ne.0) do
            i=i+1
            iset=ctick()+2
            if(i.le.48)x=wrport(Porta,cmd(i))
             x=wrport(portCTL,h0c) !preset latch and send strobe 
             x=wrport(portCTL,h0f)
        end while
      end while         
      if(i.ne.48)then
        write(string,'('':Wrong#CmdBytesAcceptedByCpu#1:'',i3)')i
        call logger(string)
        call display1(24,1,string,34)
        msg=2
        iset=ctick()+100 !wait 5 sec and then rtn
        while(itimout(iset).ge.0) do
        end while
        return
      endif

C....reverse direction so can read data from p-buff

      x=wrport(portCTL,h2b) !Port a now = i/p (bit 5 set),
                            !  and  PC Box direct Rx->pc (bit 2 low)

      return
      end

C==================================================

      subroutine rddata(iend,msg)

 
C   DOS32      
*$pragma aux ctick = "push es" "mov ax,0040h" "mov es,ax" \
* "mov eax,es:[006ch]" "pop es" \
* parm (value) [eax]

C... iend=-1 => init routine, then set iend=0(=coLLecting)
C.. when aLL expected data in - check a few ms Longer and
C.. then return with iend=1.
      implicit real*8 (a-h,o-z)
      SAVE
      logical ex
      dimension isig(32)
      Integer*1 ibLk(864),KHDR(32),ihdr(96),
     1rec(264),byte,stat(8)
      integer*1 iamp1(264,1100),iamp2(264,1100)
      common/indata/iamp1,iamp2,iseL,isig
      Integer*2 ii
      integer*4 ctick,more,ndata,lrec,k
      common/outdat/iblk,ihdr
      character*14 TSTAMP
      character*80 string
      common/dattim/iyr,idy,ihr,imin,isec,tstamp,itcorr
      common/rdparm/ICLKIN,IDLY,IGSEP,NPTS,NANT,IRAW,ARRAY(6),
     1NINTEG,TSTEP,RWL,FFLMT,PKLMT,ISITE,MINSIG,MAXSIG,
     1PRF,ITSTRT,maxlag,khdr,itest
      equivalence (ii,byte)
C... check p-buff for data, return if 1ms timeout, keep trk and
C.... crash if > 1.5*TSTEP sec timeout.
C.... keep track of "mean" sig= use sum abs( -128) e.g. or what?
C...NB isig=cheap version of signaL for setting gains, because
C...need it right away for next record
C... store cheap sig in isig !! for use by sndcmd
C..if I take sum abs(x-128,y-128), .. can I make ~corr with sum(x,y)     
      if(iend.eq.1.or.msg.ne.0)return
C !this record is finished(iend) ,or aborted(msg) already
      if(iend.eq.-1)then !initiaLize
        do k=1,32
         isig(k)=0
        end do
        iend=0      !ok, =0 for further calls
        Lrec=0
        ndata=0
        morel=1  !flag that says last call got some data
      endif
C.... if we reset iset every time we enter here, it will never timout
C.... even when there no data  
      if(morel.eq.1)then
         call update  !call here so clktic change doesn't affect timers
         iset=ctick()+(1.4*tstep/0.054) !give it 40% leeway
      endif   
   10 caLL getrec(rec,ndata,more)
      if(more.eq.1) then
         morel=1
         call update !CallHereSoIfClockAdjManually,TimingNotAffected
         iset=ctick()+(1.2*tstep/0.054) !got some data so reset timer
         if(NDATA.lt.264)goto 10
         do k=1,8  !save for CPU#1 status check
           stat(k)=rec(256+k)
         end do
         lrec=lrec+1
         write(string,'(''lrec#'',i3)')lrec
         call display1(18,1,string,8)
C... accum cheap signal for use in setting next gains befor full analy.
         kk=nant*2
         do k=1,32
           k1=(k-1)*8
           do k2=1,kk
             byte=rec(k1+k2)
             isig(k)=isig(k)+iabs(ii-128) !assume offset=5v,sum abs I,Q
           end do
         end do 
c.................................            
         if(lrec.gt.npts)then
           call display1(24,1,'Abort- got too many lrecs',25)
           msg=1   !abort -- too much data
           call logger(': Abort; too many data recs received')
           return
         else  
C..... decide which alternate data store to use
C  (note since this is dos16, had to split large mat. into <64kbytes)
c ---------put seq numbers into unused status bytes--
           ii=lrec/256
           rec(260)=byte
           ii=mod(lrec,256)
           rec(259)=byte
c--------------------------------------------------
C.... now decide which "segmented" matrix to use           
           nn=lrec
           if(iseL.eq.1)then
             do k =1,264
              iamp2(k,nn)=rec(k)
             end do
           eLse  ! iseL=2
             do k =1,264
              iamp1(k,nn)=rec(k)
             end do
           endif
c          write(string,'(''stat='',8i4)')stat
c          call display1(10,40,string,37)
          call status(lrec,stat,msg) 
           ndata=0        !ready for next lrec
           if(msg.eq.0.and.mod(lrec,2).eq.0)return !let some FCA calcs through
                                                    !else this progr stays in rddata until eor
           if(msg.eq.0)goto 10
           msg=2          !commLinkErr or DataOverload(LoggedFromSubStat.)
           return
         endif   
      else    !didn't get any more data on getrec call
           morel=0
           if(ndata.eq.0.and.lrec.eq.npts)goto 200 !end of rec, OK    
           !should be alright 99.99999% of the time...
           if(itimout(iset).ge.0)return !have all avail data so far
           write(string,1011)lrec,ndata
 1011      format(':WrongDatalenOnTimout:lrec,msg=',2i4)
           call logger(string)
           call display1(24,1,string,40)
           msg=1
           return           
      endif
      return
  200 continue  !wrap-up good end of rec.(doesnt get here if abort)
C... turn Tx off
  230 ihdr(25)=isec !keep last secs as diagnotic for PRF fluctu.
      ihdr(24)=stat(1) !keep last a/d bit check status
C...put cheap sig in hdr for use in sndcmd
      do k=1,32
        ii=isig(k)/NANT/NPTS !not div-by-2 so get sig=0-255
        if(ii.gt.255)ii=255  !just in case
        ihdr(32+k)=byte
      end do
      iend=1  !flag end of (good) rec for main prog
      if(IRAW.eq.1)then
         inquire(file='c:\rtwdata\byteamps.dat',exist=ex)
         if(.not. ex)open(16,file='c:\rtwdata\byteamps.dat',
     1   form='unformatted',
     1   recordtype='fixed',access='append',share='denywr',status='new')
         if(ex)open(16,file='c:\rtwdata\byteamps.dat',
     1   form='unformatted',
     1   recordtype='fixed',access='append',share='denywr',status='old')
         nn=npts != index for last matrix
C               Note,in fortran 1st index moves fastest(not like C)
C... ALSO can't write matrix direct(without implied do loops)!! in WATCOM
C.... for large matrices
             if(isel.eq.1)write(16,err=100)ihdr,((iamp2(k,l),k=1,264),
     1           l=1,nn)
             if(isel.eq.2)write(16,err=100)ihdr,((iamp1(k,l),k=1,264),
     1           l=1,nn)
         close(16)
      endif
      return
  100 call logger(' ERROR on write raw data to file')
      call display1(24,1,'Error on write to byteamps.dat',31)
      return
      end
C===========================================================

      subroutine getrec(rec,ndata,more)
C>> gets record (264 bytes) from CPU#1; rtn msg=0 => OK got 264      
C--- don't know if assem. MUST be "in-line"- but lots of troubles
C--- making it work from sep assem prog., so for now, leave it here

C----- int*1 function rdport(int*2 portaddr);
C       returns result of port read
*$pragma aux rdport = "in al,dx" parm (value) [dx] [al]

C----- int*1 function rdmask(int*2 portaddr, int*1 mask)
C       masked read returned (port data AND mask)
*$pragma aux rdmask =  "push bx" "mov bl,al" "in al,dx" "and al,bl" \
* "pop bx" parm (value) [dx] [al]

C---- int*1 function posstrobe(int*2 portaddr,int*1 mask);
C      pos strobe (up-dwn) of mask bits
*$pragma aux posstrobe = "push bx" "mov bl,al" "in al,dx" "or al,bl" \
* "out dx,al" "xor bl,0ffh" "and al,bl" "mov bx,[1234h]" \ !time delay
* "out dx,al" "pop bx" parm (value) [dx] [al]

C DOS32 int*4 function ctick(); rtn clktic( 1800b0h/day ~1500000 ~54ms)     
*$pragma aux ctick = "push es" "mov ax,0040h" "mov es,ax" \
* "mov eax,es:[006ch]" "pop es" \
* parm (value) [eax]

      SAVE
      integer*4 more,ndata,ctick,i4old
      integer*1 rdport,rdmask,posstrobe
      integer*1 rec(264)
c      integer*2 porta,portb,portc,portctl
      integer*2 PortA,PortSTA,PortCTL,PortECR
      integer*1 bit0,bit1,bit2,bit3,bit4,bit5,bit6,bit7
c      common/ports/porta,portb,portc,portctl,bit0,bit1,bit2,
c     1bit3,bit4,bit5,bit6,bit7
      common/ports/portA,portSTA,portCTL,portECR,bit0,bit1,bit2,
     1bit3,bit4,bit5,bit6,bit7
      integer*1 h34,h2b,h29,h0f,h0e,h0d,h07,h00,h09,h0b,h0c,h28 
      data h34,h2b,h29,h0f,h0e,h0d,h07,h00,h09,h0b,h0c,h28/
     1'34'x,'2b'x,'29'x,'0f'x,'0e'x,'0d'x,'07'x,'00'x,
     1'09'x,'0b'x,'0c'x,'28'x/

      more=0   !=1 if more data rcvd before 1ms timout



c      x=posstrobe(porta,bit2) !start 1msec timer            
c      while(rdmask(portc,bit2).ne.0.or.rdmask(portc,bit0).ne.1) do 
c while 1ms timer running or strobe present
c        if(rdmask(portc,bit0).eq.0)then  !data ready for i/p? 
c          ndata=ndata+1
c          more=1     
c          rec(ndata)=rdport(portb) !get data
c          x=posstrobe(porta,bit5) !re-load latch/send strobe
c          x=posstrobe(porta,bit2) !re-trigger 1ms timer
c          if(ndata.eq.264)return     !end of lrec
c        endif     
c      end while
cC... 1 ms dead time,so return(for now)
c      return
c....ECP

c------------------------new-----------------------
c..do same timer trick as in sndcmd since we don't have hardware timer
c      - timeout min=54ms, max=2.5(?)x54ms

c  this loop replaces the 1ms hardware timer; as good ? I don't know yet
c.. port operation same as when clearing printer buffer n sndcmd()
      do k=1,10 !wait max of 0.5s or until 1 Lrec
        i4old=ctick()
        while(i4old.eq.ctick()) do 
c while 1ms timer running or strobe present
          while(rdmask(portsta,bit7).ne.0) do  !data ready for i/p? 
            ndata=ndata+1
            more=1     
c            x=wrport(portECR,h34) !ECP seems to be going off rails in mid rec,sotrythis
c            x=wrport(portCTL,h2b)
            byte=rdport(porta) !get data
            x=wrport(portctL,h28)  !preset latch again (strobe bit 1)
            x=wrport(portctL,h2b)
            rec(ndata)=byte
            if(ndata.eq.264)return     !end of lrec  
          end while     
        end while        
      enddo
C...  dead time,so return(for now)
      return



      end

C==========================================================

      subroutine Status(lrec,stat,msg)
C...check status bytes at end of ea. rec.
      implicit real*8 (a-h,o-z)
      SAVE
      common/rdparm/ICLKIN,IDLY,IGSEP,NPTS,NANT,IRAW,ARRAY(6),
     1NINTEG,TSTEP,RWL,FFLMT,PKLMT,ISITE,MINSIG,MAXSIG,
     1PRF,ITSTRT,maxlag,khdr,itest     
      integer*1 stat(8),byte,khdr(32)
      integer*2 ii
      integer*4 lrec,msg
      character*1 char
      character*80 string
      equivalence (ii,byte)
      data ifirst/0/
      msg=0
C     CHECK STATUS 1) COMM LINK
      if(stat(8).ne.-1.or.stat(7).ne.0)then
        write(string,3111)Lrec,stat
 3111   format('CmmLnkErr:lr#',i3,
     1  ' Stat=',2(4z2,1x))
        call logger(string)
        call display1(24,1,string,49)
        call incscreen(9,38) !count errs on screen
C+++++++>>>>>>>want to have screen count, or put in problems etc !!       
        msg=2 !abort rec
        return
      endif
C     CHECK STATUS: 2) A/D status
      byte=stat(1)
      if(nant.eq.3)ii=mod(ii,64) !drop ant#4 bits
      if(ii.ne.0)then !need to fix screen loc. later screen******
      kk=nant*2
        do k=1,kk
          char='Q'
          if(mod(k,2).eq.1)char='I'
          iatrib=0
          if(mod(ii,2).eq.1)iatrib=1 !inv. flash
          ii=ii/2
          call display2(7,11+k,char,iatrib)
        end do
      else
        
        iflag=0   !a/d status = ok
        call display1a(7,12,'OK      ',8,0)
      endif
C     CHECK STATUS: 3) POWER-UP FLAG      
      if(stat(5) .ne.0)then    !power up
C---have to fix this and use incscreen
        write(string,'('' Rx Interface Power-up/Reset'')')
        call logger(string)
        call incscreen(7,38)
      endif
C     CHECK STATUS: 4) Other error condx in CPU#1
C    bit 0,1,2 => DataOverload(cpu#1TooSlow),commlnkerr,SystemTestBad
C    this message stays on until CPU#1 is RESET,so don't log every one!
      byte=stat(2) 
      if(ifirst.ne.ii)then !log changes
       write(string,'(''ChangeInCpu#1ErrByte,Hex='',z2)')ii
       call logger(string)
       ifirst=ii
      endif   
      if(ii.ne.0)then !aux msg(accum err condx)
c       DisplayBits,LsbAtRight,SoLast3BitsAreAllThatMatter      
        do k=1,8
          char='0'
          if(mod(ii,2).eq.1)char='1'   !NOTE-is this in the "right"order? 
          call display2(14,38-k,char,0)
          ii=ii/2         
        end do      
      else
          call display1a(14,30,'        ',8,0) !clr "err" displ.
          call display1(13,37,'ok',2,0)  
      endif
      return
      end

C============================================================

      subroutine filout
      SAVE
      character*80 string
      character*14 tstamp
      character*1 extdrv
      Integer*1 iblk(864),ihdr(96),byte
      common/outdat/iblk,ihdr  
      character*3 filnam
      common/dattim/iyr,idy,ihr,imin,isec,tstamp,itcorr
      common/zipdrv/extdrv,filnam
      integer*2 ii
      equivalence (ii,byte)
      logical ex
      character*24 fname   !log file taken care of in subr. logger
C...get date from o/p file(don't use "present" date!)
      byte=iblk(1)
      iyr=(ii/16)*10+mod(ii,16)
      byte=iblk(3)
      idy= ii*100+iblk(4)*10+iblk(5)
      iyd=iyr*1000+idy 
C... NOTE- i5.5MeansFillFieldWithLeadingZeros,iyd <>0 !! or get blnks
      do 100 kdrv=1,2
      if(kdrv.eq.2.and.extdrv.eq.' ')goto100 !no extern driv
      if(kdrv.eq.1)       
     1  write(fname,'(''c:\rtwdata\'',a3,i5.5,''.DAT'')')filnam,iyd
      if(kdrv.eq.2)
     1  write(fname,'(a1,'':'',a3,i5.5,''.dat'')')extdrv,filnam,iyd 
     
      inquire(file=fname,exist=ex,IOSTAT=ios)
      if(.not. ex)then
         ii=0
         byte=iblk(22) !site ID => log
         write(string,1122)ii,fname
 1122    format(' SiteID:',i3,' OpenFile=',a24,
     1         ' for 864data o/p')
         call logger(string)    
         open(17,file=fname,form='unformatted',status='new',
     1   access='append',recordtype='fixed',share='denywr',
     1   IOSTAT=ios,err=800)
      else
         open(17,file=fname,form='unformatted',access='append',
     1   recordtype='fixed',status='old',IOSTAT=ios,
     1   share='denywr',err=800)
      endif
      write(17,err=900,IOSTAT=ios)iblk
      close(17,err=950,iostat=ios)
      goto100    
  800 write(string,'(''open:'',a24,'',ERR='',i5)')
     1fname,ios
      call logger(string)
      call display1(24,0,string,39)
      goto 100
  900 write(string,'(''Write:'',a24,'',ERR=''i5)')
     1fname,ios
      call logger(string)
      call display1(24,0,string,40)       
      goto 100
  950 write(string,'(''Close:'',a24,'',ERR='',i5)')
     1fname,ios
      call logger(string)
      call display1(24,0,string,40)
  100 continue
      return  
      end

C================================================

      subroutine clrscrn
*$pragma aux clr = "push ax" "push bx" "push cx" "push dx"\
* "mov ah,06h" "mov al,07h" "mov bh,al" "mov al,0" "mov ch,al" \
* "mov cl,al" "mov al,18h" "mov dh,al" "mov al,4fh" "mov dl,al" \
* "mov al,0h" "int 10h" "pop dx" "pop cx" "pop bx" "pop ax" \
*  parm (value) [al]             
      
      integer*1 clr
      x=clr()
      return
      end
      
C================================================================ 

      subroutine display
c..... backgnd display for lhs of screen
      call clrscrn
      call display1(0,7,'University of Saskatchewan',26)
      call display1(1,5,'Coherent Real Time Wind System',30)
      call display1(0,40,'|---------Wind analysis results--------',39)
      call display1(3,7,'UT=',3)
c     call display1(....  'System status:',14)
      call display1(7,1,'A/D Status:',11)
      call display1(9,0,'   |Worst |',11)
      call display1(10,0,'   |rx-zer|H#  |',16)
      call display1(11,0,'Rx#| I  Q | I/Q|',16)
      call display1(12,0,'---|------|----|',16)
      call display1(7,25,'#Intfce Rst:',12)
      call display1(9,25,'#ComLnkErrs:',12)
      call display1(11,25,'Total#Fail.:',12)
      call display1(13,25,'Cpu#1Status:',12)
c.... More to come ....
      return
      end                 

C==========================================================================
      
      subroutine logger(string)
      SAVE
      character*80 string,strng
      integer*1 istrn(80)
      equivalence (istrn(1),strng)
C!!MUST HAVE d/t defined before here
      character*24 fname
      character*14 tstamp
      character*3 filnam
      character*1 extdrv
      common/zipdrv/extdrv,filnam
      common/dattim/iyr,idy,ihr,imin,isec,tstamp,itcorr
      logical ex
      strng=string
      ilen=80   !look for end of ascii
      do k=1,80
        if(istrn(k).lt.32.or.istrn(k).gt.127)then
        ilen=k-1
        goto10
        endif
      end do  
   10 iyd=iyr*1000+idy
      if(ilen.gt.64)ilen=64 !total length line to logger=80char
C---- Note-I5.5 meansFillInLeadingZeroes;but iyd must <> 0,or get blank! 
      do 100 kdrv=1,2
      if(kdrv.eq.1)
     1  write(fname,'(''c:\rtwdata\'',a3,i5.5,''.log'')' )filnam,iyd
      if(kdrv.eq.2.and.extdrv.eq.' ')goto 100
      if(kdrv.eq.2)
     1  write(fname,'(a1,'':'',a3,i5.5,''.log'')')extdrv,filnam,iyd      
      inquire(file=fname,exist=ex,IOSTAT=ios)
      if(.not. ex)then
        open(22,file=fname,access='append',form='formatted',
     1  status='new',share='denywr',err=800,iostat=ios)
      else
        open(22,file=fname,access='append',form='formatted', 
     1  status='old',share='denywr',err=800,iostat=ios)
      endif      
      write(22,1000,err=900,iostat=ios)tstamp,(istrn(l),l=1,ilen)
 1000 format(1x,a14,':',80a1)
      close(22,err=950,iostat=ios)
      goto 100
c!!!CANT LOG THESE ERRS BECAUSE LOGGER NOT RUNNING      
  800 write(string,'(''ErrorOnOpen:'',a24,'',IOSTAT='',i2)')
     1fname,ios
      call display1(24,1,string,46)
      goto 100
  900 write(string,'(''ErrorOnWriteTo:'',a24,'',IOSTAT='',i2)')
     1fname,ios
      call display1(24,1,string,49)
      goto 100
  950 write(string,'(''ErrorOnClose:'',a24,'',IOSTAT='',i2)')
     1fname,ios
      call display1(24,1,string,48)
  100 continue
      return
      end
      
C=======================================================


      subroutine display1(irow,icol,string,nlen)
C write nlen chars of "string" staring at irow,icol; no cr,lf!

C DOS16 int*1 setcurs(int*1 row,int*1 col); top=row 0, left=col 0
C    (nb BH = "page number" 0-7; 0 works in test .. but?)
*$pragma aux setcurs = "push ax" "push bx" "mov ah,02h" "mov al,0h"\ 
* "mov bh,al" "int 10h" "pop bx" "pop ax" parm (value) [dh] [dl] 

      SAVE
      character*80 string,strng1,fmt
      character*1 strng2(80)
      equivalence (strng1,strng2(1))
      integer*1 lrow,lcol
      lrow=irow
      lcol=icol
      strng1=string
      write(fmt,1011)nlen !assume <80
 1011 format('(',i2,'a1$)')
      call setcurs(lrow,lcol) !top left = 0,0
      print fmt,(strng2(l),l=1,nlen)
      return
      end
C=======================================================================
      subroutine display1a(irow,icol,string,num,iatrib)

C...write string with attrib at row,col; assume screen at b8000h
C...attrib.eq.0 (norm) , .ne. 0 (inv. flash)
C    assumes screen char/attrib starts at b8000h (char=even#s)
C  DOS32 !!  eax= posn*256+(char/attrib code) !!!!
*$pragma aux chrout = "push edi" "mov edx,eax" "shr eax,8h" \
* "add eax,0b8000h" "mov edi,eax" "mov eax,edx" "mov [edi],al"\
* "pop edi" parm (value) [eax] modify [edx]

      SAVE
      character*80 string,strng
      integer*4 irow,icol,iatrib,iaddr,chrout
      integer*2 ii
      integer*1 ichar,istrng(80)
      equivalence (ichar,ii),(strng,istrng(1))
      strng=string
      do k=1,num
        ichar=istrng(k)
        iaddr=2*(irow*80+icol+k-1)*256
        x= chrout(iaddr+ii)
        iaddr=iaddr+256 !addr for attrib (= addr+1 !!)
        if(iatrib.eq.0)x=chrout(iaddr+7) !norm
        if(iatrib.ne.0)x=chrout(iaddr+248) !inv. flash
      end do
      return
      end

C=======================================================================

      subroutine display2(irow,icol,char,iatrib)

C...write *ONE* char with attrib at row,col; assume screen at b8000h
C...attrib.eq.0 (norm) , .ne. 0 (inv. flash)
C    assumes screen char/attrib starts at b8000h (char=even#s)

C  DOS32 !!  eax= posn*256+(char/attrib code) !!!!
*$pragma aux chrout = "push edi" "mov edx,eax" "shr eax,8h" \
* "add eax,0b8000h" "mov edi,eax" "mov eax,edx" "mov [edi],al"\
* "pop edi" parm (value) [eax] modify [edx]

      SAVE   !actually shouldn't need save ... but
      integer*4 irow,icol,iatrib,chrout,iaddr
      character*1 char,char1
      integer*2 ii
      equivalence (ichar,char1),(ii,char1)
      char1=char
      iaddr=2*(irow*80+icol)*256
      call chrout(iaddr+ii)   !character out
      iaddr=iaddr+256   !set address for attrib
      if(iatrib.eq.0)call chrout(iaddr+7) !norm
      if(iatrib.ne.0)call chrout(iaddr+248) !inv. flash
      return
      end

C============================================================

      subroutine display3(string)
C.... display on rhs and scrollup (NB top row has title,not scrolled)

C DOS16 int*1 function scrollup(); scrollup rhs (col 40-79) by 1 row
C bh = attrib of cleared line;ch,cl=(row,col) of upper left cnr
C  dh,dl=(rol,col) of lower rh cnr.

*$pragma aux scrollrhs = "push ax" "push bx" "push cx" "push dx"\
* "mov ah,06h" "mov al,07h" "mov bh,al" "mov al,01h" "mov ch,al" \
* "mov al,28h" "mov cl,al" "mov al,18h" "mov dh,al" "mov al,4fh" \
* "mov dl,al" "mov al,01h" "int 10h" "pop dx" "pop cx" "pop bx" \
*"pop ax" parm (value)             

C DOS16 int*1 setcurs(int*1 row,int*1 col); top=row 0, left=col 0
C    (nb BH = "page number" 0-7; 0 works in test .. but?)
*$pragma aux setcurs = "push ax" "push bx" "mov ah,02h" "mov al,0h"\ 
* "mov bh,al" "int 10h" "pop bx" "pop ax" parm (value) [dh] [dl] 

      SAVE
      character*80 string !only need 40,but 80 is *stndrd* in this prog.
      integer*1 scrollrhs
      call display2(23,40,'|',0) !separator between LHS/RHS
      call display1(23,41,string,38) !write to bottom line     
      x=scrollrhs()
      return
      end
      
C============================================================

      subroutine IncScreen(irow,icol)

C DOS32 ---- get character from screen mem loc (rel to b8000h)
*$pragma aux rdscrn = "mov edx,eax" "shl edx,10h" "shr edx,10h"\ 
* "add edx,0b8000h" "mov al,[edx]" parm (value) [ax] modify [edx]

C.... if screen loc = space, store ascii '1'
C... else increment value

      SAVE
      integer*1 rdscrn,ichar
      integer*2 loc
      character*1 char
      equivalence (char,ichar)
      loc=2*(irow*80+icol) !2bytes per scrn posn,1st=char,2nd=attrib
      ichar=rdscrn(loc)
      if(ichar.eq.32)ichar=48  ! '0'
      if(ichar.eq.127)ichar=-128
      ichar=ichar+1 !so 1st comes out '1'
      call display2(irow,icol,char,0) !norm. attrib
      return
      end

C==============================================================

      subroutine correL(ih)
      implicit real*8 (a-h,o-z)
      SAVE
C...aLL correLs for 1 ht, aLso NF,awid,rhozer,phizer,vz,RL, RA,TA
      dimension cross(65,3),auto6L(32,2),amp(1100,4,2),ratiq(4)
      dimension Tmean(4,2),Tvar(4,2),ISIG(32)
      Integer*1 ibLk(864),KHDR(32),ihdr(96),byte,iamp(8,1100)
      integer*1 iamp1(264,1100),iamp2(264,1100)
      common/indata/iamp1,iamp2,iseL,isig
      common/outdat/iblk,ihdr
      character*80 string
      logical ex
      integer*2 ii,ioff(32,4,2),ksigs(32,4)
      common/rdparm/ICLKIN,IDLY,IGSEP,NPTS,NANT,IRAW,ARRAY(6),
     1NINTEG,TSTEP,RWL,FFLMT,PKLMT,ISITE,MINSIG,MAXSIG,
     1PRF,ITSTRT,maxlag,khdr,itest
      EQUIVALENCE (II,BYTE)
      data pp/1.745329e-2/
      indout=96+(ih-1)*24+1 !INDEX FOR HT RECORD
c      type*,'TEST: now into correls, ht#',ih,' indout=',indout
      NLAGS=MAXLAG/3+1 !# LAGS TO DO IN AUTO
C  POKE HT# 0-31
      IBLK(INDOUT)=ih-1
      IBLK(INDOUT+11)=-1 !POKE NTD
      II=MAXLAG-1
      IBLK(INDOUT+12)=byte !POKE IRL
      iblk(indout+23)=-32  !should = $E0 = ix,ir,is=7,0,0
      mL1=MAXLAG+1
      mL2=2*MAXLAG+1
      ikm=46+ih*3 !nominaL ht
      if(ih.eq.1)midsig=999 !Look for sig nearest to 128
      
C======================unpack data      
C...OK now mess because dos16 data matrix is split into max of 3
C.. (there MAY be a way to declare it "HUGE" during compile, but
C... don't know how now)
C   Reload data for this ht and isel into iamp()
      nbins=(npts-1)/248+1   !how many matrices are the data spread over?
      k1=(ih-1)*8+1
      k2=k1+7 !i1,q1,i2,q2,i3,q3,i4,q4 (if 3-ant,then 4 = dummybytes)
      do k=k1,k2
        k3=k-k1+1
        if(isel.eq.1)then
          do i=1,npts
            iamp(k3,i)=iamp1(k,i)
          end do
        else
          do i=1,npts
            iamp(k3,i)=iamp2(k,i)
          end do
        endif       
      end do            
C=============ok loaded   (I hope!)
C....zero Lag means and s.d.s for each ant
      sumsig=0.
      do 40 irx=1,NANT
      sx=0.
      sy=0.
      sx2=0.
      sy2=0.
      INX=(IRX-1)*2+1
        do 30 it=1,NPTS
        byte=iamp(INX,it)
c        type*,'test raw:',ISEL,ih,inx,it,iamp1(inx,it),iamp2(inx,it)
        sig=fLoat(ii-128)
        amp(it,irx,1)=sig
        sx=sx+sig
        sx2=sx2+sig*sig
        byte=iamp(INX+1,it)
        sig=fLoat(ii-128)
        amp(it,irx,2)=sig
        sy=sy+sig
   30   sy2=sy2+sig*sig

      ioff(ih,irx,1)=sx/NPTS !signed aLready = diff from 5V
      ioff(ih,irx,2)=sy/NPTS !   "              "
      tmean(irx,1)=sx !sum, not avg!
      tmean(irx,2)=sy
      tvar(irx,1)=sx2
      tvar(irx,2)=sy2
      sig2=(sx2+sy2)/NPTS-(sx/NPTS)**2-(sy/NPTS)**2
      sumsig=sumsig+sig2
      ksigs(ih,irx)=sqrt(2.*sig2) !to check sig vs. ant
C      type3311,IRX,IOFF(IH,IRX,1),IOFF(IH,IRX,2),SQRT(SIG2)
c 3311 FORMAT(1X,'Test: sigs rx#',I2,' IOFF=',2I4,' sig=',F6.1)
   40 continue
      ii=int( sqrt(2.*sumsig/fLoat(NANT)+0.001)) !0.001 to avoid 0
      if(ii.gt.255)then
         call logger('test: sig>255 in correl(), fixed')
         ii=255
      endif
      write(string,1221)ikm,iblk(64+ih),(ksigs(ih,l),l=1,nant)
 1221 format(i3,'nKm;gain:',i1,' sigs:',4i4)
      call display3(string)
C...get ht of sig in mid range
      if(iabs(ii-128).Lt.midsig)then
        ihtsel=ih-1
        midsig=iabs(ii-128)
C        save i/q
        do irx=1,nant
          ratiq(irx)=0.
          if(tvar(irx,2).gt.0.001)ratiq(irx)=sqrt(tvar(irx,1)/
     1    tvar(irx,2))
        end do  
      endif
      iblk(32+ih)=byte  !="real signal"
C    (a "cheaper" sig - i.e.mean(abs(i) & abs(q) is used  to *set* gains)
c........................................................
      if(ih.eq.32)then ! get worst offsets and print to screen
        k=1       !!**** what is this for ??
        write(string,'(i2)')ihtsel
        call display1(10,13,string,2) !=ht# for i/q vals
        do IRX=1,NANT
          irow=irx+12
          write(string,'(1x,i1,'' |'')')irx
          call display1(irow,0,string,4)
          write(string,'(''|'',f4.2)')ratiq(irx)
          call display1(irow,10,string,5)
          do IQ=1,2
            icol=iq*3+1
            JJ=0
            do  KH=16,24
              int4=ioff(ih,irx,iq)
              if(iabs(int4).GT.IABS(JJ))JJ=int4
            end do          
            write(string,'(i3)')int4  !this is already -128
            call display1(irow,icol,string,3)
          end do
        end do
C----------Look at ihtsel (nearest to "midsignal") and extract NANT
C-------- sigs to store in o/p store
C....   poke sep. rx sigs
c        type*,'test best ht=',ihtsel,NANT,(ksigs(ihtsel+1,l),l=1,4)
        iblk(30)=ihtsel
        do irx=1,NANT
          inx=30-1-NANT+irx
          ii=ksigs(ihtsel+1,irx)
          ibLk(inx)=byte
        end do
C      DISPLAY separate Rx sigs for selected ht so rx/ant gains can
C             be balanced with attenuators        
          if(nant.eq.3)then
            write(string,1234)
     1      (irx,ksigs(ihtsel+1,irx),irx=1,nant)
 1234       format('sigs:',2('rx#',i1,'=',i3,','),
     1                  'rx#',i1,'=',i3)
             k=31
          elseif(nant.eq.4)then
            write(string,1235)
     1      (irx,ksigs(ihtsel+1,irx),irx=1,nant)
 1235       format('sigs:',3('rx#',i1,'=',i3,','),
     1                  'rx#',i1,'=',i3)
            k=40          
        endif
        call display1(22,0,string,k)
        write(string,'(''Test: SepRxSigsOutTo FOR025'')')
        call display3(string)
c..prev(data Nov4-12) did write(25, )( ( ,i=1,10),j,( ,i=1,32),j=1,4) BUT
c.. the last part of the format 8(1x,4z2) kept repeating!!!??? anyway
c.. maybe can use to to read       
c          write(25,9922)((iblk(i),i=1,10),j,(Ksigs(i,j),i=1,32),j=1,4)'
c... Jan27'05:fix below so we don't lose for025 with every re-boot
        inquire(file='for025',exist=ex)
        if(ex)then
          open(25,file='for025',form='formatted',access='append',
     1    status='unknown',err=41,iostat=ios)
          do j=1,4
            write(25,9922)(iblk(i),i=1,10),j,(Ksigs(i,j),i=1,32)
 9922       format(1x,10z2,' #',i1,1x,8(1x,4z2))
          enddo
        else
          open(25,file='for025',form='formatted',access='append',
     1    status='unknown',err=41,iostat=ios)      
   42     do j=1,4
            write(25,9922)(iblk(i),i=1,10),j,(Ksigs(i,j),i=1,32)
          enddo
        endif
        goto 43
   41   write(string,'(''For025 Open Error Iostat='',i3)')ios
        call display3(string)
        call logger(string)         
   43   continue        
      ENDIF   !end of ih=32 processing
      byte=iblk(32+ih)
      if(ii.Lt.5)then
        write(string,'(''Reject:SigTooLow='',i2)')ii
        call display3(string)
        byte=ibLk(64+ih)
        ii=ii+16              !check meaning - Low sig
        ibLk(64+ih)=byte
        return
      endif
C........................................................

C...do auto to ~6 Lags (untiL avg rho < FFLMT)
C    check for 1st Lag FF kickout,aLso auto wid,NF,Vz,RA,TA
C                    IRL.
c... clear for mean auto
      do ilag=1,nlags
        auto6L(ilag,1)=0.
        auto6L(ilag,2)=0.
      end do
      do 48 irx=1,NANT
      wt=1.
      if(irx.eq.4)wt=3. !get wtd avg auto because ant#4 diff S/N
      sxa=tmean(irx,1)  !"a" = 1st part of seq
      sxb=sxa
      sya=tmean(irx,2)
      syb=sya
      sx2a=tvar(irx,1)
      sx2b=sx2a
      sy2a=tvar(irx,2)
      sy2b=sy2a
      do 48 iLag=1,NLAGS !max of 6 non-zero Lags
      sxa=sxa-amp(NPTS-ilag+1,irx,1)
      sxb=sxb-amp(iLag,irx,1)
      sya=sya-amp(NPTS-ilag+1,irx,2)
      syb=syb-amp(iLag,irx,2)
      sx2a=sx2a-amp(NPTS-ilag+1,irx,1)**2
      sx2b=sx2b-amp(iLag,irx,1)**2
      sy2a=sy2a-amp(NPTS-ilag+1,irx,2)**2
      sy2b=sy2b-amp(iLag,irx,2)**2
      siiqq=0.
      siqqi=0.
      np=NPTS-iLag
      do 45 it=1,np
      xa=amp(it,irx,1)
      ya=amp(it,irx,2)
      xb=amp(it+iLag,irx,1)
      yb=amp(it+iLag,irx,2)
      siiqq=siiqq+xa*xb+ya*yb
   45 siqqi=siqqi-xa*yb+ya*xb
      va=(sx2a+sy2a)/fLoat(np)-(sxa**2+sya**2)/fLoat(np**2)
      vb=(sx2b+sy2b)/fLoat(np)-(sxb**2+syb**2)/fLoat(np**2)
      rhor=siiqq/np-sxa*sxb/fLoat(np**2)-sya*syb/fLoat(np**2)
      rhoi=siqqi/np+sxa*syb/fLoat(np**2)-sya*sxb/fLoat(np**2)
      if(va.lt.0.001.or.vb.le.0.001)then
        write(string,'(''-ve var.!! Rx#'',i1,'':'',2f9.1)')irx,va,vb
        !should set a flag in the o/p store??
        byte=iblk(64+ih)
        ii=ii+48
        iblk(64+ih)=byte
        call logger(string)
        call display3(string)
        iblk(indout)=-2  !254 in place of ht #
        return
      endif
      va=sqrt(abs(va*vb))
      auto6L(iLag,1)=auto6L(iLag,1)+wt*rhor/va
      auto6l(ilag,2)=auto6L(ilag,2)+wt*rhoi/va
c     if(ih.eq.22)type*,'test:ant#,lag#,rho=',irx,ilag,
c    1sqrt((rhor/va)**2+(rhoi/vb)**2)
      xa=sqrt(rhor**2+rhoi**2)/va
      if(xa.gt.1.01)then
         write(string,'('' a a-rho>1.01 !!='',f6.3)')xa
         call display3(string)
      endif   
   48 continue !next lag&ant
C  wt=1 here if 3ants, = 3 if 4ants
      do 50 ilag=1,nlags
      rhor=auto6L(ilag,1)/(wt-1.+NANT)
      rhoi=auto6L(ilag,2)/(wt-1.+NANT)
      auto6L(ilag,1)=sqrt(rhor**2+rhoi**2)
      auto6L(ilag,2)=999
      if(rhor.ne.0..or.rhoi.ne.0.)auto6l(ilag,2)=datan2(rhoi,rhor)/pp
c      if(ih.eq.22)
c     1type*,'Test:auto Lag#',iLag,' mean-aut=',auto6L(iLag,1)
      it=iLag !re-use
      if(auto6L(iLag,1).ge.FFLMT)goto49
          if(iLag.eq.1)then  !fast fade
            write(string,'(''FastFade:auto(1)='',f5.2)')auto6L(1,1)
            call display3(string)
            byte=ibLk(64+ih)
            ii=ii+32   !MSG ON TOP OF GAINS
            ibLk(64+ih)=byte
c            type*,'test: fast fade; ht#',ih
            return
          eLse
            x1=auto6L(iLag-1,1)-auto6L(iLag,1) !chk for zer
            if(x1.eq.0.)then !q&d fix
               ra=auto6L(iLag-1,1)
               ta=TSTEP*iLag
               goto50
            endif
            ra=FFLMT
            TA=TSTEP*( (auto6L(iLag-1,1)-FFLMT)/x1+iLag-1)
            goto53
          endif
   49 if(iLag.eq.nLags)then      
        RA=auto6L(iLag,1)
        TA=nLags*TSTEP
      endif
   50 continue


C...NOTE TA,RA come from *Linear interp* of auto 


C-----get mean auto fit parms + vz and store---------

  53  r1=auto6L(1,1)
      r2=auto6L(2,1)
c      TYPE*,'TEST:FFLMT,R1,R2=',FFLMT,R1,R2
      P1=auto6L(1,2)  ! +-180deg
      P2=auto6L(2,2)
      vz=(p1/TSTEP)*0.5*RWL/360.  !1 pt vz just in case no bettr
      iwid=0
      i1pt=1
      icrvd=0
      if(r1.Lt.FFLMT.or.r2.Lt.FFLMT)goto86
c.... 2pt fit
       rL1=dlog(r1)
       rL2=dlog(r2)
       i1pt=0
       if(p1.eq.0.)p1=1.e-10
       if(abs(p2/p1-2.).gt.0.6)icrvd=1
       VZ=(4.*P1-P2)/TSTEP*0.5*RWL/360.
         if(r1.gt.r2)then
          nf=int(100.*exp(rL1+(rL1-rL2)/3.)+0.5)
          if(nf.gt.127)nf=127
          ii=nf
          ibLk(indout+10)=byte !noise factor 0-127
          iwid=4.*sqrt(0.66/(rL1-rL2)) !auto-wid fn
          if(iwid.gt.31)iwid=31
        endif
   86 ii=iwid+i1pt*128+icrvd*64 
      write(string,'(''vz='',f6.2,'' 1pt,crvd='',2i2)')vz,i1pt,icrvd
      call display3(string)
      ibLk(indout+9)=byte
      ivz=vz*100.+32768.
      if(ivz.gt.65535)ivz=65535
      if(ivz.Lt.0.)ivz=0
      ii=mod(ivz,256)
      ibLk(indout+8)=byte
      ii=ivz/256
      ibLk(indout+7)=byte
C-------------end of Auto fits---------

C----now zeroLag cross, so can caLc reduced Lag---
      rhomin=999.
      DO 60 IXCOR=1,3
      IF(NANT.EQ.4)THEN
         ixa=4
         ixb=4-ixcor
      eLse
         ixa=ixcor+1
         if(ixa.gt.3)ixa=1
         ixb=ixcor
      endif
      siiqq=0.
      siqqi=0.
      do 55 it=1,NPTS
      x1=amp(it,ixa,1)
      y1=amp(it,ixa,2)
      x2=amp(it,ixb,1)
      y2=amp(it,ixb,2)
      siiqq=siiqq+x1*x2+y1*y2
  55  siqqi=siqqi-x1*y2+y1*x2
      x1=tmean(ixa,1)/fLoat(NPTS)
      y1=tmean(ixa,2)/fLoat(NPTS)
      x2=tmean(ixb,1)/fLoat(NPTS)
      y2=tmean(ixb,2)/fLoat(NPTS)
      v1=(tvar(ixa,1)+tvar(ixa,2))/NPTS-x1*x1-y1*y1
      v2=(tvar(ixb,1)+tvar(ixb,2))/NPTS-x2*x2-y2*y2
      if(v1*v2.LT.0.001)then
         write(string,
     1  '('' -ve or 0 variance,ht#'',i2,'' xcor#'',i2)')ih,ixcor
         iblk(indout)=-3 ! 253 as ht number
         call display3(string)
         call logger(string)
         return
      endif   
      rhor=siiqq/fLoat(NPTS)-x1*x2-y1*y2
      rhoi=siqqi/fLoat(NPTS)+x1*y2-y1*x2
      rho=sqrt((rhor**2+rhoi**2)/(v1*v2))
      cross(mL1,ixcor)=rho
      if(rho.Lt.rhomin)rhomin=rho
      jj=int(100.*rho)*512
      x1=0
      if(rhor.ne.0..or.rhoi.ne.0.)x1=datan2(rhoi,rhor)/pp
      if(x1.Lt.0.)x1=x1+360
      jj=jj+int(x1)
      ii=mod(jj,256)
      ibLk(indout+2*ixcor-1)=byte
      ii=jj/256
      ibLk(indout+2*ixcor)=byte
   60 continue

C--now reduced Lag if poss---------------
      if(rhomin.gt.0)
     1IRL=TA*((dlog(rhomin)-2.)/dlog(RA))/TSTEP+3.5 
      if(irL.Lt.MAXLAG-1)then !reduction possib
        ii=irL
        iblk(indout+12)=byte !poke into o/p
      else  !bigger than calc. lag,so set max. possibl
        irl=MAXLAG-1
      endif  

      IRL1=IRL+1 !have to caLc xcor out to irL+1 (use 3pt pkfit)

C-----------cross to +- (irL+1) Lags--------------------
C>antenna pairs in 4-ant array d43,d42,d41,p43,p42,p41
C>    "     "      3- "    "   d21,d32,d13,p21,p32,p13
C... Pxy= geograph azim for direction: ant-x to ant-y, in deg EofN

C>>>>>>>>>>>>>> Lag = +ve <<<<<<<<<<<<<<<<<
C           xxxxxxxxx:4-ixa-a:xxxxxxxxx <
C       xxxxxxxxx:i-ixb-b:xxxxxxxxx     <
C   pattern going ixa=> ixb for +ve tmax  <
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>

C>>>>>>>>>>>>>> Lag = -ve <<<<<<<<<<<<<<<<<
C       xxxxxxxxx:4-ixa-a:xxxxxxxxx       <
C           xxxxxxxxx:i-ixb-b:xxxxxxxxx   <
C  pattern going irx=>jrx for -ve tmax    <
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>


      do 150 ixcor=1,3
      IF(NANT.EQ.4)THEN
         ixa=4
         ixb=4-ixcor
      eLse
         ixa=ixcor+1
         if(ixa.gt.3)ixa=1
         ixb=ixcor
      endif
      do 140 negpos=1,3,2 ! -ve and +ve Lags
C...init zer-Lag totsum, totvar so can modif for partiaL seqs
      sxa=tmean(ixa,1)
      sxb=tmean(ixb,1)
      sya=tmean(ixa,2)
      syb=tmean(ixb,2)
      sx2a=tvar(ixa,1)
      sx2b=tvar(ixb,1)
      sy2a=tvar(ixa,2)
      sy2b=tvar(ixb,2)
C...zero Lag was aLready done
      do 140 iLag=1,irL1
      if(negpos.eq.1)then  !-ve Lags
        L1=NPTS-ilag+1
        L2=iLag
      eLse
        L1=iLag
        L2=NPTS-ilag+1
      endif
      np=NPTS-iLag

C...modify tsum sqard-amp and  sum-amp to get partiaLs
      sxa=sxa-amp(L2,ixa,1) !=last part for -ve Lags
      sxb=sxb-amp(L1,ixb,1)
      sya=sya-amp(L2,ixa,2)
      syb=syb-amp(L1,ixb,2)
      sx2a=sx2a-amp(L2,ixa,1)**2
      sx2b=sx2b-amp(L1,ixb,1)**2
      sy2a=sy2a-amp(L2,ixa,2)**2
      sy2b=sy2b-amp(L1,ixb,2)**2

      siiqq=0.
      siqqi=0.
      np=NPTS-iLag
      if(negpos.eq.1)then !-ve Lags
        i1=iLag
        i2=0
      eLse
        i1=0
        i2=iLag
      endif
      do 130 it=1,np
      xa=amp(it+i1,ixa,1)
      ya=amp(it+i1,ixa,2)
      xb=amp(it+i2,ixb,1)
      yb=amp(it+i2,ixb,2)
      siiqq=siiqq+xa*xb+ya*yb
  130 siqqi=siqqi-xa*yb+ya*xb
      va=(sx2a+sy2a)/fLoat(np)-(sxa**2+sya**2)/fLoat(np**2)
      vb=(sx2b+sy2b)/fLoat(np)-(sxb**2+syb**2)/fLoat(np**2)
      rhor=siiqq/np-sxa*sxb/fLoat(np**2)-sya*syb/fLoat(np**2)
      rhoi=siqqi/np+sxa*syb/fLoat(np**2)-sya*sxb/fLoat(np**2)
      xa=sqrt((rhor**2+rhoi**2)/(va*vb))  !recycle xa
      if(xa.gt.1.01)then
        write(string,'(''a x-rho>1.01!!='',f6.3)')xa
        call display3(string)
      endif  
      cross(mL1+(negpos-2)*iLag,ixcor)=xa
  140 continue !next Lag
  150 continue !next cross

C... IRL CLIPPED TO +-15 BEFORE THIS, corLs avaiL to +-(irL+1)
      M1=ML1-IRL
      M2=ML1+IRL
      CALL WEED(indout,cross,m1,m2,ta,ra) !any o/p comes from weed
      return
      END

C==========================================================

      SUBROUTINE WEED(indout,cross,M1,m2,ta,ra)
      implicit real*8 (a-h,o-z)
      SAVE
      character*80 string
      dimension MM(3),MX(3,2),T(3,2),R(3,2),cross(65,3)
      common/rdparm/ICLKIN,IDLY,IGSEP,NPTS,NANT,IRAW,ARRAY(6),
     1NINTEG,TSTEP,RWL,FFLMT,PKLMT,ISITE,MINSIG,MAXSIG,
     1PRF,ITSTRT,maxlag,khdr,itest
      Integer*1 iblk(864),ihdr(96),KHDR(32),byte
      common/outdat/iblk,ihdr
      integer*2 ii
      equivalence (ii,byte)
      mL1=MAXLAG+1
      ix=0 !not fast fading if got here
      ir=0
      is=0
      DO 30 I=1,3 !xcor#
      M=0
      DO 20 J=M1,M2 !lag#, mL1=0-lag
      S=CROSS(J,I)
      IF(S.LT.PKLMT)GOTO20
      IF(S.LE.CROSS(J-1,I))GOTO20
      IF(S.LT.CROSS(J+1,I))GOTO20
      M=M+1
      IF(M.EQ.1)GOTO15
      IF(S.LE.R(I,1))GOTO14
      MX(I,2)=MX(I,1)
      R(I,2)=R(I,1)
      MX(I,1)=J
      R(I,1)=S
      GOTO20
   14 IF(S.LE.R(I,2))GOTO20
      MX(I,2)=J
      R(I,2)=S
      GOTO20
   15 MX(I,1)=J
      R(I,1)=S
   20 CONTINUE !next lag
      MM(I)=M
      IF(M.GE.1)GOTO30
C...no peak .gt. PKLMT
      write(string,'('' NoSignif.PksIn #'',i1)')i
      call display3(string)
      IX=1
      IR=4
      goto850
   30 CONTINUE  !next x-cor
c      type*,'TEST#:',mx,r
C.....FIND EXACT PEAKS BY PARABOLA FIT
      DO 50 i=1,3
      IF(MM(i).GT.2)MM(i)=2
      m=MM(i)
c...make sure that sencondary pk signif wrt 1st
      DO 40 J=1,m
      MXX=MX(i,J)
      Y1=CROSS(MXX-1,i)
      Y2=R(i,J)
      Y3=CROSS(MXX+1,i)
   35 A5=(Y1+Y3)/2-Y2
      B5=(Y3-Y1)/2
      X=-B5/A5/2
      S=A5*(X**2)+B5*X+Y2
   38 T(i,J)=(X+MXX-ML1)*TSTEP
   40 R(i,J)=S
      IF(MM(i).LT.2)GOTO50
      if(r(i,1).gt.1.8*r(i,2))mm(i)=mm(i)-1
   50 CONTINUE
      write(string,'(''pks:'',3f5.2,1x,3i3,1x,'':'',3i1)')
     1(t(l,1),l=1,3),(int(100.*r(l,1)),l=1,3),(mm(l),l=1,3)
      call display3(string)
      IS=MM(1)+MM(2)+MM(3)-3
      SELECT CASE (IS+1)
      CASE(1)
        S1=0
        S2=0
        DO K=1,3
          S1=S1+T(K,1)
          S2=S2+ABS(T(K,1))
        end do
        if(s2.le.1.e-10)s2=1.e-10
        antd=s1/s2
        IF(ABS(antd).LT.0.3)GOTO120
        IR=4
        IX=3
        GOTO120
      CASE (2)
        DO K=1,3
          IF(MM(K).EQ.2)K1=K
        End do
        IR=K1
        K2=3-K1/3
        K3=2-K1/2
        S1=T(K2,1)+T(K3,1)
        S2=ABS(T(K2,1))+ABS(T(K3,1))
        antd=(S1+T(K1,1))/(S2+ABS(T(K1,1)))
        DO K=1,2
          S=T(K1,K)
          IF(ABS(S1+S)/(S2+ABS(S)).LT.0.2)GOTO95
        end do
        IR=4
        IX=4
        GOTO120
   95   T(K1,1)=T(K1,K)
        R(K1,1)=R(K1,K)
        GOTO120
      CASE (3:4)
        antd=(T(1,1)+T(2,1)+T(3,1))/
     1   (ABS(T(1,1))+ABS(T(2,1))+ABS(T(3,1)))
        IF(abs(antd).LE.0.1)then
          ir=5
          goto120
        else
          IR=4
          GO TO 850
        endif
      END SELECT
  120 T1=T(1,1)
      T2=T(2,1)
      T3=T(3,1)
      R1=R(1,1)
      R2=R(2,1)
      R3=R(3,1)
c      type*,'end of weed:',t1,t2,t3,r1,r2,r3
  850 ii=2*(int(abs(100.*antd)))
c...save sign as Lsb 
      if(antd.Lt.0.)ii=ii+1
C... NB below if ix=1 then not 3 pks, so no ntd, so left =$ff
      if(ix.ne.1)ibLk(indout+11)=byte !ntd*200 + sign bit
      ii=ix*32+ir*4+is      !leave ix=7 for now, wiLL be added to in FCA
      ibLk(indout+23)=byte
C STORE NEW PARAMS, 
      IF(ir.ne.4)CALL PMFCA(indout,ta,ra,t1,t2,t3,r1,r2,r3)
      if(ir.eq.4)then
        write(string,'('' Reject:NTD='',f5.2)')antd
        call display3(string)
      endif
      return
      END

C=================================================================

      SUBROUTINE PMFCA(indout,TA,RA,T1,T2,T3,R1,R2,R3)
      implicit real*8 (a-h,o-z)
      SAVE
C...indout points to 1st of 24byte o/p rec
      dimension ihms(3,6) !9kmLayers for print or fiLe
      character*14 TSTAMP
      common/dattim/iyr,idy,ihr,imin,isec,tstamp,itcorr
      common/rdparm/ICLKIN,IDLY,IGSEP,NPTS,NANT,IRAW,ARRAY(6),
     1NINTEG,TSTEP,RWL,FFLMT,PKLMT,ISITE,MINSIG,MAXSIG,
     1PRF,ITSTRT,maxlag,khdr,itest
      Integer*1 ibLk(864),KHDR(32),ihdr(96),byte
      integer*2 ii
      character*80 string
      equivaLence (byte,ii)
      common/outdat/iblk,ihdr
      DATA pp/1.745329E-2/,ISKIP/1/,ihms/18*0/
c      type*,'test into pmfca:',indout,ta,ra,t1,t2,t3,r1,r2,r3
      ix=0      
      nkm=49+3*(indout-96)/24
C...date/time for *STORED* data to use for hms
      byte=ibLk(1)
      iyrx=mod(ii,16)+(ii/16)*10
      idyx=ibLk(3)
      idyx=100*idyx+10*ibLk(4)+ibLk(5)
      ihrx=ibLk(7)*10+ibLk(8)
      idh=idyx*24+ihrx
      ix=0
      IF(ISKIP.eq.1)then
        idhL=idh
        iskip=0
        P1=ARRAY(4)*PP
        P2=ARRAY(5)*PP
        P3=ARRAY(6)*PP
        D=ARRAY(1) !ASSUME EQUILATERAL FOR NOW
        D2=D*D
        X1=D*dcos(p1)
        X2=D*dsin(p1)
        X3=D*dcos(p2)
        X4=D*dsin(p2)
        X5=D*dcos(p3)
        X6=D*dsin(p3)
        U1=dcos(2*P1)
        U2=dcos(2*P2)
        U3=dcos(2*P3)
        V1=dsin(2*P1)
        V2=dsin(2*P2)
        V3=dsin(2*P3)
      endif
      if(idh.ne.idhL)then
        caLL hmout(iyrx,idyx,ihrx,ihms) !aLso cLears
        idhL=idh
      endif
C.....WEIGHTED LSFIT
      S1=R1*R1
      S2=R2*R2
      S3=R3*R3
      Q1=X1*X1*S1+X3*X3*S2+X5*X5*S3
      Q=X2*X1*S1+X3*X4*S2+X5*X6*S3
      Q2=X2*X2*S1+X4*X4*S2+X6*X6*S3
      D1=Q1*Q2-Q*Q
      IF(D1.NE.0.)THEN
        A1=Q2/D1
        A=-Q/D1
        A2=Q1/D1
      ELSE
        MSG=1
        RETURN
      ENDIF
      X=T1*(X1*A1+A*X2)*S1+T2*(X3*A1+X4*A)*S2+T3*(X5*A1+X6*A)*S3
      Y=T1*(X1*A+X2*A2)*S1+T2*(X3*A+X4*A2)*S2+T3*(X5*A+X6*A2)*S3
      Q=X*X+Y*Y
      
      if((x.ne.0..or.y.ne.0.).and.Q.gt.1.e-10)THEN
         PA=datan2(Y,X)
         VA=1/SQRT(Q)
      ELSE
         iblk(indout)=-1 !255: sum tmax=0 (I assume),so set ht#=255
         MSG=2
         return
      endif
C.....END OF WLSFIT, RECONST TIMES
      T1=D*dcos(P1-PA)/VA
      T2=D*dcos(P2-PA)/VA
      T3=D*dcos(P3-PA)/VA
      VA=VA/2
      PA=PA/pp
      IF(PA.LT.0.)PA=PA+360
C.....VA,PA=APPARENT VELOCITY
C.....POOR MAN'S FCA
  111 Q=-2*dlog(RA)/TA/TA
      AMA=(-2.*dlog(R1)+Q*T1*T1)/D2
      AMB=(-2.*dlog(R2)+Q*T2*T2)/D2
      AMC=(-2.*dlog(R3)+Q*T3*T3)/D2
      AN2=AMC-AMB
      AN3=AMA-AMC
      AN1=AMB-AMA
      Y=AN2*U1+AN3*U2+AN1*U3
      X=-AN2*V1-AN3*V2-AN1*V3
      T0=datan2(Y,X)/2.
      TILT=T0/pp
      C1=dcos(P1-T0)
      C2=dcos(P2-T0)
      S1=dsin(P1-T0)
      S2=dsin(P2-T0)
      AR2=(AMA*C2*C2-AMB*C1*C1)/AN1
      AR2=AR2/(1+AR2)
      B2=(C1*C1/AR2+S1*S1)/AMA
      A2=AR2*B2
      IF(A2.GT.0..AND.B2.GT.0.)GOTO40
      IX=5
      write(string,'('' Fail: Imag. Axis'')')
      call display3(string)
      goto200
   40 iAX=SQRT(A2)
      iBX=SQRT(B2)
      X=A2*(T2*S1-T1*S2)
      Y=B2*(T1*C2-T2*C1)
      PHIPR=datan2(Y,X)
      PTR=PHIPR/pp+TILT+0.5
      IF(PTR.LT.0.)PTR=PTR+360.
      Q1=dcos(PHIPR)
      Q2=dsin(PHIPR)
      VT=Q*T1/D/(Q1*C1/A2+Q2*S1/B2)/2.
      IF(VT.GT.0.)GOTO50
      VT=-VT
      PTR=PTR-180
      IF(PTR.LT.0.)PTR=PTR+360.
   50 C2=1./(Q-4*VT*VT*(Q1*Q1/A2+Q2*Q2/B2))
      IF(C2.GT.0)GOTO60
      IX=6
      write(string,'('' Fail: Imag. Tc'')')
      call display3(string)
      goto200
   60 iTC=10.*SQRT(C2)+0.5
      IF(TILT.LT.0.)TILT=TILT+180.
      IF(iAX.GT.iBX)GOTO70
      iA1=iAX
      iAX=iBX
      iBX=iA1
      TILT=TILT-90.
      IF(TILT.LT.0.)TILT=TILT+180.
   70 ivt=10.*vt+0.5
      if(ivt.gt.65535)ivt=65535
      ii=ivt/256
      ibLk(indout+13)=byte
      ii=mod(ivt,256)
      ibLk(indout+14)=byte
      iptr=ptr+0.5
      ii=iptr/256
      ibLk(indout+15)=byte
      ii=mod(iptr,256)
      ibLk(indout+16)=byte
      ii=iax/256
      if(ii.gt.255)ii=255
      ibLk(indout+17)=byte
      ii=mod(iax,256)
      ibLk(indout+18)=byte
      ii=ibx/256
      if(ii.gt.255)ii=255
      ibLk(indout+19)=byte
      ii=mod(ibx,256)
      ibLk(indout+20)=byte
      ii=tiLt+0.5
      ibLk(indout+21)=byte
      ii=itc
      if(itc.gt.255)itc=255
      ibLk(indout+22)=byte
      write(string,'('' FCA:'',f5.1,5i4)')float(ivt)/10.,iptr,
     1iax,ibx,int(tilt),itc
      call display3(string)
C....accum hms
      i=(nkm-64)/9+1
      if(i.ge.1.and.i.Le.6)then
        ihms(2,i)=ihms(2,i)+10.*vt*dcos(ptr*pp) !VN
        ihms(3,i)=ihms(3,i)+10.*vt*dsin(ptr*pp)
        ihms(1,i)=ihms(1,i)+1
      endif
  200 byte=ibLk(indout+23) !put in new err mess
      ii=mod(ii,32)+ix*32
      ibLk(indout+23)=byte
      RETURN
      END

C============================================================

      subroutine hmout(iyrx,idyx,ihrx,ihms)
      implicit real*8 (a-h,o-z)
      SAVE
      common/rdparm/ICLKIN,IDLY,IGSEP,NPTS,NANT,IRAW,ARRAY(6),
     1NINTEG,TSTEP,RWL,FFLMT,PKLMT,ISITE,MINSIG,MAXSIG,
     1PRF,ITSTRT,maxlag,khdr,itest
      integer*1 khdr(32)
      dimension ihms(3,6)
      character*24 fname
      character*80 string
      integer ios
      logical ex
      data fname/'c:\rtwdata\hrlymean.dat'/
      inquire (file=fname,exist=ex)
      if(.not. ex)then
          !I ASSUME this type of open appends! - if I specify append
          ! everything ends up on one line!
        open(21,file=fname,status='new',share='denywr',
     1  form='formatted',access='append',err=800,iostat=ios)
        write(string,'(''Open file='',a24,'' for hrlymean o/p'')')
     1     fname
        call logger(string)
      else
        open(21,file=fname,status='old',share='denywr',
     1  form='formatted',access='append',err=800,iostat=ios)
      endif
      
      if(ihrx.eq.0)then
        write(21,
     1     '(1x,i3,'':'',i2,6(''!'',i3,''-'',i3,''nKm''))',
     1     err=900,iostat=ios)isite,iyrx,(k,k+6,k=64,112,9)
        write(21,'(1x,''dayhr '',6(''! #  VN  VE''))',
     1       err=900,iostat=ios)
      endif
      do k=1,6
        if(ihms(1,k).gt.0)then
          do ine=2,3           ! DEC12'97 MOD/fixd jun23'98
            ihms(ine,k)=(ihms(ine,k)/ihms(1,k))/10
            if(ihms(ine,k).gt.999)ihms(ine,k)=999
            if(ihms(ine,k).lt.-999)ihms(ine,k)=-999
          enddo
        endif
      end do
      idh=idyx*100+ihrx
      write(21,1211,err=900,iostat=ios)idh,ihms
 1211 format(1x,i5,1x,6('!',i2,i4,i4))      
      close(21)
      do k=1,6
        ihms(1,k)=0
        ihms(2,k)=0
        ihms(3,k)=0
      end do  
      return
  800 write(string,
     1'(''ErrorOpeningC:\rtwdata\hrlymean.dat,Iostat='',i3)')
     1 ios
      call logger(string)
      call display1(24,1,string,37)
      return
  900 write(string,
     1'(''ErrorWritingToC:\rtwdata\hrlymean.dat,Iostat='',i3)')
     1ios
      call logger(string)
      call display1(24,1,string,40)
      return     
      end

C==========================================================

      subroutine dmphms
      save
C.... dump hrlymeans file to A:hmlist.dat; replaces present
C                 hmlist.dat(if any)
      logical ex
      integer ios
      character*80 a
      nlines=0
      inquire(file='c:\rtwdata\hrlymean.dat',exist=ex)
      if(.not. ex)then
        call display3('c:\rtwdata\hrlymean.dat not found       ')
        return
      else
        open(21,err=70,file='a:hmlist.dat',
     1           status='unknown',iostat=ios)
        open(20,file='c:\rtwdata\hrlymean.dat',status='old')
        while (1.eq.1) do
          read(20,1000,err=90,end=100)a
 1000     format(a80)
          write(21,1000,err=80)a
          nlines=nlines+1
        end while
      endif
   70 call display3('Could not open a:hmlist.dat             ')
      close(21)
      return  
   80 call display3('error writing to a:\hmlist.dat          ') 
      goto100  
   90 call display3('Error reading c:\rtwdata\hrlymeans.dat  ')
  100 write(a,1001)nlines
 1001 format(1x,i5,' lines written to a:hmlist.dat')
      call display3(a)
      close(20)
      close(21)
      return
      end