*
* $Id: fmkadt.F,v 1.1.1.1 1996/03/07 15:17:43 mclareni Exp $
*
* $Log: fmkadt.F,v $
* Revision 1.1.1.1  1996/03/07 15:17:43  mclareni
* Fatmen
*
*
#include "fatmen/pilot.h"
      SUBROUTINE FMKADT
#include "fatmen/faust.inc"
#include "fatmen/fatpara.inc"
#include "fatmen/fatbug.inc"
#include "fatmen/fatloc.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*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)
      DIMENSION     IVECT(10)
      DATA          NENTRY/0/
      SAVE          NENTRY
*
*     Get tape specific parameters
*
      CALL KUGETC(VSN,LVSN)
      IF(LVSN.EQ.0) RETURN
      CALL KUGETC(VID,LVID)
      IF (VID(1:LVID) .EQ. 'VSN') THEN
         VID = VSN
         LVID = LVSN
      ENDIF
*
*     Has a VID prefix been given?
*
      JVIDP = INDEX(VID(1:LVID),'.')
      IF(JVIDP.NE.0) THEN
         VIP  = VID(1:JVIDP-1)
         LVIP = JVIDP - 1
         VID  = VID(JVIDP+1:LVID)
         LVID = LVID-JVIDP
         JP   = ICNTH(VIP(1:LVIP),PREVID,NTMS)
      ELSE
         JP   = 0
      ENDIF
 
      CALL KUGETI(FSEQ)
 
*     Add a new file to the FATMEN file catalogue
*
      CALL KUGETC(GNAME,LGNAME)
      IF(LGNAME.EQ.0) RETURN
 
      NFADDT = NFADDT + 1
*
*     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 *,'FMKADT. ',
     +      '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)
      CALL KUGETI(LOCCOD)
      CALL KUGETI(IVECT(1))
      CALL KUGETI(IVECT(2))
      CALL KUGETI(IVECT(3))
      CALL KUGETI(IVECT(4))
      CALL KUGETI(IVECT(5))
      CALL KUGETI(IVECT(6))
      CALL KUGETI(IVECT(7))
      CALL KUGETI(IVECT(8))
      CALL KUGETI(IVECT(9))
      CALL KUGETI(IVECT(10))
*
*     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
*
*     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+MLOCFA) = LOCCOD
      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
*
*     Userwords
*
      CALL UCOPY(IVECT(1),IQ(LADDBK+MUSWFA),10)
*
*     Display entry
*
      IF(IDEBFA.GE.3) THEN
         CALL FMUPKY(GNAME,LADDBK,KEYS,IRC)
         CALL FMSHOW(GNAME,LADDBK,KEYS,'A',IRC)
      ENDIF
*
*     Output this entry
*
      CALL FMPUT(GNAME,LADDBK,IRC)
*
*     Reset current directory
*
      CALL RZCDIR(PREDIR(1:LENOCC(PREDIR)),' ')
 
      END