napif.f

Go to the documentation of this file.

C------------------------------------------------------------------------------
C NeXus - Neutron & X-ray Common Data Format
C  
C Application Program Interface (Fortran 77)
C
C Copyright (C) 1997-2002 Freddie Akeroyd, Mark Koennecke
C
C This library is free software; you can redistribute it and/or
C modify it under the terms of the GNU Lesser General Public
C License as published by the Free Software Foundation; either
C version 2 of the License, or (at your option) any later version.
C
C This library 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 GNU
C Lesser General Public License for more details.
C
C You should have received a copy of the GNU Lesser General Public
C License along with this library; if not, write to the Free Software
C Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
C
C  For further information, see <http://www.nexusformat.org>
C
C $Id: napif.f 1705 2011-10-22 21:10:47Z Peter Peterson $
C------------------------------------------------------------------------------

C------------------------------------------------------------------------------
C Doxygen comments follow
C for help, see: http://www.stack.nl/~dimitri/doxygen/docblocks.html#fortranblocks
C
C------------------------------------------------------------------------------



      INTEGER FUNCTION truelen(STRING)
      CHARACTER*(*) string
      DO truelen=len(string),1,-1
          IF (string(truelen:truelen) .NE. ' ' .AND. 
     &        string(truelen:truelen) .NE. char(0) ) RETURN
      ENDDO
      truelen = 0
      END

      SUBROUTINE extract_string(ISTRING, LENMAX, STRING)
      CHARACTER*(*) string
      INTEGER i,ilen,truelen,lenmax
      INTEGER*1 istring(lenmax)
      EXTERNAL truelen
      ilen = truelen(string)
      IF (ilen .GE. lenmax) THEN
          WRITE(6,9000) lenmax, ilen+1
          RETURN
      ENDIF
      DO i=1,ilen
          istring(i) = ichar(string(i:i))
      ENDDO
      istring(ilen+1) = 0
      RETURN
 9000 FORMAT('NeXus(NAPIF/EXTRACT_STRING): String too long -',
     +       'buffer needs increasing from ', i4,' to at least ',i4)
      END

      SUBROUTINE replace_string(STRING, ISTRING)
      INTEGER*1 istring(*)
      CHARACTER*(*) string
      INTEGER i
      string = ' '
      DO i=1,len(string)
          IF (istring(i) .EQ. 0) RETURN
          string(i:i) = char(istring(i))
      ENDDO
      IF (istring(len(string)+1) .NE. 0) WRITE(6,9010) len(string) 
      RETURN
 9010 FORMAT('NeXus(NAPIF/REPLACE_STRING): String truncated - ',
     +  'buffer needs to be > ', i4)
      END

      INTEGER FUNCTION nxopen(FILENAME, ACCESS_METHOD, FILEID)
      CHARACTER*(*) filename
      INTEGER*1 ifilename(256)
      INTEGER access_method
      INTEGER fileid(*),nxifopen
      EXTERNAL nxifopen
      CALL extract_string(ifilename, 256, filename)
      nxopen = nxifopen(ifilename, access_method, fileid)
      END

      INTEGER FUNCTION nxclose(FILEID)
      INTEGER fileid(*),nxifclose
      EXTERNAL nxifclose
      nxclose = nxifclose(fileid)
      END

      INTEGER FUNCTION nxflush(FILEID)
      INTEGER fileid(*), nxifflush
      EXTERNAL nxifflush
      nxflush = nxifflush(fileid)
      END

      INTEGER FUNCTION nxmakegroup(FILEID, VGROUP, NXCLASS)
      INTEGER fileid(*),nximakegroup
      CHARACTER*(*) vgroup, nxclass
      INTEGER*1 ivgroup(256), inxclass(256)
      EXTERNAL nximakegroup
      CALL extract_string(ivgroup, 256, vgroup)
      CALL extract_string(inxclass, 256, nxclass)
      nxmakegroup = nximakegroup(fileid, ivgroup, inxclass)
      END

      INTEGER FUNCTION nxopengroup(FILEID, VGROUP, NXCLASS)
      INTEGER fileid(*),nxiopengroup
      CHARACTER*(*) vgroup, nxclass
      INTEGER*1 ivgroup(256), inxclass(256)
      EXTERNAL nxiopengroup
      CALL extract_string(ivgroup, 256, vgroup)
      CALL extract_string(inxclass, 256, nxclass)
      nxopengroup = nxiopengroup(fileid, ivgroup, inxclass)
      END

      INTEGER FUNCTION nxopenpath(FILEID, PATH)
      INTEGER fileid(*),nxiopenpath
      CHARACTER*(*) path
      INTEGER*1 ipath(256)
      EXTERNAL nxiopenpath
      CALL extract_string(ipath, 256, path)
      nxopenpath = nxiopenpath(fileid, ipath)
      END

      INTEGER FUNCTION nxgetpath(FILEID, PATH)
      INTEGER fileid(*),nxigetpath, nxifgetpath
      CHARACTER*(*) path
      INTEGER*1 ipath(1024)
      INTEGER plen
      EXTERNAL nxifgetpath
      plen = 1024
      nxgetpath = nxifgetpath(fileid,ipath,plen)
      CALL replace_string(path,ipath)
      END

      INTEGER FUNCTION nxopengrouppath(FILEID, PATH)
      INTEGER fileid(*),nxiopengrouppath
      CHARACTER*(*) path
      INTEGER*1 ipath(256)
      EXTERNAL nxiopengrouppath
      CALL extract_string(ipath, 256, path)
      nxopengrouppath = nxiopengrouppath(fileid, ipath)
      END

      INTEGER FUNCTION nxclosegroup(FILEID)
      INTEGER fileid(*),nxiclosegroup
      EXTERNAL nxiclosegroup
      nxclosegroup = nxiclosegroup(fileid)
      END

      INTEGER FUNCTION nxmakedata(FILEID, LABEL, DATATYPE, RANK, DIM)  
      INTEGER fileid(*), datatype, rank, dim(*), nxifmakedata
      CHARACTER*(*) label
      INTEGER*1 ilabel(256)
      EXTERNAL nxifmakedata
      CALL extract_string(ilabel, 256, label)
      nxmakedata = nxifmakedata(fileid, ilabel, datatype, rank, dim) 
      END

      INTEGER FUNCTION nxcompmakedata(FILEID, LABEL, DATATYPE, RANK, 
     &                                dim, compression_type, chunk)  
      INTEGER fileid(*), datatype, rank, dim(*)
      INTEGER compression_type, chunk(*)
      INTEGER nxifcompmakedata
      CHARACTER*(*) label
      INTEGER*1 ilabel(256)
      EXTERNAL nxifmakedata
      CALL extract_string(ilabel, 256, label)
      nxcompmakedata = nxifcompmakedata(fileid, ilabel, datatype, 
     &                      rank, dim, compression_type, chunk) 
      END

      INTEGER FUNCTION nxopendata(FILEID, LABEL)
      INTEGER fileid(*),nxiopendata
      CHARACTER*(*) label
      INTEGER*1 ilabel(256)
      EXTERNAL nxiopendata
      CALL extract_string(ilabel, 256, label)
      nxopendata = nxiopendata(fileid, ilabel)
      END

      INTEGER FUNCTION nxsetnumberformat(FILEID, ITYPE, FORMAT)
      INTEGER fileid(*),nxisetnumberformat,itype
      CHARACTER*(*) format
      INTEGER*1 ilabel(256)
      EXTERNAL nxisetnumberformat
      CALL extract_string(ilabel, 256, format)
      nxsetnumberformat = nxisetnumberformat(fileid, itype, ilabel)
      END

      INTEGER FUNCTION nxcompress(FILEID, COMPR_TYPE)
      INTEGER fileid(*),nxifcompress,compr_type
      EXTERNAL nxifcompress
      nxcompress = nxifcompress(fileid, compr_type)
      END

      INTEGER FUNCTION nxclosedata(FILEID)
      INTEGER fileid(*),nxiclosedata
      EXTERNAL nxiclosedata
      nxclosedata = nxiclosedata(fileid)
      END

      INTEGER FUNCTION nxgetdata(FILEID, DATA)
      INTEGER fileid(*), data(*), nxigetdata
      EXTERNAL nxigetdata
      nxgetdata = nxigetdata(fileid, data)
      END

      INTEGER FUNCTION nxgetchardata(FILEID, DATA)
      INTEGER fileid(*), nxigetdata
      CHARACTER*(*) data
      INTEGER nx_error,nx_idatlen
      parameter(nx_error=0,nx_idatlen=1024)
      INTEGER*1 idata(nx_idatlen)
      EXTERNAL nxigetdata
C *** We need to zero IDATA as GETDATA doesn't NULL terminate character data,
C *** and so we would get "buffer not big enough" messages from REPLACE_STRING
      DO i=1,nx_idatlen
          idata(i) = 0
      ENDDO
      nxgetchardata = nxigetdata(fileid, idata)
      IF (nxgetchardata .NE. nx_error) THEN
          CALL replace_string(DATA, idata)
      ENDIF
      END

      INTEGER FUNCTION nxgetslab(FILEID, DATA, START, SIZE)
      INTEGER fileid(*), data(*), start(*), size(*)
      INTEGER nx_maxrank, nx_ok
      parameter(nx_maxrank=32,nx_ok=1)
      INTEGER rank, dim(nx_maxrank), datatype, i
      INTEGER cstart(nx_maxrank), csize(nx_maxrank)
      INTEGER nxigetslab, nxgetinfo
      EXTERNAL nxigetslab
      nxgetslab = nxgetinfo(fileid, rank, dim, datatype)
      IF (nxgetslab .NE. nx_ok) RETURN
      DO i = 1, rank
         cstart(i) = start(rank-i+1) - 1
         csize(i) = SIZE(rank-i+1)
      ENDDO
      nxgetslab = nxigetslab(fileid, DATA, cstart, csize)
      END
      
      INTEGER FUNCTION nxgetattr(FILEID, NAME, DATA, DATALEN, TYPE)
      INTEGER fileid(*),data(*),datalen,type
      CHARACTER*(*) name
      INTEGER*1 iname(256)
      INTEGER nxigetattr
      EXTERNAL nxigetattr
      CALL extract_string(iname, 256, name)
      nxgetattr = nxigetattr(fileid, iname, DATA, datalen, type)
      END

      INTEGER FUNCTION nxgetcharattr(FILEID, NAME, DATA, 
     +                                 datalen, type)
      INTEGER max_datalen,nx_error
      INTEGER fileid(*), datalen, type
      parameter(max_datalen=1024,nx_error=0)
      CHARACTER*(*) name, data
      INTEGER*1 idata(max_datalen)
      INTEGER*1 iname(256)
      INTEGER nxigetattr
      EXTERNAL nxigetattr
      CALL extract_string(iname, 256, name)
      IF (datalen .GE. max_datalen) THEN
          WRITE(6,9020) datalen, max_datalen
          nxgetcharattr=nx_error
          RETURN
      ENDIF
      nxgetcharattr = nxigetattr(fileid, iname, idata, datalen, type)
      IF (nxgetcharattr .NE. nx_error) THEN
          CALL replace_string(DATA, idata)
      ENDIF
      RETURN
 9020 FORMAT('NXgetattr: asked for attribute size ', i4, 
     +       ' with buffer size only ', i4)
      END

      INTEGER FUNCTION nxputdata(FILEID, DATA)
      INTEGER fileid(*), data(*), nxiputdata
      EXTERNAL nxiputdata
      nxputdata = nxiputdata(fileid, data)
      END

      INTEGER FUNCTION nxputchardata(FILEID, DATA)
      INTEGER fileid(*), nxiputdata
      CHARACTER*(*) data
      INTEGER*1 idata(1024)
      EXTERNAL nxiputdata
      CALL extract_string(idata, 1024, data)
      nxputchardata = nxiputdata(fileid, idata)
      END

      INTEGER FUNCTION nxputslab(FILEID, DATA, START, SIZE)
      INTEGER fileid(*), data(*), start(*), size(*)
      INTEGER nx_maxrank,nx_ok
      parameter(nx_maxrank=32,nx_ok=1)
      INTEGER rank, dim(nx_maxrank), datatype, i
      INTEGER cstart(nx_maxrank), csize(nx_maxrank)
      INTEGER nxiputslab, nxgetinfo
      EXTERNAL nxiputslab
      nxputslab = nxgetinfo(fileid, rank, dim, datatype)
      IF (nxputslab .NE. nx_ok) RETURN
      DO i = 1, rank
         cstart(i) = start(rank-i+1) - 1
         csize(i) = SIZE(rank-i+1)
      ENDDO
      nxputslab = nxiputslab(fileid, DATA, cstart, csize)
      END

      INTEGER FUNCTION nxputattr(FILEID, NAME, DATA, DATALEN, TYPE)
      INTEGER fileid(*), data(*), datalen, type
      CHARACTER*(*) name
      INTEGER*1 iname(256)
      INTEGER nxifputattr
      EXTERNAL nxifputattr
      CALL extract_string(iname, 256, name)
      nxputattr = nxifputattr(fileid, iname, DATA, datalen, type)
      END

      INTEGER FUNCTION nxputcharattr(FILEID, NAME, DATA, 
     +                                 datalen, type)
      INTEGER fileid(*), datalen, type 
      CHARACTER*(*) name, data
      INTEGER*1 iname(256)
      INTEGER*1 idata(1024)
      INTEGER nxifputattr
      EXTERNAL nxifputattr
      CALL extract_string(iname, 256, name)
      CALL extract_string(idata, 1024, data)
      nxputcharattr = nxifputattr(fileid, iname, idata, datalen, type)
      END

      INTEGER FUNCTION nxgetinfo(FILEID, RANK, DIM, DATATYPE)
      INTEGER fileid(*), rank, dim(*), datatype
      INTEGER i, j, nxigetinfo, nx_char
      EXTERNAL nxigetinfo
      nxgetinfo = nxigetinfo(fileid, rank, dim, datatype)
C *** Reverse dimension array as C is ROW major, FORTRAN column major
      DO i = 1, rank/2
          j = dim(i)
          dim(i) = dim(rank-i+1)
          dim(rank-i+1) = j
      ENDDO
      END

      INTEGER FUNCTION nxgetnextentry(FILEID, NAME, CLASS, DATATYPE)
      INTEGER fileid(*), datatype
      CHARACTER*(*) name, class
      INTEGER*1 iname(256), iclass(256)
      INTEGER nxigetnextentry
      EXTERNAL nxigetnextentry
      nxgetnextentry = nxigetnextentry(fileid, iname, iclass, datatype)
      CALL replace_string(name, iname)
      CALL replace_string(class, iclass)
      END

      INTEGER FUNCTION nxgetnextattr(FILEID, PNAME, ILENGTH, ITYPE)
      INTEGER fileid(*), ilength, itype, nxigetnextattr
      CHARACTER*(*) pname
      INTEGER*1 ipname(1024)
      EXTERNAL nxigetnextattr
      nxgetnextattr = nxigetnextattr(fileid, ipname, ilength, itype)
      CALL replace_string(pname, ipname)
      END

      INTEGER FUNCTION nxgetgroupid(FILEID, LINK)
      INTEGER fileid(*), link(*), nxigetgroupid
      EXTERNAL nxigetgroupid
      nxgetgroupid = nxigetgroupid(fileid, link)
      END

      INTEGER FUNCTION nxgetdataid(FILEID, LINK)
      INTEGER fileid(*), link(*), nxigetdataid
      EXTERNAL nxigetdataid
      nxgetdataid = nxigetdataid(fileid, link)
      END

      INTEGER FUNCTION nxmakelink(FILEID, LINK)
      INTEGER fileid(*), link(*), nximakelink
      EXTERNAL nximakelink
      nxmakelink = nximakelink(fileid, link)
      END

      INTEGER FUNCTION nxmakenamedlink(FILEID, PNAME, LINK)
      INTEGER fileid(*), link(*), nximakelink
      CHARACTER*(*) pname
      INTEGER*1 iname(256)
      EXTERNAL nximakenamedlink
      CALL extract_string(iname,256,pname)
      nxmakenamedlink = nximakenamedlink(fileid, iname, link)
      END

      INTEGER FUNCTION nxopensourcegroup(FILEID)
      INTEGER fileid(*),nxiopensourcegroup
      EXTERNAL nxiopensourcegroup
      nxopensourcegroup = nxiopensourcegroup(fileid)
      END

      LOGICAL FUNCTION nxsameid(FILEID, LINK1, LINK2)
      INTEGER fileid(*), link1(*), link2(*), nxisameid, status
      EXTERNAL nxisameid
      status = nxisameid(fileid, link1, link2)
      IF (status .EQ. 1) THEN
         nxsameid = .true.
      ELSE
         nxsameid = .false.
      ENDIF
      END

      INTEGER FUNCTION nxgetgroupinfo(FILEID, NUM, NAME, CLASS)
      INTEGER fileid(*), num, nxigetgroupinfo
      CHARACTER*(*) name, class
      INTEGER*1 iname(256), iclass(256)
      EXTERNAL nxigetgroupinfo
      nxgetgroupinfo = nxigetgroupinfo(fileid, num, iname, iclass)
      CALL replace_string(name, iname)
      CALL replace_string(class, iclass)
      END

      INTEGER FUNCTION nxinitgroupdir(FILEID)
      INTEGER fileid(*), nxiinitgroupdir
      EXTERNAL nxiinitgroupdir
      nxinitgroupdir = nxiinitgroupdir(fileid)
      END

      INTEGER FUNCTION nxgetattrinfo(FILEID, NUM)
      INTEGER fileid(*), num, nxigetattrinfo
      EXTERNAL nxigetattrinfo
      nxgetattrinfo = nxigetattrinfo(fileid, num)
      END

      INTEGER FUNCTION nxinitattrdir(FILEID)
      INTEGER fileid(*), nxiinitattrdir
      EXTERNAL nxiinitattrdir
      nxinitattrdir = nxiinitattrdir(fileid)
      END

      INTEGER FUNCTION nxisexternalgroup(FILEID, VGROUP, NXCLASS, NXURL)
      INTEGER fileid(*),nxiisexternalgroup, length
      CHARACTER*(*) vgroup, nxclass, nxurl
      INTEGER*1 ivgroup(256), inxclass(256), inxurl(256)
      EXTERNAL nxiisexternalgroup
      length = 256
      CALL extract_string(ivgroup, 256, vgroup)
      CALL extract_string(inxclass, 256, nxclass)
      nxisexternalgroup = nxiisexternalgroup(fileid, ivgroup, inxclass, 
     &  inxurl,length)
      CALL replace_string(nxurl, inxurl)
      END


      INTEGER FUNCTION nxinquirefile(FILEID, NXFILE)
      INTEGER fileid(*),nxiinquirefile, length
      CHARACTER*(*) nxfile
      INTEGER*1 inxfile (1024)
      EXTERNAL nxiinquirefile
      length = 1023
      nxinquirefile = nxiinquirefile(fileid,inxfile, 1023)
      CALL replace_string(nxfile, inxfile)
      END

      INTEGER FUNCTION nxlinkexternal(FILEID, VGROUP, NXCLASS, NXURL)
      INTEGER fileid(*),nxilinkexternal
      CHARACTER*(*) vgroup, nxclass, nxurl
      INTEGER*1 ivgroup(256), inxclass(256), inxurl(1024)
      EXTERNAL nxilinkexternal
      CALL extract_string(ivgroup, 256, vgroup)
      CALL extract_string(inxclass, 256, nxclass)
      CALL extract_string(inxurl, 1023, nxurl)
      nxlinkexternal = nxilinkexternal(fileid, ivgroup,inxclass, 
     & inxurl)
      END