275 lines
8.9 KiB
Fortran
275 lines
8.9 KiB
Fortran
C----------------------------------------------------------------------------
|
|
C NeXus - Neutron & X-ray Common Data Format
|
|
C
|
|
C API Fortran Interface
|
|
C
|
|
C $Id: napif.f,v 1.1 2000/02/07 10:38:58 cvs Exp $
|
|
C
|
|
C Copyright (C) 1997, Freddie Akeroyd
|
|
C ISIS Facility, Rutherford Appleton Laboratory, UK
|
|
C
|
|
C See NAPI.C for further details
|
|
C
|
|
C 22/2/98 - Correct an NXfclose problem (free() of FORTRAN memory)
|
|
C 97/7/30 - Initial Release
|
|
C 97/7/31 - Correct NXPUTATTR/NXGETATTR and make 'implicit none' clean
|
|
C 97/8/7 - Update interface
|
|
C----------------------------------------------------------------------------
|
|
|
|
C *** Return length of a string, ignoring trailing blanks
|
|
INTEGER FUNCTION TRUELEN(STRING)
|
|
CHARACTER*(*) STRING
|
|
DO TRUELEN=LEN(STRING),1,-1
|
|
IF (STRING(TRUELEN:TRUELEN) .NE. ' ') RETURN
|
|
ENDDO
|
|
TRUELEN = 0
|
|
END
|
|
|
|
C *** Convert FORTRAN string STRING into NULL terminated C string ISTRING
|
|
SUBROUTINE EXTRACT_STRING(ISTRING, LENMAX, STRING)
|
|
CHARACTER*(*) STRING
|
|
INTEGER I,ILEN,TRUELEN,LENMAX
|
|
BYTE ISTRING(LENMAX)
|
|
EXTERNAL TRUELEN
|
|
ILEN = TRUELEN(STRING)
|
|
C WRITE(6,*)'TRUELEN: ', ILEN
|
|
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('NAPIF: String too long - buffer needs increasing from ',
|
|
+ i4,' to at least ',i4)
|
|
END
|
|
|
|
C *** Convert NULL terminated C string ISTRING to FORTRAN string STRING
|
|
SUBROUTINE REPLACE_STRING(STRING, ISTRING)
|
|
BYTE ISTRING(*)
|
|
CHARACTER*(*) STRING
|
|
INTEGER I
|
|
STRING = ' '
|
|
DO I=1,LEN(STRING)
|
|
IF (ISTRING(I) .EQ. 0) RETURN
|
|
STRING(I:I) = CHAR(ISTRING(I))
|
|
ENDDO
|
|
WRITE(6,9010) LEN(STRING)
|
|
RETURN
|
|
9010 FORMAT('NAPIF: String truncated - buffer needs to be > ', I4)
|
|
END
|
|
|
|
C *** Wrapper routines for NXAPI interface
|
|
INTEGER FUNCTION NXOPEN(FILENAME, ACCESS_METHOD, FILEID)
|
|
CHARACTER*(*) FILENAME
|
|
BYTE 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 NXMAKEGROUP(FILEID, VGROUP, NXCLASS)
|
|
INTEGER FILEID(*),NXIMAKEGROUP
|
|
CHARACTER*(*) VGROUP, NXCLASS
|
|
BYTE 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
|
|
BYTE 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 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
|
|
BYTE ILABEL(256)
|
|
EXTERNAL NXIFMAKEDATA
|
|
CALL EXTRACT_STRING(ILABEL, 256, LABEL)
|
|
NXMAKEDATA = NXIFMAKEDATA(FILEID, ILABEL, DATATYPE, RANK, DIM)
|
|
END
|
|
|
|
INTEGER FUNCTION NXOPENDATA(FILEID, LABEL)
|
|
INTEGER FILEID(*),NXIOPENDATA
|
|
CHARACTER*(*) LABEL
|
|
BYTE ILABEL(256)
|
|
EXTERNAL NXIOPENDATA
|
|
CALL EXTRACT_STRING(ILABEL, 256, LABEL)
|
|
NXOPENDATA = NXIOPENDATA(FILEID, ILABEL)
|
|
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 NXGETSLAB(FILEID, DATA, START, SIZE)
|
|
INTEGER FILEID(*), DATA(*), START(*), SIZE(*)
|
|
INTEGER NXIGETSLAB
|
|
EXTERNAL NXIGETSLAB
|
|
NXGETSLAB = NXIGETSLAB(FILEID, DATA, START, SIZE)
|
|
END
|
|
|
|
INTEGER FUNCTION NXIFGETCHARATTR(FILEID, INAME, DATA,
|
|
+ DATALEN, TYPE)
|
|
INTEGER MAX_DATALEN,NX_ERROR
|
|
INTEGER FILEID(*), DATALEN, TYPE
|
|
PARAMETER(MAX_DATALEN=1024,NX_ERROR=0)
|
|
CHARACTER*(*) DATA
|
|
BYTE IDATA(MAX_DATALEN)
|
|
BYTE INAME(*)
|
|
INTEGER NXIGETATTR
|
|
EXTERNAL NXIGETATTR
|
|
IF (DATALEN .GE. MAX_DATALEN) THEN
|
|
WRITE(6,9020) DATALEN, MAX_DATALEN
|
|
NXIFGETCHARATTR=NX_ERROR
|
|
RETURN
|
|
ENDIF
|
|
NXIFGETCHARATTR = NXIGETATTR(FILEID, INAME, IDATA, DATALEN, TYPE)
|
|
IF (NXIFGETCHARATTR .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 NXGETATTR(FILEID, NAME, DATA, DATALEN, TYPE)
|
|
INTEGER FILEID(*),DATALEN,TYPE,NX_CHAR
|
|
PARAMETER(NX_CHAR=4)
|
|
CHARACTER*(*) NAME, DATA
|
|
BYTE INAME(256)
|
|
INTEGER NXIGETATTR, NXIFGETCHARATTR
|
|
EXTERNAL NXIGETATTR, NXIFGETCHARATTR
|
|
CALL EXTRACT_STRING(INAME, 256, NAME)
|
|
IF ((TYPE .EQ. NX_CHAR) .OR. (TYPE .EQ. NX_UINT8)) THEN
|
|
NXGETATTR = NXIFGETCHARATTR(FILEID, INAME, DATA,
|
|
+ DATALEN, TYPE)
|
|
ELSE
|
|
NXGETATTR = NXIGETATTR(FILEID, INAME, DATA, DATALEN, TYPE)
|
|
ENDIF
|
|
END
|
|
|
|
INTEGER FUNCTION NXPUTDATA(FILEID, DATA)
|
|
INTEGER FILEID(*), DATA(*), NXIPUTDATA
|
|
EXTERNAL NXIPUTDATA
|
|
NXPUTDATA = NXIPUTDATA(FILEID, DATA)
|
|
END
|
|
|
|
INTEGER FUNCTION NXPUTSLAB(FILEID, DATA, START, SIZE)
|
|
INTEGER FILEID(*), DATA(*), START(*), SIZE(*)
|
|
INTEGER NXIPUTSLAB
|
|
EXTERNAL NXIPUTSLAB
|
|
NXPUTSLAB = NXIPUTSLAB(FILEID, DATA, START, SIZE)
|
|
END
|
|
|
|
INTEGER FUNCTION NXIFPUTCHARATTR(FILEID, INAME, DATA,
|
|
+ DATALEN, TYPE)
|
|
INTEGER FILEID(*), DATALEN, TYPE
|
|
BYTE INAME(*)
|
|
CHARACTER*(*) DATA
|
|
BYTE IDATA(1024)
|
|
INTEGER NXIFPUTATTR
|
|
EXTERNAL NXIFPUTATTR
|
|
CALL EXTRACT_STRING(IDATA, 1024, DATA)
|
|
NXIFPUTCHARATTR = NXIFPUTATTR(FILEID, INAME, IDATA, DATALEN, TYPE)
|
|
END
|
|
|
|
INTEGER FUNCTION NXPUTATTR(FILEID, NAME, DATA, DATALEN, TYPE)
|
|
INTEGER FILEID(*), DATALEN, TYPE, NX_CHAR
|
|
PARAMETER(NX_CHAR=4)
|
|
CHARACTER*(*) NAME, DATA
|
|
BYTE INAME(256)
|
|
INTEGER NXIFPUTATTR, NXIFPUTCHARATTR
|
|
EXTERNAL NXIFPUTATTR, NXIFPUTCHARATTR
|
|
CALL EXTRACT_STRING(INAME, 256, NAME)
|
|
IF ((TYPE .EQ. NX_CHAR) .OR. (TYPE .EQ. NX_UINT8)) THEN
|
|
NXPUTATTR = NXIFPUTCHARATTR(FILEID, INAME, DATA,
|
|
+ DATALEN, TYPE)
|
|
ELSE
|
|
NXPUTATTR = NXIFPUTATTR(FILEID, INAME, DATA, DATALEN, TYPE)
|
|
ENDIF
|
|
END
|
|
|
|
INTEGER FUNCTION NXGETINFO(FILEID, RANK, DIM, DATATYPE)
|
|
INTEGER FILEID(*), RANK, DIM(*), DATATYPE
|
|
INTEGER I, J, NXIGETINFO
|
|
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
|
|
BYTE 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
|
|
BYTE 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
|