NeXus  1
 All Files Functions Pages
napif.f
Go to the documentation of this file.
1 C------------------------------------------------------------------------------
2 C NeXus - Neutron & X-ray Common Data Format
3 C
4 C Application Program Interface (Fortran 77)
5 C
6 C Copyright (C) 1997-2002 Freddie Akeroyd, Mark Koennecke
7 C
8 C This library is free software; you can redistribute it and/or
9 C modify it under the terms of the GNU Lesser General Public
10 C License as published by the Free Software Foundation; either
11 C version 2 of the License, or (at your option) any later version.
12 C
13 C This library is distributed in the hope that it will be useful,
14 C but WITHOUT ANY WARRANTY; without even the implied warranty of
15 C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 C Lesser General Public License for more details.
17 C
18 C You should have received a copy of the GNU Lesser General Public
19 C License along with this library; if not, write to the Free Software
20 C Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 C
22 C For further information, see <http://www.nexusformat.org>
23 C
24 C $Id: napif.f 1705 2011-10-22 21:10:47Z Peter Peterson $
25 C------------------------------------------------------------------------------
26 
27 C------------------------------------------------------------------------------
28 C Doxygen comments follow
29 C for help, see: http://www.stack.nl/~dimitri/doxygen/docblocks.html#fortranblocks
30 C
63 C------------------------------------------------------------------------------
64 
65 
66 
69  INTEGER FUNCTION truelen(STRING)
70  CHARACTER*(*) string
71  DO truelen=len(string),1,-1
72  IF (string(truelen:truelen) .NE. ' ' .AND.
73  & string(truelen:truelen) .NE. char(0) ) return
74  ENDDO
75  truelen = 0
76  END
77 
80  SUBROUTINE extract_string(ISTRING, LENMAX, STRING)
81  CHARACTER*(*) string
82  INTEGER i,ilen,truelen,lenmax
83  INTEGER*1 istring(lenmax)
84  EXTERNAL truelen
85  ilen = truelen(string)
86  IF (ilen .GE. lenmax) THEN
87  WRITE(6,9000) lenmax, ilen+1
88  return
89  ENDIF
90  DO i=1,ilen
91  istring(i) = ichar(string(i:i))
92  ENDDO
93  istring(ilen+1) = 0
94  return
95  9000 format('NeXus(NAPIF/EXTRACT_STRING): String too long -',
96  + 'buffer needs increasing from ', i4,' to at least ',i4)
97  END
98 
101  SUBROUTINE replace_string(STRING, ISTRING)
102  INTEGER*1 istring(*)
103  CHARACTER*(*) string
104  INTEGER i
105  string = ' '
106  DO i=1,len(string)
107  IF (istring(i) .EQ. 0) return
108  string(i:i) = char(istring(i))
109  ENDDO
110  IF (istring(len(string)+1) .NE. 0) WRITE(6,9010) len(string)
111  return
112  9010 format('NeXus(NAPIF/REPLACE_STRING): String truncated - ',
113  + 'buffer needs to be > ', i4)
114  END
115 
118  INTEGER FUNCTION nxopen(FILENAME, ACCESS_METHOD, FILEID)
119  CHARACTER*(*) filename
120  INTEGER*1 ifilename(256)
121  INTEGER access_method
122  INTEGER fileid(*),nxifopen
123  EXTERNAL nxifopen
124  CALL extract_string(ifilename, 256, filename)
125  nxopen = nxifopen(ifilename, access_method, fileid)
126  END
127 
128  INTEGER FUNCTION nxclose(FILEID)
129  INTEGER fileid(*),nxifclose
130  EXTERNAL nxifclose
131  nxclose = nxifclose(fileid)
132  END
133 
134  INTEGER FUNCTION nxflush(FILEID)
135  INTEGER fileid(*), nxifflush
136  EXTERNAL nxifflush
137  nxflush = nxifflush(fileid)
138  END
139 
140  INTEGER FUNCTION nxmakegroup(FILEID, VGROUP, NXCLASS)
141  INTEGER fileid(*),nximakegroup
142  CHARACTER*(*) vgroup, nxclass
143  INTEGER*1 ivgroup(256), inxclass(256)
144  EXTERNAL nximakegroup
145  CALL extract_string(ivgroup, 256, vgroup)
146  CALL extract_string(inxclass, 256, nxclass)
147  nxmakegroup = nximakegroup(fileid, ivgroup, inxclass)
148  END
149 
150  INTEGER FUNCTION nxopengroup(FILEID, VGROUP, NXCLASS)
151  INTEGER fileid(*),nxiopengroup
152  CHARACTER*(*) vgroup, nxclass
153  INTEGER*1 ivgroup(256), inxclass(256)
154  EXTERNAL nxiopengroup
155  CALL extract_string(ivgroup, 256, vgroup)
156  CALL extract_string(inxclass, 256, nxclass)
157  nxopengroup = nxiopengroup(fileid, ivgroup, inxclass)
158  END
159 
160  INTEGER FUNCTION nxopenpath(FILEID, PATH)
161  INTEGER fileid(*),nxiopenpath
162  CHARACTER*(*) path
163  INTEGER*1 ipath(256)
164  EXTERNAL nxiopenpath
165  CALL extract_string(ipath, 256, path)
166  nxopenpath = nxiopenpath(fileid, ipath)
167  END
168 
169  INTEGER FUNCTION nxgetpath(FILEID, PATH)
170  INTEGER fileid(*),nxigetpath, nxifgetpath
171  CHARACTER*(*) path
172  INTEGER*1 ipath(1024)
173  INTEGER plen
174  EXTERNAL nxifgetpath
175  plen = 1024
176  nxgetpath = nxifgetpath(fileid,ipath,plen)
177  CALL replace_string(path,ipath)
178  END
179 
180  INTEGER FUNCTION nxopengrouppath(FILEID, PATH)
181  INTEGER fileid(*),nxiopengrouppath
182  CHARACTER*(*) path
183  INTEGER*1 ipath(256)
184  EXTERNAL nxiopengrouppath
185  CALL extract_string(ipath, 256, path)
186  nxopengrouppath = nxiopengrouppath(fileid, ipath)
187  END
188 
189  INTEGER FUNCTION nxclosegroup(FILEID)
190  INTEGER fileid(*),nxiclosegroup
191  EXTERNAL nxiclosegroup
192  nxclosegroup = nxiclosegroup(fileid)
193  END
194 
195  INTEGER FUNCTION nxmakedata(FILEID, LABEL, DATATYPE, RANK, DIM)
196  INTEGER fileid(*), datatype, rank, dim(*), nxifmakedata
197  CHARACTER*(*) label
198  INTEGER*1 ilabel(256)
199  EXTERNAL nxifmakedata
200  CALL extract_string(ilabel, 256, label)
201  nxmakedata = nxifmakedata(fileid, ilabel, datatype, rank, dim)
202  END
203 
204  INTEGER FUNCTION nxcompmakedata(FILEID, LABEL, DATATYPE, RANK,
205  & dim, compression_type, chunk)
206  INTEGER fileid(*), datatype, rank, dim(*)
207  INTEGER compression_type, chunk(*)
208  INTEGER nxifcompmakedata
209  CHARACTER*(*) label
210  INTEGER*1 ilabel(256)
211  EXTERNAL nxifmakedata
212  CALL extract_string(ilabel, 256, label)
213  nxcompmakedata = nxifcompmakedata(fileid, ilabel, datatype,
214  & rank, dim, compression_type, chunk)
215  END
216 
217  INTEGER FUNCTION nxopendata(FILEID, LABEL)
218  INTEGER fileid(*),nxiopendata
219  CHARACTER*(*) label
220  INTEGER*1 ilabel(256)
221  EXTERNAL nxiopendata
222  CALL extract_string(ilabel, 256, label)
223  nxopendata = nxiopendata(fileid, ilabel)
224  END
225 
226  INTEGER FUNCTION nxsetnumberformat(FILEID, ITYPE, FORMAT)
227  INTEGER fileid(*),nxisetnumberformat,itype
228  CHARACTER*(*) format
229  INTEGER*1 ilabel(256)
230  EXTERNAL nxisetnumberformat
231  CALL extract_string(ilabel, 256, format)
232  nxsetnumberformat = nxisetnumberformat(fileid, itype, ilabel)
233  END
234 
235  INTEGER FUNCTION nxcompress(FILEID, COMPR_TYPE)
236  INTEGER fileid(*),nxifcompress,compr_type
237  EXTERNAL nxifcompress
238  nxcompress = nxifcompress(fileid, compr_type)
239  END
240 
241  INTEGER FUNCTION nxclosedata(FILEID)
242  INTEGER fileid(*),nxiclosedata
243  EXTERNAL nxiclosedata
244  nxclosedata = nxiclosedata(fileid)
245  END
246 
247  INTEGER FUNCTION nxgetdata(FILEID, DATA)
248  INTEGER fileid(*), data(*), nxigetdata
249  EXTERNAL nxigetdata
250  nxgetdata = nxigetdata(fileid, data)
251  END
252 
253  INTEGER FUNCTION nxgetchardata(FILEID, DATA)
254  INTEGER fileid(*), nxigetdata
255  CHARACTER*(*) data
256  INTEGER nx_error,nx_idatlen
257  parameter(nx_error=0,nx_idatlen=1024)
258  INTEGER*1 idata(nx_idatlen)
259  EXTERNAL nxigetdata
260 C *** We need to zero IDATA as GETDATA doesn't NULL terminate character data,
261 C *** and so we would get "buffer not big enough" messages from REPLACE_STRING
262  DO i=1,nx_idatlen
263  idata(i) = 0
264  ENDDO
265  nxgetchardata = nxigetdata(fileid, idata)
266  IF (nxgetchardata .NE. nx_error) THEN
267  CALL replace_string(DATA, idata)
268  ENDIF
269  END
270 
271  INTEGER FUNCTION nxgetslab(FILEID, DATA, START, SIZE)
272  INTEGER fileid(*), data(*), start(*), size(*)
273  INTEGER nx_maxrank, nx_ok
274  parameter(nx_maxrank=32,nx_ok=1)
275  INTEGER rank, dim(nx_maxrank), datatype, i
276  INTEGER cstart(nx_maxrank), csize(nx_maxrank)
277  INTEGER nxigetslab, nxgetinfo
278  EXTERNAL nxigetslab
279  nxgetslab = nxgetinfo(fileid, rank, dim, datatype)
280  IF (nxgetslab .NE. nx_ok) return
281  DO i = 1, rank
282  cstart(i) = start(rank-i+1) - 1
283  csize(i) = SIZE(rank-i+1)
284  ENDDO
285  nxgetslab = nxigetslab(fileid, DATA, cstart, csize)
286  END
287 
288  INTEGER FUNCTION nxgetattr(FILEID, NAME, DATA, DATALEN, TYPE)
289  INTEGER fileid(*),data(*),datalen,type
290  CHARACTER*(*) name
291  INTEGER*1 iname(256)
292  INTEGER nxigetattr
293  EXTERNAL nxigetattr
294  CALL extract_string(iname, 256, name)
295  nxgetattr = nxigetattr(fileid, iname, DATA, datalen, type)
296  END
297 
298  INTEGER FUNCTION nxgetcharattr(FILEID, NAME, DATA,
299  + datalen, type)
300  INTEGER max_datalen,nx_error
301  INTEGER fileid(*), datalen, type
302  parameter(max_datalen=1024,nx_error=0)
303  CHARACTER*(*) name, data
304  INTEGER*1 idata(max_datalen)
305  INTEGER*1 iname(256)
306  INTEGER nxigetattr
307  EXTERNAL nxigetattr
308  CALL extract_string(iname, 256, name)
309  IF (datalen .GE. max_datalen) THEN
310  WRITE(6,9020) datalen, max_datalen
311  nxgetcharattr=nx_error
312  return
313  ENDIF
314  nxgetcharattr = nxigetattr(fileid, iname, idata, datalen, type)
315  IF (nxgetcharattr .NE. nx_error) THEN
316  CALL replace_string(DATA, idata)
317  ENDIF
318  return
319  9020 format('NXgetattr: asked for attribute size ', i4,
320  + ' with buffer size only ', i4)
321  END
322 
323  INTEGER FUNCTION nxputdata(FILEID, DATA)
324  INTEGER fileid(*), data(*), nxiputdata
325  EXTERNAL nxiputdata
326  nxputdata = nxiputdata(fileid, data)
327  END
328 
329  INTEGER FUNCTION nxputchardata(FILEID, DATA)
330  INTEGER fileid(*), nxiputdata
331  CHARACTER*(*) data
332  INTEGER*1 idata(1024)
333  EXTERNAL nxiputdata
334  CALL extract_string(idata, 1024, data)
335  nxputchardata = nxiputdata(fileid, idata)
336  END
337 
338  INTEGER FUNCTION nxputslab(FILEID, DATA, START, SIZE)
339  INTEGER fileid(*), data(*), start(*), size(*)
340  INTEGER nx_maxrank,nx_ok
341  parameter(nx_maxrank=32,nx_ok=1)
342  INTEGER rank, dim(nx_maxrank), datatype, i
343  INTEGER cstart(nx_maxrank), csize(nx_maxrank)
344  INTEGER nxiputslab, nxgetinfo
345  EXTERNAL nxiputslab
346  nxputslab = nxgetinfo(fileid, rank, dim, datatype)
347  IF (nxputslab .NE. nx_ok) return
348  DO i = 1, rank
349  cstart(i) = start(rank-i+1) - 1
350  csize(i) = SIZE(rank-i+1)
351  ENDDO
352  nxputslab = nxiputslab(fileid, DATA, cstart, csize)
353  END
354 
355  INTEGER FUNCTION nxputattr(FILEID, NAME, DATA, DATALEN, TYPE)
356  INTEGER fileid(*), data(*), datalen, type
357  CHARACTER*(*) name
358  INTEGER*1 iname(256)
359  INTEGER nxifputattr
360  EXTERNAL nxifputattr
361  CALL extract_string(iname, 256, name)
362  nxputattr = nxifputattr(fileid, iname, DATA, datalen, type)
363  END
364 
365  INTEGER FUNCTION nxputcharattr(FILEID, NAME, DATA,
366  + datalen, type)
367  INTEGER fileid(*), datalen, type
368  CHARACTER*(*) name, data
369  INTEGER*1 iname(256)
370  INTEGER*1 idata(1024)
371  INTEGER nxifputattr
372  EXTERNAL nxifputattr
373  CALL extract_string(iname, 256, name)
374  CALL extract_string(idata, 1024, data)
375  nxputcharattr = nxifputattr(fileid, iname, idata, datalen, type)
376  END
377 
378  INTEGER FUNCTION nxgetinfo(FILEID, RANK, DIM, DATATYPE)
379  INTEGER fileid(*), rank, dim(*), datatype
380  INTEGER i, j, nxigetinfo, nx_char
381  EXTERNAL nxigetinfo
382  nxgetinfo = nxigetinfo(fileid, rank, dim, datatype)
383 C *** Reverse dimension array as C is ROW major, FORTRAN column major
384  DO i = 1, rank/2
385  j = dim(i)
386  dim(i) = dim(rank-i+1)
387  dim(rank-i+1) = j
388  ENDDO
389  END
390 
391  INTEGER FUNCTION nxgetnextentry(FILEID, NAME, CLASS, DATATYPE)
392  INTEGER fileid(*), datatype
393  CHARACTER*(*) name, class
394  INTEGER*1 iname(256), iclass(256)
395  INTEGER nxigetnextentry
396  EXTERNAL nxigetnextentry
397  nxgetnextentry = nxigetnextentry(fileid, iname, iclass, datatype)
398  CALL replace_string(name, iname)
399  CALL replace_string(class, iclass)
400  END
401 
402  INTEGER FUNCTION nxgetnextattr(FILEID, PNAME, ILENGTH, ITYPE)
403  INTEGER fileid(*), ilength, itype, nxigetnextattr
404  CHARACTER*(*) pname
405  INTEGER*1 ipname(1024)
406  EXTERNAL nxigetnextattr
407  nxgetnextattr = nxigetnextattr(fileid, ipname, ilength, itype)
408  CALL replace_string(pname, ipname)
409  END
410 
411  INTEGER FUNCTION nxgetgroupid(FILEID, LINK)
412  INTEGER fileid(*), link(*), nxigetgroupid
413  EXTERNAL nxigetgroupid
414  nxgetgroupid = nxigetgroupid(fileid, link)
415  END
416 
417  INTEGER FUNCTION nxgetdataid(FILEID, LINK)
418  INTEGER fileid(*), link(*), nxigetdataid
419  EXTERNAL nxigetdataid
420  nxgetdataid = nxigetdataid(fileid, link)
421  END
422 
423  INTEGER FUNCTION nxmakelink(FILEID, LINK)
424  INTEGER fileid(*), link(*), nximakelink
425  EXTERNAL nximakelink
426  nxmakelink = nximakelink(fileid, link)
427  END
428 
429  INTEGER FUNCTION nxmakenamedlink(FILEID, PNAME, LINK)
430  INTEGER fileid(*), link(*), nximakelink
431  CHARACTER*(*) pname
432  INTEGER*1 iname(256)
433  EXTERNAL nximakenamedlink
434  CALL extract_string(iname,256,pname)
435  nxmakenamedlink = nximakenamedlink(fileid, iname, link)
436  END
437 
438  INTEGER FUNCTION nxopensourcegroup(FILEID)
439  INTEGER fileid(*),nxiopensourcegroup
440  EXTERNAL nxiopensourcegroup
441  nxopensourcegroup = nxiopensourcegroup(fileid)
442  END
443 
444  LOGICAL FUNCTION nxsameid(FILEID, LINK1, LINK2)
445  INTEGER fileid(*), link1(*), link2(*), nxisameid, status
446  EXTERNAL nxisameid
447  status = nxisameid(fileid, link1, link2)
448  IF (status .EQ. 1) THEN
449  nxsameid = .true.
450  ELSE
451  nxsameid = .false.
452  ENDIF
453  END
454 
455  INTEGER FUNCTION nxgetgroupinfo(FILEID, NUM, NAME, CLASS)
456  INTEGER fileid(*), num, nxigetgroupinfo
457  CHARACTER*(*) name, class
458  INTEGER*1 iname(256), iclass(256)
459  EXTERNAL nxigetgroupinfo
460  nxgetgroupinfo = nxigetgroupinfo(fileid, num, iname, iclass)
461  CALL replace_string(name, iname)
462  CALL replace_string(class, iclass)
463  END
464 
465  INTEGER FUNCTION nxinitgroupdir(FILEID)
466  INTEGER fileid(*), nxiinitgroupdir
467  EXTERNAL nxiinitgroupdir
468  nxinitgroupdir = nxiinitgroupdir(fileid)
469  END
470 
471  INTEGER FUNCTION nxgetattrinfo(FILEID, NUM)
472  INTEGER fileid(*), num, nxigetattrinfo
473  EXTERNAL nxigetattrinfo
474  nxgetattrinfo = nxigetattrinfo(fileid, num)
475  END
476 
477  INTEGER FUNCTION nxinitattrdir(FILEID)
478  INTEGER fileid(*), nxiinitattrdir
479  EXTERNAL nxiinitattrdir
480  nxinitattrdir = nxiinitattrdir(fileid)
481  END
482 
483  INTEGER FUNCTION nxisexternalgroup(FILEID, VGROUP, NXCLASS, NXURL)
484  INTEGER fileid(*),nxiisexternalgroup, length
485  CHARACTER*(*) vgroup, nxclass, nxurl
486  INTEGER*1 ivgroup(256), inxclass(256), inxurl(256)
487  EXTERNAL nxiisexternalgroup
488  length = 256
489  CALL extract_string(ivgroup, 256, vgroup)
490  CALL extract_string(inxclass, 256, nxclass)
491  nxisexternalgroup = nxiisexternalgroup(fileid, ivgroup, inxclass,
492  & inxurl,length)
493  CALL replace_string(nxurl, inxurl)
494  END
495 
496 
497  INTEGER FUNCTION nxinquirefile(FILEID, NXFILE)
498  INTEGER fileid(*),nxiinquirefile, length
499  CHARACTER*(*) nxfile
500  INTEGER*1 inxfile (1024)
501  EXTERNAL nxiinquirefile
502  length = 1023
503  nxinquirefile = nxiinquirefile(fileid,inxfile, 1023)
504  CALL replace_string(nxfile, inxfile)
505  END
506 
507  INTEGER FUNCTION nxlinkexternal(FILEID, VGROUP, NXCLASS, NXURL)
508  INTEGER fileid(*),nxilinkexternal
509  CHARACTER*(*) vgroup, nxclass, nxurl
510  INTEGER*1 ivgroup(256), inxclass(256), inxurl(1024)
511  EXTERNAL nxilinkexternal
512  CALL extract_string(ivgroup, 256, vgroup)
513  CALL extract_string(inxclass, 256, nxclass)
514  CALL extract_string(inxurl, 1023, nxurl)
515  nxlinkexternal = nxilinkexternal(fileid, ivgroup,inxclass,
516  & inxurl)
517  END
518