478 lines
16 KiB
Fortran
478 lines
16 KiB
Fortran
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,v 1.1 2016/05/13 05:49:09 zolliker Exp $
|
|
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
|