c*****************************************************************
c**                                                             ** 
c**   PROGRAM:  READB1                                          ** 
c**                                                             **
c**   FUNCTION:  This is the main program for reading B1 data   **
c**        tapes and producing the B2 disk data format files.   **
c**        The program reads 17 characters from the HDR1 record **
c**        from the B1 tape and searches for the ID in file     **
c**        "tapeids.daf" in subdirectory "b1_dsets".  If found  **
c**        the ID will point to a file containing the data set  **
c**        name record.  After processing a file the program    **
c**        updates that record with statistics about the file.  **
c**                                                             **
c**   MODIFICATIONS:                                            **
c**        7/14/92 by L.G. added code to accept up to 5 input   **
c**        tapes for processing using the cartridge stacker.    **
c**        If reading only one tape, it will be loaded directly **
c**        into the drive.  For reading 2 to 5 tapes, place the **
c**        they will be processing from the stacker.            **
c**                                                             **
c**        8/4/92 by L.G. changed output file path from being   **
c**        a specific subdirectory to the current directory.    **
c**        Therefore the output files are not hardcoded to a    **
c**        particular directory.                                **
c*****************************************************************
c     
      character*1  yorn
      character*21 dev
      character*4 filtyp
      character*6 tapein
      character*7 reels(5), reelno
      character*35 reel35
      character*10 outfil, logfil
      integer  itpct

      include 'b2cntl.inc'

      dimension inbuff(1610)
      equivalence(inbufc,inbuff)
      equivalence(reels(1),reel35)
      data dev/'/dev/rmt1'/
      data reelno /'A00000'/
      data logfil/'A00000.log'/
c
      filtyp = 'UNKN'
      currid = '00000000000000000'

c....Open the tape_ids file for correlating data files with its 
c....corresponding output data file.
      open(7, file='/user/lgriffin/isccp/b1_dsets/tapeids.daf',
     &     status='old',access='direct',recl=28, form='formatted')

c.................................................................
c.................. SECTION FOR READING INPUT TAPE NUMBERS .......
c.................................................................

c....Read input tape numbers or stop processing here.....
 5    continue
      do 510 ix=1, 5
 510  reels(ix) = '       '
      itpct = 0

 520  continue
      itpct = itpct + 1
      write(*,550) itpct
 550  format ('       Enter input tape # ',i1,
     &        '  OR',
     &        '  Enter  "stop" ')

      read(*,'(a6)') tapein

      if(tapein(1:4).eq.'stop'.or.tapein(1:4).eq.'STOP'.or.  
     &   tapein(2:5).eq.'stop'.or.tapein(2:5).eq.'STOP') then
        if(itpct.gt.1) then
          itpct = itpct - 1
          go to 705
        else
          write(*,7) logfil
 7        format(/'"readb1" processing ended for now'/
     &    'log file = ',a10/)
          go to 900
        endif
      endif

      reels(itpct)(1:6) = tapein

c... Got 5 tapes yet ????
      if (itpct.lt.5) go to 520

c... Verify tape numbers before going on....
 705  continue
      write(*,710)(reels(ix), ix=1, 5)    
 710  format(/'Input tape numbers are:'/25x,a7/25x,a7/
     &       25x,a7/25x,a7/25x,a7/'Proceed???  [y or n]')
      read(*,'(a1)') yorn
      if (yorn.eq.'y' .or. yorn.eq.'Y') then
c... Keep of trucking.......
            go to 750
      elseif (yorn.eq.'n' .or. yorn.eq.'N') then
c... Go back and get-um again......
            go to 5
      else 
c... What did you say ???????
            go to 705
      endif

 750  continue
      if(logfil.eq.'A00000.log') then
        logfil(1:6)=reels(1) 
        open(11, file=logfil)
      endif

c... Perform stacker routine if 2 - 5 tapes requested...
      if (itpct.gt.1) then
        call stacker (dev, itpct, reel35, ierr)
        if (ierr.eq.0) then
           stop 'CALL STACKER error'
        endif
      else
        write(*,755)  
 755  format(/'               *** Only 1 tape requested ***'
     &       /' Place tape directly into cartridge drive, DO NOT USE ',
     &        'STACKER'/)
      endif

c.........................................................
c........... start of tape processing section ............
c.........................................................

c... "itpx" counts the input tapes as they are processed...
      itpx = 0

 760  continue
      itpx = itpx + 1

c... Processed all the tapes ?????  If YES, go get some more....
      if (itpx.gt.itpct)  go to 5

      reelno = reels(itpx)
      tapeno = reels(itpx)(1:6)

      write(*,8) reelno
      write(11,8) reelno
 8    format('Reading reel ',a7)

      recl=0

      call ftopen(dev,reelno,'SL','R ',ifd,ierr)
      if(ifd.lt.0) then
         write(6,10) dev,ifd,ierr
         write(11,10) dev,ifd,ierr
10       format(' error opening ',a21,2i10/)
         call ftrwnd(ifd,istat)
         call ftcls(ifd,istat,ierr)
         go to 760
      endif
c
c     write(6,20)reelno,ifd,ierr
c     write(11,20)reelno,ifd,ierr
20    format(' open returns ',a7,2i10)
      ieof=1
      incnt = 0
      ioutct = 0
      ifile = 1
      idatafile = 0
c
40    continue
      call ftread(ifd,inbuff,6500,len,ierr)
c     write(*,41) incnt, len, ierr
c41    format('ftread - incnt = ',i5,',  len = ',i5,',  ierr = ',i5)

45    if (len.eq.6440) then
        incnt = incnt + 1
        go to 400 
      endif

      dsskip = .false.

      if (len.eq.80) then
        incnt = incnt + 1
        go to 100
      endif

      if (len.le.0) go to 55

