program WTL1b2L1aLEAMPDS
c Work tape level 1b to level 1a in ASCII for LEAM in PDS format
c **20-Nov-18*
	character filen*34,flx*5,cr*1,tf*1,df(31)*1,dfj*1,time*21
	integer*2 in(10)
	integer in4(5),ia(31),itd(31),dv(31)
	logical newline,syncer
	parameter(cr='0d'x,dt=9.43385)
	equivalence(in(1),in4(1))
	common dv,newline,time,tf,df
	data ia/3*31,3*39,3*95,2*103,3*159,3*167,3*223,2*231,4*287,5*295/
&	,filen/'a17_leam_1976***t**_l1_wt**.**.tab'/
&	,time(1:15)/'1976-***T**:**:'/	
c
	do i=1,31
	 itd(i)=nint(dt*(ia(i)-1))
	 end do
c
	do nt=1,21
	 do nf=1,56
	  write(flx(1:2),'(i2)') nt
	  filen(26:27)=flx(1:2)
          flx(3:3)='.'
          write(flx(4:5),'(i2)') nf
	  filen(29:30)=flx(4:5)
          do i=4,1,-1
           if (flx(i:i).eq.' ') flx(i:5)=flx(i+1:5)//' '
           end do
	  if (filen(26:26).eq.' ') filen(26:26)='0'
	  if (filen(29:29).eq.' ') filen(29:29)='0'
	  open(1,file='../wtleaml1bs/wtleaml1b.'//flx,access='direct'
&	  ,form='unformatted',recl=20,status='old',err=29)
c
	  nr=1
