Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

NXmodule.f90 @ 1822

Visit:

Revision 1636, 53.7 KB checked in by Pete Jemian, 7 months ago (diff)
point to current WWW site in license text, refs #281
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`

Line
1	!------------------------------------------------------------------------------
2	! NeXus - Neutron & X-ray Common Data Format
3	!
4	! Application Program Interface (Fortran 90)
5	!
6	! Copyright (C) 1999-2002, Ray Osborn
7	!
8	! This library is free software; you can redistribute it and/or
9	! modify it under the terms of the GNU Lesser General Public
10	! License as published by the Free Software Foundation; either
11	! version 2 of the License, or (at your option) any later version.
12	!
13	! This library is distributed in the hope that it will be useful,
14	! but WITHOUT ANY WARRANTY; without even the implied warranty of
15	! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16	! Lesser General Public License for more details.
17	!
18	! You should have received a copy of the GNU Lesser General Public
19	! License along with this library; if not, write to the Free Software
20	! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21	!
22	! For further information, see <http://www.nexusformat.org>
23	!
24	!$Id$
25	!------------------------------------------------------------------------------
26
27	MODULE NXmodule
28
29	IMPLICIT NONE
30
31	PUBLIC
32	! *** NeXus version parameter
33	CHARACTER(len=*), PARAMETER, PUBLIC :: NeXus_version = "2.0.1"
34	! *** NeXus file access parameters
35	INTEGER, PARAMETER, PUBLIC :: NXACC_READ = 1
36	INTEGER, PARAMETER, PUBLIC :: NXACC_RDWR = 2
37	INTEGER, PARAMETER, PUBLIC :: NXACC_CREATE = 3
38	INTEGER, PARAMETER, PUBLIC :: NXACC_CREATE4 = 4
39	INTEGER, PARAMETER, PUBLIC :: NXACC_CREATE5 = 5
40	! *** NeXus status parameters
41	INTEGER, PARAMETER, PUBLIC :: NX_OK = 1
42	INTEGER, PARAMETER, PUBLIC :: NX_ERROR = 0
43	INTEGER, PARAMETER, PUBLIC :: NX_EOD = -1
44	! *** NeXus datatype parameters
45	INTEGER, PARAMETER, PUBLIC :: NX_CHAR = 4
46	INTEGER, PARAMETER, PUBLIC :: NX_FLOAT32 = 5
47	INTEGER, PARAMETER, PUBLIC :: NX_FLOAT64 = 6
48	INTEGER, PARAMETER, PUBLIC :: NX_INT8 = 20
49	INTEGER, PARAMETER, PUBLIC :: NX_UINT8 = 21
50	INTEGER, PARAMETER, PUBLIC :: NX_INT16 = 22
51	INTEGER, PARAMETER, PUBLIC :: NX_UINT16 = 23
52	INTEGER, PARAMETER, PUBLIC :: NX_INT32 = 24
53	INTEGER, PARAMETER, PUBLIC :: NX_UINT32 = 25
54	! *** NeXus compression parameters
55	INTEGER, PARAMETER, PUBLIC :: NX_COMP_NONE = 100
56	INTEGER, PARAMETER, PUBLIC :: NX_COMP_LZW = 200
57	INTEGER, PARAMETER, PUBLIC :: NX_COMP_RLE = 300
58	INTEGER, PARAMETER, PUBLIC :: NX_COMP_HUF = 400
59	! *** NeXus Unlimited parameters
60	INTEGER, PARAMETER, PUBLIC :: NX_UNLIMITED = -1
61	! *** NeXus limits
62	INTEGER, PARAMETER, PUBLIC :: NX_MAXRANK = 32
63	INTEGER, PARAMETER, PUBLIC :: NX_MAXNAMELEN = 64
64	INTEGER, PARAMETER, PUBLIC :: NX_MAXSTACK = 20
65	! *** Kind parameters for different byte lengths (not guaranteed to work)
66	INTEGER, PARAMETER, PUBLIC :: NXi1 = selected_int_kind(2)
67	INTEGER, PARAMETER, PUBLIC :: NXi2 = selected_int_kind(4)
68	INTEGER, PARAMETER, PUBLIC :: NXi4 = selected_int_kind(8)
69	INTEGER, PARAMETER, PUBLIC :: NXr4 = kind(1.0)
70	INTEGER, PARAMETER, PUBLIC :: NXr8 = kind(1.0D0)
71	! *** NeXus type definitions
72	TYPE, PUBLIC :: NXlink
73	INTEGER(kind=NXi4) :: dummy(1040) ! at least as large as in napi.h
74	END TYPE
75	TYPE, PUBLIC :: NXhandle
76	INTEGER(kind=NXi4) :: dummy(5120) ! at least as large as in nxstack.c
77	END TYPE
78	! *** Buffers for each type of parameter
79	INTEGER(KIND=NXi1), ALLOCATABLE, PRIVATE :: buffer_i1(:)
80	INTEGER(KIND=NXi2), ALLOCATABLE, PRIVATE :: buffer_i2(:)
81	INTEGER(KIND=NXi4), ALLOCATABLE, PRIVATE :: buffer_i4(:)
82	REAL(KIND=NXr4), ALLOCATABLE, PRIVATE :: buffer_r4(:)
83	REAL(KIND=NXr8), ALLOCATABLE, PRIVATE :: buffer_r8(:)
84	INTEGER, PRIVATE :: NXrank, NXdims(NX_MAXRANK), NXtype, NXsize
85	! * NeXus core functions *
86	PUBLIC :: NXopen, NXclose, NXflush
87	PUBLIC :: NXmakegroup, NXopengroup, NXclosegroup
88	PUBLIC :: NXmakedata, NXopendata, NXcompress, NXclosedata
89	PUBLIC :: NXgetdata, NXgetslab, NXgetattr, NXputdata, NXputslab, NXputattr
90	PUBLIC :: NXgetinfo, NXgetnextentry, NXgetnextattr
91	PUBLIC :: NXgetgroupID, NXgetdataID, NXsameID, NXmakelink
92	PUBLIC :: NXgetgroupinfo, NXinitgroupdir, NXgroupdir
93	PUBLIC :: NXgetattrinfo, NXinitattrdir, NXattrdir
94	PUBLIC :: NXreverse, NXCstring, NXFstring, NXdatatype, NXerror
95	! * NeXus generic interfaces *
96	INTERFACE NXgetdata
97	MODULE PROCEDURE NXgeti1, NXgeti2, NXgeti4, NXgetr4, NXgetr8, NXgetchar
98	END INTERFACE
99	INTERFACE NXgetslab
100	MODULE PROCEDURE NXgeti1slab, NXgeti2slab, NXgeti4slab, &
101	NXgetr4slab, NXgetr8slab
102	END INTERFACE
103	INTERFACE NXgetattr
104	MODULE PROCEDURE NXgeti1attr, NXgeti2attr, NXgeti4attr, NXgetr4attr, &
105	NXgetr8attr, NXgetcharattr
106	END INTERFACE
107	INTERFACE NXputdata
108	MODULE PROCEDURE NXputi1, NXputi2, NXputi4, NXputr4, NXputr8, NXputchar
109	END INTERFACE
110	INTERFACE NXputslab
111	MODULE PROCEDURE NXputi1slab, NXputi2slab, NXputi4slab, &
112	NXputr4slab, NXputr8slab
113	END INTERFACE
114	INTERFACE NXputattr
115	MODULE PROCEDURE NXputi1attr, NXputi2attr, NXputi4attr, &
116	NXputr4attr, NXputr8attr, NXputcharattr
117	END INTERFACE
118
119	CONTAINS
120	!------------------------------------------------------------------------------
121	!NXopen opens a NeXus file and returns a file ID
122	FUNCTION NXopen (file_name, access_method, file_id) RESULT (status)
123
124	CHARACTER(len=*), INTENT(in) :: file_name
125	INTEGER, INTENT(in) :: access_method
126	TYPE(NXhandle), INTENT(out) :: file_id
127	TYPE(NXhandle) :: new_id
128	INTEGER :: status, nxifopen
129	EXTERNAL nxifopen
130
131	status = nxifopen (NXCstring(file_name), access_method, new_id)
132	file_id = new_id
133
134	END FUNCTION NXopen
135	!------------------------------------------------------------------------------
136	!NXclose closes a NeXus file defined by its file ID
137	FUNCTION NXclose (file_id) RESULT (status)
138
139	TYPE(NXhandle), INTENT(in) :: file_id
140	INTEGER :: status, nxifclose
141	EXTERNAL nxifclose
142
143	status = nxifclose (file_id)
144
145	END FUNCTION NXclose
146	!------------------------------------------------------------------------------
147	!NXflush flushes all pending data to disk
148	FUNCTION NXflush (file_id) RESULT (status)
149
150	TYPE(NXhandle), INTENT(inout) :: file_id
151	INTEGER :: status, nxifflush
152	EXTERNAL nxifflush
153
154	status = nxifflush (file_id)
155
156	END FUNCTION NXflush
157	!------------------------------------------------------------------------------
158	!NXmakegroup creates a NeXus group
159	FUNCTION NXmakegroup (file_id, group_name, group_class) RESULT (status)
160
161	TYPE(NXhandle), INTENT(in) :: file_id
162	CHARACTER(len=*), INTENT(in) :: group_name, group_class
163	INTEGER :: status, nximakegroup
164	EXTERNAL nximakegroup
165
166	status = nximakegroup(file_id, NXCstring(group_name), &
167	NXCstring(group_class))
168
169	END FUNCTION NXmakegroup
170	!------------------------------------------------------------------------------
171	!NXopengroup opens an existing NeXus group for input/output
172	FUNCTION NXopengroup (file_id, group_name, group_class) RESULT (status)
173
174	TYPE(NXhandle), INTENT(in) :: file_id
175	CHARACTER(len=*), INTENT(in) :: group_name, group_class
176	INTEGER :: status, nxiopengroup
177	EXTERNAL nxiopengroup
178
179	status = nxiopengroup(file_id, NXCstring(group_name), &
180	NXCstring(group_class))
181
182	END FUNCTION NXopengroup
183	!------------------------------------------------------------------------------
184	!NXclosegroup closes a NeXus group
185	FUNCTION NXclosegroup (file_id) RESULT (status)
186
187	TYPE(NXhandle), INTENT(in) :: file_id
188	INTEGER :: status, nxiclosegroup
189	EXTERNAL nxiclosegroup
190
191	status = nxiclosegroup(file_id)
192
193	END FUNCTION NXclosegroup
194	!------------------------------------------------------------------------------
195	!NXmakedata creates a NeXus data set (optionally with compression)
196	FUNCTION NXmakedata (file_id, data_name, data_type, data_rank, &
197	data_dimensions, compress_type, chunk_size) &
198	RESULT (status)
199
200	TYPE(NXhandle), INTENT(in) :: file_id
201	CHARACTER(len=*), INTENT(in) :: data_name
202	INTEGER, INTENT(in) :: data_type,data_rank,data_dimensions(:)
203	INTEGER, OPTIONAL,INTENT(in) :: compress_type, chunk_size(:)
204	INTEGER, ALLOCATABLE :: NXchunk_size(:)
205	INTEGER :: status, i, nxifmakedata, nxifcompmakedata
206	EXTERNAL nxifmakedata, nxifcompmakedata
207
208	IF (PRESENT(compress_type)) THEN
209	IF (PRESENT(chunk_size)) THEN
210	ALLOCATE (NXchunk_size(data_rank))
211	NXchunk_size = chunk_size
212	ELSE
213	ALLOCATE (NXchunk_size(data_rank))
214	NXchunk_size = (/(data_dimensions(i),i=1,data_rank)/)
215	END IF
216	status = nxifcompmakedata(file_id, NXCstring(data_name), data_type, &
217	data_rank, data_dimensions, compress_type, NXchunk_size)
218	DEALLOCATE (NXchunk_size)
219	ELSE
220	status = nxifmakedata(file_id, NXCstring(data_name), data_type, &
221	data_rank, data_dimensions)
222	END IF
223
224	END FUNCTION NXmakedata
225	!------------------------------------------------------------------------------
226	!NXopendata opens an existing NeXus data set for input/output
227	FUNCTION NXopendata (file_id, data_name) RESULT (status)
228
229	TYPE(NXhandle), INTENT(in) :: file_id
230	CHARACTER(len=*), INTENT(in) :: data_name
231	INTEGER :: status, nxiopendata
232	EXTERNAL nxiopendata
233
234	status = nxiopendata(file_id, NXCstring(data_name))
235
236	END FUNCTION NXopendata
237	!------------------------------------------------------------------------------
238	!NXcompress sets the compression algorithm for the open NeXus data set
239	FUNCTION NXcompress (file_id, compress_type) RESULT (status)
240
241	TYPE(NXhandle), INTENT(in) :: file_id
242	INTEGER, INTENT(in) :: compress_type
243	INTEGER :: status, nxifcompress
244	EXTERNAL nxifcompress
245
246	status = nxifcompress(file_id, compress_type)
247
248	END FUNCTION NXcompress
249	!------------------------------------------------------------------------------
250	!NXclosedata closes a NeXus data set
251	FUNCTION NXclosedata (file_id) RESULT (status)
252
253	TYPE(NXhandle), INTENT(in) :: file_id
254	INTEGER :: status, nxiclosedata
255	EXTERNAL nxiclosedata
256
257	status = nxiclosedata(file_id)
258
259	END FUNCTION NXclosedata
260	!------------------------------------------------------------------------------
261	!NXgetdata reads data from the open data set
262	!
263	!The following routines define the generic function NXgetdata
264	!------------------------------------------------------------------------------
265	!NXgeti1 reads an integer*1 array from the open data set
266	FUNCTION NXgeti1 (file_id, data) RESULT (status)
267
268	TYPE(NXhandle), INTENT(in) :: file_id
269	INTEGER(KIND=NXi1), INTENT(out) :: data(:)
270	INTEGER :: status, nxigetdata
271	EXTERNAL nxigetdata
272
273	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
274	IF (status /= NX_OK) RETURN
275	NXsize = PRODUCT(NXdims(1:NXrank))
276	IF (NXsize > size(data)) THEN
277	CALL NXerror ("The supplied array is not large enough for the data")
278	status = NX_ERROR
279	ELSE IF (NXtype == NX_INT8 .OR. NXtype == NX_UINT8) THEN
280	ALLOCATE (buffer_i1(NXsize))
281	status = nxigetdata(file_id, buffer_i1)
282	data = buffer_i1
283	DEALLOCATE (buffer_i1)
284	ELSE IF (NXtype == NX_INT16 .OR. NXtype == NX_UINT16) THEN
285	ALLOCATE (buffer_i2(NXsize))
286	status = nxigetdata(file_id, buffer_i2)
287	IF (abs(maxval(buffer_i2)) <= HUGE(data)) THEN
288	data = buffer_i2
289	ELSE
290	CALL NXerror ("Input values too large for data type")
291	status = NX_ERROR
292	END IF
293	DEALLOCATE (buffer_i2)
294	ELSE IF (NXtype == NX_INT32 .OR. NXtype == NX_UINT32) THEN
295	ALLOCATE (buffer_i4(NXsize))
296	status = nxigetdata(file_id, buffer_i4)
297	IF (abs(maxval(buffer_i4)) <= HUGE(data)) THEN
298	data = buffer_i4
299	ELSE
300	CALL NXerror ("Input values too large for data type")
301	status = NX_ERROR
302	END IF
303	DEALLOCATE (buffer_i4)
304	ELSE
305	call NXerror &
306	("The datatype is incompatible with the supplied variable")
307	status = NX_ERROR
308	END IF
309
310	END FUNCTION NXgeti1
311	!------------------------------------------------------------------------------
312	!NXgeti2 reads an integer*2 array from the open data set
313	FUNCTION NXgeti2 (file_id, data) RESULT (status)
314
315	TYPE(NXhandle), INTENT(in) :: file_id
316	INTEGER(KIND=NXi2), INTENT(out) :: data(:)
317	INTEGER :: status, nxigetdata
318	EXTERNAL nxigetdata
319
320	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
321	IF (status /= NX_OK) RETURN
322	NXsize = PRODUCT(NXdims(1:NXrank))
323	IF (NXsize > size(data)) THEN
324	CALL NXerror ("The supplied array is not large enough for the data")
325	status = NX_ERROR
326	ELSE IF (NXtype == NX_INT8 .OR. NXtype == NX_UINT8) THEN
327	ALLOCATE (buffer_i1(NXsize))
328	status = nxigetdata(file_id, buffer_i1)
329	data = buffer_i1
330	DEALLOCATE (buffer_i1)
331	ELSE IF (NXtype == NX_INT16 .OR. NXtype == NX_UINT16) THEN
332	ALLOCATE (buffer_i2(NXsize))
333	status = nxigetdata(file_id, buffer_i2)
334	data = buffer_i2
335	DEALLOCATE (buffer_i2)
336	ELSE IF (NXtype == NX_INT32 .OR. NXtype == NX_UINT32) THEN
337	ALLOCATE (buffer_i4(NXsize))
338	status = nxigetdata(file_id, buffer_i4)
339	IF (abs(maxval(buffer_i4)) <= HUGE(data)) THEN
340	data = buffer_i4
341	ELSE
342	CALL NXerror ("Input values too large for data type")
343	status = NX_ERROR
344	END IF
345	DEALLOCATE (buffer_i4)
346	ELSE
347	call NXerror &
348	("The datatype is incompatible with the supplied variable")
349	status = NX_ERROR
350	END IF
351
352	END FUNCTION NXgeti2
353	!------------------------------------------------------------------------------
354	!NXgeti4 reads an integer*4 array from the open data set
355	FUNCTION NXgeti4 (file_id, data) RESULT (status)
356
357	TYPE(NXhandle), INTENT(in) :: file_id
358	INTEGER(KIND=NXi4), INTENT(out) :: data(:)
359	INTEGER :: status, nxigetdata
360	EXTERNAL nxigetdata
361
362	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
363	IF (status /= NX_OK) RETURN
364	NXsize = PRODUCT(NXdims(1:NXrank))
365	IF (NXsize > size(data)) THEN
366	CALL NXerror ("The supplied array is not large enough for the data")
367	status = NX_ERROR
368	ELSE IF (NXtype == NX_INT8 .OR. NXtype == NX_UINT8) THEN
369	ALLOCATE (buffer_i1(NXsize))
370	status = nxigetdata(file_id, buffer_i1)
371	data = buffer_i1
372	DEALLOCATE (buffer_i1)
373	ELSE IF (NXtype == NX_INT16 .OR. NXtype == NX_UINT16) THEN
374	ALLOCATE (buffer_i2(NXsize))
375	status = nxigetdata(file_id, buffer_i2)
376	data = buffer_i2
377	DEALLOCATE (buffer_i2)
378	ELSE IF (NXtype == NX_INT32 .OR. NXtype == NX_UINT32) THEN
379	ALLOCATE (buffer_i4(NXsize))
380	status = nxigetdata(file_id, buffer_i4)
381	data = buffer_i4
382	DEALLOCATE (buffer_i4)
383	ELSE
384	call NXerror &
385	("The datatype is incompatible with the supplied variable")
386	status = NX_ERROR
387	END IF
388
389	END FUNCTION NXgeti4
390	!------------------------------------------------------------------------------
391	!NXgetr4 reads a real*4 array from the open data set
392	FUNCTION NXgetr4 (file_id, data) RESULT (status)
393
394	TYPE(NXhandle), INTENT(in) :: file_id
395	REAL(KIND=NXr4), INTENT(out) :: data(:)
396	INTEGER :: status, nxigetdata
397	EXTERNAL nxigetdata
398
399	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
400	IF (status /= NX_OK) RETURN
401	NXsize = PRODUCT(NXdims(1:NXrank))
402	IF (NXsize > size(data)) THEN
403	CALL NXerror ("The supplied array is not large enough for the data")
404	status = NX_ERROR
405	ELSE IF (NXtype == NX_FLOAT32) THEN
406	ALLOCATE (buffer_r4(NXsize))
407	status = nxigetdata(file_id, buffer_r4)
408	data = buffer_r4
409	DEALLOCATE (buffer_r4)
410	ELSE IF (NXtype == NX_FLOAT64) THEN
411	ALLOCATE (buffer_r8(NXsize))
412	status = nxigetdata(file_id, buffer_r8)
413	data = buffer_r8
414	DEALLOCATE (buffer_r8)
415	ELSE
416	call NXerror &
417	("The datatype is incompatible with the supplied variable")
418	status = NX_ERROR
419	END IF
420
421	END FUNCTION NXgetr4
422	!------------------------------------------------------------------------------
423	!NXgetr8 reads a real*8 array from the open data set
424	FUNCTION NXgetr8 (file_id, data) RESULT (status)
425
426	TYPE(NXhandle), INTENT(in) :: file_id
427	REAL(KIND=NXr8), INTENT(out) :: data(:)
428	INTEGER :: status, nxigetdata
429	EXTERNAL nxigetdata
430
431	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
432	IF (status /= NX_OK) RETURN
433	NXsize = PRODUCT(NXdims(1:NXrank))
434	IF (NXsize > size(data)) THEN
435	CALL NXerror ("The supplied array is not large enough for the data")
436	status = NX_ERROR
437	ELSE IF (NXtype == NX_FLOAT32) THEN
438	ALLOCATE (buffer_r4(NXsize))
439	status = nxigetdata(file_id, buffer_r4)
440	data = buffer_r4
441	DEALLOCATE (buffer_r4)
442	ELSE IF (NXtype == NX_FLOAT64) THEN
443	ALLOCATE (buffer_r8(NXsize))
444	status = nxigetdata(file_id, buffer_r8)
445	IF (abs(maxval(buffer_r8)) <= HUGE(data)) THEN
446	data = buffer_r8
447	ELSE
448	CALL NXerror ("Input values too large for data type")
449	status = NX_ERROR
450	END IF
451	DEALLOCATE (buffer_r8)
452	ELSE
453	call NXerror &
454	("The datatype is incompatible with the supplied variable")
455	status = NX_ERROR
456	END IF
457
458	END FUNCTION NXgetr8
459	!------------------------------------------------------------------------------
460	!NXgetchar reads a character string from the open data set
461	FUNCTION NXgetchar (file_id, data) RESULT (status)
462
463	TYPE(NXhandle), INTENT(in) :: file_id
464	CHARACTER(len=*), INTENT(out) :: data
465	INTEGER :: status, nxigetdata
466	INTEGER(kind=NXi1) :: Cstring(255)
467	EXTERNAL nxigetdata
468
469	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
470	IF (status /= NX_OK) RETURN
471	NXsize = PRODUCT(NXdims(1:NXrank))
472	IF (NXsize > len(data)) THEN
473	CALL NXerror ("The supplied string is not large enough for the data")
474	status = NX_ERROR
475	ELSE IF (NXtype == NX_CHAR) THEN
476	Cstring = 0 !HDF does not add null termination so ensure it's there
477	status = nxigetdata(file_id, Cstring)
478	IF (status == NX_OK) data = trim(NXFstring(Cstring))
479	ELSE
480	call NXerror &
481	("The datatype is incompatible with the supplied variable")
482	status = NX_ERROR
483	END IF
484
485	END FUNCTION NXgetchar
486	!------------------------------------------------------------------------------
487	!NXgetslab reads a slab of the open data set
488	!
489	!The following routines define the generic function NXgetslab
490	!------------------------------------------------------------------------------
491	!NXgeti1slab reads a slab of integer*1 data from the open data set
492	FUNCTION NXgeti1slab (file_id, data, data_start, data_size) RESULT (status)
493
494	TYPE(NXhandle), INTENT(in) :: file_id
495	INTEGER, INTENT(in) :: data_start(:), data_size(:)
496	INTEGER(KIND=NXi1), INTENT(out) :: data(:)
497	INTEGER :: status, nxigetslab
498	EXTERNAL nxigetslab
499
500	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
501	IF (status /= NX_OK) RETURN
502	NXsize = PRODUCT(data_size(1:NXrank))
503	IF (NXsize > size(data)) THEN
504	CALL NXerror ("The supplied array is not large enough for the data")
505	status = NX_ERROR
506	ELSE IF (NXtype == NX_INT8 .OR. NXtype == NX_UINT8) THEN
507	ALLOCATE (buffer_i1(NXsize))
508	status = nxigetslab(file_id, buffer_i1, &
509	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
510	data = buffer_i1
511	DEALLOCATE (buffer_i1)
512	ELSE IF (NXtype == NX_INT16 .OR. NXtype == NX_UINT16) THEN
513	ALLOCATE (buffer_i2(NXsize))
514	status = nxigetslab(file_id, buffer_i2, &
515	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
516	IF (abs(maxval(buffer_i2)) <= HUGE(data)) THEN
517	data = buffer_i2
518	ELSE
519	CALL NXerror ("Input values too large for data type")
520	status = NX_ERROR
521	END IF
522	DEALLOCATE (buffer_i2)
523	ELSE IF (NXtype == NX_INT32 .OR. NXtype == NX_UINT32) THEN
524	ALLOCATE (buffer_i4(NXsize))
525	status = nxigetslab(file_id, buffer_i4, &
526	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
527	IF (abs(maxval(buffer_i4)) <= HUGE(data)) THEN
528	data = buffer_i4
529	ELSE
530	CALL NXerror ("Input values too large for data type")
531	status = NX_ERROR
532	END IF
533	DEALLOCATE (buffer_i4)
534	ELSE
535	call NXerror &
536	("The datatype is incompatible with the supplied variable")
537	status = NX_ERROR
538	END IF
539
540	END FUNCTION NXgeti1slab
541	!------------------------------------------------------------------------------
542	!NXgeti2slab reads a slab of integer*2 data from the open data set
543	FUNCTION NXgeti2slab (file_id, data, data_start, data_size) RESULT (status)
544
545	TYPE(NXhandle), INTENT(in) :: file_id
546	INTEGER, INTENT(in) :: data_start(:), data_size(:)
547	INTEGER(KIND=NXi2), INTENT(out) :: data(:)
548	INTEGER :: status, nxigetslab
549	EXTERNAL nxigetslab
550
551	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
552	IF (status /= NX_OK) RETURN
553	NXsize = PRODUCT(data_size(1:NXrank))
554	IF (NXsize > size(data)) THEN
555	CALL NXerror ("The supplied array is not large enough for the data")
556	status = NX_ERROR
557	ELSE IF (NXtype == NX_INT8 .OR. NXtype == NX_UINT8) THEN
558	ALLOCATE (buffer_i1(NXsize))
559	status = nxigetslab(file_id, buffer_i1, &
560	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
561	data = buffer_i1
562	DEALLOCATE (buffer_i1)
563	ELSE IF (NXtype == NX_INT16 .OR. NXtype == NX_UINT16) THEN
564	ALLOCATE (buffer_i2(NXsize))
565	status = nxigetslab(file_id, buffer_i2, &
566	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
567	data = buffer_i2
568	DEALLOCATE (buffer_i2)
569	ELSE IF (NXtype == NX_INT32 .OR. NXtype == NX_UINT32) THEN
570	ALLOCATE (buffer_i4(NXsize))
571	status = nxigetslab(file_id, buffer_i4, &
572	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
573	IF (abs(maxval(buffer_i4)) <= HUGE(data)) THEN
574	data = buffer_i4
575	ELSE
576	CALL NXerror ("Input values too large for data type")
577	status = NX_ERROR
578	END IF
579	DEALLOCATE (buffer_i4)
580	ELSE
581	call NXerror &
582	("The datatype is incompatible with the supplied variable")
583	status = NX_ERROR
584	END IF
585
586	END FUNCTION NXgeti2slab
587	!------------------------------------------------------------------------------
588	!NXgeti4slab reads a slab of integer*4 data from the open data set
589	FUNCTION NXgeti4slab (file_id, data, data_start, data_size) RESULT (status)
590
591	TYPE(NXhandle), INTENT(in) :: file_id
592	INTEGER, INTENT(in) :: data_start(:), data_size(:)
593	INTEGER(KIND=NXi4), INTENT(out) :: data(:)
594	INTEGER :: status, nxigetslab
595	EXTERNAL nxigetslab
596
597	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
598	IF (status /= NX_OK) RETURN
599	NXsize = PRODUCT(data_size(1:NXrank))
600	IF (NXsize > size(data)) THEN
601	CALL NXerror ("The supplied array is not large enough for the data")
602	status = NX_ERROR
603	ELSE IF (NXtype == NX_INT8 .OR. NXtype == NX_UINT8) THEN
604	ALLOCATE (buffer_i1(NXsize))
605	status = nxigetslab(file_id, buffer_i1, &
606	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
607	data = buffer_i1
608	DEALLOCATE (buffer_i1)
609	ELSE IF (NXtype == NX_INT16 .OR. NXtype == NX_UINT16) THEN
610	ALLOCATE (buffer_i2(NXsize))
611	status = nxigetslab(file_id, buffer_i2, &
612	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
613	data = buffer_i2
614	DEALLOCATE (buffer_i2)
615	ELSE IF (NXtype == NX_INT32 .OR. NXtype == NX_UINT32) THEN
616	ALLOCATE (buffer_i4(NXsize))
617	status = nxigetslab(file_id, buffer_i4, &
618	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
619	data = buffer_i4
620	DEALLOCATE (buffer_i4)
621	ELSE
622	call NXerror &
623	("The datatype is incompatible with the supplied variable")
624	status = NX_ERROR
625	END IF
626
627	END FUNCTION NXgeti4slab
628	!------------------------------------------------------------------------------
629	!NXgetr4slab reads a slab of real*4 data from the open data set
630	FUNCTION NXgetr4slab (file_id, data, data_start, data_size) RESULT (status)
631
632	TYPE(NXhandle), INTENT(in) :: file_id
633	INTEGER, INTENT(in) :: data_start(:), data_size(:)
634	REAL(KIND=NXr4), INTENT(out) :: data(:)
635	INTEGER :: status, nxigetslab
636	EXTERNAL nxigetslab
637
638	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
639	IF (status /= NX_OK) RETURN
640	NXsize = PRODUCT(data_size(1:NXrank))
641	IF (NXsize > size(data)) THEN
642	CALL NXerror ("The supplied array is not large enough for the data")
643	status = NX_ERROR
644	ELSE IF (NXtype == NX_FLOAT32) THEN
645	ALLOCATE (buffer_r4(NXsize))
646	status = nxigetslab(file_id, buffer_r4, &
647	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
648	data = buffer_r4
649	DEALLOCATE (buffer_r4)
650	ELSE IF (NXtype == NX_FLOAT64) THEN
651	ALLOCATE (buffer_r8(NXsize))
652	status = nxigetslab(file_id, buffer_r8, &
653	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
654	IF (abs(maxval(buffer_r8)) <= HUGE(data)) THEN
655	data = buffer_r8
656	ELSE
657	CALL NXerror ("Input values too large for data type")
658	status = NX_ERROR
659	END IF
660	DEALLOCATE (buffer_r8)
661	ELSE
662	call NXerror &
663	("The datatype is incompatible with the supplied variable")
664	status = NX_ERROR
665	END IF
666
667	END FUNCTION NXgetr4slab
668	!------------------------------------------------------------------------------
669	!NXgetr8slab reads a slab of real*8 data from the open data set
670	FUNCTION NXgetr8slab (file_id, data, data_start, data_size) RESULT (status)
671
672	TYPE(NXhandle), INTENT(in) :: file_id
673	INTEGER, INTENT(in) :: data_start(:), data_size(:)
674	REAL(KIND=NXr8), INTENT(out) :: data(:)
675	INTEGER :: status, nxigetslab
676	EXTERNAL nxigetslab
677
678	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
679	IF (status /= NX_OK) RETURN
680	NXsize = PRODUCT(data_size(1:NXrank))
681	IF (NXsize > size(data)) THEN
682	CALL NXerror ("The supplied array is not large enough for the data")
683	status = NX_ERROR
684	ELSE IF (NXtype == NX_FLOAT32) THEN
685	ALLOCATE (buffer_r4(NXsize))
686	status = nxigetslab(file_id, buffer_r4, &
687	NXreverse(NXrank,data_start), NXreverse(NXrank,data_size))
688	data = buffer_r4
689	DEALLOCATE (buffer_r4)
690	ELSE IF (NXtype == NX_FLOAT64) THEN
691	ALLOCATE (buffer_r8(NXsize))
692	status = nxigetslab(file_id, buffer_r8, &
693	NXreverse(NXrank,data_start), NXreverse(NXrank,data_size))
694	data = buffer_r8
695	DEALLOCATE (buffer_r8)
696	ELSE
697	call NXerror &
698	("The datatype is incompatible with the supplied variable")
699	status = NX_ERROR
700	END IF
701
702	END FUNCTION NXgetr8slab
703	!------------------------------------------------------------------------------
704	!NXgetattr reads attributes from the open data set
705	!
706	!The following routines define the generic function NXgetattr
707	!------------------------------------------------------------------------------
708	!NXgeti1attr reads an integer*1 attribute from the open data set
709	FUNCTION NXgeti1attr (file_id, attr_name, value, attr_length, attr_type) &
710	RESULT (status)
711
712	TYPE(NXhandle), INTENT(in) :: file_id
713	CHARACTER(len=*), INTENT(in) :: attr_name
714	INTEGER(KIND=NXi1), INTENT(out) :: value
715	INTEGER, OPTIONAL, INTENT(inout) :: attr_length
716	INTEGER, OPTIONAL, INTENT(in) :: attr_type
717	INTEGER :: status, nxigetattr, value_length, value_type
718	EXTERNAL nxigetattr
719
720	value_length = 1; value_type = NX_INT8
721	status = nxigetattr(file_id, NXCstring(attr_name), value, value_length, &
722	value_type)
723
724	END FUNCTION NXgeti1attr
725	!------------------------------------------------------------------------------
726	!NXgeti2attr reads an integer*2 attribute from the open data set
727	FUNCTION NXgeti2attr (file_id, attr_name, value, attr_length, attr_type) &
728	RESULT (status)
729
730	TYPE(NXhandle), INTENT(in) :: file_id
731	CHARACTER(len=*), INTENT(in) :: attr_name
732	INTEGER(KIND=NXi2), INTENT(out) :: value
733	INTEGER, OPTIONAL, INTENT(inout) :: attr_length
734	INTEGER, OPTIONAL, INTENT(in) :: attr_type
735	INTEGER :: status, nxigetattr, value_length, value_type
736	EXTERNAL nxigetattr
737
738	value_length = 1; value_type = NX_INT16
739	status = nxigetattr(file_id, NXCstring(attr_name), value, value_length, &
740	value_type)
741
742	END FUNCTION NXgeti2attr
743	!------------------------------------------------------------------------------
744	!NXgeti4attr reads an integer*4 attribute from the open data set
745	FUNCTION NXgeti4attr (file_id, attr_name, value, attr_length, attr_type) &
746	RESULT (status)
747
748	TYPE(NXhandle), INTENT(in) :: file_id
749	CHARACTER(len=*), INTENT(in) :: attr_name
750	INTEGER(KIND=NXi4), INTENT(out) :: value
751	INTEGER, OPTIONAL, INTENT(inout) :: attr_length
752	INTEGER, OPTIONAL, INTENT(in) :: attr_type
753	INTEGER :: status, nxigetattr, value_length, value_type
754	EXTERNAL nxigetattr
755
756	value_length = 1; value_type = NX_INT32
757	status = nxigetattr(file_id, NXCstring(attr_name), value, value_length, &
758	value_type)
759
760	END FUNCTION NXgeti4attr
761	!------------------------------------------------------------------------------
762	!NXgetr4attr reads a real*4 attribute from the open data set
763	FUNCTION NXgetr4attr (file_id, attr_name, value, attr_length, attr_type) &
764	RESULT (status)
765
766	TYPE(NXhandle), INTENT(in) :: file_id
767	CHARACTER(len=*), INTENT(in) :: attr_name
768	REAL(KIND=NXr4), INTENT(out) :: value
769	INTEGER, OPTIONAL, INTENT(inout) :: attr_length
770	INTEGER, OPTIONAL, INTENT(in) :: attr_type
771	INTEGER :: status, nxigetattr, value_length, value_type
772	EXTERNAL nxigetattr
773
774	value_length = 1; value_type = NX_FLOAT32
775	status = nxigetattr(file_id, NXCstring(attr_name), value, value_length, &
776	value_type)
777
778	END FUNCTION NXgetr4attr
779	!------------------------------------------------------------------------------
780	!NXgetr8attr reads a real*8 attribute from the open data set
781	FUNCTION NXgetr8attr (file_id, attr_name, value, attr_length, attr_type) &
782	RESULT (status)
783
784	TYPE(NXhandle), INTENT(in) :: file_id
785	CHARACTER(len=*), INTENT(in) :: attr_name
786	REAL(KIND=NXr8), INTENT(out) :: value
787	INTEGER, OPTIONAL, INTENT(inout) :: attr_length
788	INTEGER, OPTIONAL, INTENT(in) :: attr_type
789	INTEGER :: status, nxigetattr, value_length, value_type
790	EXTERNAL nxigetattr
791
792	value_length = 1; value_type = NX_FLOAT64
793	status = nxigetattr(file_id, NXCstring(attr_name), value, value_length, &
794	value_type)
795
796	END FUNCTION NXgetr8attr
797	!------------------------------------------------------------------------------
798	!NXgetcharattr reads a character attribute from the open data set
799	FUNCTION NXgetcharattr (file_id, attr_name, value, attr_length, attr_type) &
800	RESULT (status)
801
802	TYPE(NXhandle), INTENT(in) :: file_id
803	CHARACTER(len=*), INTENT(in) :: attr_name
804	CHARACTER(len=*), INTENT(out) :: value
805	INTEGER, OPTIONAL, INTENT(inout) :: attr_length
806	INTEGER, OPTIONAL, INTENT(in) :: attr_type
807	INTEGER :: status, nxigetattr, value_length, value_type
808	INTEGER(kind=NXi1) :: Cstring(255)
809	EXTERNAL nxigetattr
810
811	value_length = len(value); value_type = NX_CHAR
812	Cstring = 0
813	status = nxigetattr(file_id, NXCstring(attr_name), Cstring, &
814	value_length, value_type)
815	value = trim(NXFstring(Cstring))
816
817	END FUNCTION NXgetcharattr
818	!------------------------------------------------------------------------------
819	!NXputdata writes data into the open data set
820	!
821	!The following routines define the generic function NXputdata
822	!------------------------------------------------------------------------------
823	!NXputi1 writes an integer*1 array to the open data set
824	FUNCTION NXputi1 (file_id, data) RESULT (status)
825
826	TYPE(NXhandle), INTENT(in) :: file_id
827	INTEGER(KIND=NXi1), INTENT(in) :: data(:)
828	INTEGER :: status, nxiputdata
829	EXTERNAL nxiputdata
830
831	status = nxiputdata(file_id, data)
832
833	END FUNCTION NXputi1
834	!------------------------------------------------------------------------------
835	!NXputi2 writes an integer*2 array to the open data set
836	FUNCTION NXputi2 (file_id, data) RESULT (status)
837
838	TYPE(NXhandle), INTENT(in) :: file_id
839	INTEGER(KIND=NXi2), INTENT(in) :: data(:)
840	INTEGER :: status, nxiputdata
841	EXTERNAL nxiputdata
842
843	status = nxiputdata(file_id, data)
844
845	END FUNCTION NXputi2
846	!------------------------------------------------------------------------------
847	!NXputi1 writes an integer*4 array to the open data set
848	FUNCTION NXputi4 (file_id, data) RESULT (status)
849
850	TYPE(NXhandle), INTENT(in) :: file_id
851	INTEGER(KIND=NXi4), INTENT(in) :: data(:)
852	INTEGER :: status, nxiputdata
853	EXTERNAL nxiputdata
854
855	status = nxiputdata(file_id, data)
856
857	END FUNCTION NXputi4
858	!------------------------------------------------------------------------------
859	!NXputreal writes a real*4 array to the open data set
860	FUNCTION NXputr4 (file_id, data) RESULT (status)
861
862	TYPE(NXhandle), INTENT(in) :: file_id
863	REAL(KIND=NXr4), INTENT(in) :: data(:)
864	INTEGER :: status, nxiputdata
865	EXTERNAL nxiputdata
866
867	status = nxiputdata(file_id, data)
868
869	END FUNCTION NXputr4
870	!------------------------------------------------------------------------------
871	!NXputr8 writes a real*8 array to the open data set
872	FUNCTION NXputr8 (file_id, data) RESULT (status)
873
874	TYPE(NXhandle), INTENT(in) :: file_id
875	REAL(KIND=NXr8), INTENT(in) :: data(:)
876	INTEGER :: status, nxiputdata
877	EXTERNAL nxiputdata
878
879	status = nxiputdata(file_id, data)
880
881	END FUNCTION NXputr8
882	!------------------------------------------------------------------------------
883	!NXputchar writes a character string to the open data set
884	FUNCTION NXputchar (file_id, data) RESULT (status)
885
886	TYPE(NXhandle), INTENT(in) :: file_id
887	CHARACTER(len=*), INTENT(in) :: data
888	INTEGER :: status, nxiputdata
889	EXTERNAL nxiputdata
890
891	status = nxiputdata(file_id, NXCstring(data))
892
893	END FUNCTION NXputchar
894	!------------------------------------------------------------------------------
895	!NXputslab writes a slab of data into the open data set
896	!
897	!The following routines define the generic function NXputslab
898	!------------------------------------------------------------------------------
899	!NXputi1slab writes a slab of integer*1 data into the open data set
900	FUNCTION NXputi1slab (file_id, data, data_start, data_size) RESULT (status)
901
902	TYPE(NXhandle), INTENT(in) :: file_id
903	INTEGER, INTENT(in) :: data_start(:), data_size(:)
904	INTEGER(KIND=NXi1), INTENT(in) :: data(:)
905	INTEGER :: status, nxiputslab
906	EXTERNAL nxiputslab
907
908	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
909	status = nxiputslab(file_id, data, &
910	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
911
912	END FUNCTION NXputi1slab
913	!------------------------------------------------------------------------------
914	!NXputi2slab writes a slab of integer*2 data into the open data set
915	FUNCTION NXputi2slab (file_id, data, data_start, data_size) RESULT (status)
916
917	TYPE(NXhandle), INTENT(in) :: file_id
918	INTEGER, INTENT(in) :: data_start(:), data_size(:)
919	INTEGER(KIND=NXi2), INTENT(in) :: data(:)
920	INTEGER :: status, nxiputslab
921	EXTERNAL nxiputslab
922
923	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
924	status = nxiputslab(file_id, data, &
925	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
926
927	END FUNCTION NXputi2slab
928	!------------------------------------------------------------------------------
929	!NXputi4slab writes a slab of integer*4 data into the open data set
930	FUNCTION NXputi4slab (file_id, data, data_start, data_size) RESULT (status)
931
932	TYPE(NXhandle), INTENT(in) :: file_id
933	INTEGER, INTENT(in) :: data_start(:), data_size(:)
934	INTEGER(KIND=NXi4), INTENT(in) :: data(:)
935	INTEGER :: status, nxiputslab
936	EXTERNAL nxiputslab
937
938	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
939	status = nxiputslab(file_id, data, &
940	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
941
942	END FUNCTION NXputi4slab
943	!------------------------------------------------------------------------------
944	!NXputr4slab writes a slab of real*4 data into the open data set
945	FUNCTION NXputr4slab (file_id, data, data_start, data_size) RESULT (status)
946
947	TYPE(NXhandle), INTENT(in) :: file_id
948	INTEGER, INTENT(in) :: data_start(:), data_size(:)
949	REAL(KIND=NXr4), INTENT(in) :: data(:)
950	INTEGER :: status, nxiputslab
951	EXTERNAL nxiputslab
952
953	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
954	status = nxiputslab(file_id, data, &
955	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
956
957	END FUNCTION NXputr4slab
958	!------------------------------------------------------------------------------
959	!NXputr8slab writes a slab of real*8 data into the open data set
960	FUNCTION NXputr8slab (file_id, data, data_start, data_size) RESULT (status)
961
962	TYPE(NXhandle), INTENT(in) :: file_id
963	INTEGER, INTENT(in) :: data_start(:), data_size(:)
964	REAL(KIND=NXr8), INTENT(in) :: data(:)
965	INTEGER :: status, nxiputslab
966	EXTERNAL nxiputslab
967
968	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
969	status = nxiputslab(file_id, data, &
970	NXreverse(NXrank,data_start)-1, NXreverse(NXrank,data_size))
971
972	END FUNCTION NXputr8slab
973	!------------------------------------------------------------------------------
974	!NXputattr writes an attribute of the open data set
975	!
976	!The following routines define the generic function NXputdata
977	!------------------------------------------------------------------------------
978	!NXputi1attr writes an integer*1 attribute of the open data set
979	FUNCTION NXputi1attr (file_id, name, value, value_length, value_type) &
980	RESULT (status)
981
982	TYPE(NXhandle), INTENT(in) :: file_id
983	CHARACTER(len=*), INTENT(in) :: name
984	INTEGER(KIND=NXi1), INTENT(in) :: value
985	INTEGER, OPTIONAL, INTENT(in) :: value_length
986	INTEGER, OPTIONAL, INTENT(in) :: value_type
987	INTEGER :: status, nxifputattr
988	EXTERNAL nxifputattr
989
990	status = nxifputattr(file_id, NXCstring(name), value, 1, NX_INT8)
991
992	END FUNCTION NXputi1attr
993	!------------------------------------------------------------------------------
994	!NXputi2attr writes an integer*2 attribute of the open data set
995	FUNCTION NXputi2attr (file_id, name, value, value_length, value_type) &
996	RESULT (status)
997
998	TYPE(NXhandle), INTENT(in) :: file_id
999	CHARACTER(len=*), INTENT(in) :: name
1000	INTEGER(KIND=NXi2), INTENT(in) :: value
1001	INTEGER, OPTIONAL, INTENT(in) :: value_length
1002	INTEGER, OPTIONAL, INTENT(in) :: value_type
1003	INTEGER :: status, nxifputattr
1004	EXTERNAL nxifputattr
1005
1006	status = nxifputattr(file_id, NXCstring(name), value, 1, NX_INT16)
1007
1008	END FUNCTION NXputi2attr
1009	!------------------------------------------------------------------------------
1010	!NXputi4attr writes an integer*4 attribute of the open data set
1011	FUNCTION NXputi4attr (file_id, name, value, value_length, value_type) &
1012	RESULT (status)
1013
1014	TYPE(NXhandle), INTENT(in) :: file_id
1015	CHARACTER(len=*), INTENT(in) :: name
1016	INTEGER(KIND=NXi4), INTENT(in) :: value
1017	INTEGER, OPTIONAL, INTENT(in) :: value_length
1018	INTEGER, OPTIONAL, INTENT(in) :: value_type
1019	INTEGER :: status, nxifputattr
1020	EXTERNAL nxifputattr
1021
1022	status = nxifputattr(file_id, NXCstring(name), value, 1, NX_INT32)
1023
1024	END FUNCTION NXputi4attr
1025	!------------------------------------------------------------------------------
1026	!NXputr4attr writes a real*4 attribute of the open data set
1027	FUNCTION NXputr4attr (file_id, name, value, value_length, value_type) &
1028	RESULT (status)
1029
1030	TYPE(NXhandle), INTENT(in) :: file_id
1031	CHARACTER(len=*), INTENT(in) :: name
1032	REAL(KIND=NXr4), INTENT(in) :: value
1033	INTEGER, OPTIONAL, INTENT(in) :: value_length
1034	INTEGER, OPTIONAL, INTENT(in) :: value_type
1035	INTEGER :: status, nxifputattr
1036	EXTERNAL nxifputattr
1037
1038	status = nxifputattr(file_id, NXCstring(name), value, 1, NX_FLOAT32)
1039
1040	END FUNCTION NXputr4attr
1041	!------------------------------------------------------------------------------
1042	!NXputr8attr writes a real*8 attribute of the open data set
1043	FUNCTION NXputr8attr (file_id, name, value, value_length, value_type) &
1044	RESULT (status)
1045
1046	TYPE(NXhandle), INTENT(in) :: file_id
1047	CHARACTER(len=*), INTENT(in) :: name
1048	REAL(KIND=NXr8), INTENT(in) :: value
1049	INTEGER, OPTIONAL, INTENT(in) :: value_length
1050	INTEGER, OPTIONAL, INTENT(in) :: value_type
1051	INTEGER :: status, nxifputattr
1052	EXTERNAL nxifputattr
1053
1054	status = nxifputattr(file_id, NXCstring(name), value, 1, NX_FLOAT64)
1055
1056	END FUNCTION NXputr8attr
1057	!------------------------------------------------------------------------------
1058	!NXputcharattr writes character attribute of the open data set
1059	FUNCTION NXputcharattr (file_id, name, value, value_length, value_type) &
1060	RESULT (status)
1061
1062	TYPE(NXhandle), INTENT(in) :: file_id
1063	CHARACTER(len=*), INTENT(in) :: name
1064	CHARACTER(len=*), INTENT(in) :: value
1065	INTEGER, OPTIONAL, INTENT(in) :: value_length
1066	INTEGER, OPTIONAL, INTENT(in) :: value_type
1067	INTEGER :: status, nxifputattr
1068	EXTERNAL nxifputattr
1069
1070	status = nxifputattr(file_id, NXCstring(name), NXCstring(value), &
1071	len_trim(value), NX_CHAR)
1072
1073	END FUNCTION NXputcharattr
1074	!------------------------------------------------------------------------------
1075	!------------------------------------------------------------------------------
1076	!NXgetinfo gets the rank, dimensions and type of the open data set
1077	FUNCTION NXgetinfo (file_id, data_rank, data_dimensions, data_type) &
1078	RESULT (status)
1079
1080	TYPE(NXhandle), INTENT(in) :: file_id
1081	INTEGER, INTENT(out) :: data_rank, data_dimensions(:), data_type
1082	INTEGER :: status, nxigetinfo, i, j, dimensions(size(data_dimensions))
1083	EXTERNAL nxigetinfo
1084
1085	status = nxigetinfo(file_id, data_rank, dimensions, data_type)
1086	IF (status == NX_OK) THEN
1087	data_dimensions = NXreverse (data_rank, dimensions)
1088	END IF
1089
1090	END FUNCTION NXgetinfo
1091	!------------------------------------------------------------------------------
1092	!NXgetnextentry implements a directory search of the open group
1093	FUNCTION NXgetnextentry (file_id, name, class, data_type) RESULT (status)
1094
1095	TYPE(NXhandle), INTENT(in) :: file_id
1096	CHARACTER(len=*), INTENT(out) :: name, class
1097	INTEGER, INTENT(out) :: data_type
1098	INTEGER :: status, nxigetnextentry, i, j
1099	INTEGER(kind=NXi1) :: Cname(NX_MAXNAMELEN), Cclass(NX_MAXNAMELEN)
1100	EXTERNAL nxigetnextentry
1101
1102	status = nxigetnextentry(file_id, Cname, Cclass, data_type)
1103	name = trim(NXFstring(Cname))
1104	class = trim(NXFstring(Cclass))
1105
1106	END FUNCTION NXgetnextentry
1107	!------------------------------------------------------------------------------
1108	!NXgetnextattr implements a search of all the attributes of the open data set
1109	FUNCTION NXgetnextattr (file_id, attr_name, attr_length, attr_type) &
1110	RESULT (status)
1111
1112	TYPE(NXhandle), INTENT(in) :: file_id
1113	CHARACTER(len=*), INTENT(out) :: attr_name
1114	INTEGER, INTENT(out) :: attr_length, attr_type
1115	INTEGER :: status, nxigetnextattr
1116	INTEGER(kind=NXi1) :: Cstring(NX_MAXNAMELEN)
1117	EXTERNAL nxigetnextattr
1118
1119	status = nxigetnextattr(file_id, Cstring, attr_length, attr_type)
1120	attr_name = trim(NXFstring(Cstring))
1121
1122	END FUNCTION NXgetnextattr
1123	!------------------------------------------------------------------------------
1124	!NXgetgroupID returns the identifier of the open group as an NXlink structure
1125	FUNCTION NXgetgroupID (file_id, group_id) RESULT (status)
1126
1127	TYPE(NXhandle), INTENT(in) :: file_id
1128	TYPE(NXlink), INTENT(out) :: group_id
1129	TYPE(NXlink) :: current_id
1130	INTEGER :: status, nxigetgroupid
1131	EXTERNAL nxigetgroupid
1132
1133	status = nxigetgroupid(file_id, current_id)
1134	group_id = current_id
1135
1136	END FUNCTION NXgetgroupID
1137	!------------------------------------------------------------------------------
1138	!NXgetdataID returns the identifier of the open data set as an NXlink structure
1139	FUNCTION NXgetdataID (file_id, data_id) RESULT (status)
1140
1141	TYPE(NXhandle), INTENT(in) :: file_id
1142	TYPE(NXlink), INTENT(out) :: data_id
1143	TYPE(NXlink) :: current_id
1144	INTEGER :: status, nxigetdataid
1145	EXTERNAL nxigetdataid
1146
1147	status = nxigetdataid(file_id, current_id)
1148	data_id = current_id
1149
1150	END FUNCTION NXgetdataID
1151	!------------------------------------------------------------------------------
1152	!NXsameID checks that two group or data ID's are the same
1153	FUNCTION NXsameID (file_id, first_id, second_id) RESULT (same)
1154
1155	TYPE(NXhandle), INTENT(in) :: file_id
1156	TYPE(NXlink), INTENT(in) :: first_id, second_id
1157	LOGICAL :: same
1158	INTEGER :: status, nxisameid
1159	EXTERNAL nxisameid
1160
1161	status = nxisameid(file_id, first_id, second_id)
1162	IF (status == NX_OK) THEN
1163	same = .TRUE.
1164	ELSE
1165	same = .FALSE.
1166	ENDIF
1167
1168	END FUNCTION NXsameID
1169	!------------------------------------------------------------------------------
1170	!NXmakelink links a data item (group or set) to another group
1171	FUNCTION NXmakelink (file_id, link) RESULT (status)
1172
1173	TYPE(NXhandle), INTENT(in) :: file_id
1174	TYPE(NXlink), INTENT(in) :: link
1175	INTEGER :: status, nximakelink
1176	EXTERNAL nximakelink
1177
1178	status = nximakelink(file_id, link)
1179
1180	END FUNCTION NXmakelink
1181	!------------------------------------------------------------------------------
1182	!NXgetgroupinfo returns the number of entries, name and class of the open group
1183	FUNCTION NXgetgroupinfo (file_id, item_number, group_name, group_class) &
1184	RESULT (status)
1185
1186	TYPE(NXhandle), INTENT(in) :: file_id
1187	INTEGER, INTENT(out) :: item_number
1188	CHARACTER(len=*), INTENT(out), OPTIONAL :: group_name, group_class
1189	TYPE(NXlink) :: group_id, new_id
1190	INTEGER :: status, nxigetgroupinfo
1191	INTEGER(kind=NXi1) :: Cname(NX_MAXNAMELEN), Cclass(NX_MAXNAMELEN)
1192	EXTERNAL nxigetgroupinfo
1193
1194	status = nxigetgroupinfo (file_id, item_number, Cname, Cclass)
1195	IF (PRESENT(group_name)) group_name = trim(NXFstring(Cname))
1196	IF (PRESENT(group_class)) group_class = trim(NXFstring(Cclass))
1197
1198	END FUNCTION NXgetgroupinfo
1199	!------------------------------------------------------------------------------
1200	!NXinitgroupdir initializes data searches using NXgetnextentry
1201	FUNCTION NXinitgroupdir (file_id) RESULT (status)
1202
1203	TYPE(NXhandle), INTENT(inout) :: file_id
1204	INTEGER :: status, nxiinitgroupdir
1205	EXTERNAL nxiinitgroupdir
1206
1207	status = nxiinitgroupdir (file_id)
1208
1209	END FUNCTION NXinitgroupdir
1210	!------------------------------------------------------------------------------
1211	!NXgroupdir returns a list of items in the currently open group
1212	FUNCTION NXgroupdir (file_id, item_number, item_name, item_class) &
1213	RESULT (status)
1214
1215	TYPE(NXhandle), INTENT(inout) :: file_id
1216	INTEGER, INTENT(out) :: item_number
1217	CHARACTER(len=*) :: item_name(:), item_class(:)
1218	CHARACTER(len=len(item_name)) :: name
1219	CHARACTER(len=len(item_class)) :: class
1220	INTEGER :: status
1221
1222	status = NXinitgroupdir (file_id)
1223	item_number = 0
1224	DO
1225	status = NXgetnextentry (file_id, name, class, NXtype)
1226	IF (status == NX_OK .AND. &
1227	(class(1:2) == "NX" .OR. class(1:3) == "SDS")) THEN
1228	item_number = item_number + 1
1229	IF (item_number > size(item_name) .OR. &
1230	item_number > size(item_class)) THEN
1231	CALL NXerror ("Number of items greater than array size")
1232	status = NX_ERROR
1233	RETURN
1234	END IF
1235	item_name(item_number) = trim(name)
1236	item_class(item_number) = trim(class)
1237	ELSE IF (status == NX_EOD) THEN
1238	EXIT
1239	ELSE IF (status == NX_ERROR) THEN
1240	RETURN
1241	END IF
1242	END DO
1243	status = NX_OK
1244
1245	END FUNCTION NXgroupdir
1246	!------------------------------------------------------------------------------
1247	!NXgetattrinfo returns the number of attributes of the open data set
1248	FUNCTION NXgetattrinfo (file_id, attr_number) RESULT (status)
1249
1250	TYPE(NXhandle), INTENT(inout) :: file_id
1251	INTEGER, INTENT(out) :: attr_number
1252	INTEGER :: status, nxigetattrinfo
1253	EXTERNAL nxigetattrinfo
1254
1255	status = nxigetattrinfo (file_id, attr_number)
1256
1257	END FUNCTION NXgetattrinfo
1258	!------------------------------------------------------------------------------
1259	!NXinitattrdir initializes attribute searches using NXgetnextattr
1260	FUNCTION NXinitattrdir (file_id) RESULT (status)
1261
1262	TYPE(NXhandle), INTENT(inout) :: file_id
1263	INTEGER :: status, nxiinitattrdir
1264	EXTERNAL nxiinitattrdir
1265
1266	status = nxiinitattrdir (file_id)
1267
1268	END FUNCTION NXinitattrdir
1269	!------------------------------------------------------------------------------
1270	!NXattrdir returns a list of NeXus attributes of current data item
1271	FUNCTION NXattrdir (file_id, attr_number, attr_name) RESULT (status)
1272
1273	TYPE(NXhandle), INTENT(inout) :: file_id
1274	INTEGER, INTENT(out) :: attr_number
1275	CHARACTER(len=*) :: attr_name(:)
1276	CHARACTER(len=len(attr_name)) :: name
1277	INTEGER :: status
1278
1279	status = NXinitattrdir (file_id)
1280	attr_number = 0
1281	DO
1282	status = NXgetnextattr (file_id, name, NXsize, NXtype)
1283	IF (status == NX_OK) THEN
1284	attr_number = attr_number + 1
1285	IF (attr_number > size(attr_name)) THEN
1286	CALL NXerror ("Number of attributes greater than array size")
1287	status = NX_ERROR
1288	RETURN
1289	ELSE
1290	attr_name(attr_number) = trim(name)
1291	END IF
1292	ELSE IF (status == NX_EOD) THEN
1293	EXIT
1294	ELSE IF (status == NX_ERROR) THEN
1295	RETURN
1296	END IF
1297	END DO
1298	status = NX_OK
1299
1300	END FUNCTION NXattrdir
1301	!------------------------------------------------------------------------------
1302	!NXreverse reverses dimensions for transferring data from F90 to C
1303	FUNCTION NXreverse (rank, dimensions) RESULT (reversed_dimensions)
1304
1305	INTEGER, INTENT(in) :: rank
1306	INTEGER, INTENT(in) :: dimensions(:)
1307	INTEGER :: reversed_dimensions(size(dimensions))
1308	INTEGER :: i
1309
1310	DO i = 1,rank
1311	reversed_dimensions(i) = dimensions(rank-i+1)
1312	END DO
1313
1314	END FUNCTION NXreverse
1315	!------------------------------------------------------------------------------
1316	!NXCstring converts a Fortran string into a C string
1317	FUNCTION NXCstring (string) RESULT (array)
1318
1319	CHARACTER(len=*), INTENT(in) :: string
1320	INTEGER(kind=NXi1) :: array(255)
1321	INTEGER :: i
1322
1323	DO i = 1,min(len_trim(string),(size(array)-1))
1324	array(i) = ichar(string(i:i))
1325	END DO
1326	array(len_trim(string)+1) = 0
1327
1328	END FUNCTION NXCstring
1329	!------------------------------------------------------------------------------
1330	!NXFstring converts a C string into a Fortran string
1331	FUNCTION NXFstring (array) RESULT (string)
1332
1333	INTEGER(kind=NXi1), INTENT(in) :: array(:)
1334	CHARACTER(len=255) :: string
1335	INTEGER :: i
1336
1337	string = " "
1338	DO i = 1,size(array)
1339	IF (array(i) == 0) EXIT
1340	string(i:i) = char(array(i))
1341	END DO
1342
1343	END FUNCTION NXFstring
1344	!------------------------------------------------------------------------------
1345	!NXdatatype converts a NeXus data type into a character string
1346	FUNCTION NXdatatype (int_type) RESULT (char_type)
1347
1348	INTEGER, INTENT(in) :: int_type
1349	CHARACTER(len=10) :: char_type
1350
1351	SELECT CASE (int_type)
1352	CASE(NX_CHAR); char_type = "NX_CHAR"
1353	CASE(NX_FLOAT32); char_type = "NX_FLOAT32"
1354	CASE(NX_FLOAT64); char_type = "NX_FLOAT64"
1355	CASE(NX_INT8); char_type = "NX_INT8"
1356	CASE(NX_INT16); char_type = "NX_INT16"
1357	CASE(NX_INT32); char_type = "NX_INT32"
1358	CASE(NX_UINT32); char_type = "NX_UINT32"
1359	CASE DEFAULT; char_type = "UNKNOWN"
1360	END SELECT
1361
1362	END FUNCTION NXdatatype
1363	!------------------------------------------------------------------------------
1364	!NXerror prints out an error message to the default unit
1365	SUBROUTINE NXerror (message)
1366
1367	CHARACTER(len=*), INTENT(in) :: message
1368
1369	PRINT *, "NXerror : "//message
1370
1371	END SUBROUTINE NXerror
1372
1373	END MODULE NXmodule

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/bindings/f90/NXmodule.f90 @ 1822

Download in other formats: