Initial revision

2000-02-07 10:38:55 +00:00
commit fdc6b051c9
846 changed files with 230218 additions and 0 deletions
--- a/napif.f
+++ b/napif.f
@@ -0,0 +1,274 @@
+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