c************
c  Description: Groups Input files into a single record oriented file
c
c  Author:	JGS
c
c  $Revision: 1.2 $
c  $Modtime:   16 Feb 1996 16:07:54  $
c              24 Jul 2002 KCS - Added /T2000 switch to treat type-2000
c                                frames as logical elements
c                                                          
c************
	program GROUP

	implicit none
c
	include 'primitive.inc'
c
        logical*4       t2000
	integer*4	maxfiles        
	parameter(	maxfiles = L_subrecords)
	integer*4	L_bbuf
	parameter(	L_bbuf = 32768)
	record /HEADER/ HIN(maxfiles), HOUT
	integer*4	aloc, bloc, roff
	integer*4	i, j, it, iu, n, nfiles, mfiles, maxbpe, LPER
	integer*4	ngot, ngotn, nget, nrecords, irecords, iabs
	character	name*4
	real*8		start, size
c
        logical*4 done
        integer*4 len_fn
        
	call M$CHECKIN

c get the number of input files
	mfiles = Mc.number_parameters - 1
c
c  KCS 23 July 2002 The /T2000 switch means treat type-2000 frames as
c                   logical elements 
c
         t2000 = M$GET_SWITCH('T2000') .GT. 0

c open and test input file #1
	HIN(1).file_name = M$APICK(2)
	HIN(1).type_allow = '1000,2000,3000,5000'	
	HIN(1).format_allow = ' '
	call M$INOK (HIN(1))
	if (HIN(1).class .eq. 2 .and. .not. t2000)
     &                    call M$FORCE1000(HIN(1))
	maxbpe = HIN(1).bpe

c setup output file
	call M$PROPAGATE(HIN(1), HOUT)
	HOUT.file_name = M$APICK(1)
	if ((HOUT.class .eq. 1) .or. (HOUT.class .eq. 2)) then
	  HOUT.class = 3
	  HOUT.type = 3000
	  HOUT.subrecords    = 0
	  HOUT.record_length = 0		! <<< GED  3/12/93
	  if (t2000) then
             HOUT.subrecords = 1
             HOUT.subr(1).name = 'TR01'                          
             HOUT.subr(1).format = HIN(1).format
             HOUT.subr(1).offset = 0
             HOUT.record_length = HOUT.record_length + HIN(1).bpe 
          else
             call M$ADDSUBR(HOUT,'TR01',HIN(1).format)
          endif
	endif

c set the maximum size of the record
	if (HOUT.class .eq. 5) then
	  nrecords = L_components
	else
	  nrecords = L_subrecords
	endif


