program L1b2L1aHFEM3CPDS
c level 1b to level 1a in AACII for HFE Mode 3 combined, PDS format
c **28-Jul-18**
	character filen*28,stdy*6,time*15,tf*1,df*1,meas(4,12)*3
&	,mna(12)*2,mnx(4)*1,timej(12)*21,tfj(12)*1,dfj(4,12)*1,cr*1
	integer*2 in(7,128)
	integer itd(4),kth(6,2,4),khj(4,12)
	logical mode3
	parameter (cr='0d'x)
	data filen/'a**_hfe_1975_l1_arcsav_3.tab'/,stdy(3:3)/'.'/
&	,mna/'50','51','60','61','56','57','70','71','80','81','76','77'/
&	,mnx/'A','B','C','D'/,time/'1975-***T**:**:'/
	common timej,khj,tfj,dfj
c
	write(*,"('station: '$)")
	read(*,'(a2)') stdy(1:2)
	filen(2:3)=stdy(1:2)
	if (stdy(2:2).eq.'5') then
	 tds=990.54
	else
	 tds=999.97
	 end if
	do i=1,4
	 itd(i)=nint(1207.52*i-tds)
	 end do
	open(7,file='../hfel1aPDSs/'//filen)
	write(7,"(12(a23,4(1xa5,1xa1),1x),a1/12(14xa9,4(i6,' |'),1x),a1)") 
&	('year day hr:mn:sc.ms  f',('DH'//mna(j)//mnx(i),'f',i=1,4),j=1,12),cr,
&	('time+ms |',(itd(i),i=1,4),j=1,12),cr
c
	call clearline
	mode3=.false.
	ls=0
	nr=0
	write(*,"('days: '$)")
	read(*,*) id1,id2
	do id=id1,id2
	 write(stdy(4:6),'(i3)') id
	 if (stdy(4:4).eq.' ') stdy(4:4)='0'
	 open(1,file='../hfel1b'//stdy(1:2)//'s/hfel1b.'//stdy
&	 ,access='direct',form='unformatted',recl=1792,status='old',err=29)
	 write(*,*) stdy
	 nr=0
	 nrec=1
10	 read(1,rec=nrec,end=19) in
	 do k=1,128
	  if (in(1,k).eq.0) go to 18
	  in6=in(6,k)
	  in7=in(7,k)
c check frame count
	  kfc=and(in6,'7f'x)
	  if (and(kfc,1).eq.0) then
c even numbered frame
	   kr=and(rshift(in7,8),3)
	   if (kr.ne.nr) go to 17
c skip if not Mode 3
	   if (kr.eq.1) mode3=and(in7,'e0'x).eq.'20'x
	   if (kr.ge.1.and..not.mode3) go to 17
c save in(2-7,k) in kth
	   do i=1,6
	    kth(i,1,kr+1)=in(i+1,k)
	    end do
	  else
c odd numbered frame; if Mode 3, save in(5-7) in kth
	   if (kr.ge.1.and..not.mode3) go to 17
	   do i=4,6
	    kth(i,2,kr+1)=in(i+1,k)
	    end do
	   if (kr.lt.3) then
	    nr=kr+1
	    go to 18
	    end if
	   if(and(kth(6,1,3),'10'x).ne.0) go to 17
	   ks=and(rshift(kth(6,1,1),3),1)+and(rshift(kth(6,1,3),4),14)+1
	   if (ks.gt.6) ks=ks-2
c if this set should be on a new line, first output the line in memory
	   if (ks.le.ls) then
	    write(7,1) (timej(j),tfj(j),(khj(i,j),dfj(i,j),i=1,4),j=1,12),cr
1	    format(12(a21,1xa1,4(i6,1xa1),1x),1a)
	    call clearline
	    end if
	   ls=ks
c decode and put the time on output line
	   it=or(or(and(lshift(kth(1,1,1),28),'70000000'x)
&	   ,and(lshift(kth(2,1,1),12),'ffff000'x))
&	   ,and(rshift(kth(3,1,1),4),'fff'x))
	   kd=it/5400000
	   it=mod(it,5400000)
	   kh=it/225000
	   it=mod(it,225000)
	   km=it/3750
	   sec=(mod(it,3750)*16+and(kth(3,1,1),15))/1000.
	   write(time(6:8),'(i3)')kd
	   write(time(10:11),'(i2)') kh
	   write(time(13:14),'(i2)') km
	   timej(ks)(1:15)=time
	   write(timej(ks)(16:21),'(f6.3)') sec
	   do i=6,16
	    if (timej(ks)(i:i).eq.' ') timej(ks)(i:i)='0'
	    end do
	   tfj(ks)='-'
	   if (and(kth(1,1,1),'40'x).ne.0.or.iabs(kd-id).gt.1) tfj(ks)='*'
c decode and put the data on output line
	   do i=1,4
	    khj(i,ks)=or(and(lshift(kth(6,1,i),10),'1c00'x)
&	    ,and(kth(6,2,i),'3ff'x))
	    dfj(i,ks)='-'
	    if (and(or(kth(6,1,i),kth(6,2,i)),'f400'x).ne.0) dfj(i,ks)='*'
	    if (or(kth(4,1,i),kth(4,2,i)).ne.'3890'x.or
&	    .and(or(kth(5,1,i),kth(5,2,i)),'ff00'x).ne.'ed00'x) dfj(i,ks)='*'
	    end do
	   end if
17	  nr=0
18	  end do
	 nrec=nrec+1
	 go to 10
19	 close(1)
29	 end do
	write(7,1) (timej(j),tfj(j),(khj(i,j),dfj(i,j),i=1,4),j=1,12),cr
	close(7)
	stop
	end

	subroutine clearline
	character timej(12)*21,tfj(12),dfj(4,12)
	integer khj(4,12)
	common timej,khj,tfj,dfj
c
	do j=1,12
	 timej(j)='9999                 '
	 tfj(j)='-'
	 do i=1,4
	  khj(i,j)=-9
	  dfj(i,j)='-'
	  end do
	 end do
	return
	end