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