| 1 | C------------------------------------------------------------------------------ |
|---|
| 2 | C NeXus - Neutron & X-ray Common Data Format |
|---|
| 3 | C |
|---|
| 4 | C Test program for NeXus FORTRAN 77 interface |
|---|
| 5 | C |
|---|
| 6 | C Copyright (C) 1997-2002, Freddie Akeroyd |
|---|
| 7 | C |
|---|
| 8 | C This library is free software; you can redistribute it and/or |
|---|
| 9 | C modify it under the terms of the GNU Lesser General Public |
|---|
| 10 | C License as published by the Free Software Foundation; either |
|---|
| 11 | C version 2 of the License, or (at your option) any later version. |
|---|
| 12 | C |
|---|
| 13 | C This library is distributed in the hope that it will be useful, |
|---|
| 14 | C but WITHOUT ANY WARRANTY; without even the implied warranty of |
|---|
| 15 | C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
|---|
| 16 | C Lesser General Public License for more details. |
|---|
| 17 | C |
|---|
| 18 | C You should have received a copy of the GNU Lesser General Public |
|---|
| 19 | C License along with this library; if not, write to the Free Software |
|---|
| 20 | C Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
|---|
| 21 | C |
|---|
| 22 | C For further information, see <http://www.nexusformat.org> |
|---|
| 23 | C |
|---|
| 24 | C $Id$ |
|---|
| 25 | C------------------------------------------------------------------------------ |
|---|
| 26 | |
|---|
| 27 | INCLUDE 'napif.inc' |
|---|
| 28 | INTEGER NXRANK, NXDIMS(NX_MAXRANK), NXTYPE, NXLEN |
|---|
| 29 | INTEGER ENTRY_STATUS, ATTR_STATUS, STAT |
|---|
| 30 | INTEGER*4 I, J |
|---|
| 31 | REAL*4 R |
|---|
| 32 | INTEGER*1 I1_ARRAY(4) |
|---|
| 33 | INTEGER*2 I2_ARRAY(4) |
|---|
| 34 | INTEGER*4 I4_ARRAY(4) |
|---|
| 35 | REAL*4 R4_ARRAY(4,5) |
|---|
| 36 | REAL*8 R8_ARRAY(4,5) |
|---|
| 37 | INTEGER*4 ARRAY_DIMS(2), UNLIMITED_DIMS(1) |
|---|
| 38 | INTEGER*4 CHUNK_SIZE(2) |
|---|
| 39 | INTEGER*4 SLAB_START(2), SLAB_SIZE(2) |
|---|
| 40 | CHARACTER*64 NAME, CLASS |
|---|
| 41 | CHARACTER*128 CHAR_BUFFER |
|---|
| 42 | INTEGER*1 CHAR_BUFFER_B(128) |
|---|
| 43 | CHARACTER*64 GROUP_NAME, CLASS_NAME |
|---|
| 44 | CHARACTER*70 PATH |
|---|
| 45 | INTEGER FILEID(NXHANDLESIZE) |
|---|
| 46 | INTEGER GLINK(NXLINKSIZE), DLINK(NXLINKSIZE), BLINK(NXLINKSIZE) |
|---|
| 47 | INTEGER*4 COMP_ARRAY(20,100) |
|---|
| 48 | INTEGER*4 DIMS(2), CDIMS(2), UDIMS(1) |
|---|
| 49 | INTEGER*1 I1_BUFFER(4) |
|---|
| 50 | INTEGER*2 I2_BUFFER(4) |
|---|
| 51 | INTEGER*4 I4_BUFFER(4), U_BUFFER(7) |
|---|
| 52 | REAL*4 R4_BUFFER(4) |
|---|
| 53 | REAL*8 R8_BUFFER(16) |
|---|
| 54 | DATA I1_ARRAY /1, 2, 3, 4/ |
|---|
| 55 | DATA I2_ARRAY /1000, 2000, 3000, 4000/ |
|---|
| 56 | DATA I4_ARRAY /1000000, 2000000, 3000000, 4000000/ |
|---|
| 57 | DATA R4_ARRAY /1.,2.,3.,4.,5.,6.,7.,8.,9.,10.,11.,12.,13.,14., |
|---|
| 58 | + 15.,16.,17.,18.,19.,20./ |
|---|
| 59 | DATA R8_ARRAY/1.,2.,3.,4.,5.,6.,7.,8.,9.,10.,11.,12.,13.,14., |
|---|
| 60 | + 15.,16.,17.,18.,19.,20./ |
|---|
| 61 | DATA ARRAY_DIMS /4, 5/ |
|---|
| 62 | DATA CHUNK_SIZE /4, 5/ |
|---|
| 63 | DATA U_BUFFER /0,1,2,3,4,5,6/ |
|---|
| 64 | EQUIVALENCE (CHAR_BUFFER, CHAR_BUFFER_B) |
|---|
| 65 | |
|---|
| 66 | IF (NXOPEN('NXtest.nxs', NXACC_CREATE5, FILEID) .NE. NX_OK) STOP |
|---|
| 67 | IF (NXMAKEGROUP(FILEID, 'entry', 'NXentry') .NE. NX_OK) STOP |
|---|
| 68 | IF (NXOPENGROUP(FILEID, 'entry', 'NXentry') .NE. NX_OK) STOP |
|---|
| 69 | IF (NXMAKEDATA(FILEID, 'ch_data', NX_CHAR, 1, 10) .NE. NX_OK) |
|---|
| 70 | + STOP |
|---|
| 71 | IF (NXOPENDATA(FILEID, 'ch_data') .NE. NX_OK) STOP |
|---|
| 72 | IF (NXPUTCHARDATA(FILEID, 'NeXus data') .NE. NX_OK) STOP |
|---|
| 73 | IF (NXCLOSEDATA(FILEID) .NE. NX_OK) STOP |
|---|
| 74 | IF (NXMAKEDATA(FILEID, 'i1_data', NX_INT8, 1, 4) .NE. NX_OK) |
|---|
| 75 | + STOP |
|---|
| 76 | IF (NXOPENDATA(FILEID, 'i1_data') .NE. NX_OK) STOP |
|---|
| 77 | IF (NXPUTDATA(FILEID, I1_ARRAY) .NE. NX_OK) STOP |
|---|
| 78 | IF (NXCLOSEDATA(FILEID) .NE. NX_OK) STOP |
|---|
| 79 | IF (NXMAKEDATA(FILEID, 'i2_data', NX_INT16, 1, 4) .NE. NX_OK) |
|---|
| 80 | + STOP |
|---|
| 81 | IF (NXOPENDATA(FILEID, 'i2_data') .NE. NX_OK) STOP |
|---|
| 82 | IF (NXPUTDATA(FILEID, I2_ARRAY) .NE. NX_OK) STOP |
|---|
| 83 | IF (NXCLOSEDATA(FILEID) .NE. NX_OK) STOP |
|---|
| 84 | IF (NXMAKEDATA(FILEID, 'i4_data', NX_INT32, 1, 4) .NE. NX_OK) |
|---|
| 85 | + STOP |
|---|
| 86 | IF (NXOPENDATA(FILEID, 'i4_data') .NE. NX_OK) STOP |
|---|
| 87 | IF (NXPUTDATA(FILEID, I4_ARRAY) .NE. NX_OK) STOP |
|---|
| 88 | IF (NXCLOSEDATA(FILEID) .NE. NX_OK) STOP |
|---|
| 89 | IF (NXCOMPMAKEDATA(FILEID, 'r4_data', NX_FLOAT32, 2, |
|---|
| 90 | + ARRAY_DIMS, NX_COMP_LZW, CHUNK_SIZE) .NE. NX_OK) STOP |
|---|
| 91 | IF (NXOPENDATA(FILEID, 'r4_data') .NE. NX_OK) STOP |
|---|
| 92 | IF (NXPUTDATA(FILEID, R4_ARRAY) .NE. NX_OK) STOP |
|---|
| 93 | IF (NXCLOSEDATA(FILEID) .NE. NX_OK) STOP |
|---|
| 94 | IF (NXMAKEDATA(FILEID, 'r8_data', NX_FLOAT64, 2, ARRAY_DIMS) |
|---|
| 95 | + .NE. NX_OK) STOP |
|---|
| 96 | IF (NXOPENDATA(FILEID, 'r8_data') .NE. NX_OK) STOP |
|---|
| 97 | SLAB_START(1) = 1 |
|---|
| 98 | SLAB_START(2) = 5 |
|---|
| 99 | SLAB_SIZE(1) = 4 |
|---|
| 100 | SLAB_SIZE(2) = 1 |
|---|
| 101 | IF (NXPUTSLAB(FILEID, R8_ARRAY(1,5), SLAB_START, SLAB_SIZE) |
|---|
| 102 | + .NE. NX_OK) STOP |
|---|
| 103 | SLAB_START(1) = 1 |
|---|
| 104 | SLAB_START(2) = 1 |
|---|
| 105 | SLAB_SIZE(1) = 4 |
|---|
| 106 | SLAB_SIZE(2) = 4 |
|---|
| 107 | IF (NXPUTSLAB(FILEID, R8_ARRAY, SLAB_START, SLAB_SIZE) |
|---|
| 108 | + .NE. NX_OK) STOP |
|---|
| 109 | IF (NXPUTCHARATTR(FILEID, 'ch_attribute', 'NeXus',5,NX_CHAR) |
|---|
| 110 | + .NE. NX_OK) STOP |
|---|
| 111 | IF (NXPUTATTR(FILEID, 'i4_attribute', 42, 1, NX_INT32) |
|---|
| 112 | + .NE. NX_OK) STOP |
|---|
| 113 | IF (NXPUTATTR(FILEID, 'r4_attribute', 3.14159265, 1, |
|---|
| 114 | + NX_FLOAT32) .NE. NX_OK) STOP |
|---|
| 115 | IF (NXGETDATAID(FILEID, DLINK) .NE. NX_OK) STOP |
|---|
| 116 | IF (NXCLOSEDATA(FILEID) .NE. NX_OK) STOP |
|---|
| 117 | IF (NXMAKEGROUP(FILEID, 'data', 'NXdata') .NE. NX_OK) STOP |
|---|
| 118 | IF (NXOPENGROUP(FILEID, 'data', 'NXdata') .NE. NX_OK) STOP |
|---|
| 119 | IF (NXMAKELINK(FILEID, DLINK) .NE. NX_OK) STOP |
|---|
| 120 | DIMS(1) = 20 |
|---|
| 121 | DIMS(2) = 100 |
|---|
| 122 | DO I = 1,100 |
|---|
| 123 | DO J = 1,20 |
|---|
| 124 | COMP_ARRAY(J,I) = I-1 |
|---|
| 125 | END DO |
|---|
| 126 | END DO |
|---|
| 127 | CDIMS(1) = 20 |
|---|
| 128 | CDIMS(2) = 20 |
|---|
| 129 | IF (NXCOMPMAKEDATA(FILEID, 'comp_data', NX_INT32, 2, DIMS, |
|---|
| 130 | + NX_COMP_LZW, CDIMS) .NE. NX_OK) STOP |
|---|
| 131 | IF (NXOPENDATA(FILEID, 'comp_data') .NE. NX_OK) STOP |
|---|
| 132 | IF (NXPUTDATA(FILEID, COMP_ARRAY) .NE. NX_OK) STOP |
|---|
| 133 | IF (NXCLOSEDATA(FILEID) .NE. NX_OK) STOP |
|---|
| 134 | IF (NXFLUSH(FILEID) .NE. NX_OK) STOP |
|---|
| 135 | UDIMS(1) = NX_UNLIMITED |
|---|
| 136 | IF (NXMAKEDATA(FILEID, 'flush_data', NX_INT32, 1, UDIMS) |
|---|
| 137 | + .NE. NX_OK) STOP |
|---|
| 138 | SLAB_SIZE(1) = 1 |
|---|
| 139 | DO I = 1,7 |
|---|
| 140 | SLAB_START(1) = I |
|---|
| 141 | IF (NXOPENDATA(FILEID, 'flush_data') .NE. NX_OK) STOP |
|---|
| 142 | IF (NXPUTSLAB(FILEID, U_BUFFER(I), SLAB_START, |
|---|
| 143 | + SLAB_SIZE) .NE. NX_OK) STOP |
|---|
| 144 | STAT = NXCLOSEDATA(FILEID) |
|---|
| 145 | IF (NXFLUSH(FILEID) .NE. NX_OK) STOP |
|---|
| 146 | END DO |
|---|
| 147 | IF (NXCLOSEGROUP(FILEID) .NE. NX_OK) STOP |
|---|
| 148 | IF (NXMAKEGROUP(FILEID, 'sample', 'NXsample') .NE. NX_OK) STOP |
|---|
| 149 | IF (NXOPENGROUP(FILEID, 'sample', 'NXsample') .NE. NX_OK) STOP |
|---|
| 150 | IF (NXMAKEDATA(FILEID, 'ch_data', NX_CHAR, 1, 12) .NE. |
|---|
| 151 | + NX_OK) STOP |
|---|
| 152 | IF (NXOPENDATA(FILEID, 'ch_data') .NE. NX_OK) STOP |
|---|
| 153 | IF (NXPUTCHARDATA(FILEID, 'NeXus sample') .NE. NX_OK) STOP |
|---|
| 154 | IF (NXCLOSEDATA(FILEID) .NE. NX_OK) STOP |
|---|
| 155 | IF (NXGETGROUPID (FILEID, GLINK) .NE. NX_OK) STOP |
|---|
| 156 | IF (NXCLOSEGROUP (FILEID) .NE. NX_OK) STOP |
|---|
| 157 | IF (NXCLOSEGROUP (FILEID) .NE. NX_OK) STOP |
|---|
| 158 | IF (NXMAKEGROUP (FILEID, "link", "NXentry") .NE. NX_OK) STOP |
|---|
| 159 | IF (NXOPENGROUP (FILEID, "link", "NXentry") .NE. NX_OK) STOP |
|---|
| 160 | IF (NXMAKELINK (fileid, GLINK) .NE. NX_OK) STOP |
|---|
| 161 | IF (NXCLOSEGROUP(FILEID) .NE. NX_OK) STOP |
|---|
| 162 | IF (NXCLOSE(FILEID) .NE. NX_OK) STOP |
|---|
| 163 | C *** read data |
|---|
| 164 | IF (NXOPEN('NXtest.nxs', NXACC_READ, FILEID) .NE. NX_OK) STOP |
|---|
| 165 | IF (NXGETATTRINFO(FILEID, J) .NE. NX_OK) STOP |
|---|
| 166 | IF (J .GT. 0) WRITE(*,'(1X,A,I2)') |
|---|
| 167 | + 'Number of global attributes: ', J |
|---|
| 168 | DO I = 1,J |
|---|
| 169 | ATTR_STATUS = NXGETNEXTATTR(FILEID,NAME,NXDIMS,NXTYPE) |
|---|
| 170 | IF (ATTR_STATUS .EQ. NX_ERROR) THEN |
|---|
| 171 | STOP |
|---|
| 172 | ELSE IF (ATTR_STATUS .EQ. NX_OK) THEN |
|---|
| 173 | NXLEN = LEN(CHAR_BUFFER) |
|---|
| 174 | IF (NXGETCHARATTR(FILEID, NAME, CHAR_BUFFER, NXLEN, NXTYPE) |
|---|
| 175 | + .NE. NX_OK) STOP |
|---|
| 176 | IF ((NAME .NE. 'HDF5_Version') .AND. |
|---|
| 177 | + (NAME .NE. 'file_time')) THEN |
|---|
| 178 | WRITE(*,'(4X,A)') NAME(1:LEN_TRIM(NAME))//' = ' |
|---|
| 179 | + //CHAR_BUFFER(1:LEN_TRIM(CHAR_BUFFER)) |
|---|
| 180 | END IF |
|---|
| 181 | END IF |
|---|
| 182 | END DO |
|---|
| 183 | IF (NXOPENGROUP(FILEID, 'entry', 'NXentry') .NE. NX_OK) STOP |
|---|
| 184 | IF (NXGETGROUPINFO(FILEID, I, GROUP_NAME, CLASS_NAME) .NE. |
|---|
| 185 | + NX_OK) STOP |
|---|
| 186 | WRITE(*,'(1X,A,I2,A)') 'Group: ' |
|---|
| 187 | + //GROUP_NAME(1:LEN_TRIM(GROUP_NAME))//'(' |
|---|
| 188 | + //CLASS_NAME(1:LEN_TRIM(CLASS_NAME)) |
|---|
| 189 | + //') contains ',I,' items' |
|---|
| 190 | 100 ENTRY_STATUS=NXGETNEXTENTRY(FILEID,NAME,CLASS,NXTYPE) |
|---|
| 191 | IF (ENTRY_STATUS .EQ. NX_ERROR) STOP |
|---|
| 192 | IF (CLASS(1:LEN_TRIM(CLASS)) .NE. 'SDS') THEN |
|---|
| 193 | IF (ENTRY_STATUS .NE. NX_EOD) THEN |
|---|
| 194 | WRITE(*,'(4X,A)') 'Subgroup: '//NAME(1:LEN_TRIM(NAME))//'(' |
|---|
| 195 | + //CLASS(1:LEN_TRIM(CLASS))//')' |
|---|
| 196 | ENTRY_STATUS = NX_OK |
|---|
| 197 | END IF |
|---|
| 198 | ELSE IF (ENTRY_STATUS .EQ. NX_OK) THEN |
|---|
| 199 | IF (NXOPENDATA(FILEID,NAME) .NE. NX_OK) STOP |
|---|
| 200 | IF(NXGETPATH(FILEID,PATH) .NE. NX_OK) STOP |
|---|
| 201 | WRITE(*,FMT='(1X,A,A)') 'Path = ', PATH(1:LEN_TRIM(PATH)) |
|---|
| 202 | IF (NXGETINFO(FILEID,NXRANK,NXDIMS,NXTYPE) .NE. NX_OK) STOP |
|---|
| 203 | WRITE(*,FMT='(4X,A,I2,A)') NAME(1:LEN_TRIM(NAME))//'(', |
|---|
| 204 | + NXTYPE,')' |
|---|
| 205 | IF (NXTYPE .EQ. NX_CHAR) THEN |
|---|
| 206 | IF (NXGETCHARDATA(FILEID,CHAR_BUFFER) .NE. NX_OK) STOP |
|---|
| 207 | WRITE(*,FMT='(4X,A)') |
|---|
| 208 | + 'Values : '//CHAR_BUFFER(1:NXDIMS(1)) |
|---|
| 209 | ELSE IF (NXTYPE .EQ. NX_INT8) THEN |
|---|
| 210 | IF (NXGETDATA(FILEID,I1_BUFFER) .NE. NX_OK) STOP |
|---|
| 211 | WRITE(*,FMT='(4X,A,4I3)') 'Values : ', I1_BUFFER |
|---|
| 212 | ELSE IF (NXTYPE .EQ. NX_INT16) THEN |
|---|
| 213 | IF (NXGETDATA(FILEID,I2_BUFFER) .NE. NX_OK) STOP |
|---|
| 214 | WRITE(*,FMT='(4X,A,4I6)') 'Values : ', I2_BUFFER |
|---|
| 215 | ELSE IF (NXTYPE .EQ. NX_INT32) THEN |
|---|
| 216 | IF (NXGETDATA(FILEID,I4_BUFFER) .NE. NX_OK) STOP |
|---|
| 217 | WRITE(*,FMT='(4X,A,4I12)') 'Values : ', I4_BUFFER |
|---|
| 218 | ELSE IF (NXTYPE .EQ. NX_FLOAT32) THEN |
|---|
| 219 | SLAB_START(1) = 1 |
|---|
| 220 | SLAB_START(2) = 1 |
|---|
| 221 | SLAB_SIZE(1) = 4 |
|---|
| 222 | SLAB_SIZE(2) = 1 |
|---|
| 223 | IF (NXGETSLAB(FILEID, R4_BUFFER, SLAB_START, SLAB_SIZE) |
|---|
| 224 | + .NE. NX_OK) STOP |
|---|
| 225 | WRITE(*,FMT='(4X,A,4F7.2)') 'Values : ', R4_BUFFER |
|---|
| 226 | SLAB_START(2) = 2 |
|---|
| 227 | IF (NXGETSLAB(FILEID, R4_BUFFER, SLAB_START, SLAB_SIZE) |
|---|
| 228 | + .NE. NX_OK) STOP |
|---|
| 229 | WRITE(*,FMT='(4X,A,4F7.2)') ' : ', R4_BUFFER |
|---|
| 230 | SLAB_START(2) = 3 |
|---|
| 231 | IF (NXGETSLAB(FILEID, R4_BUFFER, SLAB_START, SLAB_SIZE) |
|---|
| 232 | + .NE. NX_OK) STOP |
|---|
| 233 | WRITE(*,FMT='(4X,A,4F7.2)') ' : ', R4_BUFFER |
|---|
| 234 | SLAB_START(2) = 4 |
|---|
| 235 | IF (NXGETSLAB(FILEID, R4_BUFFER, SLAB_START, SLAB_SIZE) |
|---|
| 236 | + .NE. NX_OK) STOP |
|---|
| 237 | WRITE(*,FMT='(4X,A,4F7.2)') ' : ', R4_BUFFER |
|---|
| 238 | SLAB_START(2) = 5 |
|---|
| 239 | IF (NXGETSLAB(FILEID, R4_BUFFER, SLAB_START, SLAB_SIZE) |
|---|
| 240 | + .NE. NX_OK) STOP |
|---|
| 241 | WRITE(*,FMT='(4X,A,4F7.2)') ' : ', R4_BUFFER |
|---|
| 242 | ELSE IF (NXTYPE .EQ. NX_FLOAT64) THEN |
|---|
| 243 | SLAB_START(1) = 1 |
|---|
| 244 | SLAB_START(2) = 1 |
|---|
| 245 | SLAB_SIZE(1) = 4 |
|---|
| 246 | SLAB_SIZE(2) = 1 |
|---|
| 247 | IF (NXGETSLAB(FILEID, R8_BUFFER, SLAB_START, SLAB_SIZE) |
|---|
| 248 | + .NE. NX_OK) STOP |
|---|
| 249 | WRITE(*,FMT='(4X,A,4F7.2)') 'Values : ', |
|---|
| 250 | + (R8_BUFFER(I), I=1,4) |
|---|
| 251 | SLAB_START(2) = 2 |
|---|
| 252 | IF (NXGETSLAB(FILEID, R8_BUFFER, SLAB_START, SLAB_SIZE) |
|---|
| 253 | + .NE. NX_OK) STOP |
|---|
| 254 | WRITE(*,FMT='(4X,A,4F7.2)') ' : ', |
|---|
| 255 | + (R8_BUFFER(I), I=1,4) |
|---|
| 256 | SLAB_START(2) = 3 |
|---|
| 257 | IF (NXGETSLAB(FILEID, R8_BUFFER, SLAB_START, SLAB_SIZE) |
|---|
| 258 | + .NE. NX_OK) STOP |
|---|
| 259 | WRITE(*,FMT='(4X,A,4F7.2)') ' : ', |
|---|
| 260 | + (R8_BUFFER(I), I=1,4) |
|---|
| 261 | SLAB_START(2) = 4 |
|---|
| 262 | IF (NXGETSLAB(FILEID, R8_BUFFER, SLAB_START, SLAB_SIZE) |
|---|
| 263 | + .NE. NX_OK) STOP |
|---|
| 264 | WRITE(*,FMT='(4X,A,4F7.2)') ' : ', |
|---|
| 265 | + (R8_BUFFER(I), I=1,4) |
|---|
| 266 | SLAB_START(2) = 5 |
|---|
| 267 | IF (NXGETSLAB(FILEID, R8_BUFFER, SLAB_START, SLAB_SIZE) |
|---|
| 268 | + .NE. NX_OK) STOP |
|---|
| 269 | WRITE(*,FMT='(4X,A,4F7.2)') ' : ', |
|---|
| 270 | + (R8_BUFFER(I), I=1,4) |
|---|
| 271 | END IF |
|---|
| 272 | 200 ATTR_STATUS = NXGETNEXTATTR (FILEID, NAME, NXDIMS, NXTYPE) |
|---|
| 273 | IF (ATTR_STATUS .EQ. NX_ERROR) STOP |
|---|
| 274 | IF (ATTR_STATUS .EQ. NX_OK) THEN |
|---|
| 275 | IF (NXTYPE .EQ. NX_CHAR) THEN |
|---|
| 276 | LENGTH=LEN(CHAR_BUFFER) |
|---|
| 277 | IF (NXGETCHARATTR(FILEID,NAME,CHAR_BUFFER,LENGTH,NXTYPE) |
|---|
| 278 | + .NE. NX_OK) STOP |
|---|
| 279 | WRITE(*,FMT='(7X,A)') NAME(1:LEN_TRIM(NAME))//' : ' |
|---|
| 280 | + //CHAR_BUFFER(1:LEN_TRIM(CHAR_BUFFER)) |
|---|
| 281 | ELSE IF (NXTYPE .EQ. NX_INT32) THEN |
|---|
| 282 | LENGTH=1 |
|---|
| 283 | IF (NXGETATTR(FILEID,NAME,I,LENGTH,NXTYPE) |
|---|
| 284 | + .NE. NX_OK) STOP |
|---|
| 285 | WRITE(*,FMT='(7X,A,I5)') NAME(1:LEN_TRIM(NAME))//' : ', |
|---|
| 286 | + I |
|---|
| 287 | ELSE IF (NXTYPE .EQ. NX_FLOAT32) THEN |
|---|
| 288 | LENGTH=1 |
|---|
| 289 | IF (NXGETATTR(FILEID,NAME,R,LENGTH,NXTYPE) |
|---|
| 290 | + .NE. NX_OK) STOP |
|---|
| 291 | WRITE(*,FMT='(7X,A,F10.6)') NAME(1:LEN_TRIM(NAME)) |
|---|
| 292 | + //' : ', R |
|---|
| 293 | END IF |
|---|
| 294 | END IF |
|---|
| 295 | IF (ATTR_STATUS .NE. NX_EOD) GOTO 200 |
|---|
| 296 | IF (NXCLOSEDATA(FILEID) .NE. NX_OK) STOP |
|---|
| 297 | END IF |
|---|
| 298 | IF (ENTRY_STATUS .NE. NX_EOD) GOTO 100 |
|---|
| 299 | IF (NXCLOSEGROUP(FILEID) .NE. NX_OK) STOP |
|---|
| 300 | IF (NXOPENGROUP (FILEID, "link", "NXentry") .NE. NX_OK) STOP |
|---|
| 301 | IF (NXGETGROUPID (FILEID, GLINK) .NE. NX_OK) STOP |
|---|
| 302 | IF (NXCLOSEGROUP (FILEID) .NE. NX_OK) STOP |
|---|
| 303 | IF (NXOPENGROUP (FILEID, "link", "NXentry") .NE. NX_OK) STOP |
|---|
| 304 | IF (NXGETGROUPID (FILEID, BLINK) .NE. NX_OK) STOP |
|---|
| 305 | IF (NXSAMEID(FILEID, GLINK, BLINK)) THEN |
|---|
| 306 | WRITE(*,*) 'Link Check OK' |
|---|
| 307 | ELSE |
|---|
| 308 | WRITE(*,*) 'Link Check Failed' |
|---|
| 309 | ENDIF |
|---|
| 310 | IF (NXCLOSEGROUP(FILEID) .NE. NX_OK) STOP |
|---|
| 311 | IF (NXCLOSE(FILEID) .NE. NX_OK) STOP |
|---|
| 312 | END |
|---|
| 313 | C---------------------------------------------------------------------- |
|---|
| 314 | C LEN_TRIM trims remaining blanks and tabs from the end of "string" |
|---|
| 315 | C INTEGER FUNCTION LEN_TRIM (STRING) |
|---|
| 316 | C INTEGER I |
|---|
| 317 | C CHARACTER*(*) STRING |
|---|
| 318 | C I = LEN(STRING) |
|---|
| 319 | C DO WHILE (I .GE. 1 .AND. |
|---|
| 320 | C +(STRING(I:I).EQ.' '.OR. STRING(I:I).EQ.CHAR(0).OR. |
|---|
| 321 | C + STRING(I:I).EQ.CHAR(9))) |
|---|
| 322 | C I = I - 1 |
|---|
| 323 | C END DO |
|---|
| 324 | C LEN_TRIM = MIN(I,LEN(STRING)) |
|---|
| 325 | C RETURN |
|---|
| 326 | C END |
|---|
| 327 | |
|---|
