Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

NXUmodule.f90 @ 1822

Visit:

Revision 1636, 55.1 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	! Fortran 90 Utilities
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 NXUmodule
28
29	USE NXmodule
30	PUBLIC
31	! * NeXus utility functions *
32	PUBLIC :: NXUwriteglobals, NXUwritegroup, NXUwritedata, NXUreaddata
33	PUBLIC :: NXUsetcompress
34	PUBLIC :: NXUfindgroup, NXUfindclass, NXUfinddata, NXUfindattr
35	PUBLIC :: NXUfindsignal, NXUfindaxis
36	PUBLIC :: NXUfindlink, NXUresumelink
37	! *** NeXus utility internal functions
38	PRIVATE :: NXUpreparedata, NXUconfirmdata, NXUsearchgroup
39	! *** NeXus utility global variables
40	INTEGER, PRIVATE :: NXcompress_type = NX_COMP_NONE
41	INTEGER, PRIVATE :: NXcompress_size = 1000
42	INTEGER, PRIVATE :: group_level
43	INTEGER, PRIVATE :: NXrank, NXdims(NX_MAXRANK), NXtype, NXsize
44	! * NeXus generic interfaces *
45	INTERFACE NXUwritedata
46	MODULE PROCEDURE NXUwritei4, NXUwriter4, NXUwriter8, NXUwritechar, &
47	NXUwritei4array, NXUwriter4array, &
48	NXUwriter8array, NXUwrite2Di4array, &
49	NXUwrite2Dr4array, NXUwrite2Dr8array, &
50	NXUwrite3Di4array, NXUwrite3Dr4array, &
51	NXUwrite3Dr8array
52	END INTERFACE
53	INTERFACE NXUreaddata
54	MODULE PROCEDURE NXUreadi4, NXUreadr4, NXUreadr8, NXUreadchar, &
55	NXUreadi4array, NXUreadr4array, NXUreadr8array, &
56	NXUread2Di4array, NXUread2Dr4array, &
57	NXUread2Dr8array, NXUread3Di4array, &
58	NXUread3Dr4array, NXUread3Dr8array
59	END INTERFACE
60
61	CONTAINS
62	!------------------------------------------------------------------------------
63	!NXUwriteglobals writes the global attributes to a file
64	FUNCTION NXUwriteglobals (file_id, user, affiliation, address, phone, fax, &
65	email) RESULT (status)
66
67	TYPE(NXhandle), INTENT(in) :: file_id
68	CHARACTER(len=*), INTENT(in), OPTIONAL :: user, affiliation, address, &
69	phone, fax, email
70	INTEGER :: status
71
72	IF (PRESENT(user)) THEN
73	status = NXputattr (file_id, "user", trim(user))
74	IF (status /= NX_OK) RETURN
75	END IF
76	IF (PRESENT(affiliation)) THEN
77	status = NXputattr (file_id, "affiliation", trim(affiliation))
78	IF (status /= NX_OK) RETURN
79	END IF
80	IF (PRESENT(address)) THEN
81	status = NXputattr (file_id, "address", trim(address))
82	IF (status /= NX_OK) RETURN
83	END IF
84	IF (PRESENT(phone)) THEN
85	status = NXputattr (file_id, "telephone_number", trim(phone))
86	IF (status /= NX_OK) RETURN
87	END IF
88	IF (PRESENT(fax)) THEN
89	status = NXputattr (file_id, "fax_number", trim(fax))
90	IF (status /= NX_OK) RETURN
91	END IF
92	IF (PRESENT(email)) THEN
93	status = NXputattr (file_id, "email", trim(email))
94	IF (status /= NX_OK) RETURN
95	END IF
96
97	END FUNCTION NXUwriteglobals
98	!------------------------------------------------------------------------------
99	!NXUwritegroup creates and leaves open a group
100	FUNCTION NXUwritegroup (file_id, group_name, group_class) RESULT (status)
101
102	TYPE(NXhandle), INTENT(in) :: file_id
103	CHARACTER(len=*), INTENT(in) :: group_name, group_class
104	INTEGER :: status
105
106	status = NXmakegroup (file_id, group_name, group_class)
107	IF (status == NX_OK) THEN
108	status = NXopengroup (file_id, group_name, group_class)
109	END IF
110
111	END FUNCTION NXUwritegroup
112	!------------------------------------------------------------------------------
113	!NXUwritedata creates and writes a data set
114	!
115	!The following routines define the generic function NXUwritedata
116	!------------------------------------------------------------------------------
117	!NXUwritei4 writes a scalar integer*4 data item
118	FUNCTION NXUwritei4 (file_id, data_name, data, units) RESULT (status)
119
120	TYPE(NXhandle), INTENT(inout) :: file_id
121	CHARACTER(len=*), INTENT(in) :: data_name
122	INTEGER(kind=NXi4), INTENT(in) :: data
123	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
124	INTEGER :: status
125
126	status = NXUpreparedata (file_id, data_name, NX_INT32, 1, (/1/))
127	IF (status /= NX_OK) RETURN
128	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
129	status = NXputattr (file_id, "units", units)
130	IF (status /= NX_OK) RETURN
131	END IF
132	status = NXputdata (file_id, (/ data /))
133
134	END FUNCTION NXUwritei4
135	!------------------------------------------------------------------------------
136	!NXUwriter4 writes a scalar real*4 data item
137	FUNCTION NXUwriter4 (file_id, data_name, data, units) RESULT (status)
138
139	TYPE(NXhandle), INTENT(inout) :: file_id
140	CHARACTER(len=*), INTENT(in) :: data_name
141	REAL(kind=NXr4), INTENT(in) :: data
142	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
143	INTEGER :: status
144
145	status = NXUpreparedata (file_id, data_name, NX_FLOAT32, 1, (/1/))
146	IF (status /= NX_OK) RETURN
147	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
148	status = NXputattr (file_id, "units", units)
149	IF (status /= NX_OK) RETURN
150	END IF
151	status = NXputdata (file_id, (/ data /))
152
153	END FUNCTION NXUwriter4
154	!------------------------------------------------------------------------------
155	!NXUwriter8 writes a scalar real*8 data item
156	FUNCTION NXUwriter8 (file_id, data_name, data, units) RESULT (status)
157
158	TYPE(NXhandle), INTENT(inout) :: file_id
159	CHARACTER(len=*), INTENT(in) :: data_name
160	REAL(kind=NXr8), INTENT(in) :: data
161	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
162	INTEGER :: status
163
164	status = NXUpreparedata (file_id, data_name, NX_FLOAT64, 1, (/1/))
165	IF (status /= NX_OK) RETURN
166	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
167	status = NXputattr (file_id, "units", units)
168	IF (status /= NX_OK) RETURN
169	END IF
170	status = NXputdata (file_id, (/ data /))
171
172	END FUNCTION NXUwriter8
173	!------------------------------------------------------------------------------
174	!NXUwritechar writes a character data item
175	FUNCTION NXUwritechar (file_id, data_name, data, units) RESULT (status)
176
177	TYPE(NXhandle), INTENT(inout) :: file_id
178	CHARACTER(len=*), INTENT(in) :: data_name
179	CHARACTER(len=*), INTENT(in) :: data
180	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
181	INTEGER :: status
182
183	status = NXUpreparedata (file_id, data_name, NX_CHAR, 1, &
184	(/len_trim(data)/))
185	IF (status /= NX_OK) RETURN
186	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
187	status = NXputattr (file_id, "units", units, len_trim(units), NX_CHAR)
188	IF (status /= NX_OK) RETURN
189	END IF
190	status = NXputdata (file_id, data)
191
192	END FUNCTION NXUwritechar
193	!------------------------------------------------------------------------------
194	!NXUwritei4array writes 1D integer*4 array data
195	FUNCTION NXUwritei4array (file_id, data_name, data, units, data_start, &
196	data_size) RESULT (status)
197
198	TYPE(NXhandle), INTENT(inout) :: file_id
199	CHARACTER(len=*), INTENT(in) :: data_name
200	INTEGER(kind=NXi4), INTENT(in) :: data(:)
201	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
202	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
203	INTEGER :: status
204
205	status = NXUpreparedata (file_id, data_name, NX_INT32, 1, (/size(data)/))
206	IF (status /= NX_OK) RETURN
207	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
208	status = NXputattr (file_id, "units", units)
209	IF (status /= NX_OK) RETURN
210	END IF
211	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
212	status = NXputslab (file_id, data, data_start, data_size)
213	ELSE
214	status = NXputdata (file_id, data)
215	END IF
216
217	END FUNCTION NXUwritei4array
218	!------------------------------------------------------------------------------
219	!NXUwriter4array writes 1D real*4 array data
220	FUNCTION NXUwriter4array (file_id, data_name, data, units, data_start, &
221	data_size) RESULT (status)
222
223	TYPE(NXhandle), INTENT(inout) :: file_id
224	CHARACTER(len=*), INTENT(in) :: data_name
225	REAL(kind=NXr4), INTENT(in) :: data(:)
226	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
227	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
228	INTEGER :: status
229
230	status = NXUpreparedata (file_id, data_name, NX_FLOAT32, 1, &
231	(/size(data)/))
232	IF (status /= NX_OK) RETURN
233	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
234	status = NXputattr (file_id, "units", units)
235	IF (status /= NX_OK) RETURN
236	END IF
237	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
238	status = NXputslab (file_id, data, data_start, data_size)
239	ELSE
240	status = NXputdata (file_id, data)
241	END IF
242
243	END FUNCTION NXUwriter4array
244	!------------------------------------------------------------------------------
245	!NXUwriter8array writes real*8 array data
246	FUNCTION NXUwriter8array (file_id, data_name, data, units, data_start, &
247	data_size) RESULT (status)
248
249	TYPE(NXhandle), INTENT(inout) :: file_id
250	CHARACTER(len=*), INTENT(in) :: data_name
251	REAL(kind=NXr8), INTENT(in) :: data(:)
252	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
253	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
254	INTEGER :: status
255
256	status = NXUpreparedata (file_id, data_name, NX_FLOAT64, 1, &
257	(/size(data)/))
258	IF (status /= NX_OK) RETURN
259	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
260	status = NXputattr (file_id, "units", units)
261	IF (status /= NX_OK) RETURN
262	END IF
263	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
264	status = NXputslab (file_id, data, data_start, data_size)
265	ELSE
266	status = NXputdata (file_id, data)
267	END IF
268
269	END FUNCTION NXUwriter8array
270	!------------------------------------------------------------------------------
271	!NXUwrite2Di4array writes 2D integer*4 data
272	FUNCTION NXUwrite2Di4array (file_id, data_name, data, units, data_start, &
273	data_size) RESULT (status)
274
275	TYPE(NXhandle), INTENT(inout) :: file_id
276	CHARACTER(len=*), INTENT(in) :: data_name
277	INTEGER(kind=NXi4), INTENT(in) :: data(:,:)
278	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
279	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
280	INTEGER :: status
281	INTEGER, ALLOCATABLE :: buffer(:)
282
283	status = NXUpreparedata (file_id, data_name, NX_INT32, 2, shape(data))
284	IF (status /= NX_OK) RETURN
285	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
286	status = NXputattr (file_id, "units", units)
287	IF (status /= NX_OK) RETURN
288	END IF
289	ALLOCATE (buffer(size(data)))
290	buffer = RESHAPE (data, (/ size(data) /))
291	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
292	status = NXputslab (file_id, buffer, data_start, data_size)
293	ELSE
294	status = NXputdata(file_id, buffer)
295	END IF
296	DEALLOCATE (buffer)
297
298	END FUNCTION NXUwrite2Di4array
299	!------------------------------------------------------------------------------
300	!NXUwrite2Dr4array writes 2D real*4 data
301	FUNCTION NXUwrite2Dr4array (file_id, data_name, data, units, data_start, &
302	data_size) RESULT (status)
303
304	TYPE(NXhandle), INTENT(inout) :: file_id
305	CHARACTER(len=*), INTENT(in) :: data_name
306	REAL(kind=NXr4), INTENT(in) :: data(:,:)
307	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
308	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
309	INTEGER :: status
310	REAL(kind=NXr4), ALLOCATABLE :: buffer(:)
311
312	status = NXUpreparedata (file_id, data_name, NX_FLOAT32, 2, shape(data))
313	IF (status /= NX_OK) RETURN
314	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
315	status = NXputattr (file_id, "units", units)
316	IF (status /= NX_OK) RETURN
317	END IF
318	ALLOCATE (buffer(size(data)))
319	buffer = RESHAPE (data, (/ size(data) /))
320	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
321	status = NXputslab (file_id, buffer, data_start, data_size)
322	ELSE
323	status = NXputdata(file_id, buffer)
324	END IF
325	DEALLOCATE (buffer)
326
327	END FUNCTION NXUwrite2Dr4array
328	!------------------------------------------------------------------------------
329	!NXUwrite2Dr8array writes 2D real*8 data
330	FUNCTION NXUwrite2Dr8array (file_id, data_name, data, units, data_start, &
331	data_size) RESULT (status)
332
333	TYPE(NXhandle), INTENT(inout) :: file_id
334	CHARACTER(len=*), INTENT(in) :: data_name
335	REAL(kind=NXr8), INTENT(in) :: data(:,:)
336	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
337	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
338	INTEGER :: status
339	REAL(kind=NXr8), ALLOCATABLE :: buffer(:)
340
341	status = NXUpreparedata (file_id, data_name, NX_FLOAT64, 2, shape(data))
342	IF (status /= NX_OK) RETURN
343	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
344	status = NXputattr (file_id, "units", units)
345	IF (status /= NX_OK) RETURN
346	END IF
347	ALLOCATE (buffer(size(data)))
348	buffer = RESHAPE (data, (/ size(data) /))
349	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
350	status = NXputslab (file_id, buffer, data_start, data_size)
351	ELSE
352	status = NXputdata(file_id, buffer)
353	END IF
354	DEALLOCATE (buffer)
355
356	END FUNCTION NXUwrite2Dr8array
357	!------------------------------------------------------------------------------
358	!NXUwrite3Di4array writes 3D integer*4 data
359	FUNCTION NXUwrite3Di4array (file_id, data_name, data, units, data_start, &
360	data_size) RESULT (status)
361
362	TYPE(NXhandle), INTENT(inout) :: file_id
363	CHARACTER(len=*), INTENT(in) :: data_name
364	INTEGER(kind=NXi4), INTENT(in) :: data(:,:,:)
365	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
366	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
367	INTEGER :: status
368	INTEGER, ALLOCATABLE :: buffer(:)
369
370	status = NXUpreparedata (file_id, data_name, NX_INT32, 3, shape(data))
371	IF (status /= NX_OK) RETURN
372	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
373	status = NXputattr (file_id, "units", units)
374	IF (status /= NX_OK) RETURN
375	END IF
376	ALLOCATE (buffer(size(data)))
377	buffer = RESHAPE (data, (/ size(data) /))
378	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
379	status = NXputslab (file_id, buffer, data_start, data_size)
380	ELSE
381	status = NXputdata(file_id, buffer)
382	END IF
383	DEALLOCATE (buffer)
384
385	END FUNCTION NXUwrite3Di4array
386	!------------------------------------------------------------------------------
387	!NXUwrite3Dr4array writes 3D real*4 data
388	FUNCTION NXUwrite3Dr4array (file_id, data_name, data, units, data_start, &
389	data_size) RESULT (status)
390
391	TYPE(NXhandle), INTENT(inout) :: file_id
392	CHARACTER(len=*), INTENT(in) :: data_name
393	REAL(kind=NXr4), INTENT(in) :: data(:,:,:)
394	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
395	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
396	INTEGER :: status
397	REAL(kind=NXr4), ALLOCATABLE :: buffer(:)
398
399	status = NXUpreparedata (file_id, data_name, NX_FLOAT32, 3, shape(data))
400	IF (status /= NX_OK) RETURN
401	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
402	status = NXputattr (file_id, "units", units)
403	IF (status /= NX_OK) RETURN
404	END IF
405	ALLOCATE (buffer(size(data)))
406	buffer = RESHAPE (data, (/ size(data) /))
407	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
408	status = NXputslab (file_id, buffer, data_start, data_size)
409	ELSE
410	status = NXputdata(file_id, buffer)
411	END IF
412	DEALLOCATE (buffer)
413
414	END FUNCTION NXUwrite3Dr4array
415	!------------------------------------------------------------------------------
416	!NXUwrite3Dr8array writes 3D real*8 data
417	FUNCTION NXUwrite3Dr8array (file_id, data_name, data, units, data_start, &
418	data_size) RESULT (status)
419
420	TYPE(NXhandle), INTENT(inout) :: file_id
421	CHARACTER(len=*), INTENT(in) :: data_name
422	REAL(kind=NXr8), INTENT(in) :: data(:,:,:)
423	CHARACTER(len=*), INTENT(in), OPTIONAL :: units
424	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
425	INTEGER :: status
426	REAL(kind=NXr8), ALLOCATABLE :: buffer(:)
427
428	status = NXUpreparedata (file_id, data_name, NX_FLOAT64, 3, shape(data))
429	IF (status /= NX_OK) RETURN
430	IF (PRESENT(units) .AND. NXUfindattr(file_id, "units") == NX_EOD) THEN
431	status = NXputattr (file_id, "units", units)
432	IF (status /= NX_OK) RETURN
433	END IF
434	ALLOCATE (buffer(size(data)))
435	buffer = RESHAPE (data, (/ size(data) /))
436	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
437	status = NXputslab (file_id, buffer, data_start, data_size)
438	ELSE
439	status = NXputdata(file_id, buffer)
440	END IF
441	DEALLOCATE (buffer)
442
443	END FUNCTION NXUwrite3Dr8array
444	!------------------------------------------------------------------------------
445	!NXUreaddata reads data
446	!
447	!The following routines define the generic function NXUreaddata
448	!------------------------------------------------------------------------------
449	!NXUreadi4 reads a scalar integer*4 data item
450	FUNCTION NXUreadi4 (file_id, data_name, data, units) RESULT (status)
451
452	TYPE(NXhandle), INTENT(inout) :: file_id
453	CHARACTER(len=*), INTENT(in) :: data_name
454	INTEGER(kind=NXi4), INTENT(out) :: data
455	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
456	INTEGER :: status, dimensions(NX_MAXRANK)
457	INTEGER(kind=NXi4) :: buffer(1)
458
459	status = NXUconfirmdata (file_id, data_name, NX_INT32, 1, dimensions)
460	IF (status /= NX_OK) RETURN
461	IF (dimensions(1) /= 1) THEN
462	status = NX_ERROR
463	RETURN
464	END IF
465	status = NXgetdata(file_id, buffer)
466	IF (status == NX_OK) THEN
467	data = buffer(1)
468	IF (PRESENT(units)) THEN
469	status = NXgetattr (file_id, "units", units)
470	END IF
471	END IF
472
473	END FUNCTION NXUreadi4
474	!------------------------------------------------------------------------------
475	!NXgetr4 reads a scalar real*4 data item
476	FUNCTION NXUreadr4 (file_id, data_name, data, units) RESULT (status)
477
478	TYPE(NXhandle), INTENT(inout) :: file_id
479	CHARACTER(len=*), INTENT(in) :: data_name
480	REAL(kind=NXr4), INTENT(out) :: data
481	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
482	INTEGER :: status, dimensions(NX_MAXRANK)
483	REAL(kind=NXr4) :: buffer(1)
484
485	status = NXUconfirmdata (file_id, data_name, NX_FLOAT32, 1, dimensions)
486	IF (status /= NX_OK) RETURN
487	IF (dimensions(1) /= 1) THEN
488	status = NX_ERROR
489	RETURN
490	END IF
491	status = NXgetdata(file_id, buffer)
492	IF (status == NX_OK) THEN
493	data = buffer(1)
494	IF (PRESENT(units)) THEN
495	status = NXgetattr (file_id, "units", units)
496	END IF
497	END IF
498
499	END FUNCTION NXUreadr4
500	!------------------------------------------------------------------------------
501	!NXgetr8 reads a scalar real*8 data item
502	FUNCTION NXUreadr8 (file_id, data_name, data, units) RESULT (status)
503
504	TYPE(NXhandle), INTENT(inout) :: file_id
505	CHARACTER(len=*), INTENT(in) :: data_name
506	REAL(kind=NXr8), INTENT(out) :: data
507	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
508	INTEGER :: status, dimensions(NX_MAXRANK)
509	REAL(kind=NXr8) :: buffer(1)
510
511	status = NXUconfirmdata (file_id, data_name, NX_FLOAT64, 1, dimensions)
512	IF (status /= NX_OK) RETURN
513	IF (dimensions(1) /= 1) THEN
514	status = NX_ERROR
515	RETURN
516	END IF
517	status = NXgetdata(file_id, buffer)
518	IF (status == NX_OK) THEN
519	data = buffer(1)
520	IF (PRESENT(units)) THEN
521	status = NXgetattr (file_id, "units", units)
522	END IF
523	END IF
524
525	END FUNCTION NXUreadr8
526	!------------------------------------------------------------------------------
527	!NXgetchar reads a character string
528	FUNCTION NXUreadchar (file_id, data_name, data, units) RESULT (status)
529
530	TYPE(NXhandle), INTENT(inout) :: file_id
531	CHARACTER(len=*), INTENT(in) :: data_name
532	CHARACTER(len=*), INTENT(out) :: data
533	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
534	INTEGER :: status, dimensions(NX_MAXRANK)
535
536	status = NXUconfirmdata (file_id, data_name, NX_CHAR, 1, dimensions)
537	IF (status /= NX_OK) RETURN
538	IF (dimensions(1) > len(data)) THEN
539	status = NX_ERROR
540	RETURN
541	END IF
542	status = NXgetdata(file_id, data)
543	IF (status == NX_OK .and. PRESENT(units)) THEN
544	status = NXgetattr (file_id, "units", units)
545	END IF
546
547	END FUNCTION NXUreadchar
548	!------------------------------------------------------------------------------
549	!NXUreadi4array reads an integer*4 array
550	FUNCTION NXUreadi4array (file_id, data_name, data, units, data_start, &
551	data_size) RESULT (status)
552
553	TYPE(NXhandle), INTENT(inout) :: file_id
554	CHARACTER(len=*), INTENT(in) :: data_name
555	INTEGER(kind=NXi4), POINTER :: data(:)
556	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
557	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
558	INTEGER :: status, dimensions(NX_MAXRANK)
559
560	status = NXUconfirmdata (file_id, data_name, NX_INT32, 1, dimensions)
561	IF (status /= NX_OK) RETURN
562	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
563	ALLOCATE (data(data_size(1)))
564	status = NXgetslab (file_id, data, data_start, data_size)
565	ELSE
566	ALLOCATE (data(dimensions(1)))
567	status = NXgetdata (file_id, data)
568	END IF
569	IF (status == NX_OK .and. PRESENT(units)) THEN
570	status = NXgetattr (file_id, "units", units)
571	END IF
572
573	END FUNCTION NXUreadi4array
574	!------------------------------------------------------------------------------
575	!NXUreadr4array reads a real*4 array
576	FUNCTION NXUreadr4array (file_id, data_name, data, units, data_start, &
577	data_size) RESULT (status)
578
579	TYPE(NXhandle), INTENT(inout) :: file_id
580	CHARACTER(len=*), INTENT(in) :: data_name
581	REAL(kind=NXr4), POINTER :: data(:)
582	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
583	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
584	INTEGER :: status, dimensions(NX_MAXRANK)
585
586	status = NXUconfirmdata (file_id, data_name, NX_FLOAT32, 1, dimensions)
587	IF (status /= NX_OK) RETURN
588	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
589	ALLOCATE (data(data_size(1)))
590	status = NXgetslab (file_id, data, data_start, data_size)
591	ELSE
592	ALLOCATE (data(dimensions(1)))
593	status = NXgetdata (file_id, data)
594	END IF
595	IF (status == NX_OK .and. PRESENT(units)) THEN
596	status = NXgetattr (file_id, "units", units)
597	END IF
598
599	END FUNCTION NXUreadr4array
600	!------------------------------------------------------------------------------
601	!NXUreadr8array reads a real*8 array
602	FUNCTION NXUreadr8array (file_id, data_name, data, units, data_start, &
603	data_size) RESULT (status)
604
605	TYPE(NXhandle), INTENT(inout) :: file_id
606	CHARACTER(len=*), INTENT(in) :: data_name
607	REAL(kind=NXr8), POINTER :: data(:)
608	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
609	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
610	INTEGER :: status, dimensions(NX_MAXRANK)
611
612	status = NXUconfirmdata (file_id, data_name, NX_FLOAT64, 1, dimensions)
613	IF (status /= NX_OK) RETURN
614	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
615	ALLOCATE (data(data_size(1)))
616	status = NXgetslab (file_id, data, data_start, data_size)
617	ELSE
618	ALLOCATE (data(dimensions(1)))
619	status = NXgetdata (file_id, data)
620	END IF
621	IF (status == NX_OK .and. PRESENT(units)) THEN
622	status = NXgetattr (file_id, "units", units)
623	END IF
624
625	END FUNCTION NXUreadr8array
626	!------------------------------------------------------------------------------
627	!NXUread2Di4array reads a 2D integer*4 array
628	FUNCTION NXUread2Di4array (file_id, data_name, data, units, data_start, &
629	data_size) RESULT (status)
630
631	TYPE(NXhandle), INTENT(inout) :: file_id
632	CHARACTER(len=*), INTENT(in) :: data_name
633	INTEGER(kind=NXi4), POINTER :: data(:,:)
634	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
635	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
636	INTEGER :: status, dimensions(NX_MAXRANK), data_shape(2)
637	INTEGER, ALLOCATABLE :: buffer(:)
638
639	status = NXUconfirmdata (file_id, data_name, NX_INT32, 2, dimensions)
640	IF (status /= NX_OK) RETURN
641	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
642	ALLOCATE (buffer(PRODUCT(data_size(1:2))))
643	status = NXgetslab (file_id, buffer, data_start, data_size)
644	IF (status == NX_OK) THEN
645	ALLOCATE (data(data_size(1),data_size(2)))
646	data_shape = data_size(1:2)
647	data = RESHAPE (buffer, data_shape)
648	END IF
649	ELSE
650	ALLOCATE (buffer(PRODUCT(dimensions(1:2))))
651	status = NXgetdata(file_id, buffer)
652	IF (status == NX_OK) THEN
653	ALLOCATE (data(dimensions(1),dimensions(2)))
654	data = RESHAPE (buffer, dimensions(1:2))
655	END IF
656	END IF
657	IF (status == NX_OK .and. PRESENT(units)) THEN
658	status = NXgetattr (file_id, "units", units)
659	END IF
660	DEALLOCATE (buffer)
661
662	END FUNCTION NXUread2Di4array
663	!------------------------------------------------------------------------------
664	!NXUread2Dr4array reads a 2D real*4 array
665	FUNCTION NXUread2Dr4array (file_id, data_name, data, units, data_start, &
666	data_size) RESULT (status)
667
668	TYPE(NXhandle), INTENT(inout) :: file_id
669	CHARACTER(len=*), INTENT(in) :: data_name
670	REAL(kind=NXr4), POINTER :: data(:,:)
671	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
672	INTEGER, INTENT(in), OPTIONAL ::data_start(:), data_size(:)
673	INTEGER :: status, dimensions(NX_MAXRANK), data_shape(2)
674	REAL, ALLOCATABLE :: buffer(:)
675
676	status = NXUconfirmdata (file_id, data_name, NX_FLOAT32, 2, dimensions)
677	IF (status /= NX_OK) RETURN
678	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
679	ALLOCATE (buffer(PRODUCT(data_size(1:2))))
680	status = NXgetslab (file_id, buffer, data_start, data_size)
681	IF (status == NX_OK) THEN
682	ALLOCATE (data(data_size(1),data_size(2)))
683	data_shape = data_size(1:2)
684	data = RESHAPE (buffer, data_shape)
685	END IF
686	ELSE
687	ALLOCATE (buffer(PRODUCT(dimensions(1:2))))
688	status = NXgetdata(file_id, buffer)
689	IF (status == NX_OK) THEN
690	ALLOCATE (data(dimensions(1),dimensions(2)))
691	data = RESHAPE (buffer, dimensions(1:2))
692	END IF
693	END IF
694	IF (status == NX_OK .and. PRESENT(units)) THEN
695	status = NXgetattr (file_id, "units", units)
696	END IF
697	DEALLOCATE (buffer)
698
699	END FUNCTION NXUread2Dr4array
700	!------------------------------------------------------------------------------
701	!NXUread2Dr8array reads a 2D real*8 precision array
702	FUNCTION NXUread2Dr8array (file_id, data_name, data, units, data_start, &
703	data_size) RESULT (status)
704
705	TYPE(NXhandle), INTENT(inout) :: file_id
706	CHARACTER(len=*), INTENT(in) :: data_name
707	REAL(kind=NXr8), POINTER :: data(:,:)
708	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
709	INTEGER, INTENT(in), OPTIONAL ::data_start(:), data_size(:)
710	INTEGER :: status, dimensions(NX_MAXRANK), data_shape(2)
711	REAL, ALLOCATABLE :: buffer(:)
712
713	status = NXUconfirmdata (file_id, data_name, NX_FLOAT64, 2, dimensions)
714	IF (status /= NX_OK) RETURN
715	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
716	ALLOCATE (buffer(PRODUCT(data_size(1:2))))
717	status = NXgetslab (file_id, buffer, data_start, data_size)
718	IF (status == NX_OK) THEN
719	ALLOCATE (data(data_size(1),data_size(2)))
720	data_shape = data_size(1:2)
721	data = RESHAPE (buffer, data_shape)
722	END IF
723	ELSE
724	ALLOCATE (buffer(PRODUCT(dimensions(1:2))))
725	status = NXgetdata(file_id, buffer)
726	IF (status == NX_OK) THEN
727	ALLOCATE (data(dimensions(1),dimensions(2)))
728	data = RESHAPE (buffer, dimensions(1:2))
729	END IF
730	END IF
731	IF (status == NX_OK .and. PRESENT(units)) THEN
732	status = NXgetattr (file_id, "units", units)
733	END IF
734	DEALLOCATE (buffer)
735
736	END FUNCTION NXUread2Dr8array
737	!------------------------------------------------------------------------------
738	!NXUread3Di4array reads a 3D integer*4 array
739	FUNCTION NXUread3Di4array (file_id, data_name, data, units, data_start, &
740	data_size) RESULT (status)
741
742	TYPE(NXhandle), INTENT(inout) :: file_id
743	CHARACTER(len=*), INTENT(in) :: data_name
744	INTEGER(kind=NXi4), POINTER :: data(:,:,:)
745	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
746	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
747	INTEGER :: status, dimensions(NX_MAXRANK), data_shape(3)
748	INTEGER, ALLOCATABLE :: buffer(:)
749
750	status = NXUconfirmdata (file_id, data_name, NX_INT32, 3, dimensions)
751	IF (status /= NX_OK) RETURN
752	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
753	ALLOCATE (buffer(PRODUCT(data_size(1:3))))
754	status = NXgetslab (file_id, buffer, data_start, data_size)
755	IF (status == NX_OK) THEN
756	ALLOCATE (data(data_size(1),data_size(2),data_size(3)))
757	data_shape = data_size(1:3)
758	data = RESHAPE (buffer, data_shape)
759	END IF
760	ELSE
761	ALLOCATE (buffer(PRODUCT(dimensions(1:3))))
762	status = NXgetdata(file_id, buffer)
763	IF (status == NX_OK) THEN
764	ALLOCATE (data(dimensions(1),dimensions(2),dimensions(3)))
765	data = RESHAPE (buffer, dimensions(1:3))
766	END IF
767	END IF
768	IF (status == NX_OK .and. PRESENT(units)) THEN
769	status = NXgetattr (file_id, "units", units)
770	END IF
771	DEALLOCATE (buffer)
772
773	END FUNCTION NXUread3Di4array
774	!------------------------------------------------------------------------------
775	!NXUread3Dr4array reads a 3D real*4 array
776	FUNCTION NXUread3Dr4array (file_id, data_name, data, units, data_start, &
777	data_size) RESULT (status)
778
779	TYPE(NXhandle), INTENT(inout) :: file_id
780	CHARACTER(len=*), INTENT(in) :: data_name
781	REAL(kind=NXr4), POINTER :: data(:,:,:)
782	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
783	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
784	INTEGER :: status, dimensions(NX_MAXRANK), data_shape(3)
785	REAL, ALLOCATABLE :: buffer(:)
786
787	status = NXUconfirmdata (file_id, data_name, NX_FLOAT32, 3, dimensions)
788	IF (status /= NX_OK) RETURN
789	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
790	ALLOCATE (buffer(PRODUCT(data_size(1:3))))
791	status = NXgetslab (file_id, buffer, data_start, data_size)
792	IF (status == NX_OK) THEN
793	ALLOCATE (data(data_size(1),data_size(2),data_size(3)))
794	data_shape = data_size(1:3)
795	data = RESHAPE (buffer, data_shape)
796	END IF
797	ELSE
798	ALLOCATE (buffer(PRODUCT(dimensions(1:3))))
799	status = NXgetdata(file_id, buffer)
800	IF (status == NX_OK) THEN
801	ALLOCATE (data(dimensions(1),dimensions(2),dimensions(3)))
802	data = RESHAPE (buffer, dimensions(1:3))
803	END IF
804	END IF
805	IF (status == NX_OK .and. PRESENT(units)) THEN
806	status = NXgetattr (file_id, "units", units)
807	END IF
808	DEALLOCATE (buffer)
809
810	END FUNCTION NXUread3Dr4array
811	!------------------------------------------------------------------------------
812	!NXUread3Dr8array reads a 3D real*8 array
813	FUNCTION NXUread3Dr8array (file_id, data_name, data, units, data_start, &
814	data_size) RESULT (status)
815
816	TYPE(NXhandle), INTENT(inout) :: file_id
817	CHARACTER(len=*), INTENT(in) :: data_name
818	REAL(kind=NXr8), POINTER :: data(:,:,:)
819	CHARACTER(len=*), INTENT(out), OPTIONAL :: units
820	INTEGER, INTENT(in), OPTIONAL :: data_start(:), data_size(:)
821	INTEGER :: status, dimensions(NX_MAXRANK), data_shape(3)
822	REAL, ALLOCATABLE :: buffer(:)
823
824	status = NXUconfirmdata (file_id, data_name, NX_FLOAT64, 3, dimensions)
825	IF (status /= NX_OK) RETURN
826	IF (PRESENT(data_start) .AND. PRESENT(data_size)) THEN
827	ALLOCATE (buffer(PRODUCT(data_size(1:3))))
828	status = NXgetslab (file_id, buffer, data_start, data_size)
829	IF (status == NX_OK) THEN
830	ALLOCATE (data(data_size(1),data_size(2),data_size(3)))
831	data_shape = data_size(1:3)
832	data = RESHAPE (buffer, data_shape)
833	END IF
834	ELSE
835	ALLOCATE (buffer(PRODUCT(dimensions(1:3))))
836	status = NXgetdata(file_id, buffer)
837	IF (status == NX_OK) THEN
838	ALLOCATE (data(dimensions(1),dimensions(2),dimensions(3)))
839	data = RESHAPE (buffer, dimensions(1:3))
840	END IF
841	END IF
842	IF (status == NX_OK .and. PRESENT(units)) THEN
843	status = NXgetattr (file_id, "units", units)
844	END IF
845	DEALLOCATE (buffer)
846
847	END FUNCTION NXUread3Dr8array
848	!------------------------------------------------------------------------------
849	!------------------------------------------------------------------------------
850	!NXUsetcompress sets the default compression type and minimum size
851	FUNCTION NXUsetcompress (file_id, compress_type, compress_size) &
852	RESULT (status)
853
854	TYPE(NXhandle), INTENT(inout) :: file_id
855	INTEGER, INTENT(in) :: compress_type
856	INTEGER, INTENT(in), OPTIONAL :: compress_size
857	INTEGER :: status
858
859	IF (compress_type == NX_COMP_LZW .OR. compress_type == NX_COMP_HUF .OR. &
860	compress_type == NX_COMP_RLE .OR. compress_type == NX_COMP_NONE) THEN
861	NXcompress_type = compress_type
862	IF (PRESENT(compress_size)) NXcompress_size = compress_size
863	status = NX_OK
864	ELSE
865	call NXerror ("Invalid compression option")
866	status = NX_ERROR
867	END IF
868
869	END FUNCTION NXUsetcompress
870	!------------------------------------------------------------------------------
871	!NXUfindgroup finds if a NeXus group of the specified name exists
872	FUNCTION NXUfindgroup (file_id, group_name, group_class) RESULT (status)
873
874	TYPE(NXhandle), INTENT(inout) :: file_id
875	CHARACTER(len=*), INTENT(in) :: group_name
876	CHARACTER(len=*), INTENT(out), OPTIONAL :: group_class
877	CHARACTER(len=NX_MAXNAMELEN), ALLOCATABLE :: name(:), class(:)
878	INTEGER :: status, n, i
879
880	status = NXgetgroupinfo (file_id, n)
881	IF (status /= NX_OK) RETURN
882	ALLOCATE (name(n), class(n), STAT=status)
883	IF (status /= 0) THEN
884	call NXerror ("Unable to allocate directory arrays")
885	status = NX_ERROR
886	RETURN
887	END IF
888	status = NXgroupdir (file_id, n, name, class)
889	IF (status == NX_OK) THEN
890	status = NX_EOD
891	DO i = 1,n
892	IF (trim(name(i)) == trim(group_name)) THEN
893	group_class = trim(class(i))
894	IF (class(i)(1:2) == "NX") THEN
895	status = NX_OK
896	ELSE
897	CALL NXerror (trim(name(i))//" is not a group")
898	status = NX_ERROR
899	END IF
900	EXIT
901	END IF
902	END DO
903	END IF
904	DEALLOCATE (name, class)
905
906	END FUNCTION NXUfindgroup
907	!------------------------------------------------------------------------------
908	!NXUfindclass finds if a NeXus group of the specified class exists
909	FUNCTION NXUfindclass (file_id, group_class, group_name, find_index) &
910	RESULT (status)
911
912	TYPE(NXhandle), INTENT(inout) :: file_id
913	CHARACTER(len=*), INTENT(in) :: group_class
914	CHARACTER(len=*), INTENT(out) :: group_name
915	INTEGER, INTENT(in), OPTIONAL :: find_index
916	CHARACTER(len=NX_MAXNAMELEN), ALLOCATABLE :: name(:), class(:)
917	INTEGER :: status, n, i, j
918
919	status = NXgetgroupinfo (file_id, n)
920	IF (status /= NX_OK) RETURN
921	ALLOCATE (name(n), class(n), STAT=status)
922	IF (status /= 0) THEN
923	CALL NXerror ("Unable to allocate directory arrays")
924	status = NX_ERROR
925	RETURN
926	END IF
927	status = NXgroupdir (file_id, n, name, class)
928	IF (status == NX_OK) THEN
929	j = 0
930	status = NX_EOD
931	DO i = 1,n
932	IF (trim(class(i)) == trim(group_class)) THEN
933	IF (PRESENT(find_index)) THEN
934	j = j + 1
935	IF (j < find_index) CYCLE
936	END IF
937	group_name = trim(name(i))
938	status = NX_OK
939	EXIT
940	END IF
941	END DO
942	END IF
943	DEALLOCATE (name, class)
944
945	END FUNCTION NXUfindclass
946	!------------------------------------------------------------------------------
947	!NXUfinddata finds if a NeXus data item is in the current group
948	FUNCTION NXUfinddata (file_id, data_name) RESULT (status)
949
950	TYPE(NXhandle), INTENT(inout) :: file_id
951	CHARACTER(len=*), INTENT(in) :: data_name
952	CHARACTER(len=NX_MAXNAMELEN), ALLOCATABLE :: name(:), class(:)
953	INTEGER :: status, n, i
954
955	status = NXgetgroupinfo (file_id, n)
956	IF (status /= NX_OK) RETURN
957	ALLOCATE (name(n), class(n), STAT=status)
958	IF (status /= 0) THEN
959	call NXerror ("Unable to allocate directory arrays")
960	status = NX_ERROR
961	RETURN
962	END IF
963	status = NXgroupdir (file_id, n, name, class)
964	IF (status == NX_OK) THEN
965	status = NX_EOD
966	DO i = 1,n
967	IF (trim(name(i)) == trim(data_name)) THEN
968	IF (class(i)(1:3) == "SDS") THEN
969	status = NX_OK
970	ELSE
971	CALL NXerror (trim(name(i))//" is not a data item")
972	status = NX_ERROR
973	END IF
974	EXIT
975	END IF
976	END DO
977	END IF
978	DEALLOCATE (name, class)
979
980	END FUNCTION NXUfinddata
981	!------------------------------------------------------------------------------
982	!NXUfindattr finds if a NeXus attribute exists
983	FUNCTION NXUfindattr (file_id, attr_name) RESULT (status)
984
985	TYPE(NXhandle), INTENT(inout) :: file_id
986	CHARACTER(len=*), INTENT(in) :: attr_name
987	CHARACTER(len=NX_MAXNAMELEN), ALLOCATABLE :: name(:)
988	INTEGER :: status, n, i
989
990	status = NXgetattrinfo (file_id, n)
991	IF (status /= NX_OK) RETURN
992	ALLOCATE (name(n), STAT=status)
993	IF (status /= 0) THEN
994	call NXerror ("Unable to allocate directory arrays")
995	status = NX_ERROR
996	RETURN
997	END IF
998	status = NXattrdir (file_id, n, name)
999	IF (status == NX_OK) THEN
1000	status = NX_EOD
1001	DO i = 1,n
1002	IF (trim(name(i)) == trim(attr_name)) status = NX_OK
1003	END DO
1004	END IF
1005	DEALLOCATE (name)
1006
1007	END FUNCTION NXUfindattr
1008	!------------------------------------------------------------------------------
1009	!NXUfindsignal finds the NeXus data item containing the required signal
1010	FUNCTION NXUfindsignal (file_id, signal, data_name, data_rank, data_type, &
1011	data_dimensions) RESULT (status)
1012
1013	TYPE(NXhandle), INTENT(inout) :: file_id
1014	INTEGER, INTENT(in) :: signal
1015	CHARACTER(len=*) :: data_name
1016	INTEGER, INTENT(out) :: data_rank, data_type, data_dimensions(:)
1017	CHARACTER(len=len(data_name)) :: name
1018	CHARACTER(len=NX_MAXNAMELEN) :: class, attr_name
1019	INTEGER :: status, value
1020
1021	status = NXinitgroupdir (file_id)
1022	IF (status /= NX_OK) RETURN
1023	DO
1024	status = NXgetnextentry (file_id, name, class, NXtype)
1025	IF (status == NX_OK .AND. class == "SDS") THEN
1026	status = NXopendata (file_id, name)
1027	IF (status /= NX_OK) RETURN
1028	status = NXUfindattr (file_id, "signal")
1029	IF (status == NX_OK) THEN
1030	status = NXgetattr (file_id, "signal", value)
1031	IF (status /= NX_OK) RETURN
1032	IF (value == signal) THEN
1033	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
1034	IF (status == NX_OK) THEN
1035	data_name = name
1036	data_rank = NXrank
1037	data_type = NXtype
1038	data_dimensions = NXdims
1039	RETURN
1040	END IF
1041	END IF
1042	ELSE IF (status == NX_EOD) THEN
1043	CYCLE
1044	ELSE IF (status == NX_ERROR) THEN
1045	RETURN
1046	END IF
1047	ELSE IF (status == NX_EOD) THEN
1048	CALL NXerror ("No data with the attribute ""signal"" found")
1049	status = NX_ERROR
1050	EXIT
1051	ELSE IF (status == NX_ERROR) THEN
1052	RETURN
1053	END IF
1054	END DO
1055
1056	END FUNCTION NXUfindsignal
1057	!------------------------------------------------------------------------------
1058	!NXUfindaxis finds the NeXus data item containing the required axis
1059	FUNCTION NXUfindaxis (file_id, axis, primary, data_name, data_type, &
1060	data_dimensions) RESULT (status)
1061
1062	TYPE(NXhandle), INTENT(inout) :: file_id
1063	INTEGER, INTENT(in) :: axis, primary
1064	CHARACTER(len=*) :: data_name
1065	INTEGER, INTENT(out) :: data_type, data_dimensions(NX_MAXRANK)
1066	CHARACTER(len=len(data_name)) :: name
1067	CHARACTER(len=NX_MAXNAMELEN) :: class, attr_name
1068	CHARACTER(len=255) :: axis_list
1069	INTEGER :: status, signal=1, value, data_rank, C_axis, i, j, k
1070
1071	!First find data with "signal" attribute to check for "axes" attribute
1072	status = NXUfindsignal (file_id, signal, data_name, data_rank, &
1073	data_type, data_dimensions)
1074	IF (status /= NX_OK) RETURN
1075	!The axis number cannot be greater than the data rank
1076	IF (axis > data_rank) THEN
1077	CALL NXerror ("Axis number greater than the data rank")
1078	status = NX_ERROR
1079	RETURN
1080	END IF
1081	!Check for "axes" attribute
1082	status = NXopendata (file_id, data_name)
1083	IF (status /= NX_OK) RETURN
1084	status = NXUfindattr (file_id, "axes")
1085	IF (status == NX_ERROR) THEN
1086	RETURN
1087	ELSE IF (status == NX_OK) THEN !"axes" attribute found
1088	status = NXgetattr (file_id, "axes", axis_list)
1089	!Strip off brackets around axis list
1090	IF (index(axis_list,"[") > 0) THEN
1091	axis_list = axis_list(index(axis_list,"[")+1:len(axis_list))
1092	END IF
1093	IF (index(axis_list,"]") > 0) THEN
1094	axis_list = axis_list(1:index(axis_list,"]")-1)
1095	END IF
1096	!"axes" lists the axes in C (row-major) order so the axis numbers are reversed
1097	C_axis = data_rank - axis + 1
1098	!Find axis label by looking for the delimiting commas
1099	j = 1
1100	DO i = 1,C_axis
1101	k = scan(axis_list(j:),",:") - 1
1102	IF (k < 0) k = len(trim(axis_list)) - j + 1
1103	IF (k < 0) THEN !We've run out of delimiters
1104	CALL NXerror ("Data attribute ""axes"" is not correctly defined")
1105	status = NX_ERROR
1106	RETURN
1107	END IF
1108	name = adjustl(axis_list(j:j+k-1))
1109	j = j + k + 1
1110	END DO
1111	!Open data to retrieve information about the dimension scale
1112	status = NXopendata (file_id, name)
1113	IF (status /= NX_OK) RETURN
1114	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
1115	IF (status == NX_OK) THEN
1116	data_name = name
1117	data_type = NXtype
1118	data_dimensions = NXdims(1)
1119	RETURN
1120	ELSE
1121	RETURN
1122	END IF
1123	END IF
1124	!Otherwise, check for "axis" attribute in each NXdata item
1125	status = NXinitgroupdir (file_id)
1126	IF (status /= NX_OK) RETURN
1127	DO
1128	status = NXgetnextentry (file_id, name, class, NXtype)
1129	IF (status == NX_OK .AND. class == "SDS") THEN
1130	status = NXopendata (file_id, name)
1131	IF (status /= NX_OK) RETURN
1132	status = NXUfindattr (file_id, "axis")
1133	IF (status == NX_OK) THEN
1134	status = NXgetattr (file_id, "axis", value)
1135	IF (status /= NX_OK) RETURN
1136	IF (value == axis) THEN
1137	status = NXUfindattr (file_id, "primary")
1138	IF (status == NX_OK) THEN
1139	status = NXgetattr (file_id, "primary", value)
1140	ELSE IF (status == NX_EOD) THEN
1141	value = 1
1142	ELSE
1143	RETURN
1144	END IF
1145	IF (value == primary) THEN
1146	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
1147	IF (status == NX_OK) THEN
1148	data_name = name
1149	data_type = NXtype
1150	data_dimensions = NXdims(1)
1151	RETURN
1152	ELSE
1153	RETURN
1154	END IF
1155	END IF
1156	END IF
1157	END IF
1158	ELSE IF (status == NX_EOD) THEN
1159	CALL NXerror ("Requested axis not found")
1160	status = NX_ERROR
1161	EXIT
1162	ELSE IF (status == NX_ERROR) THEN
1163	RETURN
1164	END IF
1165	END DO
1166
1167	END FUNCTION NXUfindaxis
1168	!------------------------------------------------------------------------------
1169	!NXUfindlink finds another link to a NeXus data item and opens the group
1170	FUNCTION NXUfindlink (file_id, group_id, group_class) RESULT (status)
1171
1172	TYPE(NXhandle), INTENT(inout) :: file_id
1173	TYPE(NXlink), INTENT(out) :: group_id
1174	CHARACTER(len=*), INTENT(in), OPTIONAL :: group_class
1175	TYPE(NXlink) :: data_id
1176	INTEGER :: status
1177
1178	!Get current group and data IDs
1179	status = NXgetgroupID (file_id, group_id)
1180	IF (status /= NX_OK) RETURN
1181	status = NXgetdataID (file_id, data_id)
1182	IF (status /= NX_OK) RETURN
1183	!Start the search in the group one level up
1184	status = NXclosegroup (file_id)
1185	IF (status /= NX_OK) RETURN
1186	!Start recursive searches for this data ID within this group
1187	group_level = 0
1188	status = NXUsearchgroup (file_id, group_id, data_id, group_class)
1189
1190	END FUNCTION NXUfindlink
1191	!------------------------------------------------------------------------------
1192	!NXUresumelink reopens the original group from which NXUfindlink was called
1193	FUNCTION NXUresumelink (file_id, group_id) RESULT (status)
1194
1195	TYPE(NXhandle), INTENT(inout) :: file_id
1196	TYPE(NXlink), INTENT(in) :: group_id
1197	TYPE(NXlink) :: new_id
1198	CHARACTER(len=NX_MAXNAMELEN), ALLOCATABLE :: name(:), class(:)
1199	INTEGER :: status, n, i
1200
1201	!Return to group level from which the link search was started
1202	DO i = 1, group_level
1203	status = NXclosegroup (file_id)
1204	IF (status /= NX_OK) RETURN
1205	END DO
1206	!Obtain list of groups at this level
1207	status = NXgetgroupinfo (file_id, n)
1208	IF (status /= NX_OK) RETURN
1209	ALLOCATE (name(n), class(n), STAT=status)
1210	IF (status /= 0) THEN
1211	CALL NXerror ("Unable to allocate space for group info")
1212	status = NX_ERROR
1213	RETURN
1214	END IF
1215	status = NXgroupdir (file_id, n, name, class)
1216	IF (status == NX_OK) THEN
1217	DO i = 1,n
1218	IF (class(i)(1:2) == "NX") THEN
1219	status = NXopengroup (file_id, name(i), class(i))
1220	IF (status /= NX_OK) EXIT
1221	status = NXgetgroupID (file_id, new_id)
1222	IF (status /= NX_OK) EXIT
1223	IF (NXsameID (file_id, new_id, group_id)) EXIT !Original group found
1224	status = NXclosegroup (file_id)
1225	IF (status /= NX_OK) EXIT
1226	END IF
1227	status = NX_EOD
1228	END DO
1229	END IF
1230	!None of the groups was the correct one
1231	DEALLOCATE (name, class)
1232
1233	END FUNCTION NXUresumelink
1234	!------------------------------------------------------------------------------
1235	!NXUsearchgroup searches a group for the required data
1236	RECURSIVE FUNCTION NXUsearchgroup (file_id, group_id, data_id, &
1237	group_class) RESULT (status)
1238
1239	TYPE(NXhandle), INTENT(inout) :: file_id
1240	TYPE(NXlink), INTENT(in) :: group_id, data_id
1241	CHARACTER(len=*), INTENT(in), OPTIONAL :: group_class
1242	TYPE(NXlink) :: new_id
1243	CHARACTER(len=NX_MAXNAMELEN), ALLOCATABLE :: name(:), class(:)
1244	CHARACTER(len=NX_MAXNAMELEN) :: current_group, current_class
1245	INTEGER :: status, n, i
1246
1247	!Obtain list of groups contained within this group
1248	status = NXgetgroupinfo (file_id, n, current_group, current_class)
1249	IF (status /= NX_OK) RETURN
1250	ALLOCATE (name(n), class(n), STAT=status)
1251	IF (status /= 0) THEN
1252	CALL NXerror ("Unable to allocate space for group info")
1253	status = NX_ERROR
1254	RETURN
1255	END IF
1256	status = NXgroupdir (file_id, n, name, class)
1257	IF (status == NX_OK) THEN
1258	DO i = 1,n
1259	IF (class(i)(1:3) == "SDS") THEN
1260	IF (PRESENT(group_class) .AND. &
1261	trim(group_class) /= trim(current_class)) THEN
1262	status = NX_EOD
1263	CYCLE
1264	END IF
1265	status = NXopendata (file_id, name(i))
1266	IF (status /= NX_OK) EXIT
1267	status = NXgetdataID (file_id, new_id)
1268	IF (status /= NX_OK) EXIT
1269	IF (NXsameID (file_id, new_id, data_id)) THEN !Linked item found
1270	status = NX_OK
1271	EXIT
1272	END IF
1273	ELSE IF (class(i)(1:2) == "NX") THEN
1274	status = NXopengroup (file_id, name(i), class(i))
1275	IF (status /= NX_OK) EXIT
1276	status = NXgetgroupID (file_id, new_id)
1277	IF (status /= NX_OK) EXIT
1278	!Skip this group if it's where we started
1279	IF (NXsameID (file_id, new_id, group_id)) THEN
1280	status = NXclosegroup (file_id)
1281	IF (status /= NX_OK) EXIT
1282	CYCLE
1283	END IF
1284	group_level = group_level + 1
1285	status = NXUsearchgroup(file_id, group_id, data_id, group_class)
1286	IF (status == NX_OK) EXIT !The item must have been found
1287	status = NXclosegroup (file_id)
1288	group_level = group_level - 1
1289	IF (status /= NX_OK) EXIT
1290	END IF
1291	status = NX_EOD
1292	END DO
1293	END IF
1294	!Return an error status because nothing has been found in this group
1295	DEALLOCATE (name, class)
1296
1297	END FUNCTION NXUsearchgroup
1298	!------------------------------------------------------------------------------
1299	!NXUpreparedata creates and opens a data set
1300	FUNCTION NXUpreparedata (file_id, data_name, data_type, data_rank, &
1301	data_dimensions) RESULT (status)
1302
1303	TYPE(NXhandle), INTENT(inout) :: file_id
1304	CHARACTER(len=*), INTENT(in) :: data_name
1305	INTEGER, INTENT(in) :: data_type, data_rank
1306	INTEGER, INTENT(in) :: data_dimensions(:)
1307	INTEGER :: status, i
1308
1309	status = NXUfinddata (file_id, data_name)
1310	IF (status == NX_EOD) THEN !Data item needs to be created
1311	IF (NXcompress_type /= NX_COMP_NONE .AND. &
1312	PRODUCT(data_dimensions(1:data_rank)) > NXcompress_size) THEN
1313	status = NXmakedata (file_id, data_name, data_type, data_rank, &
1314	data_dimensions, NXcompress_type)
1315	ELSE
1316	status = NXmakedata (file_id, data_name, data_type, data_rank, &
1317	data_dimensions)
1318	END IF
1319	IF (status == NX_OK) status = NXopendata (file_id, data_name)
1320	ELSE if (status == NX_OK) THEN !Data item already exists
1321	status = NXopendata (file_id, data_name)
1322	IF (status /= NX_OK) RETURN
1323	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
1324	IF (NXtype /= data_type) THEN
1325	CALL NXerror ("Type of existing data item does not match new data")
1326	status = NX_ERROR
1327	ELSE IF (NXrank /= data_rank) THEN
1328	CALL NXerror ("Rank of existing data item does not match new data")
1329	status = NX_ERROR
1330	ELSE
1331	DO i = 1,NXrank
1332	IF (data_dimensions(i) > NXdims(i)) THEN
1333	call NXerror ("Size of new data too large for existing item")
1334	status = NX_ERROR
1335	EXIT
1336	END IF
1337	END DO
1338	END IF
1339	END IF
1340
1341	END FUNCTION NXUpreparedata
1342	!------------------------------------------------------------------------------
1343	!NXUconfirmdata checks that a dataset has the expected type, rank & dimensions
1344	FUNCTION NXUconfirmdata (file_id, data_name, data_type, data_rank, &
1345	data_dimensions) RESULT (status)
1346
1347	TYPE(NXhandle), INTENT(inout) :: file_id
1348	CHARACTER(len=*), INTENT(in) :: data_name
1349	INTEGER, INTENT(in) :: data_type, data_rank
1350	INTEGER, INTENT(out) :: data_dimensions(:)
1351	INTEGER :: status
1352
1353	status = NXopendata (file_id, data_name)
1354	IF (status /= NX_OK) RETURN
1355	status = NXgetinfo (file_id, NXrank, NXdims, NXtype)
1356	IF (status /= NX_OK) RETURN
1357	IF (NXrank == data_rank) THEN
1358	!Check that the types match, or that they are both integer or real
1359	IF (NXtype /= data_type .AND. (NXtype/10) /= (data_type/10)) THEN
1360	CALL NXerror ("Type of data does not match supplied array")
1361	ELSE
1362	data_dimensions(1:NXrank) = NXdims(1:NXrank)
1363	status = NX_OK
1364	RETURN
1365	END IF
1366	ELSE
1367	CALL NXerror ("Rank of data does not match supplied array")
1368	END IF
1369	status = NXclosedata(file_id)
1370	status = NX_ERROR
1371
1372	END FUNCTION NXUconfirmdata
1373
1374	END MODULE NXUmodule

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

Context Navigation

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

Download in other formats: