c.....program hkls................................................
c scans hkl file for absent refls, space group and Laue symmetry .
c input file:   HKL      output file:   HKLT                     .
c While scanning for Laue symmetry, it is often better to first  .
c scan for absent reflections (i=1). This creates two files HKLO . 
c containing only obs refl(f2>2s), and HKLS having only strong   .
c refl(f2>10s). Rename one of these as HKL and scan for Laue     .
c symmetry - saves time and space                                .
c..........................mvr/dec.'98............................  
c
      character*65 txt
      open(2,file='hklt',status='new')
c 
c 1. absent reflections, f2>2s
c 2. given h k l 
c 3. given condition:
c    1. 0kl   2. h0l   3. hk0   4. 00l   5. 0k0   6. h00
c    7. hhl
c 4. Laue symmetry check:
c    1. C3h   2. D3h
c
   55 write(*,40)
      read(*,*,end=1)i
      goto(61,62,63,64) i
c..................................................absent refl.. 
   61 open(1,file='hkl')
      open(3,file='hklo',status='new')
      open(4,file='hkls',status='new')
    5 read(1,50,end=55) ih,ik,il,f2,s
      if(f2.gt.2.*s)then
      write(3,50)ih,ik,il,f2,s
        if(f2.gt.10.*s)write(4,50)ih,ik,il,f2,s
      else
      write(2,50)ih,ik,il,f2,s
      write(*,50)ih,ik,il,f2,s
      endif
      goto 5
c..................................................given hkl..
   62 write(*,30)
      read(*,*,end=55)iht,ikt,ilt
      open(1,file='hkl')
    2 read(1,10,end=4)ih,ik,il,txt
      if((iht.eq.ih).and.(ikt.eq.ik).and.(ilt.eq.il)) then
      write(*,10)ih,ik,il,txt
      write(2,10)ih,ik,il,txt
      goto 62
      endif
      goto 2
    4 write(*,20)
      goto 62
c..................................................system. absences..
   63 write(*,60)
      read(*,*,end=55)j
      open(1,file='hkl')
   79 read(1,10,end=63)ih,ik,il,txt
      goto(81,82,83,84,85,86,87) j   
c..................................................0kl
   81 if(ih.ne.0) goto 79
      write(*,10)ih,ik,il,txt
      write(2,10)ih,ik,il,txt
      goto 79
c..................................................h0l
   82 if(ik.ne.0) goto 79
      write(*,10)ih,ik,il,txt
      write(2,10)ih,ik,il,txt
      goto 79
c..................................................hk0
   83 if(il.ne.0) goto 79
      write(*,10)ih,ik,il,txt
      write(2,10)ih,ik,il,txt
      goto 79
c..................................................00l
   84 if((ih.ne.0).or.(ik.ne.0)) goto 79
      write(*,10)ih,ik,il,txt
      write(2,10)ih,ik,il,txt
      goto 79
c..................................................0k0
   85 if((ih.ne.0).or.(il.ne.0)) goto 79
      write(*,10)ih,ik,il,txt
      write(2,10)ih,ik,il,txt
      goto 79
c..................................................h00
   86 if((ik.ne.0).or.(il.ne.0)) goto 79
      write(*,10)ih,ik,il,txt
      write(2,10)ih,ik,il,txt
      goto 79
c..................................................hhl
   87 if(ih.ne.ik) goto 79
      write(*,10)ih,ik,il,txt
      write(2,10)ih,ik,il,txt
      goto 79
c..................................................Laue symmetry..
   64 write(*,70)
      read(*,*,end=55) j
      goto(91,92)j
c..................................................C3h
   91 call hex(1)
      goto 64
c..................................................D3h
   92 call hex(2)
      goto 64
c
    1 stop
   10 format(3i4,a65)  
   20 format(5x,'not found')
   30 format(/3x,'h,k,l ?')
   40 format(1x,'I ? 1(unobs); 2(given hkl)'/
     11x,'    3(0kl, h00 etc.); 4(Laue symmetry)')      
   50 format(3i4,2f8.2)
   60 format(1x,'J ? 1(0kl); 2(h0l); 3(hk0); 4(00l); 5(0k0); 6(h00)'
     1/5x,'7(hhl)')
   70 format(1x,'Laue symmetry? 1(C3h); 2(D3h)')
	end
c
      subroutine hex(npg)
      dimension iht(1000),ikt(1000),f2t(1000),st(1000)
      write(*,10)
	read(*,*)j
c....................................scan layer by layer on l
      l=-1
