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