*
* $Id: fmkatt.F,v 1.1.1.1 1996/03/07 15:17:43 mclareni Exp $
*
* $Log: fmkatt.F,v $
* Revision 1.1.1.1  1996/03/07 15:17:43  mclareni
* Fatmen
*
*
#include "fatmen/pilot.h"
      SUBROUTINE FMKATT
#include "fatmen/fatpara.inc"
#include "fatmen/fatsys.inc"
#include "fatmen/fatbug.inc"
#include "fatmen/fatloc.inc"
#include "fatmen/fattyp.inc"
      PARAMETER (LURCOR=200000)
      COMMON/CRZT/IXSTOR,IXDIV,IFENCE(2),LEV,LEVIN,BLVECT(LURCOR)
      DIMENSION    LQ(999),IQ(999),Q(999)
      EQUIVALENCE (IQ(1),Q(1),LQ(9)),(LQ(1),LEV)
#include "fatmen/fatron.inc"
#include "fatmen/fatusr.inc"
      COMMON /QUEST/IQUEST(100)
      CHARACTER*255 GNAME,DSN,CHPATH,GNAME2
      CHARACTER*255 PATHN
      CHARACTER*20  FNAME
      CHARACTER*4   FFORM
      CHARACTER*8   HOSTN
      INTEGER       CPLEV,FSEQ
      CHARACTER*8   POOL,LIB
      CHARACTER*6   VSN
      CHARACTER*15  VID
      CHARACTER*8   VIP
      CHARACTER*255 PREDIR
#include "fatmen/fatvidp.inc"
      CHARACTER*4   RECFM
      INTEGER       LRECL,BLOCK,FSIZE
      CHARACTER*80  COMM
      PARAMETER     (LKEYFA=10)
      DIMENSION     KEYS(LKEYFA)
      DATA          NENTRY/0/
      SAVE          NENTRY
#include "fatmen/fatinit.inc"
*
*     Get tape specific parameters
*
      CALL KUGETC(POOL,LPOOL)
      IF(LPOOL.EQ.0) RETURN
      CALL KUGETC(LIB,LLIB)
      IF(LLIB.EQ.0) RETURN
*
*     Add a new file to the FATMEN file catalogue
*
      CALL KUGETC(GNAME,LGNAME)
      IF(LGNAME.EQ.0) RETURN
*
*     GNAME is in current directory, if full path name not specified
*
 
      CALL FMFIXF(GNAME,GNAME2)
      GNAME  = GNAME2
      LGNAME = LENOCC(GNAME)
      IF(IDEBFA.GE.0) PRINT *,GNAME(1:LGNAME)
 
      CALL KUGETC(DSN,  LDSN)
      IF(LDSN.EQ.0) THEN
         IF(IDEBFA.GE.0) PRINT *,'FMKATT. ',
     +      'Dataset name will be generated by FATMEN'
      CALL FMFNM(DSN)
      LDSN = LENOCC(DSN)
      ENDIF
      CALL KUGETC(FFORM,LFFORM)
      CALL KUGETI(CPLEV)
      CALL KUGETC(HOSTN,LHOSTN)
      CALL KUGETC(COMM,LCOMM)
      CALL KUGETC(RECFM,LRECFM)
      CALL KUGETI(LRECL)
      CALL KUGETI(BLOCK)
      CALL KUGETI(FSIZE)
      CALL KUGETI(MEDIA)
*
*     Save current directory
*
      CALL RZCDIR(PREDIR,'R')
 
      IF(NENTRY.EQ.0) THEN
         JBIAS = 2
         CALL FMBOOK(GNAME,KEYS,LADDBK,LSUP,JBIAS,IRC)
         NENTRY = 1
         ELSE
         CALL FMFILL(GNAME,LADDBK,KEYS,'A',IRC)
         ENDIF
*
*     Try to allocate a new tape
*
      IF(IDEBFA.GE.0) PRINT *,'FMKATT. trying to allocate a ',
     +   CHMTYP(MEDIA),' from pool ',POOL(1:LPOOL),
     +   ' in library ',LIB(1:LLIB),'...'
 
      CALL FMALLO(CHMTYP(MEDIA),' ',' ',LIB(1:LLIB),POOL(1:LPOOL),
     +            LADDBK,' ',VSN,VID,IRC)
 
      IF(IRC.NE.0) THEN
         IF(IDEBFA.GE.-3) PRINT *,'FMKATT. return code ',IRC,
     +      ' from FMALLO'
         RETURN
      ELSE
         IF(IDEBFA.GE.-1) PRINT *,'FMKATT. allocated VSN/VID = ',
     +      VSN,' ',VID
      ENDIF
 
      LVSN = LENOCC(VSN)
      LVID = LENOCC(VID)
 
      JP   = 0
      FSEQ = 1
*
*     Override various fields as required
*
      IF(LDSN.GT.0) THEN
        CALL VBLANK(IQ(LADDBK+MFQNFA),NFQNFA/4)
        CALL UCTOH(DSN,IQ(LADDBK+MFQNFA),4,LDSN)
        ENDIF
 
      IF (HOSTN(1:8) .NE. 'THISNODE') THEN
         CALL VBLANK(IQ(LADDBK+MHSNFA),NHSNFA/4)
         CALL UCTOH(HOSTN,IQ(LADDBK+MHSNFA),4,LHOSTN)
         ENDIF
 
      CALL UCTOH(FFORM,IQ(LADDBK+MFLFFA),4,LFFORM)
      IQ(LADDBK+MCPLFA) = CPLEV
      IQ(LADDBK+MMTPFA) = 1
      IQ(LADDBK+MLOCFA) = 1
      KEYS(MKCLFA)      = CPLEV
 
      IF(NUMLOC.EQ.1) THEN
         IQ(LADDBK+MLOCFA) = MFMLOC(1)
         KEYS(MKLCFA)      = MFMLOC(1)
      ENDIF
 
      CALL VBLANK(IQ(LADDBK+MUCMFA),NUCMFA/4)
      CALL UCTOH(COMM,IQ(LADDBK+MUCMFA),4,LCOMM)
 
      CALL UCTOH(RECFM,IQ(LADDBK+MRFMFA),4,LRECFM)
      IQ(LADDBK+MRLNFA) = LRECL
      IQ(LADDBK+MBLNFA) = BLOCK
      IQ(LADDBK+MFSZFA) = FSIZE
 
         CALL UCTOH(VSN,IQ(LADDBK+MVSNFA),4,LVSN)
         CALL UCTOH(VID,IQ(LADDBK+MVIDFA),4,LVID)
         IQ(LADDBK+MVIPFA) = JP
         IQ(LADDBK+MFSQFA) = FSEQ
*        IQ(LADDBK+MMTPFA) = 2
         IQ(LADDBK+MMTPFA) = MEDIA
 
*
*     Display entry
*
      IF(IDEBFA.GE.3) CALL FMSHOW(GNAME,LADDBK,KEYS,'A',IRC)
*
*     Output this entry
*
      CALL FMPUT(GNAME,LADDBK,IRC)
*
*     Reset current directory
*
      CALL RZCDIR(PREDIR(1:LENOCC(PREDIR)),' ')
 
      END