source: trunk/test/NXtest.f90 @ 1822

Revision 1636, 10.0 KB checked in by Pete Jemian, 7 months ago (diff)

point to current WWW site in license text, refs #281
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1!------------------------------------------------------------------------------
2! NeXus - Neutron & X-ray Common Data Format
3! 
4! Test program for the Fortran 90 API
5!
6! Copyright (C) 1999-2002, Ray Osborn
7!
8! This library is free software; you can redistribute it and/or
9! modify it under the terms of the GNU Lesser General Public
10! License as published by the Free Software Foundation; either
11! version 2 of the License, or (at your option) any later version.
12!
13! This library is distributed in the hope that it will be useful,
14! but WITHOUT ANY WARRANTY; without even the implied warranty of
15! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16! Lesser General Public License for more details.
17!
18! You should have received a copy of the GNU Lesser General Public
19! License along with this library; if not, write to the Free Software
20! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
21!
22!  For further information, see <http://www.nexusformat.org>
23!
24! $Id$
25!------------------------------------------------------------------------------
26
27program NXtest
28
29   use NXmodule
30
31   integer :: NXrank, NXdims(NX_maxrank), NXtype, NXlen, entry_status, attr_status
32   integer(kind=NXi1), dimension(4) :: i1_array = (/1, 2, 3, 4/)
33   integer(kind=NXi2), dimension(4) :: i2_array = (/1000, 2000, 3000, 4000/)
34   integer(kind=NXi4), dimension(4) :: i4_array = (/1000000, 2000000, 3000000, 4000000/)
35   real(kind=NXr4), dimension(4,5) :: r4_array
36   real(kind=NXr8), dimension(4,5) :: r8_array
37   integer(kind=NXi4), dimension(4) :: i4_buffer
38   real(kind=NXr4), dimension(4) :: r4_buffer
39   real(kind=NXr8), dimension(16) :: r8_buffer
40   integer(kind=NXi4), dimension(2000) :: comp_array
41   integer(kind=NXi4) :: i, j
42   real(kind=NXr4) :: r
43   character(len=20) :: char_buffer
44   character(len=NX_maxnamelen) :: name, class
45   type(NXhandle) :: fileid
46   type(NXlink) :: glink, dlink, blink
47
48   r4_array = reshape ((/(i*1.0_NXr4,i=1,20)/),(/4,5/))
49   r8_array = reshape ((/(i*1.0_NXr8,i=1,20)/),(/4,5/))
50! *** create file
51   if (NXopen("NXtest.nxs", NXACC_CREATE5, fileid) /= NX_OK) stop
52   if (NXmakegroup(fileid, "entry", "NXentry") /= NX_OK) stop
53   if (NXopengroup(fileid, "entry", "NXentry") /= NX_OK) stop
54      if (NXmakedata(fileid, "ch_data", NX_CHAR, 1, (/10/)) /= NX_OK) stop
55      if (NXopendata(fileid, "ch_data") /= NX_OK) stop
56         if (NXputdata(fileid, "NeXus data") /= NX_OK) stop
57      if (NXclosedata(fileid) /= NX_OK) stop
58      if (NXmakedata(fileid, "i1_data", NX_INT8, 1, (/4/)) /= NX_OK) stop
59      if (NXopendata(fileid, "i1_data") /= NX_OK) stop
60         if (NXputdata(fileid, i1_array) /= NX_OK) stop
61      if (NXclosedata(fileid) /= NX_OK) stop
62      if (NXmakedata(fileid, "i2_data", NX_INT16, 1, (/4/)) /= NX_OK) stop
63      if (NXopendata(fileid, "i2_data") /= NX_OK) stop
64         if (NXputdata(fileid, i2_array) /= NX_OK) stop
65      if (NXclosedata(fileid) /= NX_OK) stop
66      if (NXmakedata(fileid, "i4_data", NX_INT32, 1, (/4/)) /= NX_OK) stop
67      if (NXopendata(fileid, "i4_data") /= NX_OK) stop
68         if (NXputdata(fileid, i4_array) /= NX_OK) stop
69      if (NXclosedata(fileid) /= NX_OK) stop
70      if (NXmakedata(fileid, "r4_data", NX_FLOAT32, 2, (/4,5/), NX_COMP_LZW, (/4,5/)) /= NX_OK) stop
71      if (NXopendata(fileid, "r4_data") /= NX_OK) stop
72         if (NXputdata(fileid, reshape(r4_array,(/size(r4_array)/))) /= NX_OK) stop
73      if (NXclosedata(fileid) /= NX_OK) stop
74      if (NXmakedata(fileid, "r8_data", NX_FLOAT64, 2, (/4,5/)) /= NX_OK) stop
75      if (NXopendata(fileid, "r8_data") /= NX_OK) stop
76         r8_buffer(1:4) = reshape(r8_array(1:4,5:5),(/4/))
77         if (NXputslab(fileid, r8_buffer, (/1,5/), (/4,1/)) /= NX_OK) stop
78         r8_buffer = reshape(r8_array(1:4,1:4),(/16/))
79         if (NXputslab(fileid, r8_buffer, (/1,1/), (/4,4/)) /= NX_OK) stop
80         if (NXputattr(fileid, "ch_attribute", "NeXus") /= NX_OK) stop
81         if (NXputattr(fileid, "i4_attribute", 42) /= NX_OK) stop
82         if (NXputattr(fileid, "r4_attribute", 3.141593_NXr4) /= NX_OK) stop
83         if (NXgetdataID(fileid, dlink) /= NX_OK) stop
84      if (NXclosedata(fileid) /= NX_OK) stop
85      if (NXmakegroup(fileid, "data", "NXdata") /= NX_OK) stop
86      if (NXopengroup(fileid, "data", "NXdata") /= NX_OK) stop
87         if (NXmakelink(fileid, dlink) /= NX_OK) stop
88         if (NXmakedata(fileid, "comp_data", NX_INT32, 2, (/20,100/)) /= NX_OK) stop
89         if (NXopendata(fileid, "comp_data") /= NX_OK) stop
90            comp_array = (/((j-1,i=1,20),j=1,100)/)
91            if (NXputdata(fileid, comp_array) /= NX_OK) stop
92         if (NXclosedata(fileid) /= NX_OK) stop
93         if (NXflush(fileid) /= NX_OK) stop
94         if (NXmakedata(fileid, "flush_data", NX_INT32, 1, (/NX_UNLIMITED/)) /= NX_OK) stop
95            do i = 1,7
96               if (NXopendata(fileid, "flush_data") /= NX_OK) stop
97                  if (NXputslab(fileid, (/i/), (/i/), (/1/)) /= NX_OK) stop
98                  if (NXflush(fileid) /= NX_OK) stop
99            end do
100      if (NXclosegroup(fileid) /= NX_OK) stop
101      if (NXmakegroup(fileid, "sample", "NXsample") /= NX_OK) stop
102      if (NXopengroup(fileid, "sample", "NXsample") /= NX_OK) stop
103         print 300, "Writing character data"
104         if (NXmakedata(fileid, "ch_data", NX_CHAR, 1, (/12/)) /= NX_OK) stop
105         if (NXopendata(fileid, "ch_data") /= NX_OK) stop
106            if (NXputdata(fileid, "NeXus sample") /= NX_OK) stop
107         if (NXclosedata(fileid) /= NX_OK) stop
108         if (NXgetgroupID(fileid, glink) /= NX_OK) stop
109      if (NXclosegroup(fileid) /= NX_OK) stop
110   if (NXclosegroup(fileid) /= NX_OK) stop
111   if (NXmakegroup(fileid, "link", "NXentry") /= NX_OK) stop
112   if (NXopengroup(fileid, "link", "NXentry") /= NX_OK) stop
113      if (NXmakelink(fileid, glink) /= NX_OK) stop
114   if (NXclosegroup(fileid) /= NX_OK) stop
115   if (NXclose(fileid) /= NX_OK) stop
116! *** read data
117   if (NXopen("NXtest.nxs", NXACC_READ, fileid) /= NX_OK) stop
118   if (NXgetattrinfo(fileid, i) /= NX_OK) stop
119   if (i > 0) print 200, "Number of global attributes: ", i
120   attr_status = NX_OK
121   do while (attr_status == NX_OK)
122      attr_status = NXgetnextattr(fileid, name, NXlen, NXtype)
123      if (attr_status == NX_ERROR) stop
124      if (attr_status == NX_OK) then
125             if ((name /= "HDF_version") .and. (name /= "HDF5_Version") .and. &
126                 (name /= "file_time")) then
127            select case (NXtype)
128               case (NX_CHAR)
129                  NXlen = len(char_buffer)
130                  if (NXgetattr(fileid, name, char_buffer, NXlen, NXtype) /= NX_OK) stop
131                     print 300, "   "//trim(name)//" = "//trim(char_buffer)
132            end select
133         end if
134      end if
135   end do
136   if (NXopengroup(fileid, "entry", "NXentry") /= NX_OK) stop
137   if (NXgetgroupinfo(fileid, i, name, class) /= NX_OK) stop
138      print '(A,i8,A)', "Group: "//trim(name)//"("//trim(class)//") contains ", i, " items"
139   do
140      entry_status = NXgetnextentry(fileid, name, class, NXtype)
141      if (entry_status == NX_ERROR) then
142         stop
143      else if (entry_status == NX_EOD) then
144         exit
145      else if (trim(class) /= "SDS") then
146         print 300, "   Subgroup: "//trim(name)//"("//trim(class)//")"
147      else if (entry_status == NX_OK) then
148         if (NXopendata(fileid, name) /= NX_OK) stop
149            if (NXgetinfo(fileid, NXrank, NXdims, NXtype) /= NX_OK) stop
150            print 300, "   "//trim(name)//" : ", trim(NXdatatype(NXtype))
151            if (NXtype == NX_CHAR) then
152               if (NXgetdata(fileid, char_buffer) /= NX_OK) stop
153               print 300, "   Values : ", trim(char_buffer)
154            else if (NXtype == NX_INT8 .or. NXtype == NX_INT16 .or. NXtype == NX_INT32) then
155               if (NXgetdata(fileid, i4_buffer) /= NX_OK) stop
156               print 200, "   Values : ", i4_buffer
157            else if (NXtype == NX_FLOAT32 .or. NXtype == NX_FLOAT64) then
158               if (NXgetslab(fileid, r4_buffer, (/1,1/), (/4,1/)) /= NX_OK) stop
159               print 100, "   Values : ", r4_buffer
160               if (NXgetslab(fileid, r4_buffer, (/1,2/), (/4,1/)) /= NX_OK) stop
161               print 100, "          : ", r4_buffer
162               if (NXgetslab(fileid, r4_buffer, (/1,3/), (/4,1/)) /= NX_OK) stop
163               print 100, "          : ", r4_buffer
164               if (NXgetslab(fileid, r4_buffer, (/1,4/), (/4,1/)) /= NX_OK) stop
165               print 100, "          : ", r4_buffer
166               if (NXgetslab(fileid, r4_buffer, (/1,5/), (/4,1/)) /= NX_OK) stop
167               print 100, "          : ", r4_buffer
168            end if
169            do
170               attr_status = NXgetnextattr(fileid, name, NXdims(1), NXtype) 
171               if (attr_status == NX_ERROR) then
172                  stop
173               else if (attr_status == NX_EOD) then
174                  exit
175               else if (attr_status == NX_OK) then
176                  if (NXtype == NX_CHAR) then
177                     if (NXgetattr(fileid, name, char_buffer) /= NX_OK) stop
178                     print 300, "   "//trim(name)//" : ", trim(char_buffer)
179                  else if (NXtype == NX_INT32) then
180                     if (NXgetattr(fileid, name, i) /= NX_OK) stop
181                     print 200, "   "//trim(name)//" : ", i
182                  else if (NXtype == NX_FLOAT32) then
183                     if (NXgetattr(fileid, name, r) /= NX_OK) stop
184                     print 100, "   "//trim(name)//" : ", r
185                  end if
186               end if
187            end do
188         if (NXclosedata(fileid) /= NX_OK) stop
189      end if
190   end do
191   if (NXclosegroup(fileid) /= NX_OK) stop
192   if (NXopengroup(fileid, "link", "NXentry") /= NX_OK) stop
193      if (NXgetgroupID(fileid, glink) /= NX_OK) stop
194   if (NXclosegroup(fileid) /= NX_OK) stop
195   if (NXopengroup(fileid, "link", "NXentry") /= NX_OK) stop
196      if (NXgetgroupID(fileid, blink) /= NX_OK) stop
197      if (NXsameID(fileid, glink, blink)) then
198         print 300, "Link Check OK"
199      else
200         print 300, "Link Check Failed"
201      end if
202   if (NXclosegroup(fileid) /= NX_OK) stop
203   if (NXclose(fileid) /= NX_OK) stop
204
205 100 format(A,4f12.7)
206 200 format(A,4i8)
207 300 format(4A)
208
209end program NXtest
Note: See TracBrowser for help on using the repository browser.