NeXus  1
 All Classes Files Functions Variables
NXUmodule.f90
Go to the documentation of this file.
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: NXUmodule.f90 1636 2011-10-13 21:09:07Z Pete Jemian $
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
Generated by   doxygen 1.8.8