program WTLEAMHKs
c get LEAM house keeping data from Work tapes - may need manual cleanup
c **22-Dec-18**
	character filen*26,flx*5,cr*1,tf(4)*1,vf(3,4)*1
	integer*2 in(10)
	integer in4(5),ifc(3),idt(3),kt(2,4),kv(3,4),s(4)
	logical first,newcyc,last,badt
	parameter (cr='0d'x,dt=9.43385)
	equivalence (in(1),in4(1))
	data ifc/83,84,85/,filen/'a17_leam_1976_l1_wt_hk.tab'/
	common kt,kv,m3,s,tf,vf,newcyc,last
c
	open(2,file='../WT-N-LEAM.txt',status='old')
	do j=1,3
	 idt(j)=nint(((ifc(j)-83)*64+32)*dt)
	 end do
	open(7,file='../leaml1aPDSs/'//filen//'-p')
	write(7,1) 'year-dayThr:mn:sc.ms  f',cr,'time+ms  |  x',idt,cr
1	format(a23,'  m AJ-m f  n AJ-n f AJ-11 f',a1/13xa13
&	,i5,' |  x',i5,' |',i6,' |',a1)
c
100	read(2,*,end=29) nt,nf
	write(flx,'(i2,a1,i2)') nt,'.',nf
	do i=4,1,-1
	 if (flx(i:i).eq.' ') flx(i:5)=flx(i+1:5)//' '
	 end do
	open(1,file='../wtleaml1bs/wtleaml1b.'//flx,access='direct'
&	,form='unformatted',recl=20,status='old',err=100)
	write(*,*) flx
c
	nr=1
	newcyc=.true.
	last=.false.
	idts=0
	do i=1,3
	 kv(i,4)=-9
	 vf(i,4)='-'
	 end do
10	read(1,rec=nr,end=19) in
	if (in(1).eq.0.or.in(2).eq.0) go to 17
c get frame count
	kfc=and(in(6),'7f'x)
	do j=1,3
	 if (kfc.eq.ifc(j)) go to 12
	 end do
	go to 17
c det sync
12	in5=in(5)
	in6=in(6)
	ksyn=and(rshift(in4(3),8),'3fffff'x)
	if (ksyn.ne.'3890ed'x) then
	 if(kfc.ne.nfc) then
	  nfc=mod(nfc+1,90)
	  go to 18
	  end if
	 end if
c get time/16 and write out if passed current range
	if (and(in4(1),8).eq.0) then
	 ktt=or(and(lshift(in4(1),28),'70000000'x)
&	 ,and(rshift(in4(2),4),'fffffff'x))
	 badt=iabs(ktt-lit).gt.5400000.or.and(in4(1),'4000'x).ne.0
	 if (newcyc.or.ktt.lt.lit.or.badt) go to 15
	else
	 if (idt(j).gt.idts) go to 15
	 go to 18
	 end if
	call saveout
15	if (newcyc) then
c get full time
	 idts=idt(j)-idt(1)
	 tf(4)='-'
	 if (and(in4(1),'4008'x).ne.0) tf(4)='*'
         kt(1,4)=or(and(lshift(in4(1),17),'e0000'x)
&        ,and(rshift(in4(2),15),'1ffff'x))
         kt(2,4)=and(in4(2),'7fff'x)-idts
         if (kt(2,4).lt.0) then
          kt(2,4)=and(kt(2,4),'7fff'x)
          kt(1,4)=kt(1,4)-1
          end if                 
         it=or(and(lshift(kt(1,4),11),'7ffff800'x)
&        ,and(rshift(kt(2,4),4),'fff'x))
	 lit=it+3358
	 newcyc=.false.
	 end if
	vf(j,4)='-'
	if (ksyn.ne.'3890ed'x.or.and(in(7),'8000'x).ne.0) vf(j,4)='*'
c get HK data value
	kv(j,4)=in(7)
	if (and(kv(j,4),'8000'x).ne.0) kv(j,4)=and(kv(j,4),'3ff'x)
	if (j.eq.3) call saveout
17	nfc=mod(kfc+1,90)
18	nr=nr+1
	go to 10
19	close(1)
	go to 100
29	close(2)
	last=.true.
	call saveout
	close(7)
	stop
	end

	subroutine saveout
	character time*21,tf(4)*1,vf(3,4)*1
	integer kt(2,4),kv(3,4),s(4)
	logical tgap,nokv1,newcyc,tgap,badt,nokv1,ltbad,last
	data time(1:15)/'1976-***T**:**:'/,ls/0/
	common kt,kv,m3,s,tf,vf,newcyc,last
c
	if (last) then
	 if (m3.ne.88) m3=mod(m3,5)+1
	 call out(3)
	 return
	 end if
	s(4)=(kv(1,4)/4)
	if (s(4).gt.0) s(4)=1
	tgap=(kt(1,4)-lt)/3.ne.0
	badt=tf(4).eq.'*'
	nokv1=kv(1,4).eq.-9	
	if (ls.eq.0) then
	 if (badt.or.nokv1) then
	  m3=88
	  call out(4)
	 else
	  call move(4,1)
	  lt=kt(1,4)
	  ls=1
	  end if
	else if (ls.eq.1) then
	 if (tgap.or.badt.or.nokv1) then
	  m3=88
	  call out(1)
	  call out(4)
	  ls=0
	 else
	  call move(4,2)
	  lt=kt(1,4)
	  ls=2
	  end if
	else if (ls.eq.2) then
	 if (tgap.or.badt.or.nokv1) then
	  m3=88
	  call out(1)
	  call out(2)
	  call out(4)
	  ls=0
	 else
	  call move(4,3)
	  lt=kt(1,4)
	  ls=3
	  end if
	else if (ls.eq.3) then
	 if (tgap) then
	  if (badt.or.nokv1) then
	   ms=88
	   do i=1,4
	    call out(i)
	    end do
	   ls=0
	  else
	   if (m3.ne.88) m3=mod(m3,5)+1
	   do i=1,3
	    call out(i)
	    end do
	   call move(4,1)
	   lt=kt(1,4)
	   ls=1
	   end if
	 else if (nokv1) then
	 if (m3.ne.88) m3=mod(m3,5)+1
	  do i=1,3
	   call out(i)
	   end do
	  ls=0
	 else
	  go to 10
	  end if
	else if (nokv1) then
	 if (m3.ne.88) m3=mod(m3,5)+1
	 call out(3)
	 call out(4)
	 ls=0
	else if (tgap.and..not.badt.and..not.ltbad) then
	 if (m3.ne.88) m3=mod(m3,5)+1
	 call out(3)
	 call move(4,1)
	 lt=kt(1,4)
	 ls=1
	else
	 go to 10
	 end if
	go to 20
c determine m3
10	if (s(1).eq.1.and.s(2).eq.1.and.s(3).eq.1.and.s(4).eq.0) then
	 m3=1
	else if (s(1).eq.1.and.s(2).eq.1.and.s(3).eq.0.and.s(4).eq.0) then
	 m3=2
	else if (s(1).eq.1.and.s(2).eq.0.and.s(3).eq.0.and.s(4).eq.1) then
	 m3=3
	else if (s(1).eq.0.and.s(2).eq.0.and.s(3).eq.1.and.s(4).eq.1) then
	 m3=4
	else if (s(1).eq.0.and.s(2).eq.1.and.s(3).eq.1.and.s(4).eq.1) then
	 m3=5
	else
	 m3=88
	 end if
c output/move
	if (ls.eq.3) then
	 do n=1,3
	  call out(n)
	  call move(n+1,n)
	  end do
	 if (badt) then
	  lt=lt+2
	 else
	  lt=kt(1,4)
	  end if
	 ls=4
	else
	 call out(3)
	 do i=1,3
	  call move(i+1,i)
	  end do
	 end if
	if (badt) then
	 if (m3.ne.88) m3=mod(m3,5)+1
	 lt=lt+3
	else
	 lt=kt(1,4)
	 end if
20	do i=1,3
	 kv(i,n)=-9
	 vf(i,n)='-'
	 end do
	newcyc=.true.
	ltbad=tbad
	return
	end

	subroutine move(nf,nt)
c	save k(t,v,f,s) in nf to nt
	character tf(4)*1,vf(3,4)*1
	integer kt(2,4),kv(3,4),s(4)
	common kt,kv,m3,s,tf,vf,newcyc
c
	kt(1,nt)=kt(1,nf)
	kt(2,nt)=kt(2,nf)
	tf(nt)=tf(nf)
	do i=1,3
	 kv(i,nt)=kv(i,nf)
	 vf(i,nt)=vf(i,nf)
	 end do
	s(nt)=s(nf)
	return
	end

	subroutine out(n)
c	output ln
	character time*21,tf(4)*1,vf(3,4)*1,cr*1
	integer kt(2,4),kv(3,4),s(4)
	logical newcyc
	parameter (cr='0d'x)
	data time(1:15)/'1976-***T**:**:'/
	common kt,kv,m3,s,tf,vf,newcyc
c
	it=or(and(lshift(kt(1,n),11),'7ffff800'x)
&       ,and(rshift(kt(2,n),4),'7ff'x))
	kd=it/5400000
	it=mod(it,5400000)
	kh=it/225000
	it=mod(it,225000)
	km=it/3750
	sec=(mod(it,3750)*16+and(kt(2,n),15))/1000.
	write(time(6:8),'(i3)') kd
	if (time(6:6).eq.' ') time(6:6)='0'
	if (time(7:7).eq.' ') time(7:7)='0'
	write(time(10:11),'(i2)') kh
	write(time(13:14),'(i2)') km
	write(time(16:21),'(f6.3)') sec
	do i=10,16,3
	 if (time(i:i).eq.' ') time(i:i)='0'
	 end do
	if (m3.ne.88) then
	 if (n.eq.3) then
	  maj=m3
	 else
	  maj=m3+n-3
	  if (maj.le.0) maj=maj+5
	  end if
	 naj=maj+5
	else
	 maj=m3
	 naj=m3
	 end if
	write(7,'(a21,1xa1,i3,i5,1xa1,i3,i5,1xa1,i6,1xa1,a1)')
&	time,tf(n),maj,kv(1,n),vf(1,n),naj,(kv(i,n),vf(i,n),i=2,3),cr
	if (last) return
	lt=kt(1,n)
	nmaj=mod(maj,5)+1
	return
	end