c open the rest of the input files
	nfiles = 1
        done = .FALSE.
        n = 2
	do while (.NOT. done) 
	  HIN(n).file_name = M$APICK(n+1)
          len_fn = M$LENGTH(HIN(n).file_name)
	  write(*,*) 'Input file ',n,' = ',HIN(n).file_name(1:len_fn)
          if (HIN(n).file_name .EQ. ' ') goto 100
          HIN(n).type_allow = '1000,2000,3000,5000'	
	  HIN(n).format_allow = ' '
	  call M$INOK(HIN(n))
	  irecords = 1
	  if (HIN(n).class .gt. 2) irecords = HIN(n).subrecords
	  if (HIN(n).class .eq. 2 .and. .not. t2000)
     &                            call M$FORCE1000(HIN(n))
	  maxbpe = max(maxbpe, HIN(n).bpe)
	  if (HOUT.subrecords+irecords .gt. nrecords) then
	    call M$WARNING ('Too many output records, files '//
     &	    M$APICK(n+1)//' and on will be ignored')
	    call M$CLOSE (HIN(n))
	    goto 100
	  endif
	  if ((HIN(n).class .eq. 1) .or. (HIN(n).class .eq. 2)) then
	    write(name, '(2hTR,i2.2)') n
	    if (HOUT.class.eq.3) then
              if (t2000) then
                 i = HOUT.subrecords+1            ! Add the full frame as
                 HOUT.subrecords = i              !   the subrecord
                 HOUT.subr(i).name = name                          
                 HOUT.subr(i).format = HIN(n).format
                 HOUT.subr(i).offset = HOUT.record_length
                 HOUT.record_length = HOUT.record_length 
     &                              + HIN(n).bpe 
              else                                               
   	         call M$ADDSUBR(HOUT, name, HIN(n).format)
              endif
	    else 
	      call M$ADDCOMP(HOUT, name, HIN(n).format, 1, 0)
	    endif
	  elseif (HIN(n).class .eq. 3) then
	    do i = 1,HIN(n).subrecords
	      if (HOUT.class .eq. 3) then
		call M$ADDSUBR(HOUT,HIN(n).subr(i).name,
     &				HIN(n).subr(i).format)
	      else
		call M$ADDCOMP(HOUT,HIN(n).subr(i).name,
     &				HIN(n).subr(i).format,1,0)
	      endif
	    enddo
	  elseif (HIN(n).class .eq. 5) then
	    do i = 1,HIN(n).components
	      if (HOUT.class.eq.3) then
		call M$ADDSUBR (HOUT,HIN(n).comp(i).name,
     &				HIN(n).comp(i).format)
	      else
		it = HIN(n).comp(i).type
		iu = HIN(n).comp(i).units
		call M$ADDCOMP (HOUT,HIN(n).comp(i).name,
     &				HIN(n).comp(i).format,it,iu)
	      endif
	    enddo
	  endif
	  nfiles = n
          n = n + 1
	enddo
  100	continue
c
c check for duplicate names
	do j = 1, HOUT.subrecords
	  do i = j+1, HOUT.subrecords
	    if (HOUT.subr(i).name .eq. HOUT.subr(j).name) then
	      call M$WARNING ('Duplicate output record named: '//
     &		HOUT.subr(i).name)
	      goto 200
	    endif
	  enddo
  200	enddo
c
c align the input files
	iabs = max(0,M$GET_SWITCH('ABS'))
	call M$MALIGN (HIN, nfiles, iabs, HOUT.size, HOUT.xstart)
c
c allocate the output file
	call M$ALLOCATE (HOUT)
c
c get buffers 
	LPER = M$XFER_LENGTH(HOUT.bpe,L_bbuf)
	call M$MALLOC(maxbpe*LPER, aloc)
	call M$MALLOC(HOUT.bpe*LPER, bloc)
c
c signal end of preamble
	call M$SYNC
c
c loop through buffers
	do while (M$DO(LPER, nget))

	  roff = 0
	  ngot = LPER
	  do n = 1, nfiles
            HIN(n).xfer_len = LPER
	    call M$GRABX(HIN(n), %val(aloc), ngotn)
	    ngot = min(ngotn, ngot)
	    call M$VMOVNB(%val(aloc), HIN(n).bpe,
     &	            %val(bloc+roff), HOUT.bpe, ngot, HIN(n).bpe)
	    roff = roff + HIN(n).bpe
	  enddo
	  call M$FILAD(HOUT, %val(bloc), ngot)

	enddo
c
c close files
	do n = 1, nfiles
	  call M$CLOSE(HIN(n))
	enddo
	call M$CLOSE(HOUT)

	call M$RETURN

	end




	subroutine M$MALIGN (hcbs,nfiles,iabs,size,start)
	real*8 size,start,dsize,dstart
	integer*4 nfiles,iabs,n
	include 'headers.inc'
	record /HEADER/ hcb,hcbs(*)
c
	hcb.main = hcbs(1).main
	hcb.size = hcbs(1).size
	do n = 2,nfiles
	  call M$ALIGN(hcb,hcbs(n),iabs,size,start)
	  hcb.xstart = start
	  hcb.size = size
	enddo
	do n = 1,nfiles
	  call M$ALIGN(hcb,hcbs(n),iabs,dsize,dstart)
	enddo
c
	return

	end
