c
c  $Revision: 1.1 $
c  $Modtime:   04 Aug 1997 12:37:44  $
c  
c************
c  Description:	Create Type 3000 file header
c
c  Author:	ged 05/94
c
c  Revisions:	
c
c************
	program f3000

	implicit none
	include 'primitive.inc'

	record /HEADER/	hcb
	integer*4	i,n
	character*80	string
	character*4	format, format0
	logical*4	nh

	call m$checkin

c start filling in Type 3000 header
	call m$initialize (hcb)
	hcb.file_name = m$apick(1)
	hcb.type = 3000

c pick up subrecord NAME/FORMAT and continue to populate header
	n = 2
	do while (m$ppick(n))
	  string = m$upick(n)
	  i = INDEX (string, '/')
	  if (i.lt.0) call m$error ('Field syntax must be NAME/FORMAT')
	  format = m$test_format (string(i+1:), ' ')
	  call m$addsrec (hcb, string(1:i-1), format)
	  if (n .eq. 2) then		! save first format for NH check
	    nh = .false.
	    format0 = format
	  else
	    nh = nh .or. format .ne. format0
	  endif
	  n = n+1
	enddo

c finish with format and allocate
	if (nh)      hcb.format = 'NH'
	if (.not.nh) hcb.format = format
	call m$allocate (hcb)	! no need to touch EOF since size=0
	call m$close (hcb)

	call m$return
	end