100	  read(1,rec=nr) in
	  it=or(and(lshift(in4(1),28),'70000000'x),
&	   and(rshift(in4(2),4),'fffffff'x))
	  if (it.eq.0) then
	   nr=nr+1
	   go to 100
	   end if
	  id=it/5400000
	  ih=mod(it,5400000)/225000
 	  write(filen(14:16),'(i3)') id
	  write(filen(18:19),'(i2)') ih
	  if (filen(14:14).eq.' ') filen(14:14)='0'
	  if (filen(18:18).eq.' ') filen(18:18)='0'
	  open(7,file='../leaml1aPDSs/'//filen)
	  write(7,1) 'year-dayThr:mn:sc.ms  f',(i,i=1,31),cr
1	  format(a23,9(' DJ-',i1,' f'),22(' DJ-',i2,' f'),a1)
	  write(7,"(13xa10,9(i5,' |'),22(i6,' |'),a1)")
&	  'time+ms  |',(itd(i),i=1,31),cr
	  idh=id*24+ih
	  write(*,*) flx,' ',filen(14:19),' ',filen(26:30),id,ih,idh
	  open(8,file='../leaml1aPDSs/leamlialog.'//flx)
c
	  nr=1
	  newline=.true.
	  do i=1,31
	   dv(i)=-9
	   df(i)='-'
	   end do
10	  read(1,rec=nr,end=19) in
c get sync
	  in5=in(5)
	  in6=in(6)
	  ksyn=and(rshift(in4(3),8),'3fffff'x)
	  if(ksyn.eq.'3890ed'x) then
	   syncer=.false.
	  else
	   kxs=xor(ksyn,'3890ed'x)
	   nib=0
	   do i=1,22
	    if (and(kxs,1).ne.0) nib=nib+1
	    kxs=rshift(kxs,1)
	    end do
	   syncer=nib.gt.2
	   if (syncer) write(8,"(i4,i3,1xa8,z7,' out of sync - skip')")
&	    nr,k,time(10:17),ksync
	   end if
c get ALSEP frame count
	  kfc=and(in(6),'7f'x)
	  mfc=mod(kfc+4,5)+1
c if not new line and frame count increment is not 1
c  output the partically filled line
	  if (.not.newline) then
	   if (mod(lfc,5).eq.0) then
	    call out
	   else if (.not.(kfc.ge.lfc+1.and.kfc.le.int((lfc+5)/5)*5)) then
	    if (kfc.ne.0) call out
	    end if
	   end if
c get time if new line
	  if (newline) then
	   it=or(and(lshift(in4(1),28),'70000000'x),
&	   and(rshift(in4(2),4),'fffffff'x))
	   kd=it/5400000
	   it=mod(it,5400000)
	   kh=it/225000
	   it=mod(it,225000)
	   km=it/3750
	   sec=(mod(it,3750)*16+and(in4(2),15))/1000.
	   kdh=kd*24+kh
	   tf='-'
	   if (and(in4(1),8).ne.0.or.kdh.lt.idh.or.kdh.gt.idh+24) tf='*'
c if mfc is not 1, adjust reference time
	   if (mfc.ne.1.and.kd.gt.0) then
	    sec=sec-(mfc-1)*64*dt/1000.
	    if (sec.lt.0) then
	     sec=sec+60.
	     km=km-1
	     if (km.lt.0) then
	      km=km+60
	      kh=kh-1
	      if (kh.lt.0) then
	       kh=kh+24
	       kd=kd-1
	       end if
	      end if
	     end if
	    end if
	   write(time(6:8),'(i3)')kd
	   if (time(6:6).eq.' ') time(6:6)='0'
	   write(time(10:11),'(i2)') kh
	   write(time(13:14),'(i2)') km
	   write(time(16:21),'(f6.3)') sec
	   do i=7,16,3
	    if (time(i:i).eq.' ') time(i:i)='0'
	    end do
	   newline=.false.
	   end if
	  lfc=kfc
c LEAM data
	  do j=1,2
	   kv=in(j+8)
	   dfj='-'
	   if (syncer) dfj='*'
	   go to (11,12,13,14,15), mfc
11	   if (j.eq.1) then
	    dv(1)=and(rshift(kv,6),15)
	    dv(2)=and(rshift(kv,3),7)
	    dv(3)=and(kv,7)
	    df(1)=dfj
	    df(2)=dfj
	    df(3)=dfj
	   else
	    dv(4)=and(rshift(kv,6),15)
	    dv(5)=and(rshift(kv,3),7)
	    dv(6)=and(kv,7)
	    df(4)=dfj
	    df(5)=dfj
	    df(6)=dfj
	    end if
	   go to 16
12	   if (j.eq.1) then
	    dv(7)=and(rshift(kv,6),15)
	    dv(8)=and(rshift(kv,3),7)
	    dv(9)=and(kv,7)
	    df(7)=dfj
	    df(8)=dfj
	    df(9)=dfj
	   else
	    dv(10)=and(rshift(kv,6),15)
	    dv(11)=and(kv,'3f'x)
	    df(10)=dfj
	    df(11)=dfj
	    end if
	   go to 16
13	   if (j.eq.1) then
	    dv(12)=and(rshift(kv,6),15)
	    dv(13)=and(rshift(kv,3),7)
	    dv(14)=and(kv,7)
	    df(12)=dfj
	    df(13)=dfj
	    df(14)=dfj
	   else
	    dv(15)=and(rshift(kv,6),15)
	    dv(16)=and(rshift(kv,3),7)
	    dv(17)=and(kv,7)
	    df(15)=dfj
	    df(16)=dfj
	    df(17)=dfj
	    end if
	   go to 16
14	   if (j.eq.1) then
	    dv(18)=and(rshift(kv,6),15)
	    dv(19)=and(rshift(kv,3),7)
	    dv(20)=and(kv,7)
	    df(18)=dfj
	    df(19)=dfj
	    df(20)=dfj
	   else
	    dv(21)=and(rshift(kv,6),15)
	    dv(22)=and(kv,'3f'x)
	    df(21)=dfj
	    df(22)=dfj
	    end if
	   go to 16
15	   if (j.eq.1) then
	    dv(23)=and(rshift(kv,8),3)
	    dv(24)=and(rshift(kv,6),3)
	    dv(25)=and(rshift(kv,3),7)
	    dv(26)=and(kv,7)
	    do i=23,26
	     df(i)=dfj
	     end do
	   else
	    dv(27)=and(rshift(kv,8),3)
	    dv(28)=and(rshift(kv,7),1)
	    dv(29)=and(rshift(kv,6),1)
	    dv(30)=and(rshift(kv,3),7)
	    dv(31)=and(kv,7)
	    do i=27,31
	     df(i)=dfj
	     end do
	    call out
	    end if
16	   end do
	  nr=nr+1
	  go to 10
19	  close(1)
	  if (.not.newline) call out
	  close(7)
29	  end do
	 end do
	stop
	end

	subroutine out
	character time*21,cr*1,tf*1,df(31)*1
	integer dv(31)
	logical newline
	parameter (cr='0d'x)
	common dv,newline,time,tf,df
c
	write(7,'(a21,1xa1,9(i5,1xa1),22(i6,1xa1),a1)')
&	 time,tf,(dv(i),df(i),i=1,31),cr
	do i=1,31
	 dv(i)=-9
	 df(i)='-'
	 end do
	newline=.true.
	return
	end