c...A block of data was read whose size was different than those
c...sizes expected (6440 or 80)...
c...Print an error message and skip the remainder of the block....
c...
      incnt = incnt + 1
      write(*,50) len, ifile, incnt, filtyp, currid
      write(11,50) len, ifile, incnt, filtyp, currid
 50   format(/'!!! Unexpected blocksize of ',i6,' in file ',i3,
     +         ', rec ',i5,', ftype ',a4/'!!! skipping file ',
     +         a17/)

c...READ Blocks of data until len is not positive.....
 52   continue
      call ftread(ifd,inbuff,6500,len,ierr)
      if(len.gt.0) then
        incnt = incnt + 1
        go to 52
      endif

c.... TEST NEGATIVE AND ZERO....
 55   continue
      if (len.lt.0) then
        incnt = incnt + 1
c       write(*,60) ifile, incnt, filtyp, len 
        write(11,60) ifile, incnt, filtyp, len, ierr 
 60     format(/'Read error detected - file ',i3,', rec ',i5,
     +         ', ftype ',a4,',  len=',i5,',  ierr=',i5/
     +      'Getting a new input tape'/)
        call ftrwnd(ifd,istat)
        call ftcls(ifd,istat,ierr)
        go to 760
      endif

c..len = 0, an end of file was detected........
c..check for end of tape, incnt = 0.....
      if (incnt.eq.0) then
	write(6,65) reelno
 65     format(/'   End of processing input tape ',a6/)
        write(11,65) reelno
        call ftrwnd(ifd,istat)
        call ftcls(ifd,istat,ierr)
        go to 760
      endif

      write(*,70) ifile, filtyp, incnt
      write(11,70) ifile, filtyp, incnt
 70   format(/'End of input file #',i2,' (',a4,')',i7,' recs') 
 
      incnt = 0
      ioutct = 0
      filtyp = 'UNKN'
      ifile = ifile + 1
      go to 40

c...process the ibm label portion of the data tape....
 100  continue
      call eaconv (inbuff,80)
c     write(*,110)inbufc(1:80)
c     write(11,110)inbufc(1:80)
 110  format(a80)
      if (inbufc(1:2).eq.'EO') then
        filtyp = 'EOF '
      elseif (inbufc(1:2).eq.'HD') then
        filtyp = 'HDR '
        if (inbufc(3:4).eq.'R1') then
          currid = inbufc (5:21)
        endif
      endif
      go to 40
c
c
c..process a data file.
 400  continue
      filtyp = 'DATA'

c...If skipping the file, go back to read until a new file is found..
c...this condition can be true for the 2nd thru last record of a file
c...to skip.
      if(dsskip) go to 40

c...Just read 1st rec of a new file...
c...compute data file number and convert to an integer.

      idatafile = idatafile + 1
      write(fileno,'(i1)') idatafile
      write(*,420)currid 
      write(11,420)currid 
 420  format(/'current data set # is ',a17)
      call b2data
      currid = '00000000000000000'

c...If this file was processed...do some final closeout stuff..
      if(.not.dsskip) then
c...Store input tape no, file no, blocks written, and rewrite the record...
        dsetrec(44:49) = tapeno
        dsetrec(51:51) = fileno
        write(dsetrec(73:76),'(i4)') ioutct
        write(8,'(a80)',rec=idsrno) dsetrec
        close(8)
        close(15)
      endif
      go to 45

 900  continue
      close(11)
      stop
      end

C == EACONV =========================================================== 
C                                                                       
C    TYPE ---- SUBROUTINE           LANGUAGE - VS FORTRAN               
C    VERSION - 1.15                 DATE ----- MARCH 15, 1985          
C    AUTHOR -- GUY GARNETT          COMPANY -- SM SYSTEMS & RESEARCH    
C    CALL BY - GENERAL UTILITY                                          
C    CALL TO - *NONE*                                                   
C    MODS ON - NOVEMBER 7, 1985     MODS BY -- GUY GARNETT (SMSRC)      
C                                                                       
C == PURPOSE ========================================================== 
C       EACONV TAKES INPUT ARRAY 'STRING' AND CONVERTS 'COUNT' BYTES    
C    IN PLACE FROM EBCDIC TO ASCII.  'COUNT' IS RETURNED UNCHANGED.     
C       MODIFIED ON 11/07/85 TO CONFORM TO ANSI X3.4-1977 STANDARD,     
C    BUT WITH ISO 2022 EIGHT BIT EXTENSIONS.                            
C                                                                       
C == DECLARATION ====================================================== 
C                                                                       
       SUBROUTINE EACONV(STRING,COUNT)                                  
       CHARACTER*(*) STRING                                         
       INTEGER*4 COUNT                                                 
C                                                                       
       CHARACTER*1 CTABLE(0:255)                                        
       INTEGER*4   I                                                    