14    write(*,80)
      read(*,*)lsc
      if(lsc.eq.99)goto 99
      if (lsc.lt.0)then
      l=l+1
      else
      l=lsc
      endif
  16  open(1,file='hkl')
      i=0
  12	read(1,50,end=11)ih,ik,il,f2,s
      if(il.ne.l)goto 12
      i=i+1
      iht(i)=ih
      ikt(i)=ik
      f2t(i)=f2
      st(i)=s
      goto 12
  11  n=i
      if(n.eq.0)goto 99
      write(*,20)l,n
      write(2,30)
      write(2,20)l,n
      write(2,40)
c..
      do 13 i=1,n
      nh=iht(i)
      nk=ikt(i)
      if((nh.eq.0).and.(nk.eq.0))goto 13
      write(2,70)
c..................................................h k l
      neq=1
	write(2,60)neq,nh,nk,f2t(i),st(i)
c..................................................-k h+k l
      mh=-nk
      mk=nh+nk
      if((j.eq.1).and.(mh.lt.0))goto 103
      if((j.eq.2).and.(mk.lt.0))goto 103
      call scan(2,i,n,mh,mk,iht,ikt,f2t,st)	
c..................................................h+k -h l
 103  mh=nh+nk
      mk=-nh
      if((j.eq.1).and.(mh.lt.0))goto 104
      if((j.eq.2).and.(mk.lt.0))goto 104
      call scan(3,i,n,mh,mk,iht,ikt,f2t,st)
c..................................................-h-k h l
 104  mh=-nh-nk
      mk=nh
      if((j.eq.1).and.(mh.lt.0))goto 105
      if((j.eq.2).and.(mk.lt.0))goto 105
      call scan(4,i,n,mh,mk,iht,ikt,f2t,st)	
c..................................................k -h-k l
 105  mh=nk
      mk=-nh-nk
      if((j.eq.1).and.(mh.lt.0))goto 66
      if((j.eq.2).and.(mk.lt.0))goto 66
      call scan(5,i,n,mh,mk,iht,ikt,f2t,st)	
 66   if(npg.eq.1)goto 13    
c..................................................k h l
      mh=nk
      mk=nh
      if((j.eq.1).and.(mh.lt.0))goto 108
      if((j.eq.2).and.(mk.lt.0))goto 108
      call scan(7,i,n,mh,mk,iht,ikt,f2t,st)		
c..................................................h -h-k l
 108  mk=-nh-nk
      if((j.eq.2).and.(mk.lt.0))goto 109
      call scan(8,i,n,nh,mk,iht,ikt,f2t,st)	  
c..................................................-h-k k l
 109  mh=-nh-nk
      if((j.eq.1).and.(mh.lt.0))goto 110
      call scan(9,i,n,mh,nk,iht,ikt,f2t,st)	
c..................................................-h h+k l
 110  mh=-nh
      mk=nh+nk
      if((j.eq.1).and.(mh.lt.0))goto 111
      if((j.eq.2).and.(mk.lt.0))goto 111
      call scan(10,i,n,mh,mk,iht,ikt,f2t,st)		
c..................................................h+k -k l
 111  mh=nh+nk
      mk=-nk
      if((j.eq.1).and.(mh.lt.0))goto 112
      if((j.eq.2).and.(mk.lt.0))goto 112
      call scan(11,i,n,mh,mk,iht,ikt,f2t,st)		
c..................................................-k -h l
 112  mh=-nk
      mk=-nh
      if((j.eq.1).and.(mh.lt.0))goto 13
      if((j.eq.2).and.(mk.lt.0))goto 13
      call scan(12,i,n,mh,mk,iht,ikt,f2t,st)		
   13 continue
      if(lsc.ge.0)goto 14
      l=l+1
	goto 16
c..
   10 format(1x,'assumes l > 0; and h or k > 0'/
     13x,'Which index is + only, h (1) or k (2) ?')
   20 format(3x,'l = ',i4,4x,i4,' refl')
   30 format(/)
   40 format('-----------------------------------------')
   50 format(3i4,2f8.2)
   60 format(i4,':',2x,2i4,4x,2f8.2)   
   70 format('---------------------------')
   80 format(1x,'L-value for the layer?'/
     13x '-ve L wll scan all layers, 99 to exit')
   99 return
      end
c	
	subroutine scan(neq,i,n,mh,mk,iht,ikt,f2t,st)
      dimension iht(1000),ikt(1000),f2t(1000),st(1000)	
      do 14 k=1,n
      if((mh.ne.iht(k)).or.(mk.ne.ikt(k)))goto 14
      write(2,50)neq,iht(k),ikt(k),f2t(k),st(k)
      goto 16
   14 continue
   16 return  
   50 format(i4,':',2x,2i4,4x,2f8.2)
      end
