C   Purpose   :<TITLE>get file name from known File-ID (f,s,v)</TITLE>
C      OPTIONS /EXTEND_SOURCE
CDEC$ NOFREEFORM
CDEC$ FIXEDFORMLINESIZE:132
      PROGRAM FID2NAME
C
C=========================================
C
C   Purpose   :get file name from known File-ID (f,s,v)
C   Inputs    : DCL foreign command line
C          FID2NAME/SYMBOL=symbol disk/FID=(f,s,v)
C          default disk is SYS$DISK:
C          default symbol is FILE_NAME
C
C        Copyright (C) 2006   Joseph Huber (huber AT mppmu.mpg.de)

C This program is free software; you can redistribute it and/or modify
C it under the terms of the GNU General Public License as published by
C the Free Software Foundation; either version 2 of the License, or
C (at your option) any later version.
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C=========================================
C +
C
C Update 2007-12-04: make it working for FID>32367 (24 bit numbers)
C Declarations.
C -
      IMPLICIT NONE
      integer fid2name_table    
!DEC$ if defined (VAX)
      external fid2name_table   !older VAX Fortran
!DEC$ else
!DEC$ attributes extern :: fid2name_table
!DEC$ endif

!      include 'FID2NAME_COMMON.FOR'
      INCLUDE '($libdef)'
      INCLUDE '($SSdef)'
      INCLUDE '($STSDEF)'
      INCLUDE '($IOdef)'
      INCLUDE '(LIB$ROUTINES)'
      INCLUDE '(STR$ROUTINES)'
      INCLUDE '($CLIDEF)'
      INCLUDE '(CLI$routines)'
      INCLUDE '($FIDDEF)'

      CHARACTER*4096 name
      CHARACTER*48 disk
      CHARACTER*32 symbol
      INTEGER i,code,iostat,id
      INTEGER*2 chan,ll,lld,lln,lls
      record /FIDDEF/ FID
      
      integer iostat_to_status
      external iostat_to_status
      integer init_cli_for
      external init_cli_for
      integer sys$assign
      external CLI$_NEGATED
C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
C Entry Point.
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      ll = 0
      code = init_cli_for(fid2name_table,'FID2NAME')
      IF (.NOT.code) CALL exit(code)

      IF (cli$present('HELP')) THEN
       PRINT *,' FID2NAME[/SYMBOL=sym][/LOG] [disk:]/FID=(f,s,v)'
       PRINT *,' Puts the name of the file given by file-ID FID'
       PRINT *,' into DCL symbol specified by sym.'
       PRINT *,' Default symbol is FILE_NAME.'
       PRINT *,' Default disk is SYS$DISK: .'
       PRINT *,' /LOG: write resulting filespec to SYS$OUTPUT.'
       Call Exit(1)
      ENDIF

      disk='SYS$DISK:'
      IF (cli$present('P1')) THEN
         code=cli$get_value('P1',disk,lld)
      ENDIF
      call STR$TRIM(disk,disk,lld)

      symbol = 'FILE_NAME'
      IF (cli$present('SYMBOL')) THEN
        code=cli$get_value('SYMBOL',symbol,lls)
      ENDIF
      call STR$TRIM(symbol,symbol,lls)

      FID.FID$W_NUM=1
      FID.FID$W_SEQ=1
      FID.FID$B_NMX=0
      FID.FID$B_RVN=0

      IF (cli$present('FID')) THEN
        code=1
        i=1
        DO WHILE (code.AND.(i.LE.3))
         code=cli$get_value('FID',name,ll)
         IF (code) THEN
          READ(name(1:ll),'(I)',err=8000,iostat=iostat) id
         IF (i .EQ. 1) THEN
          FID.FID$W_NUM=IAND(id,'FFFF'X)
          FID.FID$B_NMX=ISHFT(id,-16)
         ELSE
          IF (i .EQ. 2) FID.FID$W_SEQ=id
          IF (i .EQ. 3) FID.FID$B_RVN=id
         ENDIF
         ENDIF
         i=i+1
        END DO
      ENDIF
      code = LIB$fid_to_name(disk,FID,name,lln)
      if (code) then
       code = lib$set_symbol(symbol(1:lls),name(1:lln))
       i=CLI$PRESENT('LOG')
       IF (i.and.(i.ne.%LOC(CLI$_NEGATED))) then
        i = LIB$PUT_OUTPUT(name(1:lln))
       endif
      endif
      CALL exit(code)

8000  Call exit(iostat_to_status(iostat))
      END