C                                                                       
C == INITIALIZE ======================================================= 
C  CTABLE DEFINES THE TRANSLATION FUNCTION: ASCII = CTABLE(EBCDIC)      
C                                                                       
       DATA CTABLE /                                                    
     * Z00,Z01,Z02,Z03,Z9C,Z09,Z86,Z7F,Z97,Z8D,Z8E,Z0B,Z0C,Z0D,Z0E,Z0F, 
     * Z10,Z11,Z12,Z13,Z9D,Z85,Z08,Z87,Z18,Z19,Z92,Z8F,Z1C,Z1D,Z1E,Z1F, 
     * Z80,Z81,Z82,Z83,Z84,Z0A,Z17,Z1B,Z88,Z89,Z8A,Z8B,Z8C,Z05,Z06,Z07, 
     * Z90,Z91,Z16,Z93,Z94,Z95,Z96,Z04,Z98,Z99,Z9A,Z9B,Z14,Z15,Z9E,Z1A,
     * Z20,ZA0,ZA1,ZA2,ZA3,ZA4,ZA5,ZA6,ZA7,ZA8,Z5B,Z2E,Z3C,Z28,Z2B,Z21, 
     * Z26,ZA9,ZAA,ZAB,ZAC,ZAD,ZAE,ZAF,ZB0,ZB1,Z5D,Z24,Z2A,Z29,Z3B,Z5E, 
     * Z2D,Z2F,ZB2,ZB3,ZB4,ZB5,ZB6,ZB7,ZB8,ZB9,Z7C,Z2C,Z25,Z5F,Z3E,Z3F, 
     * ZBA,ZBB,ZBC,ZBD,ZBE,ZBF,ZC0,ZC1,ZC2,Z60,Z3A,Z23,Z40,Z27,Z3D,Z22, 
     * ZC3,Z61,Z62,Z63,Z64,Z65,Z66,Z67,Z68,Z69,ZC4,ZC5,ZC6,ZC7,ZC8,ZC9, 
     * ZCA,Z6A,Z6B,Z6C,Z6D,Z6E,Z6F,Z70,Z71,Z72,ZCB,ZCC,ZCD,ZCE,ZCF,ZD0, 
     * ZD1,Z7E,Z73,Z74,Z75,Z76,Z77,Z78,Z79,Z7A,ZD2,ZD3,ZD4,ZD5,ZD6,ZD7, 
     * ZD8,ZD9,ZDA,ZDB,ZDC,ZDD,ZDE,ZDF,ZE0,ZE1,ZE2,ZE3,ZE4,ZE5,ZE6,ZE7, 
     * Z7B,Z41,Z42,Z43,Z44,Z45,Z46,Z47,Z48,Z49,ZE8,ZE9,ZEA,ZEB,ZEC,ZED, 
     * Z7D,Z4A,Z4B,Z4C,Z4D,Z4E,Z4F,Z50,Z51,Z52,ZEE,ZEF,ZF0,ZF1,ZF2,ZF3, 
     * Z5C,Z9F,Z53,Z54,Z55,Z56,Z57,Z58,Z59,Z5A,ZF4,ZF5,ZF6,ZF7,ZF8,ZF9, 
     * Z30,Z31,Z32,Z33,Z34,Z35,Z36,Z37,Z38,Z39,ZFA,ZFB,ZFC,ZFD,ZFE,ZFF  
     * /                                                                
C                                                                       
C == CONVERT ========================================================== 
C       USE I TO STEP THROUGH STRING.  EACH BYTE IS TRANSLATED USING    
C    THE CTABLE FUNCTION, AND THEN REPLACED INTO STRING.                
C                                                                       
       DO 1000 I=1,COUNT                                                
            STRING(I:I) = CTABLE(ICHAR(STRING(I:I)))                    
 1000  CONTINUE                                                         
       RETURN                                                           
       END                                                              
C=======================B2DATA=======================
C
      SUBROUTINE B2DATA
C
      include 'b2cntl.inc'

      call get_dsrec

c...Is this a file to process?????
      if (.not.dsskip) call dfile

      return
      end

c----------------------------------------------------------------
      subroutine get_dsrec
c  Purpose:  To read the "data set" record from the appropriate data
c            set file.  File 7 contains a list of the data set id's 
c            and their 10-day data set filename.  File 8 contains the
c            "10-day data set" records.
c            Both files are "direct" access files.  File 7 "tapeids.daf"
c            is direct access in order to do a binary search to locate
c            data set id's more easily.  The "10-day data set" files are
c            direct access be able to update the files after processing
c            a tape file. 
c
      character*80  filout
      character*60  dset_file
      character*11  dsfile
      character*17  dset_id
 
      include 'b2cntl.inc'

 10   continue
      idiff = 8192
      ipos = 8192
      ieq1 = 0

 20   continue
      if (idiff.ne.1) then
        idiff = idiff * .5
      else
        ieq1 = ieq1 + 1
        if (ieq1.gt.1) then
           go to 40
        endif
      endif

c....Total of 9201 records, dont read a rec numbered higher than 9201.
      if (ipos.gt.9201) then
         ipos = ipos - idiff
         go to 20
      endif

      read(7,'(a17,a11)',rec=ipos) dset_id, dsfile

      if(currid.lt.dset_id) then
        ipos = ipos - idiff
      elseif (currid.gt.dset_id) then
             ipos = ipos + idiff
      else
c...found an equal id....
        go to 100
      endif
      go to 20

 40   continue
      write(*,50)currid
      write(11,50)currid
 50   format(//'File skipped!!! No data set rec for HDR1 id ',a17//)
      dsskip = .true.
      return

 100  continue
      dset_file = '/user/lgriffin/isccp/b1_dsets/'//dsfile//'.daf'            
      write(*,110) dset_file
      write(11,110) dset_file
 110  format('Opening data set file ',a60)
      open (8,file=dset_file,status='old',access='direct',
     &      form='formatted',recl=80)
c     f8opn = .true.
      idsrno = 0

 120  continue

c...search for a datset-rec in file 8 that matches the tape label id..
c...When a file has been processed, its tapeno and fileno are stored
c...in the datset-rec.
c...Occasionally duplicate file id's occur and multiple datset-recs occur,
c...the program tries to distinguish one from another by saving the input
c...tapeno and fileno as they are processed.
c...If a file is reprocessed for some reason, the tapeno and fileno must
c...agree and the processing info will again be written in the datset-rec.

      idsrno = idsrno + 1
      read (8,'(a80)', rec=idsrno, err=200)dsetrec 

c...If pos 44 = T, move spaces to 44 - 52...
      if(dsetrec(44:44).eq.'T'.or.dsetrec(44:47).eq.'stop') then
        dsetrec(44:52) = '         '
      endif

      if(currid .ne. dsetrec(26:42)) go to 120
      write(*,121)dsetrec(1:60)
      write(11,121)dsetrec(1:60)
 121  format('eq= ',a60)

c...you've got the right ID....check the tape# and file no...
c...if input tape no is blank, use this datset-rec.
c...if the input tape no and file number match the info in the
c.....datset-rec, use this datset-rec.

      if(dsetrec(44:49).eq.'      ') go to 130
      if(tapeno.eq.dsetrec(44:49).and.fileno.eq.dsetrec(51:51))
     &   go to 130
c...Go back and read another dsetrec.
      go to 120

 130  continue
      write(*,135) dsetrec(1:76)
      write(11,135) dsetrec(1:76)
 135  format(/'ds= ',a76)

      satlte = dsetrec(10:11)
c     filout = '/user/lgriffin/operator/outpt/' // dsetrec(13:42) //
c    &         '.' // tapeno // '.' // fileno
      filout = dsetrec(13:42) // '.' // tapeno // '.' // fileno
      open(15,file=filout,form='unformatted',status='unknown')
      return

 200  continue

c....data file could not be found...skip the tape file..
      close (8)
      write(*,220)currid
      write(11,220)currid
 220  format(//'!!!ERROR ERROR ERROR!!! no matching record in file 8'/
     & '!!! File skipped !!! No data set rec for HDR1 id ',a17//)
      dsskip = .true.
      return

 300  continue
      write(*,310)dset_file
 310  format('error opening unit 8, dsfile',a60)
      stop
      end

C---------------------------------------------------------------------
C   *** SUBROUTINE  : DFILE                                             
C   *** PROGRAMMER  : JEAN GRIMES                                       
C   *** FUNCTION    : TO CREATE AND WRITE TO TAPE THE B2 DATA FILE      
C                     FOR ONE GAC DATASET.                              
C                                                                       
C   *** INCLUSION OF COMMON AREAS ***                                   
C                                                                       
       SUBROUTINE DFILE                                     
       INCLUDE 'b2cntl.inc'                                            
C                                                                       
C   *** DECLARATION OF INTERNAL VARIABLES                               
C                                                                       
       INTEGER*2   INBUFH(3220)                                         
       INTEGER*4   OUTBFF(2034), INBUFF(1610)                                         
       INTEGER*4      NSCANS,NOSCAN,NPHYRC                      
       EQUIVALENCE (INBUFC,INBUFH)                                      
       EQUIVALENCE (OUTBFC,OUTBFF)                                      
       EQUIVALENCE (INBUFC,INBUFF)                                      
C                                                                       
       do 5, i=1, 2034
         outbff(i) = 0
 5     continue
       ovrlay = outbfc

       NSCANS = 0                                                       
C                                                                       
C  *** READ DATASET HEADER FOR THIS DATASET ***                         
C                                                                       
C      CALL FFGET(INBUFC,TFILE,IRECL,*1100)                             
C...This is the 1st rec...its already been read...

       NOSCAN = INBUFH(5)/8                                             
       NPHYRC = NOSCAN/16                                               
       IF (MOD(NOSCAN,16) .NE. 0) NPHYRC = NPHYRC + 1                   
       WRITE(6,10) INBUFH(5),NOSCAN,NPHYRC                              
       WRITE(11,10) INBUFH(5),NOSCAN,NPHYRC                              
 10    FORMAT(1H ,'TOTAL SCANS ',I10 ,'  SAMPLED SCANS ',I6,            
     1 '  PHY REC ',I6)                                                 
c
c  *** Store NOSCAN and NPHYRC in the datset-rec....
c
       write(dsetrec(65:72),'(2i4)') NOSCAN, NPHYRC
C                                                                       
C  *** CALL SUBROUTINE TO CREATE THE DATA FILE HEADER ***               
C                                                                       
       CALL DFHEAD                                                      
C                                                                       
C  *** FOR EACH PHYSICAL RECORD TO BE CREATED, PRODUCE PHYSICAL ***     
C      RECORD HEADER AND THE 16 LOGICAL RECORDS.                        
C                                                                       
       DO 1000 I = 1,NPHYRC                                             
c           CALL FFGET(INBUFC,TFILE,IRECL,*1100)                        
            call ftread (ifd, inbuff, 6500, len, ierr)
            if(len.ne.6440) go to 1100

            incnt = incnt + 1
            CALL PRHEAD(I)                                       
            DO 500 J = 1,16                                             
               SCANCT = SCANCT + 1                                      
C                                                                       
C  *** UNUSED LOGICAL RECORDS IN THE LAST PHYSICAL RECORD ARE ZERO ***  
C      FILLED.                                                          
C                                                                       
               IF (NSCANS .GT. NOSCAN) THEN                             
                  DO 100 M=1,126                                        
                     OUTBFF(18+(J-1)*126+M) = 0                         
 100              CONTINUE                                              
               ELSE                                                     
C                                                                       
C  *** READ THE NEXT RECORD, CREATE THE LOGICAL RECORD HEADER AND ***   
C      DATA GROUP VIA SUBROUTINES, BOTH OF THESE ARE PLACED IN THE      
C      LOGICAL RECORD BUFFER.                                           
C                                                                       
c                 IF (J .NE. 1) CALL FFGET(INBUFC,TFILE,IRECL,*1100)    
                  if (j .ne. 1) then
                    call ftread (ifd, inbuff, 6500, len, ierr)
                    if(len.ne.6440) go to 1100
                    incnt = incnt + 1
                  endif

                  CALL LHEADR(J)                                        
                  CALL DGROUP                                           
                  NSCANS = NSCANS + 1                                   
C                                                                       
C  *** MOVE THE LOGICAL RECORD INTO THE OUTPUT BUFFER ***               
C                                                                       
                  DO 200 L=1,504                                        
                     LL = 72+(J-1)*504+L                                
                     OUTBFC(LL:LL)=LOGREC(L:L)                          
 200              CONTINUE                                              
C                                                                       
C  *** PASS OVER THE NEXT 3 RECORDS SO THAT EVERY EIGHTH SCAN LINE ***  
C      IS SAMPLED.                                                      
C                                                                       
                  IF (I .NE. NPHYRC) THEN                               
                    DO 300 K=1,3                                        
c                      CALL FFGET(INBUFC,TFILE,IRECL,*1100)             
                       call ftread (ifd, inbuff, 6500, len, ierr)
                       if(len.eq.6440) then
                         incnt = incnt + 1
                       elseif (len.eq.0) then 
                           go to 1100
                       else
                         write(11,290) len, ierr, ifile, incnt
 290                     format(/'!!! Unexpected blocksize of ',i6,
     +                     '  ierr=',i5,'  in file ',i3,
     +                     ', rec ',i5)
                         incnt = incnt + 1
                       endif

 300                CONTINUE                                            
                  ENDIF                                                 
               ENDIF                                                    
 500         CONTINUE                                                   
C                                                                       
C  *** WRITE THE OUTPUT BUFFER TO TAPE ***                              
C                                                                       
c            CALL FFPUT(OUTBFC,20,8136)                                 
c            write(15,'(a8136)') OUTBFC
             write (15) (OUTBFF(II), II=1, 2034)
             ioutct = ioutct + 1
             outbfc = ovrlay
 1000  CONTINUE                                                         
 1100  CONTINUE                                                         
c      IFILE = IFILE + 1                                                
c      CALL FFPOSN(2,20,IFILE)                                          

c....if len = 6440 then end of input file not reached...keep reading..
       if (len.eq.6440) then      
         call ftread (ifd, inbuff, 6500, len, ierr)
         incnt = incnt + 1
         go to 1100
       endif

c....len not = 6440, assume its the end of file....
       write(*,1130)incnt,ioutct
       write(11,1130)incnt,ioutct
 1130  format(/'End of Data File - ',i8,' blks in    ',i8,' blks out')
       RETURN                                                           
       END                                                              

c---------------------------------------------------------------
c---------------------------------------------------------------
C  *** SUBROUTINE  : DFHEAD                                             
C  *** PROGRAMMER  : JEAN GRIMES                                        
C  *** FUNCTION    : TO CREATE AND WRITE TO TAPE THE DATA FILE HEADER   
C                                                                       
C  MODIFICATIONS: SEPTEMBER  1, 1988 BY KEVIN LANGLOIS (SMSRC)          
C                 THIS COMMON WAS MODIFIED TO INCLUDE NOAA10(NG) AND    
C                 NOAA11(NH) SAT-ID'S.                                  
C                                                                       
C                 MAY 14, 1991 BY GEOF GOODRUM (SDSD)                   
C                 REMOVED C$B2CNS COMMON AND SAT-ID VARIABLES. FIXED    
C                 SATELLITE CHANNEL COUNT ROUTINE. FIXED CHANNEL        
C                 WAVELENGTH ROUTINE. ADDED MORE EFFICIENT IF BLOCK     
C                 FOR SAT-IDS.                                          
C                                                                       
C*********************************************************************  
C                                                                       
       SUBROUTINE DFHEAD                                                
C                                                                       
C  *** INCLUSION OF COMMON AREAS ***                                    
C                                                                       
       INCLUDE 'b2cntl.inc'                                             
C                                                                       
C  *** DECLARATION OF INTERNAL VARIABLES ***                            
C                                                                       
       INTEGER*4   DFHDR(2034), NCHSAT(6:12)                            
       EQUIVALENCE (OUTBFC,DFHDR)                                      
C                                                                       
C  *** DATA STATEMENTS ***                                              
C                                                                       
       DATA NCHSAT/4,5,4,5,4,5,5/                                       
C                                                                       
C  CREATE SATELLITE ID FIELD ENTRY                                      
C                                                                       
       IF (SATLTE .EQ. 'ND') THEN                                       
          DFHDR(1) = 12                                                 
       ELSE IF (SATLTE .EQ. 'NH') THEN                                  
          DFHDR(1) = 11                                                 
       ELSE IF (SATLTE .EQ. 'NG') THEN                                  
          DFHDR(1) = 10                                                 
       ELSE IF (SATLTE .EQ. 'NF') THEN                                  
          DFHDR(1) = 9                                                  
       ELSE IF (SATLTE .EQ. 'NE') THEN                                  
          DFHDR(1) = 8                                                  
       ELSE IF (SATLTE .EQ. 'NC') THEN                                  
          DFHDR(1) = 7                                                  
       ELSE IF (SATLTE .EQ. 'NA') THEN                                  
          DFHDR(1) = 6                                                  
       ELSE                                                             
          WRITE (6,*) '>>> UPDATE DFHEAD SOURCE CODE <<<'               
          STOP                                                          
       ENDIF                                                            
C                                                                       
C  CREATE CHANNEL COUNT ENTRY                                           
C                                                                       
       DFHDR(2)=NCHSAT(DFHDR(1))                                        
C                                                                       
       DFHDR(3) = 0                                                     
       DFHDR(4) = 0                                                     
C                                                                       
C  *** SPECTRAL BAND WIDTH RANGE IN 1000TH OF A MICROMETER ***          
C  *** CONTAINS TWO WORDS, LOW VALUE AND HIGH VALUE                     
C                                                                       
C  *** CHANNEL 1 ***                                                    
C                                                                       
       DFHDR(5) = 580                                                   
       DFHDR(6) = 680                                                   
C                                                                       
C  *** CHANNEL 2 ***                                                    
C                                                                       
       DFHDR(7) = 725                                                   
       DFHDR(8) = 1100                                                  
C                                                                       
C  *** CHANNEL 3 ***                                                    
C                                                                       
       DFHDR(9) = 3550                                                  
       DFHDR(10) = 3930                                                 
C                                                                       
C  *** CHANNEL 4 AND 5 ***                                              
C                                                                       
       IF (DFHDR(2) .EQ. 4) THEN                                        
          DFHDR(11) = 10500                                             
          DFHDR(12) = 11500                                             
C ** FOR NOAA 6/8/10, CHANNEL 4 VALUES ARE REPEATED FOR CHANNEL 5 **    
          DFHDR(13) = 10500                                             
          DFHDR(14) = 11500                                             
       ELSE                                                             
          DFHDR(11) = 10300                                             
          DFHDR(12) = 11300                                             
          DFHDR(13) = 11500                                             
          DFHDR(14) = 12500                                             
       ENDIF                                                            
C                                                                       
C *** WRITE FOR DEBUGGING ONLY ***                                      
C      DO 100 I = 1,14                                                  
C         WRITE(6,200) I,DFHDR(I)                                       
C100   CONTINUE                                                         
C200   FORMAT(1H ,'I =',I2,'  HDR(I)= ',I8)                             
C                                                                       
C      CALL FFPUT(DFHDR,20,8136)                                        
c      write (15,'(a8136)') OUTBF
       write (15) (DFHDR(II), II=1, 2034)
       ioutct = ioutct + 1
       OUTBFC = OVRLAY
       RETURN                                                           
       END                                                              
c-------------------------------------------------------------
C   *** SUBROUTINE  : PRHEAD                                               
C   *** PROGRAMMER  : JEAN GRIMES                                          
C   *** FUNCTION    : TO CREATE THE PHYSICAL RECORD HEADER AND PLACE        
C                   : IT IN THE OUTPUT BUFFER                              
C                                                                          
C  MODIFICATIONS: SEPTEMBER  1, 1988 BY KEVIN LANGLOIS (SMSRC)             
C                 THIS COMMON WAS MODIFIED TO INCLUDE NOAA10(NG) AND       
C                 NOAA11(NH) SAT-ID'S.                                     
C                                                                          
C                 MAY 14, 1991 BY GEOF GOODRUM (SDSD)                      
C                 REMOVED C$B2CNS COMMON AND SAT-ID VARIABLES. REWROTE      
C                 SAT-ID IF BLOCK TO INCREASE READABILITY AND              
C                 EFFICIENCY.                                              
C                                                                          
C**********************************************************************   
C                                                                          
       SUBROUTINE PRHEAD(SEQNO)                                     
C                                                                          
C *** INCLUSION OF BLOCK DATA ***                                          
C                                                                          
       INCLUDE 'b2cntl.inc'                                                
C                                                                          
C *** DECLARATION OF INTERNAL PARAMETERS                                   
C                                                                          
       INTEGER*4 SEQNO,ITIME                                         
       INTEGER*4 IDATE                                                 
       CHARACTER*1 BLANK                                                   
       CHARACTER*11 DATIM                                                   
       INTEGER*2    INBUFH(3220),OUTBFH(4068),DATEH                        
       INTEGER*4    OUTBFF(2034)                                   
       EQUIVALENCE (INBUFC,INBUFH)                                         
       EQUIVALENCE (OUTBFC,OUTBFH)                                         
       EQUIVALENCE (OUTBFC,OUTBFF)                                         
C                                                                          
       DATA BLANK/' '/                                                     
C
C                                                                          
C  *** BLANK OUT THE OUTPUT BUFFER SINCE UNUSED BYTES CONTAIN BLANKS ***   
C                                                                          
       DO 100 I = 1,72                                                     
          OUTBFC(I:I) = BLANK                                              
 100   CONTINUE                                                            
C                                                                          
C  *** BYTE 1 AND 2 CONTAIN THE PHYSICAL RECORD SEQUENCE NUMBER ***        
       OUTBFH(1) = SEQNO                                                   
C  *** BYTE 4 CONTAINS THE SATELLITE ID                                    
       IF (SATLTE .EQ. 'ND') THEN                                          
          OUTBFC(4:4) = CHAR(12)                                           
       ELSE IF (SATLTE .EQ. 'NH') THEN                                     
          OUTBFC(4:4) = CHAR(11)                                           
       ELSE IF (SATLTE .EQ. 'NG') THEN                                     
          OUTBFC(4:4) = CHAR(10)                                           
       ELSE IF (SATLTE .EQ. 'NF') THEN                                     
          OUTBFC(4:4) = CHAR(9)                                            
       ELSE IF (SATLTE .EQ. 'NE') THEN                                     
          OUTBFC(4:4) = CHAR(8)                                            
       ELSE IF (SATLTE .EQ. 'NC') THEN                                     
          OUTBFC(4:4) = CHAR(7)                                            
       ELSE IF (SATLTE .EQ. 'NA') THEN                                     
          OUTBFC(4:4) = CHAR(6)                                            
       ELSE                                                                
          WRITE (6,*) '>>> UPDATE PRHEAD SOURCE CODE <<<'                  
          STOP                                                             
       ENDIF                                                               
C                                                                          
C  *** BYTES 7 THRU 12 CONTAIN THE DATE AND TIME GROUP OF ***              
C      FIRST SCAN IN PHYSICAL RECORD                                       
       OUTBFC(7:12) = INBUFC(3:8)                                          
C                                                                          
C  *** FIND OUT CURRENT DATE AND TIME **                                   
C                                                                          
       CALL DAYTIM(DATIM)                                      
       READ(UNIT=DATIM,FMT=50)YR, JDAY, HR, MIN, SEC                  
 50    FORMAT(I2,I3,3I2)                  
c
c  ** Store date/time in dsetrec....
c
       dsetrec(53:63) = DATIM
C                                                                          
C  ** COMPUTE GMT TIME OF DAY IN MILLISECONDS                              
C                                                                          
       ITIME = ((HR*3600) + (MIN*60) + SEC) * 1000                         
c      write(11,65) YR,JDAY,HR,MIN,SEC,ITIME
 65    format('YR/JDAY/HR/MIN/SEC = ',5i4,'  ITIME = ',I10)
       OUTBFF(5) = ITIME                                                   
C                                                                      
C ** PUT DATE IN PROPER FORMAT                                      
C                                                                     
       IDATE = ISHFT(YR,9)                                           
       DATEH = IOR(IDATE,JDAY)                                        
       OUTBFH(8) =DATEH                                                    
C                                                                          
C ** CONVERT DATASET NAME TO ASCII AND PLACE IN OUTPUT BUFFER         
C                                                                          
c      DATSET(1:42) = DSN(DSNNUM)(1:42)                                    
C                                                                          
C                                                                          
C      IF ((DSNNUM .EQ. 1) .AND. (SEQNO .LT. 6)) WRITE(6,101)              
C    1 OUTBFC(1:20),DATSET                                                 
C101   FORMAT(1H ,' PHYSICAL RECORD HDR ',Z40,/,'  DSN IN PRHEAD ',        
C    1 A42)                                                                
c      CALL EACONV(DATSET,42)                                              
       OUTBFC(21:62) = DSETREC(1:42)                             
       RETURN                                                              
       END                                                                 

c--------------------------------------------------------------
C  *** SUBROUTINE  : LHEADR                                                
C  *** PROGRAMMER  : JEAN GRIMES                                           
C  *** FUNCTION    : TO CREATE THE LOGICAL RECORD HEADER AND PLACE         
C                  : IT IN THE LOGICAL RECORD BUFFER. THIS SUBROUTINE      
C                  : WILL FORM ONLY THE FIRST PART OF THE LOGICAL RECORD   
C                  : BUFFER.  THE SUBROUTINE DGROUP WILL CREATE THE        
C                  : SECOND HALF OF THE BUFFER.                            
C                                                                          
       SUBROUTINE LHEADR(SEQNO)                                            
C                                                                          
C  *** INCLUSION OF COMMON AREAS                                           
C                                                                          
       INCLUDE 'b2cntl.inc'                                                
C                                                                          
C  *** DECLARATION OF INTERNAL VARIABLES                                   
C                                                                          
       INTEGER*4 SEQNO,K                                                   
       INTEGER*2 LOGRCH(252)                                            
       EQUIVALENCE (LOGRCH,LOGREC)                                         
C                                                                          
C  *** LOGICAL RECORD SEQUENCE NUMBER IS IN BYTES 1 AND 2 ***              
       LOGRCH(1) = SEQNO                                                   
C                                                                          
C  *** BYTES 3 THRU 52 ARE IN THE SAME FORMAT AS THEY ARE IN THE ***       
C      GAC RECORD. CONTAINS DATE & TIME GROUP, DATA QUALITY INDICATORS     
C      AND CALIBRATION COEFFICIENTS.                                       
C                                                                          
       LOGREC(3:52) = INBUFC(3:52)                                         
C                                                                          
C  ** BYTES 53 TO 69 CONTAIN 17 SOLAR ZENITH ANGLES CORRESPONDING TO       
C     EVERY FOURTH SAMPLED SAMPLE POINT STARTING WITH THE FIRST SAMPLED    
C     SAMPLE POINT AND ENDING WITH THE LAST.                               
C                                                                          
       I = 53                                                              
       DO 100 K = 55,103,3                                                 
          LOGREC(I:I) = INBUFC(K:K)                                        
          I = I + 1                                                        
 100   CONTINUE                                                            
C                                                                          
C  *** BYTES 70 TO 72 ARE ZERO FILLED ***                                  
C                                                                          
       DO 200 I = 70,72                                                    
          LOGREC(I:I) = CHAR(0)                                            
 200   CONTINUE                                                            
C                                                                          
C  *** BYTES 73 TO 140 CONTAIN THE 17 EARTH LOCATION GROUPS ***            
C                                                                          
       I = 73                                                              
       DO 300 K = 109,305,12                                               
          LOGREC(I:I+3) = INBUFC(K:K+3)                                    
          I = I + 4                                                        
 300   CONTINUE                                                            
C                                                                          
C  *** BYTES 141 TO 152 ARE ZERO FILLED ***                                
C                                                                          
       DO 400 I = 141,152                                                  
          LOGREC(I:I) = CHAR(0)                                            
 400   CONTINUE                                                            
C                                                                          
C  *** THIS WRITE IS FOR DEBUGGING PURPOSES ONLY ***                       
C                                                                          
c      IF (SCANCT .LT. 6) WRITE(11,402) INBUFC(1:50),INBUFC(51:100),        
c    1 INBUFC(101:150),INBUFC(151:200),INBUFC(201:250),INBUFC(251:300),    
c    2 INBUFC(301:308)                                                     
c402   FORMAT(1H ,'INPUT BUFFER:',/,' ',Z100,/,' ',Z100,/,' ',             
c    1 Z100,/,' ',Z100,/,' ',Z100,/,' ',Z100,/,' ',Z16,/,/,/)              
c      IF (SCANCT .LT. 6) WRITE(11,401) LOGREC(1:50),LOGREC(51:100),        
c    1 LOGREC(101:150),LOGREC(151:152)                                     
c401   FORMAT(1H ,'LOGICAL RECORD HEADER:',/,' ',Z100,/,' ',Z100,/,' ',    
c    1 Z100,/,' ',Z4)                                                      
       RETURN                                                              
       END                                                                 

c--------------------------------------------------------------
C  *** SUBROUTINE  : DGROUP                                                
C  *** PROGRAMMER  : JEAN GRIMES (SMSRC)                                   
C  *** FUNCTION    : TO SAMPLE THE GAC VIDEO DATA AND FORM THE             
C                  : DATA GROUP AND PLACE IT IN THE LATER HALF OF THE      
C                  : LOGICAL RECORD BUFFER.                                
C                                                                          
C  *** INCLUDE COMMON AREAS ***                                            
C                                                                          
       SUBROUTINE DGROUP                                                   
       INCLUDE 'b2cntl.inc'                                                
C                                                                         
C  *** DECLARATION OF INTERNAL VARIABLES ***                               
C                                                                          
       INTEGER*4 INBUFF(1610),LOGRCF(126),CHAN(5)                         
       INTEGER*4 FWORD,TWO,STATUS,EMPTY,QUATER,HALF,THRQTR,CHANEL          
       EQUIVALENCE(INBUFC,INBUFF)                                          
       EQUIVALENCE(LOGREC,LOGRCF)                                          
C                                                                          
C  *** INITIALIZATION OF INTERNAL VARIABLES ***                            
C                                                                          
       DATA TWO/Z0002/,EMPTY/0/,QUATER/1/,HALF/2/,THRQTR/3/                
C                                                                          
C  *** THE CHANNEL DATA IS SAMPLED TO EVERY SIXTH SAMPLE AND UNPACKED      
C      BEGINNING WITH SAMPLE NUMBER 13 AND ENDING WITH SAMPLE NUMBER       
C      397.  THE CHANNEL DATA IS PACKED 3 TO A FULLWORD IN THE INPUT       
C      BUFFER. THE LOGICAL RECORD CONTAINS THE LOGICAL HEADER IN BYTES     
C      NUMBER 1 TO 152.                                                    
C                                                                          
       STATUS = EMPTY                                                      
       LOGPTR = 39                                                         
       DO 200 K = 133,773,10                                               
          FWORD = INBUFF(K)                                                
          DO 50 I = 1,3                                                    
             CHAN(I) = ISHFT(FWORD,2+10*(I-1))                             
             CHAN(I) = ISHFT(CHAN(I),-22)                                  
 50       CONTINUE                                                         
          FWORD = INBUFF(K+1)                                              
          CHAN(4) = ISHFT(FWORD,2)                                         
          CHAN(4) = ISHFT(CHAN(4),-22)                                     
          CHAN(5) = ISHFT(FWORD,12)                                        
          CHAN(5) = ISHFT(CHAN(5),-22)                                     
C                                                                          
C  ***  THE CHANNEL DATA IS ROUNDED TO 8 BITS FROM 10 BITS                 
C                                                                          
          DO 100 I = 1,5                                                   
             IF (IAND(CHAN(I),TWO) .EQ. 0) THEN                           
                   CHAN(I) = ISHFT(CHAN(I),-2)                             
                ELSE                                                       
                   CHAN(I) = ISHFT(CHAN(I),-2) + 1                         
                ENDIF                                                      
C                                                                          
C  *** THE CHANNEL DATA IS PACKED ONE PER BYTE IN THE ORDER CH1,CH2,       
C      CH3,CH4,CH5.                                                        
C                                                                          
                                                                           
             IF (STATUS .EQ. EMPTY) THEN                                   
                CHANEL = ISHFT(CHAN(I),24)                                 
                STATUS = QUATER                                            
                ELSE                                                       
                IF (STATUS .EQ. QUATER) THEN                               
                   CHANEL = IOR(CHANEL,ISHFT(CHAN(I),16))                  
                   STATUS = HALF                                           
                   ELSE                                                    
                   IF (STATUS .EQ. HALF) THEN                              
                      CHANEL = IOR(CHANEL,ISHFT(CHAN(I),8))                
                      STATUS = THRQTR                                      
                      ELSE                                                 
                      IF (STATUS .EQ. THRQTR) THEN                         
                         CHANEL = IOR(CHANEL,CHAN(I))                      
                         LOGRCF(LOGPTR) = CHANEL                           
                         CHANEL = 0                                        
                         STATUS = EMPTY                                    
                         LOGPTR = LOGPTR + 1                               
                      ENDIF                                                
                   ENDIF                                                   
                ENDIF                                                      
             ENDIF                                                         
 100      CONTINUE                                                         
 200   CONTINUE                                                            
C                                                                          
       LOGRCF(LOGPTR) = CHANEL                                             
C                                                                          
C  *** BYTES 326 TO 352 ARE ZERO FILLED                                    
C                                                                          
       DO 500 I = 121,126                                                  
          LOGRCF(I) = 0                                                    
 500   CONTINUE                                                            
c      IF (SCANCT .LT. 6) THEN                                             
c         WRITE(11,801) INBUFC(449:498),INBUFC(499:548),INBUFC(549:598),    
c    1     INBUFC(599:648)                                                 
c         WRITE(11,802) LOGREC(153:202),LOGREC(203:252),LOGREC(253:302),    
c    1     LOGREC(303:352),LOGREC(353:402),LOGREC(403:452),                
c    2     LOGREC(453:502),LOGREC(503:504)                                 
c      ENDIF                                                               
c801   FORMAT(1H ,'GAC VIDEODATA',/,' ',Z100,/,' ',Z100,/,' ',Z100,/,      
c    1 ' ',Z100,/)                                                         
c802   FORMAT(1H ,'DATA GROUP',/,' ',Z100,/,' ',Z100,/,' ',Z100,/,         
c    1' ',Z100,/,' ',Z100,/,' ',Z100,/,' ',Z100,/,' ',Z4,/)                
       RETURN                                                              
       END                                                                 
