PageRenderTime 131ms CodeModel.GetById 18ms RepoModel.GetById 0ms app.codeStats 1ms

/other/netcdf_write_matrix/src/nf_test/test_put.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 6641 lines | 5687 code | 340 blank | 614 comment | 987 complexity | 2de8200fc76adb62ac8910218694729c MD5 | raw file
Possible License(s): AGPL-1.0
  1. C Do not edit this file. It is produced from the corresponding .m4 source */
  2. C********************************************************************
  3. C Copyright 1996, UCAR/Unidata
  4. C See netcdf/COPYRIGHT file for copying and redistribution conditions.
  5. C $Id: test_put.m4,v 1.15 2005/01/12 19:52:13 ed Exp $
  6. C********************************************************************
  7. C
  8. C ensure hash value within range for internal TYPE
  9. C
  10. function hash_text(type, rank, index, itype)
  11. implicit none
  12. #include "tests.inc"
  13. integer type
  14. integer rank
  15. integer index(1)
  16. integer itype
  17. doubleprecision minimum
  18. doubleprecision maximum
  19. minimum = internal_min(itype)
  20. maximum = internal_max(itype)
  21. hash_text = max(minimum, min(maximum, hash4( type, rank,
  22. + index, itype)))
  23. end
  24. #ifdef NF_INT1_T
  25. C
  26. C ensure hash value within range for internal TYPE
  27. C
  28. function hash_int1(type, rank, index, itype)
  29. implicit none
  30. #include "tests.inc"
  31. integer type
  32. integer rank
  33. integer index(1)
  34. integer itype
  35. doubleprecision minimum
  36. doubleprecision maximum
  37. minimum = internal_min(itype)
  38. maximum = internal_max(itype)
  39. hash_int1 = max(minimum, min(maximum, hash4( type, rank,
  40. + index, itype)))
  41. end
  42. #endif
  43. #ifdef NF_INT2_T
  44. C
  45. C ensure hash value within range for internal TYPE
  46. C
  47. function hash_int2(type, rank, index, itype)
  48. implicit none
  49. #include "tests.inc"
  50. integer type
  51. integer rank
  52. integer index(1)
  53. integer itype
  54. doubleprecision minimum
  55. doubleprecision maximum
  56. minimum = internal_min(itype)
  57. maximum = internal_max(itype)
  58. hash_int2 = max(minimum, min(maximum, hash4( type, rank,
  59. + index, itype)))
  60. end
  61. #endif
  62. C
  63. C ensure hash value within range for internal TYPE
  64. C
  65. function hash_int(type, rank, index, itype)
  66. implicit none
  67. #include "tests.inc"
  68. integer type
  69. integer rank
  70. integer index(1)
  71. integer itype
  72. doubleprecision minimum
  73. doubleprecision maximum
  74. minimum = internal_min(itype)
  75. maximum = internal_max(itype)
  76. hash_int = max(minimum, min(maximum, hash4( type, rank,
  77. + index, itype)))
  78. end
  79. C
  80. C ensure hash value within range for internal TYPE
  81. C
  82. function hash_real(type, rank, index, itype)
  83. implicit none
  84. #include "tests.inc"
  85. integer type
  86. integer rank
  87. integer index(1)
  88. integer itype
  89. doubleprecision minimum
  90. doubleprecision maximum
  91. minimum = internal_min(itype)
  92. maximum = internal_max(itype)
  93. hash_real = max(minimum, min(maximum, hash4( type, rank,
  94. + index, itype)))
  95. end
  96. C
  97. C ensure hash value within range for internal TYPE
  98. C
  99. function hash_double(type, rank, index, itype)
  100. implicit none
  101. #include "tests.inc"
  102. integer type
  103. integer rank
  104. integer index(1)
  105. integer itype
  106. doubleprecision minimum
  107. doubleprecision maximum
  108. minimum = internal_min(itype)
  109. maximum = internal_max(itype)
  110. hash_double = max(minimum, min(maximum, hash4( type, rank,
  111. + index, itype)))
  112. end
  113. C
  114. C check all vars in file which are (text/numeric) compatible with TYPE
  115. C
  116. subroutine check_vars_text(filename)
  117. implicit none
  118. #include "tests.inc"
  119. character*(*) filename
  120. integer ncid !/* netCDF id */
  121. integer index(MAX_RANK)
  122. integer err !/* status */
  123. integer d
  124. integer i
  125. integer j
  126. character value
  127. integer datatype
  128. integer ndims
  129. integer dimids(MAX_RANK)
  130. integer ngatts
  131. doubleprecision expect
  132. character*(NF_MAX_NAME) name
  133. integer length
  134. logical canConvert !/* Both text or both numeric */
  135. integer nok !/* count of valid comparisons */
  136. doubleprecision val
  137. nok = 0
  138. err = nf_open(filename, NF_NOWRITE, ncid)
  139. if (err .ne. 0)
  140. + call errore('nf_open: ', err)
  141. do 1, i = 1, NVARS
  142. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  143. + (NFT_TEXT .eq. NFT_TEXT)
  144. if (canConvert) then
  145. err = nf_inq_var(ncid, i, name, datatype, ndims, dimids,
  146. + ngatts)
  147. if (err .ne. 0)
  148. + call errore('nf_inq_var: ', err)
  149. if (name .ne. var_name(i))
  150. + call error('Unexpected var_name')
  151. if (datatype .ne. var_type(i))
  152. + call error('Unexpected type')
  153. if (ndims .ne. var_rank(i))
  154. + call error('Unexpected rank')
  155. do 2, j = 1, ndims
  156. err = nf_inq_dim(ncid, dimids(j), name, length)
  157. if (err .ne. 0)
  158. + call errore('nf_inq_dim: ', err)
  159. if (length .ne. var_shape(j,i))
  160. + call error('Unexpected shape')
  161. 2 continue
  162. do 3, j = 1, var_nels(i)
  163. err = index2indexes(j, var_rank(i), var_shape(1,i),
  164. + index)
  165. if (err .ne. 0)
  166. + call error('error in index2indexes()')
  167. expect = hash4( var_type(i), var_rank(i), index,
  168. + NFT_TEXT)
  169. err = nf_get_var1_text(ncid, i, index, value)
  170. if (inRange3(expect,datatype,NFT_TEXT)) then
  171. if (in_internal_range(NFT_TEXT,
  172. + expect)) then
  173. if (err .ne. 0) then
  174. call errore('nf_get_var1_text: ', err)
  175. else
  176. val = ichar(value)
  177. if (.not.equal(
  178. + val,
  179. + expect,var_type(i),
  180. + NFT_TEXT)) then
  181. call error(
  182. + 'Var value read not that expected')
  183. if (verbose) then
  184. call error(' ')
  185. call errori('varid: %d', i)
  186. call errorc('var_name: ',
  187. + var_name(i))
  188. call error('index:')
  189. do 4, d = 1, var_rank(i)
  190. call errori(' ', index(d))
  191. 4 continue
  192. call errord('expect: ', expect)
  193. call errord('got: ', val)
  194. end if
  195. else
  196. nok = nok + 1
  197. end if
  198. end if
  199. end if
  200. end if
  201. 3 continue
  202. end if
  203. 1 continue
  204. err = nf_close (ncid)
  205. if (err .ne. 0)
  206. + call errore('nf_close: ', err)
  207. call print_nok(nok)
  208. end
  209. #ifdef NF_INT1_T
  210. C
  211. C check all vars in file which are (text/numeric) compatible with TYPE
  212. C
  213. subroutine check_vars_int1(filename)
  214. implicit none
  215. #include "tests.inc"
  216. character*(*) filename
  217. integer ncid !/* netCDF id */
  218. integer index(MAX_RANK)
  219. integer err !/* status */
  220. integer d
  221. integer i
  222. integer j
  223. NF_INT1_T value
  224. integer datatype
  225. integer ndims
  226. integer dimids(MAX_RANK)
  227. integer ngatts
  228. doubleprecision expect
  229. character*(NF_MAX_NAME) name
  230. integer length
  231. logical canConvert !/* Both text or both numeric */
  232. integer nok !/* count of valid comparisons */
  233. doubleprecision val
  234. nok = 0
  235. err = nf_open(filename, NF_NOWRITE, ncid)
  236. if (err .ne. 0)
  237. + call errore('nf_open: ', err)
  238. do 1, i = 1, NVARS
  239. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  240. + (NFT_INT1 .eq. NFT_TEXT)
  241. if (canConvert) then
  242. err = nf_inq_var(ncid, i, name, datatype, ndims, dimids,
  243. + ngatts)
  244. if (err .ne. 0)
  245. + call errore('nf_inq_var: ', err)
  246. if (name .ne. var_name(i))
  247. + call error('Unexpected var_name')
  248. if (datatype .ne. var_type(i))
  249. + call error('Unexpected type')
  250. if (ndims .ne. var_rank(i))
  251. + call error('Unexpected rank')
  252. do 2, j = 1, ndims
  253. err = nf_inq_dim(ncid, dimids(j), name, length)
  254. if (err .ne. 0)
  255. + call errore('nf_inq_dim: ', err)
  256. if (length .ne. var_shape(j,i))
  257. + call error('Unexpected shape')
  258. 2 continue
  259. do 3, j = 1, var_nels(i)
  260. err = index2indexes(j, var_rank(i), var_shape(1,i),
  261. + index)
  262. if (err .ne. 0)
  263. + call error('error in index2indexes()')
  264. expect = hash4( var_type(i), var_rank(i), index,
  265. + NFT_INT1)
  266. err = nf_get_var1_int1(ncid, i, index, value)
  267. if (inRange3(expect,datatype,NFT_INT1)) then
  268. if (in_internal_range(NFT_INT1,
  269. + expect)) then
  270. if (err .ne. 0) then
  271. call errore('nf_get_var1_int1: ', err)
  272. else
  273. val = value
  274. if (.not.equal(
  275. + val,
  276. + expect,var_type(i),
  277. + NFT_INT1)) then
  278. call error(
  279. + 'Var value read not that expected')
  280. if (verbose) then
  281. call error(' ')
  282. call errori('varid: %d', i)
  283. call errorc('var_name: ',
  284. + var_name(i))
  285. call error('index:')
  286. do 4, d = 1, var_rank(i)
  287. call errori(' ', index(d))
  288. 4 continue
  289. call errord('expect: ', expect)
  290. call errord('got: ', val)
  291. end if
  292. else
  293. nok = nok + 1
  294. end if
  295. end if
  296. end if
  297. end if
  298. 3 continue
  299. end if
  300. 1 continue
  301. err = nf_close (ncid)
  302. if (err .ne. 0)
  303. + call errore('nf_close: ', err)
  304. call print_nok(nok)
  305. end
  306. #endif
  307. #ifdef NF_INT2_T
  308. C
  309. C check all vars in file which are (text/numeric) compatible with TYPE
  310. C
  311. subroutine check_vars_int2(filename)
  312. implicit none
  313. #include "tests.inc"
  314. character*(*) filename
  315. integer ncid !/* netCDF id */
  316. integer index(MAX_RANK)
  317. integer err !/* status */
  318. integer d
  319. integer i
  320. integer j
  321. NF_INT2_T value
  322. integer datatype
  323. integer ndims
  324. integer dimids(MAX_RANK)
  325. integer ngatts
  326. doubleprecision expect
  327. character*(NF_MAX_NAME) name
  328. integer length
  329. logical canConvert !/* Both text or both numeric */
  330. integer nok !/* count of valid comparisons */
  331. doubleprecision val
  332. nok = 0
  333. err = nf_open(filename, NF_NOWRITE, ncid)
  334. if (err .ne. 0)
  335. + call errore('nf_open: ', err)
  336. do 1, i = 1, NVARS
  337. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  338. + (NFT_INT2 .eq. NFT_TEXT)
  339. if (canConvert) then
  340. err = nf_inq_var(ncid, i, name, datatype, ndims, dimids,
  341. + ngatts)
  342. if (err .ne. 0)
  343. + call errore('nf_inq_var: ', err)
  344. if (name .ne. var_name(i))
  345. + call error('Unexpected var_name')
  346. if (datatype .ne. var_type(i))
  347. + call error('Unexpected type')
  348. if (ndims .ne. var_rank(i))
  349. + call error('Unexpected rank')
  350. do 2, j = 1, ndims
  351. err = nf_inq_dim(ncid, dimids(j), name, length)
  352. if (err .ne. 0)
  353. + call errore('nf_inq_dim: ', err)
  354. if (length .ne. var_shape(j,i))
  355. + call error('Unexpected shape')
  356. 2 continue
  357. do 3, j = 1, var_nels(i)
  358. err = index2indexes(j, var_rank(i), var_shape(1,i),
  359. + index)
  360. if (err .ne. 0)
  361. + call error('error in index2indexes()')
  362. expect = hash4( var_type(i), var_rank(i), index,
  363. + NFT_INT2)
  364. err = nf_get_var1_int2(ncid, i, index, value)
  365. if (inRange3(expect,datatype,NFT_INT2)) then
  366. if (in_internal_range(NFT_INT2,
  367. + expect)) then
  368. if (err .ne. 0) then
  369. call errore('nf_get_var1_int2: ', err)
  370. else
  371. val = value
  372. if (.not.equal(
  373. + val,
  374. + expect,var_type(i),
  375. + NFT_INT2)) then
  376. call error(
  377. + 'Var value read not that expected')
  378. if (verbose) then
  379. call error(' ')
  380. call errori('varid: %d', i)
  381. call errorc('var_name: ',
  382. + var_name(i))
  383. call error('index:')
  384. do 4, d = 1, var_rank(i)
  385. call errori(' ', index(d))
  386. 4 continue
  387. call errord('expect: ', expect)
  388. call errord('got: ', val)
  389. end if
  390. else
  391. nok = nok + 1
  392. end if
  393. end if
  394. end if
  395. end if
  396. 3 continue
  397. end if
  398. 1 continue
  399. err = nf_close (ncid)
  400. if (err .ne. 0)
  401. + call errore('nf_close: ', err)
  402. call print_nok(nok)
  403. end
  404. #endif
  405. C
  406. C check all vars in file which are (text/numeric) compatible with TYPE
  407. C
  408. subroutine check_vars_int(filename)
  409. implicit none
  410. #include "tests.inc"
  411. character*(*) filename
  412. integer ncid !/* netCDF id */
  413. integer index(MAX_RANK)
  414. integer err !/* status */
  415. integer d
  416. integer i
  417. integer j
  418. integer value
  419. integer datatype
  420. integer ndims
  421. integer dimids(MAX_RANK)
  422. integer ngatts
  423. doubleprecision expect
  424. character*(NF_MAX_NAME) name
  425. integer length
  426. logical canConvert !/* Both text or both numeric */
  427. integer nok !/* count of valid comparisons */
  428. doubleprecision val
  429. nok = 0
  430. err = nf_open(filename, NF_NOWRITE, ncid)
  431. if (err .ne. 0)
  432. + call errore('nf_open: ', err)
  433. do 1, i = 1, NVARS
  434. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  435. + (NFT_INT .eq. NFT_TEXT)
  436. if (canConvert) then
  437. err = nf_inq_var(ncid, i, name, datatype, ndims, dimids,
  438. + ngatts)
  439. if (err .ne. 0)
  440. + call errore('nf_inq_var: ', err)
  441. if (name .ne. var_name(i))
  442. + call error('Unexpected var_name')
  443. if (datatype .ne. var_type(i))
  444. + call error('Unexpected type')
  445. if (ndims .ne. var_rank(i))
  446. + call error('Unexpected rank')
  447. do 2, j = 1, ndims
  448. err = nf_inq_dim(ncid, dimids(j), name, length)
  449. if (err .ne. 0)
  450. + call errore('nf_inq_dim: ', err)
  451. if (length .ne. var_shape(j,i))
  452. + call error('Unexpected shape')
  453. 2 continue
  454. do 3, j = 1, var_nels(i)
  455. err = index2indexes(j, var_rank(i), var_shape(1,i),
  456. + index)
  457. if (err .ne. 0)
  458. + call error('error in index2indexes()')
  459. expect = hash4( var_type(i), var_rank(i), index,
  460. + NFT_INT)
  461. err = nf_get_var1_int(ncid, i, index, value)
  462. if (inRange3(expect,datatype,NFT_INT)) then
  463. if (in_internal_range(NFT_INT,
  464. + expect)) then
  465. if (err .ne. 0) then
  466. call errore('nf_get_var1_int: ', err)
  467. else
  468. val = value
  469. if (.not.equal(
  470. + val,
  471. + expect,var_type(i),
  472. + NFT_INT)) then
  473. call error(
  474. + 'Var value read not that expected')
  475. if (verbose) then
  476. call error(' ')
  477. call errori('varid: %d', i)
  478. call errorc('var_name: ',
  479. + var_name(i))
  480. call error('index:')
  481. do 4, d = 1, var_rank(i)
  482. call errori(' ', index(d))
  483. 4 continue
  484. call errord('expect: ', expect)
  485. call errord('got: ', val)
  486. end if
  487. else
  488. nok = nok + 1
  489. end if
  490. end if
  491. end if
  492. end if
  493. 3 continue
  494. end if
  495. 1 continue
  496. err = nf_close (ncid)
  497. if (err .ne. 0)
  498. + call errore('nf_close: ', err)
  499. call print_nok(nok)
  500. end
  501. C
  502. C check all vars in file which are (text/numeric) compatible with TYPE
  503. C
  504. subroutine check_vars_real(filename)
  505. implicit none
  506. #include "tests.inc"
  507. character*(*) filename
  508. integer ncid !/* netCDF id */
  509. integer index(MAX_RANK)
  510. integer err !/* status */
  511. integer d
  512. integer i
  513. integer j
  514. real value
  515. integer datatype
  516. integer ndims
  517. integer dimids(MAX_RANK)
  518. integer ngatts
  519. doubleprecision expect
  520. character*(NF_MAX_NAME) name
  521. integer length
  522. logical canConvert !/* Both text or both numeric */
  523. integer nok !/* count of valid comparisons */
  524. doubleprecision val
  525. nok = 0
  526. err = nf_open(filename, NF_NOWRITE, ncid)
  527. if (err .ne. 0)
  528. + call errore('nf_open: ', err)
  529. do 1, i = 1, NVARS
  530. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  531. + (NFT_REAL .eq. NFT_TEXT)
  532. if (canConvert) then
  533. err = nf_inq_var(ncid, i, name, datatype, ndims, dimids,
  534. + ngatts)
  535. if (err .ne. 0)
  536. + call errore('nf_inq_var: ', err)
  537. if (name .ne. var_name(i))
  538. + call error('Unexpected var_name')
  539. if (datatype .ne. var_type(i))
  540. + call error('Unexpected type')
  541. if (ndims .ne. var_rank(i))
  542. + call error('Unexpected rank')
  543. do 2, j = 1, ndims
  544. err = nf_inq_dim(ncid, dimids(j), name, length)
  545. if (err .ne. 0)
  546. + call errore('nf_inq_dim: ', err)
  547. if (length .ne. var_shape(j,i))
  548. + call error('Unexpected shape')
  549. 2 continue
  550. do 3, j = 1, var_nels(i)
  551. err = index2indexes(j, var_rank(i), var_shape(1,i),
  552. + index)
  553. if (err .ne. 0)
  554. + call error('error in index2indexes()')
  555. expect = hash4( var_type(i), var_rank(i), index,
  556. + NFT_REAL)
  557. err = nf_get_var1_real(ncid, i, index, value)
  558. if (inRange3(expect,datatype,NFT_REAL)) then
  559. if (in_internal_range(NFT_REAL,
  560. + expect)) then
  561. if (err .ne. 0) then
  562. call errore('nf_get_var1_real: ', err)
  563. else
  564. val = value
  565. if (.not.equal(
  566. + val,
  567. + expect,var_type(i),
  568. + NFT_REAL)) then
  569. call error(
  570. + 'Var value read not that expected')
  571. if (verbose) then
  572. call error(' ')
  573. call errori('varid: %d', i)
  574. call errorc('var_name: ',
  575. + var_name(i))
  576. call error('index:')
  577. do 4, d = 1, var_rank(i)
  578. call errori(' ', index(d))
  579. 4 continue
  580. call errord('expect: ', expect)
  581. call errord('got: ', val)
  582. end if
  583. else
  584. nok = nok + 1
  585. end if
  586. end if
  587. end if
  588. end if
  589. 3 continue
  590. end if
  591. 1 continue
  592. err = nf_close (ncid)
  593. if (err .ne. 0)
  594. + call errore('nf_close: ', err)
  595. call print_nok(nok)
  596. end
  597. C
  598. C check all vars in file which are (text/numeric) compatible with TYPE
  599. C
  600. subroutine check_vars_double(filename)
  601. implicit none
  602. #include "tests.inc"
  603. character*(*) filename
  604. integer ncid !/* netCDF id */
  605. integer index(MAX_RANK)
  606. integer err !/* status */
  607. integer d
  608. integer i
  609. integer j
  610. doubleprecision value
  611. integer datatype
  612. integer ndims
  613. integer dimids(MAX_RANK)
  614. integer ngatts
  615. doubleprecision expect
  616. character*(NF_MAX_NAME) name
  617. integer length
  618. logical canConvert !/* Both text or both numeric */
  619. integer nok !/* count of valid comparisons */
  620. doubleprecision val
  621. nok = 0
  622. err = nf_open(filename, NF_NOWRITE, ncid)
  623. if (err .ne. 0)
  624. + call errore('nf_open: ', err)
  625. do 1, i = 1, NVARS
  626. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  627. + (NFT_DOUBLE .eq. NFT_TEXT)
  628. if (canConvert) then
  629. err = nf_inq_var(ncid, i, name, datatype, ndims, dimids,
  630. + ngatts)
  631. if (err .ne. 0)
  632. + call errore('nf_inq_var: ', err)
  633. if (name .ne. var_name(i))
  634. + call error('Unexpected var_name')
  635. if (datatype .ne. var_type(i))
  636. + call error('Unexpected type')
  637. if (ndims .ne. var_rank(i))
  638. + call error('Unexpected rank')
  639. do 2, j = 1, ndims
  640. err = nf_inq_dim(ncid, dimids(j), name, length)
  641. if (err .ne. 0)
  642. + call errore('nf_inq_dim: ', err)
  643. if (length .ne. var_shape(j,i))
  644. + call error('Unexpected shape')
  645. 2 continue
  646. do 3, j = 1, var_nels(i)
  647. err = index2indexes(j, var_rank(i), var_shape(1,i),
  648. + index)
  649. if (err .ne. 0)
  650. + call error('error in index2indexes()')
  651. expect = hash4( var_type(i), var_rank(i), index,
  652. + NFT_DOUBLE)
  653. err = nf_get_var1_double(ncid, i, index, value)
  654. if (inRange3(expect,datatype,NFT_DOUBLE)) then
  655. if (in_internal_range(NFT_DOUBLE,
  656. + expect)) then
  657. if (err .ne. 0) then
  658. call errore('nf_get_var1_double: ', err)
  659. else
  660. val = value
  661. if (.not.equal(
  662. + val,
  663. + expect,var_type(i),
  664. + NFT_DOUBLE)) then
  665. call error(
  666. + 'Var value read not that expected')
  667. if (verbose) then
  668. call error(' ')
  669. call errori('varid: %d', i)
  670. call errorc('var_name: ',
  671. + var_name(i))
  672. call error('index:')
  673. do 4, d = 1, var_rank(i)
  674. call errori(' ', index(d))
  675. 4 continue
  676. call errord('expect: ', expect)
  677. call errord('got: ', val)
  678. end if
  679. else
  680. nok = nok + 1
  681. end if
  682. end if
  683. end if
  684. end if
  685. 3 continue
  686. end if
  687. 1 continue
  688. err = nf_close (ncid)
  689. if (err .ne. 0)
  690. + call errore('nf_close: ', err)
  691. call print_nok(nok)
  692. end
  693. C/*
  694. C * check all attributes in file which are (text/numeric) compatible with TYPE
  695. C * ignore any attributes containing values outside range of TYPE
  696. C */
  697. subroutine check_atts_text(ncid)
  698. implicit none
  699. #include "tests.inc"
  700. integer ncid
  701. integer err !/* status */
  702. integer i
  703. integer j
  704. integer k
  705. integer ndx(1)
  706. character value(MAX_NELS)
  707. integer datatype
  708. doubleprecision expect(MAX_NELS)
  709. integer length
  710. integer nInExtRange !/* number values within external range */
  711. integer nInIntRange !/* number values within internal range */
  712. logical canConvert !/* Both text or both numeric */
  713. integer nok !/* count of valid comparisons */
  714. doubleprecision val
  715. nok = 0
  716. do 1, i = 0, NVARS
  717. do 2, j = 1, NATTS(i)
  718. canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv.
  719. + (NFT_TEXT .eq. NFT_TEXT)
  720. if (canConvert) then
  721. err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype,
  722. + length)
  723. if (err .ne. 0)
  724. + call errore('nf_inq_att: ', err)
  725. if (datatype .ne. ATT_TYPE(j,i))
  726. + call error('nf_inq_att: unexpected type')
  727. if (length .ne. ATT_LEN(j,i))
  728. + call error('nf_inq_att: unexpected length')
  729. if (.not.(length .le. MAX_NELS))
  730. + stop 'assert(length .le. MAX_NELS)'
  731. nInIntRange = 0
  732. nInExtRange = 0
  733. do 4, k = 1, length
  734. ndx(1) = k
  735. expect(k) = hash4( datatype, -1, ndx,
  736. + NFT_TEXT)
  737. if (inRange3(expect(k), datatype,
  738. + NFT_TEXT)) then
  739. nInExtRange = nInExtRange + 1
  740. if (in_internal_range(NFT_TEXT,
  741. + expect(k)))
  742. + nInIntRange = nInIntRange + 1
  743. end if
  744. 4 continue
  745. err = nf_get_att_text(ncid, i,
  746. + ATT_NAME(j,i), value)
  747. if (nInExtRange .eq. length .and.
  748. + nInIntRange .eq. length) then
  749. if (err .ne. 0)
  750. + call error(nf_strerror(err))
  751. else
  752. if (err .ne. 0 .and. err .ne. NF_ERANGE)
  753. + call errore('OK or Range error: ', err)
  754. end if
  755. do 3, k = 1, length
  756. if (inRange3(expect(k),datatype,NFT_TEXT)
  757. + .and.
  758. + in_internal_range(NFT_TEXT,
  759. + expect(k))) then
  760. val = ichar(value(k))
  761. if (.not.equal(
  762. + val,
  763. + expect(k),datatype,
  764. + NFT_TEXT)) then
  765. call error(
  766. + 'att. value read not that expected')
  767. if (verbose) then
  768. call error(' ')
  769. call errori('varid: ', i)
  770. call errorc('att_name: ',
  771. + ATT_NAME(j,i))
  772. call errori('element number: ', k)
  773. call errord('expect: ', expect(k))
  774. call errord('got: ', val)
  775. end if
  776. else
  777. nok = nok + 1
  778. end if
  779. end if
  780. 3 continue
  781. end if
  782. 2 continue
  783. 1 continue
  784. call print_nok(nok)
  785. end
  786. #ifdef NF_INT1_T
  787. C/*
  788. C * check all attributes in file which are (text/numeric) compatible with TYPE
  789. C * ignore any attributes containing values outside range of TYPE
  790. C */
  791. subroutine check_atts_int1(ncid)
  792. implicit none
  793. #include "tests.inc"
  794. integer ncid
  795. integer err !/* status */
  796. integer i
  797. integer j
  798. integer k
  799. integer ndx(1)
  800. NF_INT1_T value(MAX_NELS)
  801. integer datatype
  802. doubleprecision expect(MAX_NELS)
  803. integer length
  804. integer nInExtRange !/* number values within external range */
  805. integer nInIntRange !/* number values within internal range */
  806. logical canConvert !/* Both text or both numeric */
  807. integer nok !/* count of valid comparisons */
  808. doubleprecision val
  809. nok = 0
  810. do 1, i = 0, NVARS
  811. do 2, j = 1, NATTS(i)
  812. canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv.
  813. + (NFT_INT1 .eq. NFT_TEXT)
  814. if (canConvert) then
  815. err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype,
  816. + length)
  817. if (err .ne. 0)
  818. + call errore('nf_inq_att: ', err)
  819. if (datatype .ne. ATT_TYPE(j,i))
  820. + call error('nf_inq_att: unexpected type')
  821. if (length .ne. ATT_LEN(j,i))
  822. + call error('nf_inq_att: unexpected length')
  823. if (.not.(length .le. MAX_NELS))
  824. + stop 'assert(length .le. MAX_NELS)'
  825. nInIntRange = 0
  826. nInExtRange = 0
  827. do 4, k = 1, length
  828. ndx(1) = k
  829. expect(k) = hash4( datatype, -1, ndx,
  830. + NFT_INT1)
  831. if (inRange3(expect(k), datatype,
  832. + NFT_INT1)) then
  833. nInExtRange = nInExtRange + 1
  834. if (in_internal_range(NFT_INT1,
  835. + expect(k)))
  836. + nInIntRange = nInIntRange + 1
  837. end if
  838. 4 continue
  839. err = nf_get_att_int1(ncid, i,
  840. + ATT_NAME(j,i), value)
  841. if (nInExtRange .eq. length .and.
  842. + nInIntRange .eq. length) then
  843. if (err .ne. 0)
  844. + call error(nf_strerror(err))
  845. else
  846. if (err .ne. 0 .and. err .ne. NF_ERANGE)
  847. + call errore('OK or Range error: ', err)
  848. end if
  849. do 3, k = 1, length
  850. if (inRange3(expect(k),datatype,NFT_INT1)
  851. + .and.
  852. + in_internal_range(NFT_INT1,
  853. + expect(k))) then
  854. val = value(k)
  855. if (.not.equal(
  856. + val,
  857. + expect(k),datatype,
  858. + NFT_INT1)) then
  859. call error(
  860. + 'att. value read not that expected')
  861. if (verbose) then
  862. call error(' ')
  863. call errori('varid: ', i)
  864. call errorc('att_name: ',
  865. + ATT_NAME(j,i))
  866. call errori('element number: ', k)
  867. call errord('expect: ', expect(k))
  868. call errord('got: ', val)
  869. end if
  870. else
  871. nok = nok + 1
  872. end if
  873. end if
  874. 3 continue
  875. end if
  876. 2 continue
  877. 1 continue
  878. call print_nok(nok)
  879. end
  880. #endif
  881. #ifdef NF_INT2_T
  882. C/*
  883. C * check all attributes in file which are (text/numeric) compatible with TYPE
  884. C * ignore any attributes containing values outside range of TYPE
  885. C */
  886. subroutine check_atts_int2(ncid)
  887. implicit none
  888. #include "tests.inc"
  889. integer ncid
  890. integer err !/* status */
  891. integer i
  892. integer j
  893. integer k
  894. integer ndx(1)
  895. NF_INT2_T value(MAX_NELS)
  896. integer datatype
  897. doubleprecision expect(MAX_NELS)
  898. integer length
  899. integer nInExtRange !/* number values within external range */
  900. integer nInIntRange !/* number values within internal range */
  901. logical canConvert !/* Both text or both numeric */
  902. integer nok !/* count of valid comparisons */
  903. doubleprecision val
  904. nok = 0
  905. do 1, i = 0, NVARS
  906. do 2, j = 1, NATTS(i)
  907. canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv.
  908. + (NFT_INT2 .eq. NFT_TEXT)
  909. if (canConvert) then
  910. err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype,
  911. + length)
  912. if (err .ne. 0)
  913. + call errore('nf_inq_att: ', err)
  914. if (datatype .ne. ATT_TYPE(j,i))
  915. + call error('nf_inq_att: unexpected type')
  916. if (length .ne. ATT_LEN(j,i))
  917. + call error('nf_inq_att: unexpected length')
  918. if (.not.(length .le. MAX_NELS))
  919. + stop 'assert(length .le. MAX_NELS)'
  920. nInIntRange = 0
  921. nInExtRange = 0
  922. do 4, k = 1, length
  923. ndx(1) = k
  924. expect(k) = hash4( datatype, -1, ndx,
  925. + NFT_INT2)
  926. if (inRange3(expect(k), datatype,
  927. + NFT_INT2)) then
  928. nInExtRange = nInExtRange + 1
  929. if (in_internal_range(NFT_INT2,
  930. + expect(k)))
  931. + nInIntRange = nInIntRange + 1
  932. end if
  933. 4 continue
  934. err = nf_get_att_int2(ncid, i,
  935. + ATT_NAME(j,i), value)
  936. if (nInExtRange .eq. length .and.
  937. + nInIntRange .eq. length) then
  938. if (err .ne. 0)
  939. + call error(nf_strerror(err))
  940. else
  941. if (err .ne. 0 .and. err .ne. NF_ERANGE)
  942. + call errore('OK or Range error: ', err)
  943. end if
  944. do 3, k = 1, length
  945. if (inRange3(expect(k),datatype,NFT_INT2)
  946. + .and.
  947. + in_internal_range(NFT_INT2,
  948. + expect(k))) then
  949. val = value(k)
  950. if (.not.equal(
  951. + val,
  952. + expect(k),datatype,
  953. + NFT_INT2)) then
  954. call error(
  955. + 'att. value read not that expected')
  956. if (verbose) then
  957. call error(' ')
  958. call errori('varid: ', i)
  959. call errorc('att_name: ',
  960. + ATT_NAME(j,i))
  961. call errori('element number: ', k)
  962. call errord('expect: ', expect(k))
  963. call errord('got: ', val)
  964. end if
  965. else
  966. nok = nok + 1
  967. end if
  968. end if
  969. 3 continue
  970. end if
  971. 2 continue
  972. 1 continue
  973. call print_nok(nok)
  974. end
  975. #endif
  976. C/*
  977. C * check all attributes in file which are (text/numeric) compatible with TYPE
  978. C * ignore any attributes containing values outside range of TYPE
  979. C */
  980. subroutine check_atts_int(ncid)
  981. implicit none
  982. #include "tests.inc"
  983. integer ncid
  984. integer err !/* status */
  985. integer i
  986. integer j
  987. integer k
  988. integer ndx(1)
  989. integer value(MAX_NELS)
  990. integer datatype
  991. doubleprecision expect(MAX_NELS)
  992. integer length
  993. integer nInExtRange !/* number values within external range */
  994. integer nInIntRange !/* number values within internal range */
  995. logical canConvert !/* Both text or both numeric */
  996. integer nok !/* count of valid comparisons */
  997. doubleprecision val
  998. nok = 0
  999. do 1, i = 0, NVARS
  1000. do 2, j = 1, NATTS(i)
  1001. canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv.
  1002. + (NFT_INT .eq. NFT_TEXT)
  1003. if (canConvert) then
  1004. err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype,
  1005. + length)
  1006. if (err .ne. 0)
  1007. + call errore('nf_inq_att: ', err)
  1008. if (datatype .ne. ATT_TYPE(j,i))
  1009. + call error('nf_inq_att: unexpected type')
  1010. if (length .ne. ATT_LEN(j,i))
  1011. + call error('nf_inq_att: unexpected length')
  1012. if (.not.(length .le. MAX_NELS))
  1013. + stop 'assert(length .le. MAX_NELS)'
  1014. nInIntRange = 0
  1015. nInExtRange = 0
  1016. do 4, k = 1, length
  1017. ndx(1) = k
  1018. expect(k) = hash4( datatype, -1, ndx,
  1019. + NFT_INT)
  1020. if (inRange3(expect(k), datatype,
  1021. + NFT_INT)) then
  1022. nInExtRange = nInExtRange + 1
  1023. if (in_internal_range(NFT_INT,
  1024. + expect(k)))
  1025. + nInIntRange = nInIntRange + 1
  1026. end if
  1027. 4 continue
  1028. err = nf_get_att_int(ncid, i,
  1029. + ATT_NAME(j,i), value)
  1030. if (nInExtRange .eq. length .and.
  1031. + nInIntRange .eq. length) then
  1032. if (err .ne. 0)
  1033. + call error(nf_strerror(err))
  1034. else
  1035. if (err .ne. 0 .and. err .ne. NF_ERANGE)
  1036. + call errore('OK or Range error: ', err)
  1037. end if
  1038. do 3, k = 1, length
  1039. if (inRange3(expect(k),datatype,NFT_INT)
  1040. + .and.
  1041. + in_internal_range(NFT_INT,
  1042. + expect(k))) then
  1043. val = value(k)
  1044. if (.not.equal(
  1045. + val,
  1046. + expect(k),datatype,
  1047. + NFT_INT)) then
  1048. call error(
  1049. + 'att. value read not that expected')
  1050. if (verbose) then
  1051. call error(' ')
  1052. call errori('varid: ', i)
  1053. call errorc('att_name: ',
  1054. + ATT_NAME(j,i))
  1055. call errori('element number: ', k)
  1056. call errord('expect: ', expect(k))
  1057. call errord('got: ', val)
  1058. end if
  1059. else
  1060. nok = nok + 1
  1061. end if
  1062. end if
  1063. 3 continue
  1064. end if
  1065. 2 continue
  1066. 1 continue
  1067. call print_nok(nok)
  1068. end
  1069. C/*
  1070. C * check all attributes in file which are (text/numeric) compatible with TYPE
  1071. C * ignore any attributes containing values outside range of TYPE
  1072. C */
  1073. subroutine check_atts_real(ncid)
  1074. implicit none
  1075. #include "tests.inc"
  1076. integer ncid
  1077. integer err !/* status */
  1078. integer i
  1079. integer j
  1080. integer k
  1081. integer ndx(1)
  1082. real value(MAX_NELS)
  1083. integer datatype
  1084. doubleprecision expect(MAX_NELS)
  1085. integer length
  1086. integer nInExtRange !/* number values within external range */
  1087. integer nInIntRange !/* number values within internal range */
  1088. logical canConvert !/* Both text or both numeric */
  1089. integer nok !/* count of valid comparisons */
  1090. doubleprecision val
  1091. nok = 0
  1092. do 1, i = 0, NVARS
  1093. do 2, j = 1, NATTS(i)
  1094. canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv.
  1095. + (NFT_REAL .eq. NFT_TEXT)
  1096. if (canConvert) then
  1097. err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype,
  1098. + length)
  1099. if (err .ne. 0)
  1100. + call errore('nf_inq_att: ', err)
  1101. if (datatype .ne. ATT_TYPE(j,i))
  1102. + call error('nf_inq_att: unexpected type')
  1103. if (length .ne. ATT_LEN(j,i))
  1104. + call error('nf_inq_att: unexpected length')
  1105. if (.not.(length .le. MAX_NELS))
  1106. + stop 'assert(length .le. MAX_NELS)'
  1107. nInIntRange = 0
  1108. nInExtRange = 0
  1109. do 4, k = 1, length
  1110. ndx(1) = k
  1111. expect(k) = hash4( datatype, -1, ndx,
  1112. + NFT_REAL)
  1113. if (inRange3(expect(k), datatype,
  1114. + NFT_REAL)) then
  1115. nInExtRange = nInExtRange + 1
  1116. if (in_internal_range(NFT_REAL,
  1117. + expect(k)))
  1118. + nInIntRange = nInIntRange + 1
  1119. end if
  1120. 4 continue
  1121. err = nf_get_att_real(ncid, i,
  1122. + ATT_NAME(j,i), value)
  1123. if (nInExtRange .eq. length .and.
  1124. + nInIntRange .eq. length) then
  1125. if (err .ne. 0)
  1126. + call error(nf_strerror(err))
  1127. else
  1128. if (err .ne. 0 .and. err .ne. NF_ERANGE)
  1129. + call errore('OK or Range error: ', err)
  1130. end if
  1131. do 3, k = 1, length
  1132. if (inRange3(expect(k),datatype,NFT_REAL)
  1133. + .and.
  1134. + in_internal_range(NFT_REAL,
  1135. + expect(k))) then
  1136. val = value(k)
  1137. if (.not.equal(
  1138. + val,
  1139. + expect(k),datatype,
  1140. + NFT_REAL)) then
  1141. call error(
  1142. + 'att. value read not that expected')
  1143. if (verbose) then
  1144. call error(' ')
  1145. call errori('varid: ', i)
  1146. call errorc('att_name: ',
  1147. + ATT_NAME(j,i))
  1148. call errori('element number: ', k)
  1149. call errord('expect: ', expect(k))
  1150. call errord('got: ', val)
  1151. end if
  1152. else
  1153. nok = nok + 1
  1154. end if
  1155. end if
  1156. 3 continue
  1157. end if
  1158. 2 continue
  1159. 1 continue
  1160. call print_nok(nok)
  1161. end
  1162. C/*
  1163. C * check all attributes in file which are (text/numeric) compatible with TYPE
  1164. C * ignore any attributes containing values outside range of TYPE
  1165. C */
  1166. subroutine check_atts_double(ncid)
  1167. implicit none
  1168. #include "tests.inc"
  1169. integer ncid
  1170. integer err !/* status */
  1171. integer i
  1172. integer j
  1173. integer k
  1174. integer ndx(1)
  1175. doubleprecision value(MAX_NELS)
  1176. integer datatype
  1177. doubleprecision expect(MAX_NELS)
  1178. integer length
  1179. integer nInExtRange !/* number values within external range */
  1180. integer nInIntRange !/* number values within internal range */
  1181. logical canConvert !/* Both text or both numeric */
  1182. integer nok !/* count of valid comparisons */
  1183. doubleprecision val
  1184. nok = 0
  1185. do 1, i = 0, NVARS
  1186. do 2, j = 1, NATTS(i)
  1187. canConvert = (ATT_TYPE(j,i) .eq. NF_CHAR) .eqv.
  1188. + (NFT_DOUBLE .eq. NFT_TEXT)
  1189. if (canConvert) then
  1190. err = nf_inq_att(ncid, i, ATT_NAME(j,i), datatype,
  1191. + length)
  1192. if (err .ne. 0)
  1193. + call errore('nf_inq_att: ', err)
  1194. if (datatype .ne. ATT_TYPE(j,i))
  1195. + call error('nf_inq_att: unexpected type')
  1196. if (length .ne. ATT_LEN(j,i))
  1197. + call error('nf_inq_att: unexpected length')
  1198. if (.not.(length .le. MAX_NELS))
  1199. + stop 'assert(length .le. MAX_NELS)'
  1200. nInIntRange = 0
  1201. nInExtRange = 0
  1202. do 4, k = 1, length
  1203. ndx(1) = k
  1204. expect(k) = hash4( datatype, -1, ndx,
  1205. + NFT_DOUBLE)
  1206. if (inRange3(expect(k), datatype,
  1207. + NFT_DOUBLE)) then
  1208. nInExtRange = nInExtRange + 1
  1209. if (in_internal_range(NFT_DOUBLE,
  1210. + expect(k)))
  1211. + nInIntRange = nInIntRange + 1
  1212. end if
  1213. 4 continue
  1214. err = nf_get_att_double(ncid, i,
  1215. + ATT_NAME(j,i), value)
  1216. if (nInExtRange .eq. length .and.
  1217. + nInIntRange .eq. length) then
  1218. if (err .ne. 0)
  1219. + call error(nf_strerror(err))
  1220. else
  1221. if (err .ne. 0 .and. err .ne. NF_ERANGE)
  1222. + call errore('OK or Range error: ', err)
  1223. end if
  1224. do 3, k = 1, length
  1225. if (inRange3(expect(k),datatype,NFT_DOUBLE)
  1226. + .and.
  1227. + in_internal_range(NFT_DOUBLE,
  1228. + expect(k))) then
  1229. val = value(k)
  1230. if (.not.equal(
  1231. + val,
  1232. + expect(k),datatype,
  1233. + NFT_DOUBLE)) then
  1234. call error(
  1235. + 'att. value read not that expected')
  1236. if (verbose) then
  1237. call error(' ')
  1238. call errori('varid: ', i)
  1239. call errorc('att_name: ',
  1240. + ATT_NAME(j,i))
  1241. call errori('element number: ', k)
  1242. call errord('expect: ', expect(k))
  1243. call errord('got: ', val)
  1244. end if
  1245. else
  1246. nok = nok + 1
  1247. end if
  1248. end if
  1249. 3 continue
  1250. end if
  1251. 2 continue
  1252. 1 continue
  1253. call print_nok(nok)
  1254. end
  1255. subroutine test_nf_put_var1_text()
  1256. implicit none
  1257. #include "tests.inc"
  1258. integer ncid
  1259. integer i
  1260. integer j
  1261. integer err
  1262. integer index(MAX_RANK)
  1263. logical canConvert !/* Both text or both numeric */
  1264. character value
  1265. doubleprecision val
  1266. value = char(int(5))!/* any value would do - only for error cases */
  1267. err = nf_create(scratch, NF_CLOBBER, ncid)
  1268. if (err .ne. 0) then
  1269. call errore('nf_create: ', err)
  1270. return
  1271. end if
  1272. call def_dims(ncid)
  1273. call def_vars(ncid)
  1274. err = nf_enddef(ncid)
  1275. if (err .ne. 0)
  1276. + call errore('nf_enddef: ', err)
  1277. do 1, i = 1, NVARS
  1278. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  1279. + (NFT_TEXT .eq. NFT_TEXT)
  1280. do 2, j = 1, var_rank(i)
  1281. index(j) = 1
  1282. 2 continue
  1283. err = nf_put_var1_text(BAD_ID, i, index, value)
  1284. if (err .ne. NF_EBADID)
  1285. + call errore('bad ncid: ', err)
  1286. err = nf_put_var1_text(ncid, BAD_VARID,
  1287. + index, value)
  1288. if (err .ne. NF_ENOTVAR)
  1289. + call errore('bad var id: ', err)
  1290. do 3, j = 1, var_rank(i)
  1291. if (var_dimid(j,i) .gt. 1) then !/* skip record dim */
  1292. index(j) = var_shape(j,i) + 1
  1293. err = nf_put_var1_text(ncid, i,
  1294. + index, value)
  1295. if (.not. canConvert) then
  1296. if (err .ne. NF_ECHAR)
  1297. + call errore('conversion: ', err)
  1298. else
  1299. if (err .ne. NF_EINVALCOORDS)
  1300. + call errore('bad index: ', err)
  1301. endif
  1302. index(j) = 0
  1303. end if
  1304. 3 continue
  1305. do 4, j = 1, var_nels(i)
  1306. err = index2indexes(j, var_rank(i), var_shape(1,i),
  1307. + index)
  1308. if (err .ne. 0)
  1309. + call error('error in index2indexes 1')
  1310. value = char(int(hash_text(var_type(i),var_rank(i),
  1311. + index, NFT_TEXT)))
  1312. err = nf_put_var1_text(ncid, i, index, value)
  1313. if (canConvert) then
  1314. val = ichar(value)
  1315. if (inRange3(val, var_type(i), NFT_TEXT)) then
  1316. if (err .ne. 0)
  1317. + call error(nf_strerror(err))
  1318. else
  1319. if (err .ne. NF_ERANGE)
  1320. + call errore('Range error: ', err)
  1321. end if
  1322. else
  1323. if (err .ne. NF_ECHAR)
  1324. + call errore('wrong type: ', err)
  1325. end if
  1326. 4 continue
  1327. 1 continue
  1328. err = nf_close(ncid)
  1329. if (err .ne. 0)
  1330. + call errore('nf_close: ', err)
  1331. call check_vars_text(scratch)
  1332. err = nf_delete(scratch)
  1333. if (err .ne. 0)
  1334. + call errorc('delete of scratch file failed: ',
  1335. + scratch)
  1336. end
  1337. #ifdef NF_INT1_T
  1338. subroutine test_nf_put_var1_int1()
  1339. implicit none
  1340. #include "tests.inc"
  1341. integer ncid
  1342. integer i
  1343. integer j
  1344. integer err
  1345. integer index(MAX_RANK)
  1346. logical canConvert !/* Both text or both numeric */
  1347. NF_INT1_T value
  1348. doubleprecision val
  1349. value = 5!/* any value would do - only for error cases */
  1350. err = nf_create(scratch, NF_CLOBBER, ncid)
  1351. if (err .ne. 0) then
  1352. call errore('nf_create: ', err)
  1353. return
  1354. end if
  1355. call def_dims(ncid)
  1356. call def_vars(ncid)
  1357. err = nf_enddef(ncid)
  1358. if (err .ne. 0)
  1359. + call errore('nf_enddef: ', err)
  1360. do 1, i = 1, NVARS
  1361. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  1362. + (NFT_INT1 .eq. NFT_TEXT)
  1363. do 2, j = 1, var_rank(i)
  1364. index(j) = 1
  1365. 2 continue
  1366. err = nf_put_var1_int1(BAD_ID, i, index, value)
  1367. if (err .ne. NF_EBADID)
  1368. + call errore('bad ncid: ', err)
  1369. err = nf_put_var1_int1(ncid, BAD_VARID,
  1370. + index, value)
  1371. if (err .ne. NF_ENOTVAR)
  1372. + call errore('bad var id: ', err)
  1373. do 3, j = 1, var_rank(i)
  1374. if (var_dimid(j,i) .gt. 1) then !/* skip record dim */
  1375. index(j) = var_shape(j,i) + 1
  1376. err = nf_put_var1_int1(ncid, i,
  1377. + index, value)
  1378. if (.not. canConvert) then
  1379. if (err .ne. NF_ECHAR)
  1380. + call errore('conversion: ', err)
  1381. else
  1382. if (err .ne. NF_EINVALCOORDS)
  1383. + call errore('bad index: ', err)
  1384. endif
  1385. index(j) = 0
  1386. end if
  1387. 3 continue
  1388. do 4, j = 1, var_nels(i)
  1389. err = index2indexes(j, var_rank(i), var_shape(1,i),
  1390. + index)
  1391. if (err .ne. 0)
  1392. + call error('error in index2indexes 1')
  1393. value = hash_int1(var_type(i),var_rank(i),
  1394. + index, NFT_INT1)
  1395. err = nf_put_var1_int1(ncid, i, index, value)
  1396. if (canConvert) then
  1397. val = value
  1398. if (inRange3(val, var_type(i), NFT_INT1)) then
  1399. if (err .ne. 0)
  1400. + call error(nf_strerror(err))
  1401. else
  1402. if (err .ne. NF_ERANGE)
  1403. + call errore('Range error: ', err)
  1404. end if
  1405. else
  1406. if (err .ne. NF_ECHAR)
  1407. + call errore('wrong type: ', err)
  1408. end if
  1409. 4 continue
  1410. 1 continue
  1411. err = nf_close(ncid)
  1412. if (err .ne. 0)
  1413. + call errore('nf_close: ', err)
  1414. call check_vars_int1(scratch)
  1415. err = nf_delete(scratch)
  1416. if (err .ne. 0)
  1417. + call errorc('delete of scratch file failed: ',
  1418. + scratch)
  1419. end
  1420. #endif
  1421. #ifdef NF_INT2_T
  1422. subroutine test_nf_put_var1_int2()
  1423. implicit none
  1424. #include "tests.inc"
  1425. integer ncid
  1426. integer i
  1427. integer j
  1428. integer err
  1429. integer index(MAX_RANK)
  1430. logical canConvert !/* Both text or both numeric */
  1431. NF_INT2_T value
  1432. doubleprecision val
  1433. value = 5!/* any value would do - only for error cases */
  1434. err = nf_create(scratch, NF_CLOBBER, ncid)
  1435. if (err .ne. 0) then
  1436. call errore('nf_create: ', err)
  1437. return
  1438. end if
  1439. call def_dims(ncid)
  1440. call def_vars(ncid)
  1441. err = nf_enddef(ncid)
  1442. if (err .ne. 0)
  1443. + call errore('nf_enddef: ', err)
  1444. do 1, i = 1, NVARS
  1445. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  1446. + (NFT_INT2 .eq. NFT_TEXT)
  1447. do 2, j = 1, var_rank(i)
  1448. index(j) = 1
  1449. 2 continue
  1450. err = nf_put_var1_int2(BAD_ID, i, index, value)
  1451. if (err .ne. NF_EBADID)
  1452. + call errore('bad ncid: ', err)
  1453. err = nf_put_var1_int2(ncid, BAD_VARID,
  1454. + index, value)
  1455. if (err .ne. NF_ENOTVAR)
  1456. + call errore('bad var id: ', err)
  1457. do 3, j = 1, var_rank(i)
  1458. if (var_dimid(j,i) .gt. 1) then !/* skip record dim */
  1459. index(j) = var_shape(j,i) + 1
  1460. err = nf_put_var1_int2(ncid, i,
  1461. + index, value)
  1462. if (.not. canConvert) then
  1463. if (err .ne. NF_ECHAR)
  1464. + call errore('conversion: ', err)
  1465. else
  1466. if (err .ne. NF_EINVALCOORDS)
  1467. + call errore('bad index: ', err)
  1468. endif
  1469. index(j) = 0
  1470. end if
  1471. 3 continue
  1472. do 4, j = 1, var_nels(i)
  1473. err = index2indexes(j, var_rank(i), var_shape(1,i),
  1474. + index)
  1475. if (err .ne. 0)
  1476. + call error('error in index2indexes 1')
  1477. value = hash_int2(var_type(i),var_rank(i),
  1478. + index, NFT_INT2)
  1479. err = nf_put_var1_int2(ncid, i, index, value)
  1480. if (canConvert) then
  1481. val = value
  1482. if (inRange3(val, var_type(i), NFT_INT2)) then
  1483. if (err .ne. 0)
  1484. + call error(nf_strerror(err))
  1485. else
  1486. if (err .ne. NF_ERANGE)
  1487. + call errore('Range error: ', err)
  1488. end if
  1489. else
  1490. if (err .ne. NF_ECHAR)
  1491. + call errore('wrong type: ', err)
  1492. end if
  1493. 4 continue
  1494. 1 continue
  1495. err = nf_close(ncid)
  1496. if (err .ne. 0)
  1497. + call errore('nf_close: ', err)
  1498. call check_vars_int2(scratch)
  1499. err = nf_delete(scratch)
  1500. if (err .ne. 0)
  1501. + call errorc('delete of scratch file failed: ',
  1502. + scratch)
  1503. end
  1504. #endif
  1505. subroutine test_nf_put_var1_int()
  1506. implicit none
  1507. #include "tests.inc"
  1508. integer ncid
  1509. integer i
  1510. integer j
  1511. integer err
  1512. integer index(MAX_RANK)
  1513. logical canConvert !/* Both text or both numeric */
  1514. integer value
  1515. doubleprecision val
  1516. value = 5!/* any value would do - only for error cases */
  1517. err = nf_create(scratch, NF_CLOBBER, ncid)
  1518. if (err .ne. 0) then
  1519. call errore('nf_create: ', err)
  1520. return
  1521. end if
  1522. call def_dims(ncid)
  1523. call def_vars(ncid)
  1524. err = nf_enddef(ncid)
  1525. if (err .ne. 0)
  1526. + call errore('nf_enddef: ', err)
  1527. do 1, i = 1, NVARS
  1528. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  1529. + (NFT_INT .eq. NFT_TEXT)
  1530. do 2, j = 1, var_rank(i)
  1531. index(j) = 1
  1532. 2 continue
  1533. err = nf_put_var1_int(BAD_ID, i, index, value)
  1534. if (err .ne. NF_EBADID)
  1535. + call errore('bad ncid: ', err)
  1536. err = nf_put_var1_int(ncid, BAD_VARID,
  1537. + index, value)
  1538. if (err .ne. NF_ENOTVAR)
  1539. + call errore('bad var id: ', err)
  1540. do 3, j = 1, var_rank(i)
  1541. if (var_dimid(j,i) .gt. 1) then !/* skip record dim */
  1542. index(j) = var_shape(j,i) + 1
  1543. err = nf_put_var1_int(ncid, i,
  1544. + index, value)
  1545. if (.not. canConvert) then
  1546. if (err .ne. NF_ECHAR)
  1547. + call errore('conversion: ', err)
  1548. else
  1549. if (err .ne. NF_EINVALCOORDS)
  1550. + call errore('bad index: ', err)
  1551. endif
  1552. index(j) = 0
  1553. end if
  1554. 3 continue
  1555. do 4, j = 1, var_nels(i)
  1556. err = index2indexes(j, var_rank(i), var_shape(1,i),
  1557. + index)
  1558. if (err .ne. 0)
  1559. + call error('error in index2indexes 1')
  1560. value = hash_int(var_type(i),var_rank(i),
  1561. + index, NFT_INT)
  1562. err = nf_put_var1_int(ncid, i, index, value)
  1563. if (canConvert) then
  1564. val = value
  1565. if (inRange3(val, var_type(i), NFT_INT)) then
  1566. if (err .ne. 0)
  1567. + call error(nf_strerror(err))
  1568. else
  1569. if (err .ne. NF_ERANGE)
  1570. + call errore('Range error: ', err)
  1571. end if
  1572. else
  1573. if (err .ne. NF_ECHAR)
  1574. + call errore('wrong type: ', err)
  1575. end if
  1576. 4 continue
  1577. 1 continue
  1578. err = nf_close(ncid)
  1579. if (err .ne. 0)
  1580. + call errore('nf_close: ', err)
  1581. call check_vars_int(scratch)
  1582. err = nf_delete(scratch)
  1583. if (err .ne. 0)
  1584. + call errorc('delete of scratch file failed: ',
  1585. + scratch)
  1586. end
  1587. subroutine test_nf_put_var1_real()
  1588. implicit none
  1589. #include "tests.inc"
  1590. integer ncid
  1591. integer i
  1592. integer j
  1593. integer err
  1594. integer index(MAX_RANK)
  1595. logical canConvert !/* Both text or both numeric */
  1596. real value
  1597. doubleprecision val
  1598. value = 5!/* any value would do - only for error cases */
  1599. err = nf_create(scratch, NF_CLOBBER, ncid)
  1600. if (err .ne. 0) then
  1601. call errore('nf_create: ', err)
  1602. return
  1603. end if
  1604. call def_dims(ncid)
  1605. call def_vars(ncid)
  1606. err = nf_enddef(ncid)
  1607. if (err .ne. 0)
  1608. + call errore('nf_enddef: ', err)
  1609. do 1, i = 1, NVARS
  1610. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  1611. + (NFT_REAL .eq. NFT_TEXT)
  1612. do 2, j = 1, var_rank(i)
  1613. index(j) = 1
  1614. 2 continue
  1615. err = nf_put_var1_real(BAD_ID, i, index, value)
  1616. if (err .ne. NF_EBADID)
  1617. + call errore('bad ncid: ', err)
  1618. err = nf_put_var1_real(ncid, BAD_VARID,
  1619. + index, value)
  1620. if (err .ne. NF_ENOTVAR)
  1621. + call errore('bad var id: ', err)
  1622. do 3, j = 1, var_rank(i)
  1623. if (var_dimid(j,i) .gt. 1) then !/* skip record dim */
  1624. index(j) = var_shape(j,i) + 1
  1625. err = nf_put_var1_real(ncid, i,
  1626. + index, value)
  1627. if (.not. canConvert) then
  1628. if (err .ne. NF_ECHAR)
  1629. + call errore('conversion: ', err)
  1630. else
  1631. if (err .ne. NF_EINVALCOORDS)
  1632. + call errore('bad index: ', err)
  1633. endif
  1634. index(j) = 0
  1635. end if
  1636. 3 continue
  1637. do 4, j = 1, var_nels(i)
  1638. err = index2indexes(j, var_rank(i), var_shape(1,i),
  1639. + index)
  1640. if (err .ne. 0)
  1641. + call error('error in index2indexes 1')
  1642. value = hash_real(var_type(i),var_rank(i),
  1643. + index, NFT_REAL)
  1644. err = nf_put_var1_real(ncid, i, index, value)
  1645. if (canConvert) then
  1646. val = value
  1647. if (inRange3(val, var_type(i), NFT_REAL)) then
  1648. if (err .ne. 0)
  1649. + call error(nf_strerror(err))
  1650. else
  1651. if (err .ne. NF_ERANGE)
  1652. + call errore('Range error: ', err)
  1653. end if
  1654. else
  1655. if (err .ne. NF_ECHAR)
  1656. + call errore('wrong type: ', err)
  1657. end if
  1658. 4 continue
  1659. 1 continue
  1660. err = nf_close(ncid)
  1661. if (err .ne. 0)
  1662. + call errore('nf_close: ', err)
  1663. call check_vars_real(scratch)
  1664. err = nf_delete(scratch)
  1665. if (err .ne. 0)
  1666. + call errorc('delete of scratch file failed: ',
  1667. + scratch)
  1668. end
  1669. subroutine test_nf_put_var1_double()
  1670. implicit none
  1671. #include "tests.inc"
  1672. integer ncid
  1673. integer i
  1674. integer j
  1675. integer err
  1676. integer index(MAX_RANK)
  1677. logical canConvert !/* Both text or both numeric */
  1678. doubleprecision value
  1679. doubleprecision val
  1680. value = 5!/* any value would do - only for error cases */
  1681. err = nf_create(scratch, NF_CLOBBER, ncid)
  1682. if (err .ne. 0) then
  1683. call errore('nf_create: ', err)
  1684. return
  1685. end if
  1686. call def_dims(ncid)
  1687. call def_vars(ncid)
  1688. err = nf_enddef(ncid)
  1689. if (err .ne. 0)
  1690. + call errore('nf_enddef: ', err)
  1691. do 1, i = 1, NVARS
  1692. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  1693. + (NFT_DOUBLE .eq. NFT_TEXT)
  1694. do 2, j = 1, var_rank(i)
  1695. index(j) = 1
  1696. 2 continue
  1697. err = nf_put_var1_double(BAD_ID, i, index, value)
  1698. if (err .ne. NF_EBADID)
  1699. + call errore('bad ncid: ', err)
  1700. err = nf_put_var1_double(ncid, BAD_VARID,
  1701. + index, value)
  1702. if (err .ne. NF_ENOTVAR)
  1703. + call errore('bad var id: ', err)
  1704. do 3, j = 1, var_rank(i)
  1705. if (var_dimid(j,i) .gt. 1) then !/* skip record dim */
  1706. index(j) = var_shape(j,i) + 1
  1707. err = nf_put_var1_double(ncid, i,
  1708. + index, value)
  1709. if (.not. canConvert) then
  1710. if (err .ne. NF_ECHAR)
  1711. + call errore('conversion: ', err)
  1712. else
  1713. if (err .ne. NF_EINVALCOORDS)
  1714. + call errore('bad index: ', err)
  1715. endif
  1716. index(j) = 0
  1717. end if
  1718. 3 continue
  1719. do 4, j = 1, var_nels(i)
  1720. err = index2indexes(j, var_rank(i), var_shape(1,i),
  1721. + index)
  1722. if (err .ne. 0)
  1723. + call error('error in index2indexes 1')
  1724. value = hash_double(var_type(i),var_rank(i),
  1725. + index, NFT_DOUBLE)
  1726. err = nf_put_var1_double(ncid, i, index, value)
  1727. if (canConvert) then
  1728. val = value
  1729. if (inRange3(val, var_type(i), NFT_DOUBLE)) then
  1730. if (err .ne. 0)
  1731. + call error(nf_strerror(err))
  1732. else
  1733. if (err .ne. NF_ERANGE)
  1734. + call errore('Range error: ', err)
  1735. end if
  1736. else
  1737. if (err .ne. NF_ECHAR)
  1738. + call errore('wrong type: ', err)
  1739. end if
  1740. 4 continue
  1741. 1 continue
  1742. err = nf_close(ncid)
  1743. if (err .ne. 0)
  1744. + call errore('nf_close: ', err)
  1745. call check_vars_double(scratch)
  1746. err = nf_delete(scratch)
  1747. if (err .ne. 0)
  1748. + call errorc('delete of scratch file failed: ',
  1749. + scratch)
  1750. end
  1751. subroutine test_nf_put_var_text()
  1752. implicit none
  1753. #include "tests.inc"
  1754. integer ncid
  1755. integer vid
  1756. integer i
  1757. integer j
  1758. integer err
  1759. integer nels
  1760. integer index(MAX_RANK)
  1761. logical canConvert !/* Both text or both numeric */
  1762. logical allInExtRange !/* All values within external range?*/
  1763. character value(MAX_NELS)
  1764. doubleprecision val
  1765. err = nf_create(scratch, NF_CLOBBER, ncid)
  1766. if (err .ne. 0) then
  1767. call errore('nf_create: ', err)
  1768. return
  1769. end if
  1770. call def_dims(ncid)
  1771. call def_vars(ncid)
  1772. err = nf_enddef(ncid)
  1773. if (err .ne. 0)
  1774. + call errore('nf_enddef: ', err)
  1775. do 1, i = 1, NVARS
  1776. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  1777. + (NFT_TEXT .eq. NFT_TEXT)
  1778. err = nf_put_var_text(BAD_ID, i, value)
  1779. if (err .ne. NF_EBADID)
  1780. + call errore('bad ncid: ', err)
  1781. err = nf_put_var_text(ncid, BAD_VARID, value)
  1782. if (err .ne. NF_ENOTVAR)
  1783. + call errore('bad var id: ', err)
  1784. nels = 1
  1785. do 3, j = 1, var_rank(i)
  1786. nels = nels * var_shape(j,i)
  1787. 3 continue
  1788. allInExtRange = .true.
  1789. do 4, j = 1, var_nels(i)
  1790. err = index2indexes(j, var_rank(i), var_shape(1,i),
  1791. + index)
  1792. if (err .ne. 0)
  1793. + call error('error in index2indexes 1')
  1794. value(j) = char(int(hash_text(var_type(i),
  1795. + var_rank(i),
  1796. + index, NFT_TEXT)))
  1797. val = ichar(value(j))
  1798. allInExtRange = allInExtRange .and.
  1799. + inRange3(val, var_type(i), NFT_TEXT)
  1800. 4 continue
  1801. err = nf_put_var_text(ncid, i, value)
  1802. if (canConvert) then
  1803. if (allInExtRange) then
  1804. if (err .ne. 0)
  1805. + call error(nf_strerror(err))
  1806. else
  1807. if (err .ne. NF_ERANGE .and.
  1808. + var_dimid(var_rank(i),i) .ne. RECDIM)
  1809. + call errore('Range error: ', err)
  1810. endif
  1811. else
  1812. if (err .ne. NF_ECHAR)
  1813. + call errore('wrong type: ', err)
  1814. endif
  1815. 1 continue
  1816. C The preceeding has written nothing for record variables, now try
  1817. C again with more than 0 records.
  1818. C Write record number NRECS to force writing of preceding records.
  1819. C Assumes variable cr is char vector with UNLIMITED dimension.
  1820. err = nf_inq_varid(ncid, "cr", vid)
  1821. if (err .ne. 0)
  1822. + call errore('nf_inq_varid: ', err)
  1823. index(1) = NRECS
  1824. err = nf_put_var1_text(ncid, vid, index, 'x')
  1825. if (err .ne. 0)
  1826. + call errore('nf_put_var1_text: ', err)
  1827. do 5 i = 1, NVARS
  1828. C Only test record variables here
  1829. if (var_rank(i) .ge. 1 .and.
  1830. + var_dimid(var_rank(i),i) .eq. RECDIM) then
  1831. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  1832. + (NFT_TEXT .eq. NFT_TEXT)
  1833. if (var_rank(i) .gt. MAX_RANK)
  1834. + stop 'var_rank(i) .gt. MAX_RANK'
  1835. if (var_nels(i) .gt. MAX_NELS)
  1836. + stop 'var_nels(i) .gt. MAX_NELS'
  1837. err = nf_put_var_text(BAD_ID, i, value)
  1838. nels = 1
  1839. do 6 j = 1, var_rank(i)
  1840. nels = nels * var_shape(j,i)
  1841. 6 continue
  1842. allInExtRange = .true.
  1843. do 7, j = 1, nels
  1844. err = index2indexes(j, var_rank(i), var_shape(1,i),
  1845. + index)
  1846. if (err .ne. 0)
  1847. + call error('error in index2indexes()')
  1848. value(j) = char(int(hash_text(var_type(i),
  1849. + var_rank(i),
  1850. + index, NFT_TEXT)))
  1851. val = ichar(value(j))
  1852. allInExtRange = allInExtRange .and.
  1853. + inRange3(val, var_type(i), NFT_TEXT)
  1854. 7 continue
  1855. err = nf_put_var_text(ncid, i, value)
  1856. if (canConvert) then
  1857. if (allInExtRange) then
  1858. if (err .ne. 0)
  1859. + call error(nf_strerror(err))
  1860. else
  1861. if (err .ne. NF_ERANGE)
  1862. + call errore('range error: ', err)
  1863. endif
  1864. else
  1865. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  1866. + call errore('wrong type: ', err)
  1867. endif
  1868. endif
  1869. 5 continue
  1870. err = nf_close(ncid)
  1871. if (err .ne. 0)
  1872. + call errore('nf_close: ', err)
  1873. call check_vars_text(scratch)
  1874. err = nf_delete(scratch)
  1875. if (err .ne. 0)
  1876. + call errorc('delete of scratch file failed: ',
  1877. + scratch)
  1878. end
  1879. #ifdef NF_INT1_T
  1880. subroutine test_nf_put_var_int1()
  1881. implicit none
  1882. #include "tests.inc"
  1883. integer ncid
  1884. integer vid
  1885. integer i
  1886. integer j
  1887. integer err
  1888. integer nels
  1889. integer index(MAX_RANK)
  1890. logical canConvert !/* Both text or both numeric */
  1891. logical allInExtRange !/* All values within external range?*/
  1892. NF_INT1_T value(MAX_NELS)
  1893. doubleprecision val
  1894. err = nf_create(scratch, NF_CLOBBER, ncid)
  1895. if (err .ne. 0) then
  1896. call errore('nf_create: ', err)
  1897. return
  1898. end if
  1899. call def_dims(ncid)
  1900. call def_vars(ncid)
  1901. err = nf_enddef(ncid)
  1902. if (err .ne. 0)
  1903. + call errore('nf_enddef: ', err)
  1904. do 1, i = 1, NVARS
  1905. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  1906. + (NFT_INT1 .eq. NFT_TEXT)
  1907. err = nf_put_var_int1(BAD_ID, i, value)
  1908. if (err .ne. NF_EBADID)
  1909. + call errore('bad ncid: ', err)
  1910. err = nf_put_var_int1(ncid, BAD_VARID, value)
  1911. if (err .ne. NF_ENOTVAR)
  1912. + call errore('bad var id: ', err)
  1913. nels = 1
  1914. do 3, j = 1, var_rank(i)
  1915. nels = nels * var_shape(j,i)
  1916. 3 continue
  1917. allInExtRange = .true.
  1918. do 4, j = 1, var_nels(i)
  1919. err = index2indexes(j, var_rank(i), var_shape(1,i),
  1920. + index)
  1921. if (err .ne. 0)
  1922. + call error('error in index2indexes 1')
  1923. value(j) = hash_int1(var_type(i),
  1924. + var_rank(i),
  1925. + index, NFT_INT1)
  1926. val = value(j)
  1927. allInExtRange = allInExtRange .and.
  1928. + inRange3(val, var_type(i), NFT_INT1)
  1929. 4 continue
  1930. err = nf_put_var_int1(ncid, i, value)
  1931. if (canConvert) then
  1932. if (allInExtRange) then
  1933. if (err .ne. 0)
  1934. + call error(nf_strerror(err))
  1935. else
  1936. if (err .ne. NF_ERANGE .and.
  1937. + var_dimid(var_rank(i),i) .ne. RECDIM)
  1938. + call errore('Range error: ', err)
  1939. endif
  1940. else
  1941. if (err .ne. NF_ECHAR)
  1942. + call errore('wrong type: ', err)
  1943. endif
  1944. 1 continue
  1945. C The preceeding has written nothing for record variables, now try
  1946. C again with more than 0 records.
  1947. C Write record number NRECS to force writing of preceding records.
  1948. C Assumes variable cr is char vector with UNLIMITED dimension.
  1949. err = nf_inq_varid(ncid, "cr", vid)
  1950. if (err .ne. 0)
  1951. + call errore('nf_inq_varid: ', err)
  1952. index(1) = NRECS
  1953. err = nf_put_var1_text(ncid, vid, index, 'x')
  1954. if (err .ne. 0)
  1955. + call errore('nf_put_var1_text: ', err)
  1956. do 5 i = 1, NVARS
  1957. C Only test record variables here
  1958. if (var_rank(i) .ge. 1 .and.
  1959. + var_dimid(var_rank(i),i) .eq. RECDIM) then
  1960. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  1961. + (NFT_INT1 .eq. NFT_TEXT)
  1962. if (var_rank(i) .gt. MAX_RANK)
  1963. + stop 'var_rank(i) .gt. MAX_RANK'
  1964. if (var_nels(i) .gt. MAX_NELS)
  1965. + stop 'var_nels(i) .gt. MAX_NELS'
  1966. err = nf_put_var_int1(BAD_ID, i, value)
  1967. nels = 1
  1968. do 6 j = 1, var_rank(i)
  1969. nels = nels * var_shape(j,i)
  1970. 6 continue
  1971. allInExtRange = .true.
  1972. do 7, j = 1, nels
  1973. err = index2indexes(j, var_rank(i), var_shape(1,i),
  1974. + index)
  1975. if (err .ne. 0)
  1976. + call error('error in index2indexes()')
  1977. value(j) = hash_int1(var_type(i),
  1978. + var_rank(i),
  1979. + index, NFT_INT1)
  1980. val = value(j)
  1981. allInExtRange = allInExtRange .and.
  1982. + inRange3(val, var_type(i), NFT_INT1)
  1983. 7 continue
  1984. err = nf_put_var_int1(ncid, i, value)
  1985. if (canConvert) then
  1986. if (allInExtRange) then
  1987. if (err .ne. 0)
  1988. + call error(nf_strerror(err))
  1989. else
  1990. if (err .ne. NF_ERANGE)
  1991. + call errore('range error: ', err)
  1992. endif
  1993. else
  1994. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  1995. + call errore('wrong type: ', err)
  1996. endif
  1997. endif
  1998. 5 continue
  1999. err = nf_close(ncid)
  2000. if (err .ne. 0)
  2001. + call errore('nf_close: ', err)
  2002. call check_vars_int1(scratch)
  2003. err = nf_delete(scratch)
  2004. if (err .ne. 0)
  2005. + call errorc('delete of scratch file failed: ',
  2006. + scratch)
  2007. end
  2008. #endif
  2009. #ifdef NF_INT2_T
  2010. subroutine test_nf_put_var_int2()
  2011. implicit none
  2012. #include "tests.inc"
  2013. integer ncid
  2014. integer vid
  2015. integer i
  2016. integer j
  2017. integer err
  2018. integer nels
  2019. integer index(MAX_RANK)
  2020. logical canConvert !/* Both text or both numeric */
  2021. logical allInExtRange !/* All values within external range?*/
  2022. NF_INT2_T value(MAX_NELS)
  2023. doubleprecision val
  2024. err = nf_create(scratch, NF_CLOBBER, ncid)
  2025. if (err .ne. 0) then
  2026. call errore('nf_create: ', err)
  2027. return
  2028. end if
  2029. call def_dims(ncid)
  2030. call def_vars(ncid)
  2031. err = nf_enddef(ncid)
  2032. if (err .ne. 0)
  2033. + call errore('nf_enddef: ', err)
  2034. do 1, i = 1, NVARS
  2035. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  2036. + (NFT_INT2 .eq. NFT_TEXT)
  2037. err = nf_put_var_int2(BAD_ID, i, value)
  2038. if (err .ne. NF_EBADID)
  2039. + call errore('bad ncid: ', err)
  2040. err = nf_put_var_int2(ncid, BAD_VARID, value)
  2041. if (err .ne. NF_ENOTVAR)
  2042. + call errore('bad var id: ', err)
  2043. nels = 1
  2044. do 3, j = 1, var_rank(i)
  2045. nels = nels * var_shape(j,i)
  2046. 3 continue
  2047. allInExtRange = .true.
  2048. do 4, j = 1, var_nels(i)
  2049. err = index2indexes(j, var_rank(i), var_shape(1,i),
  2050. + index)
  2051. if (err .ne. 0)
  2052. + call error('error in index2indexes 1')
  2053. value(j) = hash_int2(var_type(i),
  2054. + var_rank(i),
  2055. + index, NFT_INT2)
  2056. val = value(j)
  2057. allInExtRange = allInExtRange .and.
  2058. + inRange3(val, var_type(i), NFT_INT2)
  2059. 4 continue
  2060. err = nf_put_var_int2(ncid, i, value)
  2061. if (canConvert) then
  2062. if (allInExtRange) then
  2063. if (err .ne. 0)
  2064. + call error(nf_strerror(err))
  2065. else
  2066. if (err .ne. NF_ERANGE .and.
  2067. + var_dimid(var_rank(i),i) .ne. RECDIM)
  2068. + call errore('Range error: ', err)
  2069. endif
  2070. else
  2071. if (err .ne. NF_ECHAR)
  2072. + call errore('wrong type: ', err)
  2073. endif
  2074. 1 continue
  2075. C The preceeding has written nothing for record variables, now try
  2076. C again with more than 0 records.
  2077. C Write record number NRECS to force writing of preceding records.
  2078. C Assumes variable cr is char vector with UNLIMITED dimension.
  2079. err = nf_inq_varid(ncid, "cr", vid)
  2080. if (err .ne. 0)
  2081. + call errore('nf_inq_varid: ', err)
  2082. index(1) = NRECS
  2083. err = nf_put_var1_text(ncid, vid, index, 'x')
  2084. if (err .ne. 0)
  2085. + call errore('nf_put_var1_text: ', err)
  2086. do 5 i = 1, NVARS
  2087. C Only test record variables here
  2088. if (var_rank(i) .ge. 1 .and.
  2089. + var_dimid(var_rank(i),i) .eq. RECDIM) then
  2090. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  2091. + (NFT_INT2 .eq. NFT_TEXT)
  2092. if (var_rank(i) .gt. MAX_RANK)
  2093. + stop 'var_rank(i) .gt. MAX_RANK'
  2094. if (var_nels(i) .gt. MAX_NELS)
  2095. + stop 'var_nels(i) .gt. MAX_NELS'
  2096. err = nf_put_var_int2(BAD_ID, i, value)
  2097. nels = 1
  2098. do 6 j = 1, var_rank(i)
  2099. nels = nels * var_shape(j,i)
  2100. 6 continue
  2101. allInExtRange = .true.
  2102. do 7, j = 1, nels
  2103. err = index2indexes(j, var_rank(i), var_shape(1,i),
  2104. + index)
  2105. if (err .ne. 0)
  2106. + call error('error in index2indexes()')
  2107. value(j) = hash_int2(var_type(i),
  2108. + var_rank(i),
  2109. + index, NFT_INT2)
  2110. val = value(j)
  2111. allInExtRange = allInExtRange .and.
  2112. + inRange3(val, var_type(i), NFT_INT2)
  2113. 7 continue
  2114. err = nf_put_var_int2(ncid, i, value)
  2115. if (canConvert) then
  2116. if (allInExtRange) then
  2117. if (err .ne. 0)
  2118. + call error(nf_strerror(err))
  2119. else
  2120. if (err .ne. NF_ERANGE)
  2121. + call errore('range error: ', err)
  2122. endif
  2123. else
  2124. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  2125. + call errore('wrong type: ', err)
  2126. endif
  2127. endif
  2128. 5 continue
  2129. err = nf_close(ncid)
  2130. if (err .ne. 0)
  2131. + call errore('nf_close: ', err)
  2132. call check_vars_int2(scratch)
  2133. err = nf_delete(scratch)
  2134. if (err .ne. 0)
  2135. + call errorc('delete of scratch file failed: ',
  2136. + scratch)
  2137. end
  2138. #endif
  2139. subroutine test_nf_put_var_int()
  2140. implicit none
  2141. #include "tests.inc"
  2142. integer ncid
  2143. integer vid
  2144. integer i
  2145. integer j
  2146. integer err
  2147. integer nels
  2148. integer index(MAX_RANK)
  2149. logical canConvert !/* Both text or both numeric */
  2150. logical allInExtRange !/* All values within external range?*/
  2151. integer value(MAX_NELS)
  2152. doubleprecision val
  2153. err = nf_create(scratch, NF_CLOBBER, ncid)
  2154. if (err .ne. 0) then
  2155. call errore('nf_create: ', err)
  2156. return
  2157. end if
  2158. call def_dims(ncid)
  2159. call def_vars(ncid)
  2160. err = nf_enddef(ncid)
  2161. if (err .ne. 0)
  2162. + call errore('nf_enddef: ', err)
  2163. do 1, i = 1, NVARS
  2164. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  2165. + (NFT_INT .eq. NFT_TEXT)
  2166. err = nf_put_var_int(BAD_ID, i, value)
  2167. if (err .ne. NF_EBADID)
  2168. + call errore('bad ncid: ', err)
  2169. err = nf_put_var_int(ncid, BAD_VARID, value)
  2170. if (err .ne. NF_ENOTVAR)
  2171. + call errore('bad var id: ', err)
  2172. nels = 1
  2173. do 3, j = 1, var_rank(i)
  2174. nels = nels * var_shape(j,i)
  2175. 3 continue
  2176. allInExtRange = .true.
  2177. do 4, j = 1, var_nels(i)
  2178. err = index2indexes(j, var_rank(i), var_shape(1,i),
  2179. + index)
  2180. if (err .ne. 0)
  2181. + call error('error in index2indexes 1')
  2182. value(j) = hash_int(var_type(i),
  2183. + var_rank(i),
  2184. + index, NFT_INT)
  2185. val = value(j)
  2186. allInExtRange = allInExtRange .and.
  2187. + inRange3(val, var_type(i), NFT_INT)
  2188. 4 continue
  2189. err = nf_put_var_int(ncid, i, value)
  2190. if (canConvert) then
  2191. if (allInExtRange) then
  2192. if (err .ne. 0)
  2193. + call error(nf_strerror(err))
  2194. else
  2195. if (err .ne. NF_ERANGE .and.
  2196. + var_dimid(var_rank(i),i) .ne. RECDIM)
  2197. + call errore('Range error: ', err)
  2198. endif
  2199. else
  2200. if (err .ne. NF_ECHAR)
  2201. + call errore('wrong type: ', err)
  2202. endif
  2203. 1 continue
  2204. C The preceeding has written nothing for record variables, now try
  2205. C again with more than 0 records.
  2206. C Write record number NRECS to force writing of preceding records.
  2207. C Assumes variable cr is char vector with UNLIMITED dimension.
  2208. err = nf_inq_varid(ncid, "cr", vid)
  2209. if (err .ne. 0)
  2210. + call errore('nf_inq_varid: ', err)
  2211. index(1) = NRECS
  2212. err = nf_put_var1_text(ncid, vid, index, 'x')
  2213. if (err .ne. 0)
  2214. + call errore('nf_put_var1_text: ', err)
  2215. do 5 i = 1, NVARS
  2216. C Only test record variables here
  2217. if (var_rank(i) .ge. 1 .and.
  2218. + var_dimid(var_rank(i),i) .eq. RECDIM) then
  2219. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  2220. + (NFT_INT .eq. NFT_TEXT)
  2221. if (var_rank(i) .gt. MAX_RANK)
  2222. + stop 'var_rank(i) .gt. MAX_RANK'
  2223. if (var_nels(i) .gt. MAX_NELS)
  2224. + stop 'var_nels(i) .gt. MAX_NELS'
  2225. err = nf_put_var_int(BAD_ID, i, value)
  2226. nels = 1
  2227. do 6 j = 1, var_rank(i)
  2228. nels = nels * var_shape(j,i)
  2229. 6 continue
  2230. allInExtRange = .true.
  2231. do 7, j = 1, nels
  2232. err = index2indexes(j, var_rank(i), var_shape(1,i),
  2233. + index)
  2234. if (err .ne. 0)
  2235. + call error('error in index2indexes()')
  2236. value(j) = hash_int(var_type(i),
  2237. + var_rank(i),
  2238. + index, NFT_INT)
  2239. val = value(j)
  2240. allInExtRange = allInExtRange .and.
  2241. + inRange3(val, var_type(i), NFT_INT)
  2242. 7 continue
  2243. err = nf_put_var_int(ncid, i, value)
  2244. if (canConvert) then
  2245. if (allInExtRange) then
  2246. if (err .ne. 0)
  2247. + call error(nf_strerror(err))
  2248. else
  2249. if (err .ne. NF_ERANGE)
  2250. + call errore('range error: ', err)
  2251. endif
  2252. else
  2253. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  2254. + call errore('wrong type: ', err)
  2255. endif
  2256. endif
  2257. 5 continue
  2258. err = nf_close(ncid)
  2259. if (err .ne. 0)
  2260. + call errore('nf_close: ', err)
  2261. call check_vars_int(scratch)
  2262. err = nf_delete(scratch)
  2263. if (err .ne. 0)
  2264. + call errorc('delete of scratch file failed: ',
  2265. + scratch)
  2266. end
  2267. subroutine test_nf_put_var_real()
  2268. implicit none
  2269. #include "tests.inc"
  2270. integer ncid
  2271. integer vid
  2272. integer i
  2273. integer j
  2274. integer err
  2275. integer nels
  2276. integer index(MAX_RANK)
  2277. logical canConvert !/* Both text or both numeric */
  2278. logical allInExtRange !/* All values within external range?*/
  2279. real value(MAX_NELS)
  2280. doubleprecision val
  2281. err = nf_create(scratch, NF_CLOBBER, ncid)
  2282. if (err .ne. 0) then
  2283. call errore('nf_create: ', err)
  2284. return
  2285. end if
  2286. call def_dims(ncid)
  2287. call def_vars(ncid)
  2288. err = nf_enddef(ncid)
  2289. if (err .ne. 0)
  2290. + call errore('nf_enddef: ', err)
  2291. do 1, i = 1, NVARS
  2292. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  2293. + (NFT_REAL .eq. NFT_TEXT)
  2294. err = nf_put_var_real(BAD_ID, i, value)
  2295. if (err .ne. NF_EBADID)
  2296. + call errore('bad ncid: ', err)
  2297. err = nf_put_var_real(ncid, BAD_VARID, value)
  2298. if (err .ne. NF_ENOTVAR)
  2299. + call errore('bad var id: ', err)
  2300. nels = 1
  2301. do 3, j = 1, var_rank(i)
  2302. nels = nels * var_shape(j,i)
  2303. 3 continue
  2304. allInExtRange = .true.
  2305. do 4, j = 1, var_nels(i)
  2306. err = index2indexes(j, var_rank(i), var_shape(1,i),
  2307. + index)
  2308. if (err .ne. 0)
  2309. + call error('error in index2indexes 1')
  2310. value(j) = hash_real(var_type(i),
  2311. + var_rank(i),
  2312. + index, NFT_REAL)
  2313. val = value(j)
  2314. allInExtRange = allInExtRange .and.
  2315. + inRange3(val, var_type(i), NFT_REAL)
  2316. 4 continue
  2317. err = nf_put_var_real(ncid, i, value)
  2318. if (canConvert) then
  2319. if (allInExtRange) then
  2320. if (err .ne. 0)
  2321. + call error(nf_strerror(err))
  2322. else
  2323. if (err .ne. NF_ERANGE .and.
  2324. + var_dimid(var_rank(i),i) .ne. RECDIM)
  2325. + call errore('Range error: ', err)
  2326. endif
  2327. else
  2328. if (err .ne. NF_ECHAR)
  2329. + call errore('wrong type: ', err)
  2330. endif
  2331. 1 continue
  2332. C The preceeding has written nothing for record variables, now try
  2333. C again with more than 0 records.
  2334. C Write record number NRECS to force writing of preceding records.
  2335. C Assumes variable cr is char vector with UNLIMITED dimension.
  2336. err = nf_inq_varid(ncid, "cr", vid)
  2337. if (err .ne. 0)
  2338. + call errore('nf_inq_varid: ', err)
  2339. index(1) = NRECS
  2340. err = nf_put_var1_text(ncid, vid, index, 'x')
  2341. if (err .ne. 0)
  2342. + call errore('nf_put_var1_text: ', err)
  2343. do 5 i = 1, NVARS
  2344. C Only test record variables here
  2345. if (var_rank(i) .ge. 1 .and.
  2346. + var_dimid(var_rank(i),i) .eq. RECDIM) then
  2347. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  2348. + (NFT_REAL .eq. NFT_TEXT)
  2349. if (var_rank(i) .gt. MAX_RANK)
  2350. + stop 'var_rank(i) .gt. MAX_RANK'
  2351. if (var_nels(i) .gt. MAX_NELS)
  2352. + stop 'var_nels(i) .gt. MAX_NELS'
  2353. err = nf_put_var_real(BAD_ID, i, value)
  2354. nels = 1
  2355. do 6 j = 1, var_rank(i)
  2356. nels = nels * var_shape(j,i)
  2357. 6 continue
  2358. allInExtRange = .true.
  2359. do 7, j = 1, nels
  2360. err = index2indexes(j, var_rank(i), var_shape(1,i),
  2361. + index)
  2362. if (err .ne. 0)
  2363. + call error('error in index2indexes()')
  2364. value(j) = hash_real(var_type(i),
  2365. + var_rank(i),
  2366. + index, NFT_REAL)
  2367. val = value(j)
  2368. allInExtRange = allInExtRange .and.
  2369. + inRange3(val, var_type(i), NFT_REAL)
  2370. 7 continue
  2371. err = nf_put_var_real(ncid, i, value)
  2372. if (canConvert) then
  2373. if (allInExtRange) then
  2374. if (err .ne. 0)
  2375. + call error(nf_strerror(err))
  2376. else
  2377. if (err .ne. NF_ERANGE)
  2378. + call errore('range error: ', err)
  2379. endif
  2380. else
  2381. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  2382. + call errore('wrong type: ', err)
  2383. endif
  2384. endif
  2385. 5 continue
  2386. err = nf_close(ncid)
  2387. if (err .ne. 0)
  2388. + call errore('nf_close: ', err)
  2389. call check_vars_real(scratch)
  2390. err = nf_delete(scratch)
  2391. if (err .ne. 0)
  2392. + call errorc('delete of scratch file failed: ',
  2393. + scratch)
  2394. end
  2395. subroutine test_nf_put_var_double()
  2396. implicit none
  2397. #include "tests.inc"
  2398. integer ncid
  2399. integer vid
  2400. integer i
  2401. integer j
  2402. integer err
  2403. integer nels
  2404. integer index(MAX_RANK)
  2405. logical canConvert !/* Both text or both numeric */
  2406. logical allInExtRange !/* All values within external range?*/
  2407. doubleprecision value(MAX_NELS)
  2408. doubleprecision val
  2409. err = nf_create(scratch, NF_CLOBBER, ncid)
  2410. if (err .ne. 0) then
  2411. call errore('nf_create: ', err)
  2412. return
  2413. end if
  2414. call def_dims(ncid)
  2415. call def_vars(ncid)
  2416. err = nf_enddef(ncid)
  2417. if (err .ne. 0)
  2418. + call errore('nf_enddef: ', err)
  2419. do 1, i = 1, NVARS
  2420. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  2421. + (NFT_DOUBLE .eq. NFT_TEXT)
  2422. err = nf_put_var_double(BAD_ID, i, value)
  2423. if (err .ne. NF_EBADID)
  2424. + call errore('bad ncid: ', err)
  2425. err = nf_put_var_double(ncid, BAD_VARID, value)
  2426. if (err .ne. NF_ENOTVAR)
  2427. + call errore('bad var id: ', err)
  2428. nels = 1
  2429. do 3, j = 1, var_rank(i)
  2430. nels = nels * var_shape(j,i)
  2431. 3 continue
  2432. allInExtRange = .true.
  2433. do 4, j = 1, var_nels(i)
  2434. err = index2indexes(j, var_rank(i), var_shape(1,i),
  2435. + index)
  2436. if (err .ne. 0)
  2437. + call error('error in index2indexes 1')
  2438. value(j) = hash_double(var_type(i),
  2439. + var_rank(i),
  2440. + index, NFT_DOUBLE)
  2441. val = value(j)
  2442. allInExtRange = allInExtRange .and.
  2443. + inRange3(val, var_type(i), NFT_DOUBLE)
  2444. 4 continue
  2445. err = nf_put_var_double(ncid, i, value)
  2446. if (canConvert) then
  2447. if (allInExtRange) then
  2448. if (err .ne. 0)
  2449. + call error(nf_strerror(err))
  2450. else
  2451. if (err .ne. NF_ERANGE .and.
  2452. + var_dimid(var_rank(i),i) .ne. RECDIM)
  2453. + call errore('Range error: ', err)
  2454. endif
  2455. else
  2456. if (err .ne. NF_ECHAR)
  2457. + call errore('wrong type: ', err)
  2458. endif
  2459. 1 continue
  2460. C The preceeding has written nothing for record variables, now try
  2461. C again with more than 0 records.
  2462. C Write record number NRECS to force writing of preceding records.
  2463. C Assumes variable cr is char vector with UNLIMITED dimension.
  2464. err = nf_inq_varid(ncid, "cr", vid)
  2465. if (err .ne. 0)
  2466. + call errore('nf_inq_varid: ', err)
  2467. index(1) = NRECS
  2468. err = nf_put_var1_text(ncid, vid, index, 'x')
  2469. if (err .ne. 0)
  2470. + call errore('nf_put_var1_text: ', err)
  2471. do 5 i = 1, NVARS
  2472. C Only test record variables here
  2473. if (var_rank(i) .ge. 1 .and.
  2474. + var_dimid(var_rank(i),i) .eq. RECDIM) then
  2475. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  2476. + (NFT_DOUBLE .eq. NFT_TEXT)
  2477. if (var_rank(i) .gt. MAX_RANK)
  2478. + stop 'var_rank(i) .gt. MAX_RANK'
  2479. if (var_nels(i) .gt. MAX_NELS)
  2480. + stop 'var_nels(i) .gt. MAX_NELS'
  2481. err = nf_put_var_double(BAD_ID, i, value)
  2482. nels = 1
  2483. do 6 j = 1, var_rank(i)
  2484. nels = nels * var_shape(j,i)
  2485. 6 continue
  2486. allInExtRange = .true.
  2487. do 7, j = 1, nels
  2488. err = index2indexes(j, var_rank(i), var_shape(1,i),
  2489. + index)
  2490. if (err .ne. 0)
  2491. + call error('error in index2indexes()')
  2492. value(j) = hash_double(var_type(i),
  2493. + var_rank(i),
  2494. + index, NFT_DOUBLE)
  2495. val = value(j)
  2496. allInExtRange = allInExtRange .and.
  2497. + inRange3(val, var_type(i), NFT_DOUBLE)
  2498. 7 continue
  2499. err = nf_put_var_double(ncid, i, value)
  2500. if (canConvert) then
  2501. if (allInExtRange) then
  2502. if (err .ne. 0)
  2503. + call error(nf_strerror(err))
  2504. else
  2505. if (err .ne. NF_ERANGE)
  2506. + call errore('range error: ', err)
  2507. endif
  2508. else
  2509. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  2510. + call errore('wrong type: ', err)
  2511. endif
  2512. endif
  2513. 5 continue
  2514. err = nf_close(ncid)
  2515. if (err .ne. 0)
  2516. + call errore('nf_close: ', err)
  2517. call check_vars_double(scratch)
  2518. err = nf_delete(scratch)
  2519. if (err .ne. 0)
  2520. + call errorc('delete of scratch file failed: ',
  2521. + scratch)
  2522. end
  2523. subroutine test_nf_put_vara_text()
  2524. implicit none
  2525. #include "tests.inc"
  2526. integer ncid
  2527. integer i
  2528. integer j
  2529. integer k
  2530. integer d
  2531. integer err
  2532. integer nslabs
  2533. integer nels
  2534. integer start(MAX_RANK)
  2535. integer edge(MAX_RANK)
  2536. integer mid(MAX_RANK)
  2537. integer index(MAX_RANK)
  2538. logical canConvert !/* Both text or both numeric */
  2539. logical allInExtRange !/* all values within external range? */
  2540. character value(MAX_NELS)
  2541. doubleprecision val
  2542. integer udshift
  2543. err = nf_create(scratch, NF_CLOBBER, ncid)
  2544. if (err .ne. 0) then
  2545. call errore('nf_create: ', err)
  2546. return
  2547. end if
  2548. call def_dims(ncid)
  2549. call def_vars(ncid)
  2550. err = nf_enddef(ncid)
  2551. if (err .ne. 0)
  2552. + call errore('nf_enddef: ', err)
  2553. do 1, i = 1, NVARS
  2554. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  2555. + (NFT_TEXT .eq. NFT_TEXT)
  2556. if (.not.(var_rank(i) .le. MAX_RANK))
  2557. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  2558. if (.not.(var_nels(i) .le. MAX_NELS))
  2559. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  2560. do 2, j = 1, var_rank(i)
  2561. start(j) = 1
  2562. edge(j) = 1
  2563. 2 continue
  2564. err = nf_put_vara_text(BAD_ID, i, start,
  2565. + edge, value)
  2566. if (err .ne. NF_EBADID)
  2567. + call errore('bad ncid: ', err)
  2568. err = nf_put_vara_text(ncid, BAD_VARID,
  2569. + start, edge, value)
  2570. if (err .ne. NF_ENOTVAR)
  2571. + call errore('bad var id: ', err)
  2572. do 3, j = 1, var_rank(i)
  2573. if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
  2574. start(j) = var_shape(j,i) + 1
  2575. err = nf_put_vara_text(ncid, i, start,
  2576. + edge, value)
  2577. if (.not. canConvert) then
  2578. if (err .ne. NF_ECHAR)
  2579. + call errore('conversion: ', err)
  2580. else
  2581. if (err .ne. NF_EINVALCOORDS)
  2582. + call errore('bad start: ', err)
  2583. endif
  2584. start(j) = 1
  2585. edge(j) = var_shape(j,i) + 1
  2586. err = nf_put_vara_text(ncid, i, start,
  2587. + edge, value)
  2588. if (.not. canConvert) then
  2589. if (err .ne. NF_ECHAR)
  2590. + call errore('conversion: ', err)
  2591. else
  2592. if (err .ne. NF_EEDGE)
  2593. + call errore('bad edge: ', err)
  2594. endif
  2595. edge(j) = 1
  2596. end if
  2597. 3 continue
  2598. C /* Check correct error returned even when nothing to put */
  2599. do 20, j = 1, var_rank(i)
  2600. edge(j) = 0
  2601. 20 continue
  2602. err = nf_put_vara_text(BAD_ID, i, start,
  2603. + edge, value)
  2604. if (err .ne. NF_EBADID)
  2605. + call errore('bad ncid: ', err)
  2606. err = nf_put_vara_text(ncid, BAD_VARID,
  2607. + start, edge, value)
  2608. if (err .ne. NF_ENOTVAR)
  2609. + call errore('bad var id: ', err)
  2610. do 21, j = 1, var_rank(i)
  2611. if (var_dimid(j,i) .gt. 1) then ! skip record dim
  2612. start(j) = var_shape(j,i) + 2
  2613. err = nf_put_vara_text(ncid, i, start,
  2614. + edge, value)
  2615. if (.not. canConvert) then
  2616. if (err .ne. NF_ECHAR)
  2617. + call errore('conversion: ', err)
  2618. else
  2619. if (err .ne. NF_EINVALCOORDS)
  2620. + call errore('bad start: ', err)
  2621. endif
  2622. start(j) = 1
  2623. endif
  2624. 21 continue
  2625. err = nf_put_vara_text(ncid, i, start, edge, value)
  2626. if (canConvert) then
  2627. if (err .ne. 0)
  2628. + call error(nf_strerror(err))
  2629. else
  2630. if (err .ne. NF_ECHAR)
  2631. + call errore('wrong type: ', err)
  2632. endif
  2633. do 22, j = 1, var_rank(i)
  2634. edge(j) = 1
  2635. 22 continue
  2636. !/* Choose a random point dividing each dim into 2 parts */
  2637. !/* Put 2^rank (nslabs) slabs so defined */
  2638. nslabs = 1
  2639. do 4, j = 1, var_rank(i)
  2640. mid(j) = roll( var_shape(j,i) )
  2641. nslabs = nslabs * 2
  2642. 4 continue
  2643. !/* bits of k determine whether to put lower or upper part of dim */
  2644. do 5, k = 1, nslabs
  2645. nels = 1
  2646. do 6, j = 1, var_rank(i)
  2647. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  2648. start(j) = 1
  2649. edge(j) = mid(j)
  2650. else
  2651. start(j) = 1 + mid(j)
  2652. edge(j) = var_shape(j,i) - mid(j)
  2653. end if
  2654. nels = nels * edge(j)
  2655. 6 continue
  2656. allInExtRange = .true.
  2657. do 7, j = 1, nels
  2658. err = index2indexes(j, var_rank(i), edge, index)
  2659. if (err .ne. 0)
  2660. + call error('error in index2indexes 1')
  2661. do 8, d = 1, var_rank(i)
  2662. index(d) = index(d) + start(d) - 1
  2663. 8 continue
  2664. value(j)= char(int(hash_text(var_type(i),
  2665. + var_rank(i), index,
  2666. + NFT_TEXT)))
  2667. val = ichar(value(j))
  2668. allInExtRange = allInExtRange .and.
  2669. + inRange3(val, var_type(i), NFT_TEXT)
  2670. 7 continue
  2671. err = nf_put_vara_text(ncid, i, start,
  2672. + edge, value)
  2673. if (canConvert) then
  2674. if (allInExtRange) then
  2675. if (err .ne. 0)
  2676. + call error(nf_strerror(err))
  2677. else
  2678. if (err .ne. NF_ERANGE)
  2679. + call errore('range error: ', err)
  2680. end if
  2681. else
  2682. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  2683. + call errore('wrong type: ', err)
  2684. end if
  2685. 5 continue
  2686. 1 continue
  2687. err = nf_close(ncid)
  2688. if (err .ne. 0)
  2689. + call errore('nf_close: ', err)
  2690. call check_vars_text(scratch)
  2691. err = nf_delete(scratch)
  2692. if (err .ne. 0)
  2693. + call errorc('delete of scratch file failed: ',
  2694. + scratch)
  2695. end
  2696. #ifdef NF_INT1_T
  2697. subroutine test_nf_put_vara_int1()
  2698. implicit none
  2699. #include "tests.inc"
  2700. integer ncid
  2701. integer i
  2702. integer j
  2703. integer k
  2704. integer d
  2705. integer err
  2706. integer nslabs
  2707. integer nels
  2708. integer start(MAX_RANK)
  2709. integer edge(MAX_RANK)
  2710. integer mid(MAX_RANK)
  2711. integer index(MAX_RANK)
  2712. logical canConvert !/* Both text or both numeric */
  2713. logical allInExtRange !/* all values within external range? */
  2714. NF_INT1_T value(MAX_NELS)
  2715. doubleprecision val
  2716. integer udshift
  2717. err = nf_create(scratch, NF_CLOBBER, ncid)
  2718. if (err .ne. 0) then
  2719. call errore('nf_create: ', err)
  2720. return
  2721. end if
  2722. call def_dims(ncid)
  2723. call def_vars(ncid)
  2724. err = nf_enddef(ncid)
  2725. if (err .ne. 0)
  2726. + call errore('nf_enddef: ', err)
  2727. do 1, i = 1, NVARS
  2728. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  2729. + (NFT_INT1 .eq. NFT_TEXT)
  2730. if (.not.(var_rank(i) .le. MAX_RANK))
  2731. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  2732. if (.not.(var_nels(i) .le. MAX_NELS))
  2733. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  2734. do 2, j = 1, var_rank(i)
  2735. start(j) = 1
  2736. edge(j) = 1
  2737. 2 continue
  2738. err = nf_put_vara_int1(BAD_ID, i, start,
  2739. + edge, value)
  2740. if (err .ne. NF_EBADID)
  2741. + call errore('bad ncid: ', err)
  2742. err = nf_put_vara_int1(ncid, BAD_VARID,
  2743. + start, edge, value)
  2744. if (err .ne. NF_ENOTVAR)
  2745. + call errore('bad var id: ', err)
  2746. do 3, j = 1, var_rank(i)
  2747. if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
  2748. start(j) = var_shape(j,i) + 1
  2749. err = nf_put_vara_int1(ncid, i, start,
  2750. + edge, value)
  2751. if (.not. canConvert) then
  2752. if (err .ne. NF_ECHAR)
  2753. + call errore('conversion: ', err)
  2754. else
  2755. if (err .ne. NF_EINVALCOORDS)
  2756. + call errore('bad start: ', err)
  2757. endif
  2758. start(j) = 1
  2759. edge(j) = var_shape(j,i) + 1
  2760. err = nf_put_vara_int1(ncid, i, start,
  2761. + edge, value)
  2762. if (.not. canConvert) then
  2763. if (err .ne. NF_ECHAR)
  2764. + call errore('conversion: ', err)
  2765. else
  2766. if (err .ne. NF_EEDGE)
  2767. + call errore('bad edge: ', err)
  2768. endif
  2769. edge(j) = 1
  2770. end if
  2771. 3 continue
  2772. C /* Check correct error returned even when nothing to put */
  2773. do 20, j = 1, var_rank(i)
  2774. edge(j) = 0
  2775. 20 continue
  2776. err = nf_put_vara_int1(BAD_ID, i, start,
  2777. + edge, value)
  2778. if (err .ne. NF_EBADID)
  2779. + call errore('bad ncid: ', err)
  2780. err = nf_put_vara_int1(ncid, BAD_VARID,
  2781. + start, edge, value)
  2782. if (err .ne. NF_ENOTVAR)
  2783. + call errore('bad var id: ', err)
  2784. do 21, j = 1, var_rank(i)
  2785. if (var_dimid(j,i) .gt. 1) then ! skip record dim
  2786. start(j) = var_shape(j,i) + 2
  2787. err = nf_put_vara_int1(ncid, i, start,
  2788. + edge, value)
  2789. if (.not. canConvert) then
  2790. if (err .ne. NF_ECHAR)
  2791. + call errore('conversion: ', err)
  2792. else
  2793. if (err .ne. NF_EINVALCOORDS)
  2794. + call errore('bad start: ', err)
  2795. endif
  2796. start(j) = 1
  2797. endif
  2798. 21 continue
  2799. err = nf_put_vara_int1(ncid, i, start, edge, value)
  2800. if (canConvert) then
  2801. if (err .ne. 0)
  2802. + call error(nf_strerror(err))
  2803. else
  2804. if (err .ne. NF_ECHAR)
  2805. + call errore('wrong type: ', err)
  2806. endif
  2807. do 22, j = 1, var_rank(i)
  2808. edge(j) = 1
  2809. 22 continue
  2810. !/* Choose a random point dividing each dim into 2 parts */
  2811. !/* Put 2^rank (nslabs) slabs so defined */
  2812. nslabs = 1
  2813. do 4, j = 1, var_rank(i)
  2814. mid(j) = roll( var_shape(j,i) )
  2815. nslabs = nslabs * 2
  2816. 4 continue
  2817. !/* bits of k determine whether to put lower or upper part of dim */
  2818. do 5, k = 1, nslabs
  2819. nels = 1
  2820. do 6, j = 1, var_rank(i)
  2821. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  2822. start(j) = 1
  2823. edge(j) = mid(j)
  2824. else
  2825. start(j) = 1 + mid(j)
  2826. edge(j) = var_shape(j,i) - mid(j)
  2827. end if
  2828. nels = nels * edge(j)
  2829. 6 continue
  2830. allInExtRange = .true.
  2831. do 7, j = 1, nels
  2832. err = index2indexes(j, var_rank(i), edge, index)
  2833. if (err .ne. 0)
  2834. + call error('error in index2indexes 1')
  2835. do 8, d = 1, var_rank(i)
  2836. index(d) = index(d) + start(d) - 1
  2837. 8 continue
  2838. value(j)= hash_int1(var_type(i),
  2839. + var_rank(i), index,
  2840. + NFT_INT1)
  2841. val = value(j)
  2842. allInExtRange = allInExtRange .and.
  2843. + inRange3(val, var_type(i), NFT_INT1)
  2844. 7 continue
  2845. err = nf_put_vara_int1(ncid, i, start,
  2846. + edge, value)
  2847. if (canConvert) then
  2848. if (allInExtRange) then
  2849. if (err .ne. 0)
  2850. + call error(nf_strerror(err))
  2851. else
  2852. if (err .ne. NF_ERANGE)
  2853. + call errore('range error: ', err)
  2854. end if
  2855. else
  2856. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  2857. + call errore('wrong type: ', err)
  2858. end if
  2859. 5 continue
  2860. 1 continue
  2861. err = nf_close(ncid)
  2862. if (err .ne. 0)
  2863. + call errore('nf_close: ', err)
  2864. call check_vars_int1(scratch)
  2865. err = nf_delete(scratch)
  2866. if (err .ne. 0)
  2867. + call errorc('delete of scratch file failed: ',
  2868. + scratch)
  2869. end
  2870. #endif
  2871. #ifdef NF_INT2_T
  2872. subroutine test_nf_put_vara_int2()
  2873. implicit none
  2874. #include "tests.inc"
  2875. integer ncid
  2876. integer i
  2877. integer j
  2878. integer k
  2879. integer d
  2880. integer err
  2881. integer nslabs
  2882. integer nels
  2883. integer start(MAX_RANK)
  2884. integer edge(MAX_RANK)
  2885. integer mid(MAX_RANK)
  2886. integer index(MAX_RANK)
  2887. logical canConvert !/* Both text or both numeric */
  2888. logical allInExtRange !/* all values within external range? */
  2889. NF_INT2_T value(MAX_NELS)
  2890. doubleprecision val
  2891. integer udshift
  2892. err = nf_create(scratch, NF_CLOBBER, ncid)
  2893. if (err .ne. 0) then
  2894. call errore('nf_create: ', err)
  2895. return
  2896. end if
  2897. call def_dims(ncid)
  2898. call def_vars(ncid)
  2899. err = nf_enddef(ncid)
  2900. if (err .ne. 0)
  2901. + call errore('nf_enddef: ', err)
  2902. do 1, i = 1, NVARS
  2903. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  2904. + (NFT_INT2 .eq. NFT_TEXT)
  2905. if (.not.(var_rank(i) .le. MAX_RANK))
  2906. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  2907. if (.not.(var_nels(i) .le. MAX_NELS))
  2908. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  2909. do 2, j = 1, var_rank(i)
  2910. start(j) = 1
  2911. edge(j) = 1
  2912. 2 continue
  2913. err = nf_put_vara_int2(BAD_ID, i, start,
  2914. + edge, value)
  2915. if (err .ne. NF_EBADID)
  2916. + call errore('bad ncid: ', err)
  2917. err = nf_put_vara_int2(ncid, BAD_VARID,
  2918. + start, edge, value)
  2919. if (err .ne. NF_ENOTVAR)
  2920. + call errore('bad var id: ', err)
  2921. do 3, j = 1, var_rank(i)
  2922. if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
  2923. start(j) = var_shape(j,i) + 1
  2924. err = nf_put_vara_int2(ncid, i, start,
  2925. + edge, value)
  2926. if (.not. canConvert) then
  2927. if (err .ne. NF_ECHAR)
  2928. + call errore('conversion: ', err)
  2929. else
  2930. if (err .ne. NF_EINVALCOORDS)
  2931. + call errore('bad start: ', err)
  2932. endif
  2933. start(j) = 1
  2934. edge(j) = var_shape(j,i) + 1
  2935. err = nf_put_vara_int2(ncid, i, start,
  2936. + edge, value)
  2937. if (.not. canConvert) then
  2938. if (err .ne. NF_ECHAR)
  2939. + call errore('conversion: ', err)
  2940. else
  2941. if (err .ne. NF_EEDGE)
  2942. + call errore('bad edge: ', err)
  2943. endif
  2944. edge(j) = 1
  2945. end if
  2946. 3 continue
  2947. C /* Check correct error returned even when nothing to put */
  2948. do 20, j = 1, var_rank(i)
  2949. edge(j) = 0
  2950. 20 continue
  2951. err = nf_put_vara_int2(BAD_ID, i, start,
  2952. + edge, value)
  2953. if (err .ne. NF_EBADID)
  2954. + call errore('bad ncid: ', err)
  2955. err = nf_put_vara_int2(ncid, BAD_VARID,
  2956. + start, edge, value)
  2957. if (err .ne. NF_ENOTVAR)
  2958. + call errore('bad var id: ', err)
  2959. do 21, j = 1, var_rank(i)
  2960. if (var_dimid(j,i) .gt. 1) then ! skip record dim
  2961. start(j) = var_shape(j,i) + 2
  2962. err = nf_put_vara_int2(ncid, i, start,
  2963. + edge, value)
  2964. if (.not. canConvert) then
  2965. if (err .ne. NF_ECHAR)
  2966. + call errore('conversion: ', err)
  2967. else
  2968. if (err .ne. NF_EINVALCOORDS)
  2969. + call errore('bad start: ', err)
  2970. endif
  2971. start(j) = 1
  2972. endif
  2973. 21 continue
  2974. err = nf_put_vara_int2(ncid, i, start, edge, value)
  2975. if (canConvert) then
  2976. if (err .ne. 0)
  2977. + call error(nf_strerror(err))
  2978. else
  2979. if (err .ne. NF_ECHAR)
  2980. + call errore('wrong type: ', err)
  2981. endif
  2982. do 22, j = 1, var_rank(i)
  2983. edge(j) = 1
  2984. 22 continue
  2985. !/* Choose a random point dividing each dim into 2 parts */
  2986. !/* Put 2^rank (nslabs) slabs so defined */
  2987. nslabs = 1
  2988. do 4, j = 1, var_rank(i)
  2989. mid(j) = roll( var_shape(j,i) )
  2990. nslabs = nslabs * 2
  2991. 4 continue
  2992. !/* bits of k determine whether to put lower or upper part of dim */
  2993. do 5, k = 1, nslabs
  2994. nels = 1
  2995. do 6, j = 1, var_rank(i)
  2996. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  2997. start(j) = 1
  2998. edge(j) = mid(j)
  2999. else
  3000. start(j) = 1 + mid(j)
  3001. edge(j) = var_shape(j,i) - mid(j)
  3002. end if
  3003. nels = nels * edge(j)
  3004. 6 continue
  3005. allInExtRange = .true.
  3006. do 7, j = 1, nels
  3007. err = index2indexes(j, var_rank(i), edge, index)
  3008. if (err .ne. 0)
  3009. + call error('error in index2indexes 1')
  3010. do 8, d = 1, var_rank(i)
  3011. index(d) = index(d) + start(d) - 1
  3012. 8 continue
  3013. value(j)= hash_int2(var_type(i),
  3014. + var_rank(i), index,
  3015. + NFT_INT2)
  3016. val = value(j)
  3017. allInExtRange = allInExtRange .and.
  3018. + inRange3(val, var_type(i), NFT_INT2)
  3019. 7 continue
  3020. err = nf_put_vara_int2(ncid, i, start,
  3021. + edge, value)
  3022. if (canConvert) then
  3023. if (allInExtRange) then
  3024. if (err .ne. 0)
  3025. + call error(nf_strerror(err))
  3026. else
  3027. if (err .ne. NF_ERANGE)
  3028. + call errore('range error: ', err)
  3029. end if
  3030. else
  3031. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  3032. + call errore('wrong type: ', err)
  3033. end if
  3034. 5 continue
  3035. 1 continue
  3036. err = nf_close(ncid)
  3037. if (err .ne. 0)
  3038. + call errore('nf_close: ', err)
  3039. call check_vars_int2(scratch)
  3040. err = nf_delete(scratch)
  3041. if (err .ne. 0)
  3042. + call errorc('delete of scratch file failed: ',
  3043. + scratch)
  3044. end
  3045. #endif
  3046. subroutine test_nf_put_vara_int()
  3047. implicit none
  3048. #include "tests.inc"
  3049. integer ncid
  3050. integer i
  3051. integer j
  3052. integer k
  3053. integer d
  3054. integer err
  3055. integer nslabs
  3056. integer nels
  3057. integer start(MAX_RANK)
  3058. integer edge(MAX_RANK)
  3059. integer mid(MAX_RANK)
  3060. integer index(MAX_RANK)
  3061. logical canConvert !/* Both text or both numeric */
  3062. logical allInExtRange !/* all values within external range? */
  3063. integer value(MAX_NELS)
  3064. doubleprecision val
  3065. integer udshift
  3066. err = nf_create(scratch, NF_CLOBBER, ncid)
  3067. if (err .ne. 0) then
  3068. call errore('nf_create: ', err)
  3069. return
  3070. end if
  3071. call def_dims(ncid)
  3072. call def_vars(ncid)
  3073. err = nf_enddef(ncid)
  3074. if (err .ne. 0)
  3075. + call errore('nf_enddef: ', err)
  3076. do 1, i = 1, NVARS
  3077. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  3078. + (NFT_INT .eq. NFT_TEXT)
  3079. if (.not.(var_rank(i) .le. MAX_RANK))
  3080. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  3081. if (.not.(var_nels(i) .le. MAX_NELS))
  3082. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  3083. do 2, j = 1, var_rank(i)
  3084. start(j) = 1
  3085. edge(j) = 1
  3086. 2 continue
  3087. err = nf_put_vara_int(BAD_ID, i, start,
  3088. + edge, value)
  3089. if (err .ne. NF_EBADID)
  3090. + call errore('bad ncid: ', err)
  3091. err = nf_put_vara_int(ncid, BAD_VARID,
  3092. + start, edge, value)
  3093. if (err .ne. NF_ENOTVAR)
  3094. + call errore('bad var id: ', err)
  3095. do 3, j = 1, var_rank(i)
  3096. if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
  3097. start(j) = var_shape(j,i) + 1
  3098. err = nf_put_vara_int(ncid, i, start,
  3099. + edge, value)
  3100. if (.not. canConvert) then
  3101. if (err .ne. NF_ECHAR)
  3102. + call errore('conversion: ', err)
  3103. else
  3104. if (err .ne. NF_EINVALCOORDS)
  3105. + call errore('bad start: ', err)
  3106. endif
  3107. start(j) = 1
  3108. edge(j) = var_shape(j,i) + 1
  3109. err = nf_put_vara_int(ncid, i, start,
  3110. + edge, value)
  3111. if (.not. canConvert) then
  3112. if (err .ne. NF_ECHAR)
  3113. + call errore('conversion: ', err)
  3114. else
  3115. if (err .ne. NF_EEDGE)
  3116. + call errore('bad edge: ', err)
  3117. endif
  3118. edge(j) = 1
  3119. end if
  3120. 3 continue
  3121. C /* Check correct error returned even when nothing to put */
  3122. do 20, j = 1, var_rank(i)
  3123. edge(j) = 0
  3124. 20 continue
  3125. err = nf_put_vara_int(BAD_ID, i, start,
  3126. + edge, value)
  3127. if (err .ne. NF_EBADID)
  3128. + call errore('bad ncid: ', err)
  3129. err = nf_put_vara_int(ncid, BAD_VARID,
  3130. + start, edge, value)
  3131. if (err .ne. NF_ENOTVAR)
  3132. + call errore('bad var id: ', err)
  3133. do 21, j = 1, var_rank(i)
  3134. if (var_dimid(j,i) .gt. 1) then ! skip record dim
  3135. start(j) = var_shape(j,i) + 2
  3136. err = nf_put_vara_int(ncid, i, start,
  3137. + edge, value)
  3138. if (.not. canConvert) then
  3139. if (err .ne. NF_ECHAR)
  3140. + call errore('conversion: ', err)
  3141. else
  3142. if (err .ne. NF_EINVALCOORDS)
  3143. + call errore('bad start: ', err)
  3144. endif
  3145. start(j) = 1
  3146. endif
  3147. 21 continue
  3148. err = nf_put_vara_int(ncid, i, start, edge, value)
  3149. if (canConvert) then
  3150. if (err .ne. 0)
  3151. + call error(nf_strerror(err))
  3152. else
  3153. if (err .ne. NF_ECHAR)
  3154. + call errore('wrong type: ', err)
  3155. endif
  3156. do 22, j = 1, var_rank(i)
  3157. edge(j) = 1
  3158. 22 continue
  3159. !/* Choose a random point dividing each dim into 2 parts */
  3160. !/* Put 2^rank (nslabs) slabs so defined */
  3161. nslabs = 1
  3162. do 4, j = 1, var_rank(i)
  3163. mid(j) = roll( var_shape(j,i) )
  3164. nslabs = nslabs * 2
  3165. 4 continue
  3166. !/* bits of k determine whether to put lower or upper part of dim */
  3167. do 5, k = 1, nslabs
  3168. nels = 1
  3169. do 6, j = 1, var_rank(i)
  3170. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  3171. start(j) = 1
  3172. edge(j) = mid(j)
  3173. else
  3174. start(j) = 1 + mid(j)
  3175. edge(j) = var_shape(j,i) - mid(j)
  3176. end if
  3177. nels = nels * edge(j)
  3178. 6 continue
  3179. allInExtRange = .true.
  3180. do 7, j = 1, nels
  3181. err = index2indexes(j, var_rank(i), edge, index)
  3182. if (err .ne. 0)
  3183. + call error('error in index2indexes 1')
  3184. do 8, d = 1, var_rank(i)
  3185. index(d) = index(d) + start(d) - 1
  3186. 8 continue
  3187. value(j)= hash_int(var_type(i),
  3188. + var_rank(i), index,
  3189. + NFT_INT)
  3190. val = value(j)
  3191. allInExtRange = allInExtRange .and.
  3192. + inRange3(val, var_type(i), NFT_INT)
  3193. 7 continue
  3194. err = nf_put_vara_int(ncid, i, start,
  3195. + edge, value)
  3196. if (canConvert) then
  3197. if (allInExtRange) then
  3198. if (err .ne. 0)
  3199. + call error(nf_strerror(err))
  3200. else
  3201. if (err .ne. NF_ERANGE)
  3202. + call errore('range error: ', err)
  3203. end if
  3204. else
  3205. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  3206. + call errore('wrong type: ', err)
  3207. end if
  3208. 5 continue
  3209. 1 continue
  3210. err = nf_close(ncid)
  3211. if (err .ne. 0)
  3212. + call errore('nf_close: ', err)
  3213. call check_vars_int(scratch)
  3214. err = nf_delete(scratch)
  3215. if (err .ne. 0)
  3216. + call errorc('delete of scratch file failed: ',
  3217. + scratch)
  3218. end
  3219. subroutine test_nf_put_vara_real()
  3220. implicit none
  3221. #include "tests.inc"
  3222. integer ncid
  3223. integer i
  3224. integer j
  3225. integer k
  3226. integer d
  3227. integer err
  3228. integer nslabs
  3229. integer nels
  3230. integer start(MAX_RANK)
  3231. integer edge(MAX_RANK)
  3232. integer mid(MAX_RANK)
  3233. integer index(MAX_RANK)
  3234. logical canConvert !/* Both text or both numeric */
  3235. logical allInExtRange !/* all values within external range? */
  3236. real value(MAX_NELS)
  3237. doubleprecision val
  3238. integer udshift
  3239. err = nf_create(scratch, NF_CLOBBER, ncid)
  3240. if (err .ne. 0) then
  3241. call errore('nf_create: ', err)
  3242. return
  3243. end if
  3244. call def_dims(ncid)
  3245. call def_vars(ncid)
  3246. err = nf_enddef(ncid)
  3247. if (err .ne. 0)
  3248. + call errore('nf_enddef: ', err)
  3249. do 1, i = 1, NVARS
  3250. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  3251. + (NFT_REAL .eq. NFT_TEXT)
  3252. if (.not.(var_rank(i) .le. MAX_RANK))
  3253. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  3254. if (.not.(var_nels(i) .le. MAX_NELS))
  3255. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  3256. do 2, j = 1, var_rank(i)
  3257. start(j) = 1
  3258. edge(j) = 1
  3259. 2 continue
  3260. err = nf_put_vara_real(BAD_ID, i, start,
  3261. + edge, value)
  3262. if (err .ne. NF_EBADID)
  3263. + call errore('bad ncid: ', err)
  3264. err = nf_put_vara_real(ncid, BAD_VARID,
  3265. + start, edge, value)
  3266. if (err .ne. NF_ENOTVAR)
  3267. + call errore('bad var id: ', err)
  3268. do 3, j = 1, var_rank(i)
  3269. if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
  3270. start(j) = var_shape(j,i) + 1
  3271. err = nf_put_vara_real(ncid, i, start,
  3272. + edge, value)
  3273. if (.not. canConvert) then
  3274. if (err .ne. NF_ECHAR)
  3275. + call errore('conversion: ', err)
  3276. else
  3277. if (err .ne. NF_EINVALCOORDS)
  3278. + call errore('bad start: ', err)
  3279. endif
  3280. start(j) = 1
  3281. edge(j) = var_shape(j,i) + 1
  3282. err = nf_put_vara_real(ncid, i, start,
  3283. + edge, value)
  3284. if (.not. canConvert) then
  3285. if (err .ne. NF_ECHAR)
  3286. + call errore('conversion: ', err)
  3287. else
  3288. if (err .ne. NF_EEDGE)
  3289. + call errore('bad edge: ', err)
  3290. endif
  3291. edge(j) = 1
  3292. end if
  3293. 3 continue
  3294. C /* Check correct error returned even when nothing to put */
  3295. do 20, j = 1, var_rank(i)
  3296. edge(j) = 0
  3297. 20 continue
  3298. err = nf_put_vara_real(BAD_ID, i, start,
  3299. + edge, value)
  3300. if (err .ne. NF_EBADID)
  3301. + call errore('bad ncid: ', err)
  3302. err = nf_put_vara_real(ncid, BAD_VARID,
  3303. + start, edge, value)
  3304. if (err .ne. NF_ENOTVAR)
  3305. + call errore('bad var id: ', err)
  3306. do 21, j = 1, var_rank(i)
  3307. if (var_dimid(j,i) .gt. 1) then ! skip record dim
  3308. start(j) = var_shape(j,i) + 2
  3309. err = nf_put_vara_real(ncid, i, start,
  3310. + edge, value)
  3311. if (.not. canConvert) then
  3312. if (err .ne. NF_ECHAR)
  3313. + call errore('conversion: ', err)
  3314. else
  3315. if (err .ne. NF_EINVALCOORDS)
  3316. + call errore('bad start: ', err)
  3317. endif
  3318. start(j) = 1
  3319. endif
  3320. 21 continue
  3321. err = nf_put_vara_real(ncid, i, start, edge, value)
  3322. if (canConvert) then
  3323. if (err .ne. 0)
  3324. + call error(nf_strerror(err))
  3325. else
  3326. if (err .ne. NF_ECHAR)
  3327. + call errore('wrong type: ', err)
  3328. endif
  3329. do 22, j = 1, var_rank(i)
  3330. edge(j) = 1
  3331. 22 continue
  3332. !/* Choose a random point dividing each dim into 2 parts */
  3333. !/* Put 2^rank (nslabs) slabs so defined */
  3334. nslabs = 1
  3335. do 4, j = 1, var_rank(i)
  3336. mid(j) = roll( var_shape(j,i) )
  3337. nslabs = nslabs * 2
  3338. 4 continue
  3339. !/* bits of k determine whether to put lower or upper part of dim */
  3340. do 5, k = 1, nslabs
  3341. nels = 1
  3342. do 6, j = 1, var_rank(i)
  3343. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  3344. start(j) = 1
  3345. edge(j) = mid(j)
  3346. else
  3347. start(j) = 1 + mid(j)
  3348. edge(j) = var_shape(j,i) - mid(j)
  3349. end if
  3350. nels = nels * edge(j)
  3351. 6 continue
  3352. allInExtRange = .true.
  3353. do 7, j = 1, nels
  3354. err = index2indexes(j, var_rank(i), edge, index)
  3355. if (err .ne. 0)
  3356. + call error('error in index2indexes 1')
  3357. do 8, d = 1, var_rank(i)
  3358. index(d) = index(d) + start(d) - 1
  3359. 8 continue
  3360. value(j)= hash_real(var_type(i),
  3361. + var_rank(i), index,
  3362. + NFT_REAL)
  3363. val = value(j)
  3364. allInExtRange = allInExtRange .and.
  3365. + inRange3(val, var_type(i), NFT_REAL)
  3366. 7 continue
  3367. err = nf_put_vara_real(ncid, i, start,
  3368. + edge, value)
  3369. if (canConvert) then
  3370. if (allInExtRange) then
  3371. if (err .ne. 0)
  3372. + call error(nf_strerror(err))
  3373. else
  3374. if (err .ne. NF_ERANGE)
  3375. + call errore('range error: ', err)
  3376. end if
  3377. else
  3378. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  3379. + call errore('wrong type: ', err)
  3380. end if
  3381. 5 continue
  3382. 1 continue
  3383. err = nf_close(ncid)
  3384. if (err .ne. 0)
  3385. + call errore('nf_close: ', err)
  3386. call check_vars_real(scratch)
  3387. err = nf_delete(scratch)
  3388. if (err .ne. 0)
  3389. + call errorc('delete of scratch file failed: ',
  3390. + scratch)
  3391. end
  3392. subroutine test_nf_put_vara_double()
  3393. implicit none
  3394. #include "tests.inc"
  3395. integer ncid
  3396. integer i
  3397. integer j
  3398. integer k
  3399. integer d
  3400. integer err
  3401. integer nslabs
  3402. integer nels
  3403. integer start(MAX_RANK)
  3404. integer edge(MAX_RANK)
  3405. integer mid(MAX_RANK)
  3406. integer index(MAX_RANK)
  3407. logical canConvert !/* Both text or both numeric */
  3408. logical allInExtRange !/* all values within external range? */
  3409. doubleprecision value(MAX_NELS)
  3410. doubleprecision val
  3411. integer udshift
  3412. err = nf_create(scratch, NF_CLOBBER, ncid)
  3413. if (err .ne. 0) then
  3414. call errore('nf_create: ', err)
  3415. return
  3416. end if
  3417. call def_dims(ncid)
  3418. call def_vars(ncid)
  3419. err = nf_enddef(ncid)
  3420. if (err .ne. 0)
  3421. + call errore('nf_enddef: ', err)
  3422. do 1, i = 1, NVARS
  3423. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  3424. + (NFT_DOUBLE .eq. NFT_TEXT)
  3425. if (.not.(var_rank(i) .le. MAX_RANK))
  3426. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  3427. if (.not.(var_nels(i) .le. MAX_NELS))
  3428. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  3429. do 2, j = 1, var_rank(i)
  3430. start(j) = 1
  3431. edge(j) = 1
  3432. 2 continue
  3433. err = nf_put_vara_double(BAD_ID, i, start,
  3434. + edge, value)
  3435. if (err .ne. NF_EBADID)
  3436. + call errore('bad ncid: ', err)
  3437. err = nf_put_vara_double(ncid, BAD_VARID,
  3438. + start, edge, value)
  3439. if (err .ne. NF_ENOTVAR)
  3440. + call errore('bad var id: ', err)
  3441. do 3, j = 1, var_rank(i)
  3442. if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
  3443. start(j) = var_shape(j,i) + 1
  3444. err = nf_put_vara_double(ncid, i, start,
  3445. + edge, value)
  3446. if (.not. canConvert) then
  3447. if (err .ne. NF_ECHAR)
  3448. + call errore('conversion: ', err)
  3449. else
  3450. if (err .ne. NF_EINVALCOORDS)
  3451. + call errore('bad start: ', err)
  3452. endif
  3453. start(j) = 1
  3454. edge(j) = var_shape(j,i) + 1
  3455. err = nf_put_vara_double(ncid, i, start,
  3456. + edge, value)
  3457. if (.not. canConvert) then
  3458. if (err .ne. NF_ECHAR)
  3459. + call errore('conversion: ', err)
  3460. else
  3461. if (err .ne. NF_EEDGE)
  3462. + call errore('bad edge: ', err)
  3463. endif
  3464. edge(j) = 1
  3465. end if
  3466. 3 continue
  3467. C /* Check correct error returned even when nothing to put */
  3468. do 20, j = 1, var_rank(i)
  3469. edge(j) = 0
  3470. 20 continue
  3471. err = nf_put_vara_double(BAD_ID, i, start,
  3472. + edge, value)
  3473. if (err .ne. NF_EBADID)
  3474. + call errore('bad ncid: ', err)
  3475. err = nf_put_vara_double(ncid, BAD_VARID,
  3476. + start, edge, value)
  3477. if (err .ne. NF_ENOTVAR)
  3478. + call errore('bad var id: ', err)
  3479. do 21, j = 1, var_rank(i)
  3480. if (var_dimid(j,i) .gt. 1) then ! skip record dim
  3481. start(j) = var_shape(j,i) + 2
  3482. err = nf_put_vara_double(ncid, i, start,
  3483. + edge, value)
  3484. if (.not. canConvert) then
  3485. if (err .ne. NF_ECHAR)
  3486. + call errore('conversion: ', err)
  3487. else
  3488. if (err .ne. NF_EINVALCOORDS)
  3489. + call errore('bad start: ', err)
  3490. endif
  3491. start(j) = 1
  3492. endif
  3493. 21 continue
  3494. err = nf_put_vara_double(ncid, i, start, edge, value)
  3495. if (canConvert) then
  3496. if (err .ne. 0)
  3497. + call error(nf_strerror(err))
  3498. else
  3499. if (err .ne. NF_ECHAR)
  3500. + call errore('wrong type: ', err)
  3501. endif
  3502. do 22, j = 1, var_rank(i)
  3503. edge(j) = 1
  3504. 22 continue
  3505. !/* Choose a random point dividing each dim into 2 parts */
  3506. !/* Put 2^rank (nslabs) slabs so defined */
  3507. nslabs = 1
  3508. do 4, j = 1, var_rank(i)
  3509. mid(j) = roll( var_shape(j,i) )
  3510. nslabs = nslabs * 2
  3511. 4 continue
  3512. !/* bits of k determine whether to put lower or upper part of dim */
  3513. do 5, k = 1, nslabs
  3514. nels = 1
  3515. do 6, j = 1, var_rank(i)
  3516. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  3517. start(j) = 1
  3518. edge(j) = mid(j)
  3519. else
  3520. start(j) = 1 + mid(j)
  3521. edge(j) = var_shape(j,i) - mid(j)
  3522. end if
  3523. nels = nels * edge(j)
  3524. 6 continue
  3525. allInExtRange = .true.
  3526. do 7, j = 1, nels
  3527. err = index2indexes(j, var_rank(i), edge, index)
  3528. if (err .ne. 0)
  3529. + call error('error in index2indexes 1')
  3530. do 8, d = 1, var_rank(i)
  3531. index(d) = index(d) + start(d) - 1
  3532. 8 continue
  3533. value(j)= hash_double(var_type(i),
  3534. + var_rank(i), index,
  3535. + NFT_DOUBLE)
  3536. val = value(j)
  3537. allInExtRange = allInExtRange .and.
  3538. + inRange3(val, var_type(i), NFT_DOUBLE)
  3539. 7 continue
  3540. err = nf_put_vara_double(ncid, i, start,
  3541. + edge, value)
  3542. if (canConvert) then
  3543. if (allInExtRange) then
  3544. if (err .ne. 0)
  3545. + call error(nf_strerror(err))
  3546. else
  3547. if (err .ne. NF_ERANGE)
  3548. + call errore('range error: ', err)
  3549. end if
  3550. else
  3551. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  3552. + call errore('wrong type: ', err)
  3553. end if
  3554. 5 continue
  3555. 1 continue
  3556. err = nf_close(ncid)
  3557. if (err .ne. 0)
  3558. + call errore('nf_close: ', err)
  3559. call check_vars_double(scratch)
  3560. err = nf_delete(scratch)
  3561. if (err .ne. 0)
  3562. + call errorc('delete of scratch file failed: ',
  3563. + scratch)
  3564. end
  3565. subroutine test_nf_put_vars_text()
  3566. implicit none
  3567. #include "tests.inc"
  3568. integer ncid
  3569. integer d
  3570. integer i
  3571. integer j
  3572. integer k
  3573. integer m
  3574. integer err
  3575. integer nels
  3576. integer nslabs
  3577. integer nstarts !/* number of different starts */
  3578. integer start(MAX_RANK)
  3579. integer edge(MAX_RANK)
  3580. integer index(MAX_RANK)
  3581. integer index2(MAX_RANK)
  3582. integer mid(MAX_RANK)
  3583. integer count(MAX_RANK)
  3584. integer sstride(MAX_RANK)
  3585. integer stride(MAX_RANK)
  3586. logical canConvert !/* Both text or both numeric */
  3587. logical allInExtRange !/* all values within external range? */
  3588. character value(MAX_NELS)
  3589. doubleprecision val
  3590. integer udshift
  3591. err = nf_create(scratch, NF_CLOBBER, ncid)
  3592. if (err .ne. 0) then
  3593. call errore('nf_create: ', err)
  3594. return
  3595. end if
  3596. call def_dims(ncid)
  3597. call def_vars(ncid)
  3598. err = nf_enddef(ncid)
  3599. if (err .ne. 0)
  3600. + call errore('nf_enddef: ', err)
  3601. do 1, i = 1, NVARS
  3602. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  3603. + (NFT_TEXT .eq. NFT_TEXT)
  3604. if (.not.(var_rank(i) .le. MAX_RANK))
  3605. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  3606. if (.not.(var_nels(i) .le. MAX_NELS))
  3607. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  3608. do 2, j = 1, var_rank(i)
  3609. start(j) = 1
  3610. edge(j) = 1
  3611. stride(j) = 1
  3612. 2 continue
  3613. err = nf_put_vars_text(BAD_ID, i, start,
  3614. + edge, stride, value)
  3615. if (err .ne. NF_EBADID)
  3616. + call errore('bad ncid: ', err)
  3617. err = nf_put_vars_text(ncid, BAD_VARID, start,
  3618. + edge, stride,
  3619. + value)
  3620. if (err .ne. NF_ENOTVAR)
  3621. + call errore('bad var id: ', err)
  3622. do 3, j = 1, var_rank(i)
  3623. if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim
  3624. start(j) = var_shape(j,i) + 2
  3625. err = nf_put_vars_text(ncid, i, start,
  3626. + edge, stride,
  3627. + value)
  3628. if (.not. canConvert) then
  3629. if (err .ne. NF_ECHAR)
  3630. + call errore('conversion: ', err)
  3631. else
  3632. if (err .ne. NF_EINVALCOORDS)
  3633. + call errore('bad start: ', err)
  3634. endif
  3635. start(j) = 1
  3636. edge(j) = var_shape(j,i) + 1
  3637. err = nf_put_vars_text(ncid, i, start,
  3638. + edge, stride,
  3639. + value)
  3640. if (.not. canConvert) then
  3641. if (err .ne. NF_ECHAR)
  3642. + call errore('conversion: ', err)
  3643. else
  3644. if (err .ne. NF_EEDGE)
  3645. + call errore('bad edge: ', err)
  3646. endif
  3647. edge(j) = 1
  3648. stride(j) = 0
  3649. err = nf_put_vars_text(ncid, i, start,
  3650. + edge, stride,
  3651. + value)
  3652. if (.not. canConvert) then
  3653. if (err .ne. NF_ECHAR)
  3654. + call errore('conversion: ', err)
  3655. else
  3656. if (err .ne. NF_ESTRIDE)
  3657. + call errore('bad stride: ', err)
  3658. endif
  3659. stride(j) = 1
  3660. end if
  3661. 3 continue
  3662. !/* Choose a random point dividing each dim into 2 parts */
  3663. !/* Put 2^rank (nslabs) slabs so defined */
  3664. nslabs = 1
  3665. do 4, j = 1, var_rank(i)
  3666. mid(j) = roll( var_shape(j,i) )
  3667. nslabs = nslabs * 2
  3668. 4 continue
  3669. !/* bits of k determine whether to put lower or upper part of dim */
  3670. !/* choose random stride from 1 to edge */
  3671. do 5, k = 1, nslabs
  3672. nstarts = 1
  3673. do 6, j = 1, var_rank(i)
  3674. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  3675. start(j) = 1
  3676. edge(j) = mid(j)
  3677. else
  3678. start(j) = 1 + mid(j)
  3679. edge(j) = var_shape(j,i) - mid(j)
  3680. end if
  3681. if (edge(j) .gt. 0) then
  3682. stride(j) = 1+roll(edge(j))
  3683. else
  3684. stride(j) = 1
  3685. end if
  3686. sstride(j) = stride(j)
  3687. nstarts = nstarts * stride(j)
  3688. 6 continue
  3689. do 7, m = 1, nstarts
  3690. err = index2indexes(m, var_rank(i), sstride, index)
  3691. if (err .ne. 0)
  3692. + call error('error in index2indexes')
  3693. nels = 1
  3694. do 8, j = 1, var_rank(i)
  3695. count(j) = 1 + (edge(j) - index(j)) / stride(j)
  3696. nels = nels * count(j)
  3697. index(j) = index(j) + start(j) - 1
  3698. 8 continue
  3699. !/* Random choice of forward or backward */
  3700. C/* TODO
  3701. C if ( roll(2) ) {
  3702. C for (j = 1 j .lt. var_rank(i) j++) {
  3703. C index(j) += (count(j) - 1) * stride(j)
  3704. C stride(j) = -stride(j)
  3705. C }
  3706. C }
  3707. C*/
  3708. allInExtRange = .true.
  3709. do 9, j = 1, nels
  3710. err = index2indexes(j, var_rank(i), count,
  3711. + index2)
  3712. if (err .ne. 0)
  3713. + call error('error in index2indexes')
  3714. do 10, d = 1, var_rank(i)
  3715. index2(d) = index(d) +
  3716. + (index2(d)-1) * stride(d)
  3717. 10 continue
  3718. value(j) = char(int(hash_text(var_type(i),
  3719. + var_rank(i),
  3720. + index2, NFT_TEXT)))
  3721. val = ichar(value(j))
  3722. allInExtRange = allInExtRange .and.
  3723. + inRange3(val, var_type(i),
  3724. + NFT_TEXT)
  3725. 9 continue
  3726. err = nf_put_vars_text(ncid, i, index,
  3727. + count, stride,
  3728. + value)
  3729. if (canConvert) then
  3730. if (allInExtRange) then
  3731. if (err .ne. 0)
  3732. + call error(nf_strerror(err))
  3733. else
  3734. if (err .ne. NF_ERANGE)
  3735. + call errore('range error: ', err)
  3736. end if
  3737. else
  3738. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  3739. + call errore('wrong type: ', err)
  3740. end if
  3741. 7 continue
  3742. 5 continue
  3743. 1 continue
  3744. err = nf_close(ncid)
  3745. if (err .ne. 0)
  3746. + call errore('nf_close: ', err)
  3747. call check_vars_text(scratch)
  3748. err = nf_delete(scratch)
  3749. if (err .ne. 0)
  3750. + call errorc('delete of scratch file failed:',
  3751. + scratch)
  3752. end
  3753. #ifdef NF_INT1_T
  3754. subroutine test_nf_put_vars_int1()
  3755. implicit none
  3756. #include "tests.inc"
  3757. integer ncid
  3758. integer d
  3759. integer i
  3760. integer j
  3761. integer k
  3762. integer m
  3763. integer err
  3764. integer nels
  3765. integer nslabs
  3766. integer nstarts !/* number of different starts */
  3767. integer start(MAX_RANK)
  3768. integer edge(MAX_RANK)
  3769. integer index(MAX_RANK)
  3770. integer index2(MAX_RANK)
  3771. integer mid(MAX_RANK)
  3772. integer count(MAX_RANK)
  3773. integer sstride(MAX_RANK)
  3774. integer stride(MAX_RANK)
  3775. logical canConvert !/* Both text or both numeric */
  3776. logical allInExtRange !/* all values within external range? */
  3777. NF_INT1_T value(MAX_NELS)
  3778. doubleprecision val
  3779. integer udshift
  3780. err = nf_create(scratch, NF_CLOBBER, ncid)
  3781. if (err .ne. 0) then
  3782. call errore('nf_create: ', err)
  3783. return
  3784. end if
  3785. call def_dims(ncid)
  3786. call def_vars(ncid)
  3787. err = nf_enddef(ncid)
  3788. if (err .ne. 0)
  3789. + call errore('nf_enddef: ', err)
  3790. do 1, i = 1, NVARS
  3791. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  3792. + (NFT_INT1 .eq. NFT_TEXT)
  3793. if (.not.(var_rank(i) .le. MAX_RANK))
  3794. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  3795. if (.not.(var_nels(i) .le. MAX_NELS))
  3796. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  3797. do 2, j = 1, var_rank(i)
  3798. start(j) = 1
  3799. edge(j) = 1
  3800. stride(j) = 1
  3801. 2 continue
  3802. err = nf_put_vars_int1(BAD_ID, i, start,
  3803. + edge, stride, value)
  3804. if (err .ne. NF_EBADID)
  3805. + call errore('bad ncid: ', err)
  3806. err = nf_put_vars_int1(ncid, BAD_VARID, start,
  3807. + edge, stride,
  3808. + value)
  3809. if (err .ne. NF_ENOTVAR)
  3810. + call errore('bad var id: ', err)
  3811. do 3, j = 1, var_rank(i)
  3812. if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim
  3813. start(j) = var_shape(j,i) + 2
  3814. err = nf_put_vars_int1(ncid, i, start,
  3815. + edge, stride,
  3816. + value)
  3817. if (.not. canConvert) then
  3818. if (err .ne. NF_ECHAR)
  3819. + call errore('conversion: ', err)
  3820. else
  3821. if (err .ne. NF_EINVALCOORDS)
  3822. + call errore('bad start: ', err)
  3823. endif
  3824. start(j) = 1
  3825. edge(j) = var_shape(j,i) + 1
  3826. err = nf_put_vars_int1(ncid, i, start,
  3827. + edge, stride,
  3828. + value)
  3829. if (.not. canConvert) then
  3830. if (err .ne. NF_ECHAR)
  3831. + call errore('conversion: ', err)
  3832. else
  3833. if (err .ne. NF_EEDGE)
  3834. + call errore('bad edge: ', err)
  3835. endif
  3836. edge(j) = 1
  3837. stride(j) = 0
  3838. err = nf_put_vars_int1(ncid, i, start,
  3839. + edge, stride,
  3840. + value)
  3841. if (.not. canConvert) then
  3842. if (err .ne. NF_ECHAR)
  3843. + call errore('conversion: ', err)
  3844. else
  3845. if (err .ne. NF_ESTRIDE)
  3846. + call errore('bad stride: ', err)
  3847. endif
  3848. stride(j) = 1
  3849. end if
  3850. 3 continue
  3851. !/* Choose a random point dividing each dim into 2 parts */
  3852. !/* Put 2^rank (nslabs) slabs so defined */
  3853. nslabs = 1
  3854. do 4, j = 1, var_rank(i)
  3855. mid(j) = roll( var_shape(j,i) )
  3856. nslabs = nslabs * 2
  3857. 4 continue
  3858. !/* bits of k determine whether to put lower or upper part of dim */
  3859. !/* choose random stride from 1 to edge */
  3860. do 5, k = 1, nslabs
  3861. nstarts = 1
  3862. do 6, j = 1, var_rank(i)
  3863. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  3864. start(j) = 1
  3865. edge(j) = mid(j)
  3866. else
  3867. start(j) = 1 + mid(j)
  3868. edge(j) = var_shape(j,i) - mid(j)
  3869. end if
  3870. if (edge(j) .gt. 0) then
  3871. stride(j) = 1+roll(edge(j))
  3872. else
  3873. stride(j) = 1
  3874. end if
  3875. sstride(j) = stride(j)
  3876. nstarts = nstarts * stride(j)
  3877. 6 continue
  3878. do 7, m = 1, nstarts
  3879. err = index2indexes(m, var_rank(i), sstride, index)
  3880. if (err .ne. 0)
  3881. + call error('error in index2indexes')
  3882. nels = 1
  3883. do 8, j = 1, var_rank(i)
  3884. count(j) = 1 + (edge(j) - index(j)) / stride(j)
  3885. nels = nels * count(j)
  3886. index(j) = index(j) + start(j) - 1
  3887. 8 continue
  3888. !/* Random choice of forward or backward */
  3889. C/* TODO
  3890. C if ( roll(2) ) {
  3891. C for (j = 1 j .lt. var_rank(i) j++) {
  3892. C index(j) += (count(j) - 1) * stride(j)
  3893. C stride(j) = -stride(j)
  3894. C }
  3895. C }
  3896. C*/
  3897. allInExtRange = .true.
  3898. do 9, j = 1, nels
  3899. err = index2indexes(j, var_rank(i), count,
  3900. + index2)
  3901. if (err .ne. 0)
  3902. + call error('error in index2indexes')
  3903. do 10, d = 1, var_rank(i)
  3904. index2(d) = index(d) +
  3905. + (index2(d)-1) * stride(d)
  3906. 10 continue
  3907. value(j) = hash_int1(var_type(i),
  3908. + var_rank(i),
  3909. + index2, NFT_INT1)
  3910. val = value(j)
  3911. allInExtRange = allInExtRange .and.
  3912. + inRange3(val, var_type(i),
  3913. + NFT_INT1)
  3914. 9 continue
  3915. err = nf_put_vars_int1(ncid, i, index,
  3916. + count, stride,
  3917. + value)
  3918. if (canConvert) then
  3919. if (allInExtRange) then
  3920. if (err .ne. 0)
  3921. + call error(nf_strerror(err))
  3922. else
  3923. if (err .ne. NF_ERANGE)
  3924. + call errore('range error: ', err)
  3925. end if
  3926. else
  3927. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  3928. + call errore('wrong type: ', err)
  3929. end if
  3930. 7 continue
  3931. 5 continue
  3932. 1 continue
  3933. err = nf_close(ncid)
  3934. if (err .ne. 0)
  3935. + call errore('nf_close: ', err)
  3936. call check_vars_int1(scratch)
  3937. err = nf_delete(scratch)
  3938. if (err .ne. 0)
  3939. + call errorc('delete of scratch file failed:',
  3940. + scratch)
  3941. end
  3942. #endif
  3943. #ifdef NF_INT2_T
  3944. subroutine test_nf_put_vars_int2()
  3945. implicit none
  3946. #include "tests.inc"
  3947. integer ncid
  3948. integer d
  3949. integer i
  3950. integer j
  3951. integer k
  3952. integer m
  3953. integer err
  3954. integer nels
  3955. integer nslabs
  3956. integer nstarts !/* number of different starts */
  3957. integer start(MAX_RANK)
  3958. integer edge(MAX_RANK)
  3959. integer index(MAX_RANK)
  3960. integer index2(MAX_RANK)
  3961. integer mid(MAX_RANK)
  3962. integer count(MAX_RANK)
  3963. integer sstride(MAX_RANK)
  3964. integer stride(MAX_RANK)
  3965. logical canConvert !/* Both text or both numeric */
  3966. logical allInExtRange !/* all values within external range? */
  3967. NF_INT2_T value(MAX_NELS)
  3968. doubleprecision val
  3969. integer udshift
  3970. err = nf_create(scratch, NF_CLOBBER, ncid)
  3971. if (err .ne. 0) then
  3972. call errore('nf_create: ', err)
  3973. return
  3974. end if
  3975. call def_dims(ncid)
  3976. call def_vars(ncid)
  3977. err = nf_enddef(ncid)
  3978. if (err .ne. 0)
  3979. + call errore('nf_enddef: ', err)
  3980. do 1, i = 1, NVARS
  3981. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  3982. + (NFT_INT2 .eq. NFT_TEXT)
  3983. if (.not.(var_rank(i) .le. MAX_RANK))
  3984. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  3985. if (.not.(var_nels(i) .le. MAX_NELS))
  3986. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  3987. do 2, j = 1, var_rank(i)
  3988. start(j) = 1
  3989. edge(j) = 1
  3990. stride(j) = 1
  3991. 2 continue
  3992. err = nf_put_vars_int2(BAD_ID, i, start,
  3993. + edge, stride, value)
  3994. if (err .ne. NF_EBADID)
  3995. + call errore('bad ncid: ', err)
  3996. err = nf_put_vars_int2(ncid, BAD_VARID, start,
  3997. + edge, stride,
  3998. + value)
  3999. if (err .ne. NF_ENOTVAR)
  4000. + call errore('bad var id: ', err)
  4001. do 3, j = 1, var_rank(i)
  4002. if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim
  4003. start(j) = var_shape(j,i) + 2
  4004. err = nf_put_vars_int2(ncid, i, start,
  4005. + edge, stride,
  4006. + value)
  4007. if (.not. canConvert) then
  4008. if (err .ne. NF_ECHAR)
  4009. + call errore('conversion: ', err)
  4010. else
  4011. if (err .ne. NF_EINVALCOORDS)
  4012. + call errore('bad start: ', err)
  4013. endif
  4014. start(j) = 1
  4015. edge(j) = var_shape(j,i) + 1
  4016. err = nf_put_vars_int2(ncid, i, start,
  4017. + edge, stride,
  4018. + value)
  4019. if (.not. canConvert) then
  4020. if (err .ne. NF_ECHAR)
  4021. + call errore('conversion: ', err)
  4022. else
  4023. if (err .ne. NF_EEDGE)
  4024. + call errore('bad edge: ', err)
  4025. endif
  4026. edge(j) = 1
  4027. stride(j) = 0
  4028. err = nf_put_vars_int2(ncid, i, start,
  4029. + edge, stride,
  4030. + value)
  4031. if (.not. canConvert) then
  4032. if (err .ne. NF_ECHAR)
  4033. + call errore('conversion: ', err)
  4034. else
  4035. if (err .ne. NF_ESTRIDE)
  4036. + call errore('bad stride: ', err)
  4037. endif
  4038. stride(j) = 1
  4039. end if
  4040. 3 continue
  4041. !/* Choose a random point dividing each dim into 2 parts */
  4042. !/* Put 2^rank (nslabs) slabs so defined */
  4043. nslabs = 1
  4044. do 4, j = 1, var_rank(i)
  4045. mid(j) = roll( var_shape(j,i) )
  4046. nslabs = nslabs * 2
  4047. 4 continue
  4048. !/* bits of k determine whether to put lower or upper part of dim */
  4049. !/* choose random stride from 1 to edge */
  4050. do 5, k = 1, nslabs
  4051. nstarts = 1
  4052. do 6, j = 1, var_rank(i)
  4053. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  4054. start(j) = 1
  4055. edge(j) = mid(j)
  4056. else
  4057. start(j) = 1 + mid(j)
  4058. edge(j) = var_shape(j,i) - mid(j)
  4059. end if
  4060. if (edge(j) .gt. 0) then
  4061. stride(j) = 1+roll(edge(j))
  4062. else
  4063. stride(j) = 1
  4064. end if
  4065. sstride(j) = stride(j)
  4066. nstarts = nstarts * stride(j)
  4067. 6 continue
  4068. do 7, m = 1, nstarts
  4069. err = index2indexes(m, var_rank(i), sstride, index)
  4070. if (err .ne. 0)
  4071. + call error('error in index2indexes')
  4072. nels = 1
  4073. do 8, j = 1, var_rank(i)
  4074. count(j) = 1 + (edge(j) - index(j)) / stride(j)
  4075. nels = nels * count(j)
  4076. index(j) = index(j) + start(j) - 1
  4077. 8 continue
  4078. !/* Random choice of forward or backward */
  4079. C/* TODO
  4080. C if ( roll(2) ) {
  4081. C for (j = 1 j .lt. var_rank(i) j++) {
  4082. C index(j) += (count(j) - 1) * stride(j)
  4083. C stride(j) = -stride(j)
  4084. C }
  4085. C }
  4086. C*/
  4087. allInExtRange = .true.
  4088. do 9, j = 1, nels
  4089. err = index2indexes(j, var_rank(i), count,
  4090. + index2)
  4091. if (err .ne. 0)
  4092. + call error('error in index2indexes')
  4093. do 10, d = 1, var_rank(i)
  4094. index2(d) = index(d) +
  4095. + (index2(d)-1) * stride(d)
  4096. 10 continue
  4097. value(j) = hash_int2(var_type(i),
  4098. + var_rank(i),
  4099. + index2, NFT_INT2)
  4100. val = value(j)
  4101. allInExtRange = allInExtRange .and.
  4102. + inRange3(val, var_type(i),
  4103. + NFT_INT2)
  4104. 9 continue
  4105. err = nf_put_vars_int2(ncid, i, index,
  4106. + count, stride,
  4107. + value)
  4108. if (canConvert) then
  4109. if (allInExtRange) then
  4110. if (err .ne. 0)
  4111. + call error(nf_strerror(err))
  4112. else
  4113. if (err .ne. NF_ERANGE)
  4114. + call errore('range error: ', err)
  4115. end if
  4116. else
  4117. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  4118. + call errore('wrong type: ', err)
  4119. end if
  4120. 7 continue
  4121. 5 continue
  4122. 1 continue
  4123. err = nf_close(ncid)
  4124. if (err .ne. 0)
  4125. + call errore('nf_close: ', err)
  4126. call check_vars_int2(scratch)
  4127. err = nf_delete(scratch)
  4128. if (err .ne. 0)
  4129. + call errorc('delete of scratch file failed:',
  4130. + scratch)
  4131. end
  4132. #endif
  4133. subroutine test_nf_put_vars_int()
  4134. implicit none
  4135. #include "tests.inc"
  4136. integer ncid
  4137. integer d
  4138. integer i
  4139. integer j
  4140. integer k
  4141. integer m
  4142. integer err
  4143. integer nels
  4144. integer nslabs
  4145. integer nstarts !/* number of different starts */
  4146. integer start(MAX_RANK)
  4147. integer edge(MAX_RANK)
  4148. integer index(MAX_RANK)
  4149. integer index2(MAX_RANK)
  4150. integer mid(MAX_RANK)
  4151. integer count(MAX_RANK)
  4152. integer sstride(MAX_RANK)
  4153. integer stride(MAX_RANK)
  4154. logical canConvert !/* Both text or both numeric */
  4155. logical allInExtRange !/* all values within external range? */
  4156. integer value(MAX_NELS)
  4157. doubleprecision val
  4158. integer udshift
  4159. err = nf_create(scratch, NF_CLOBBER, ncid)
  4160. if (err .ne. 0) then
  4161. call errore('nf_create: ', err)
  4162. return
  4163. end if
  4164. call def_dims(ncid)
  4165. call def_vars(ncid)
  4166. err = nf_enddef(ncid)
  4167. if (err .ne. 0)
  4168. + call errore('nf_enddef: ', err)
  4169. do 1, i = 1, NVARS
  4170. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  4171. + (NFT_INT .eq. NFT_TEXT)
  4172. if (.not.(var_rank(i) .le. MAX_RANK))
  4173. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  4174. if (.not.(var_nels(i) .le. MAX_NELS))
  4175. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  4176. do 2, j = 1, var_rank(i)
  4177. start(j) = 1
  4178. edge(j) = 1
  4179. stride(j) = 1
  4180. 2 continue
  4181. err = nf_put_vars_int(BAD_ID, i, start,
  4182. + edge, stride, value)
  4183. if (err .ne. NF_EBADID)
  4184. + call errore('bad ncid: ', err)
  4185. err = nf_put_vars_int(ncid, BAD_VARID, start,
  4186. + edge, stride,
  4187. + value)
  4188. if (err .ne. NF_ENOTVAR)
  4189. + call errore('bad var id: ', err)
  4190. do 3, j = 1, var_rank(i)
  4191. if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim
  4192. start(j) = var_shape(j,i) + 2
  4193. err = nf_put_vars_int(ncid, i, start,
  4194. + edge, stride,
  4195. + value)
  4196. if (.not. canConvert) then
  4197. if (err .ne. NF_ECHAR)
  4198. + call errore('conversion: ', err)
  4199. else
  4200. if (err .ne. NF_EINVALCOORDS)
  4201. + call errore('bad start: ', err)
  4202. endif
  4203. start(j) = 1
  4204. edge(j) = var_shape(j,i) + 1
  4205. err = nf_put_vars_int(ncid, i, start,
  4206. + edge, stride,
  4207. + value)
  4208. if (.not. canConvert) then
  4209. if (err .ne. NF_ECHAR)
  4210. + call errore('conversion: ', err)
  4211. else
  4212. if (err .ne. NF_EEDGE)
  4213. + call errore('bad edge: ', err)
  4214. endif
  4215. edge(j) = 1
  4216. stride(j) = 0
  4217. err = nf_put_vars_int(ncid, i, start,
  4218. + edge, stride,
  4219. + value)
  4220. if (.not. canConvert) then
  4221. if (err .ne. NF_ECHAR)
  4222. + call errore('conversion: ', err)
  4223. else
  4224. if (err .ne. NF_ESTRIDE)
  4225. + call errore('bad stride: ', err)
  4226. endif
  4227. stride(j) = 1
  4228. end if
  4229. 3 continue
  4230. !/* Choose a random point dividing each dim into 2 parts */
  4231. !/* Put 2^rank (nslabs) slabs so defined */
  4232. nslabs = 1
  4233. do 4, j = 1, var_rank(i)
  4234. mid(j) = roll( var_shape(j,i) )
  4235. nslabs = nslabs * 2
  4236. 4 continue
  4237. !/* bits of k determine whether to put lower or upper part of dim */
  4238. !/* choose random stride from 1 to edge */
  4239. do 5, k = 1, nslabs
  4240. nstarts = 1
  4241. do 6, j = 1, var_rank(i)
  4242. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  4243. start(j) = 1
  4244. edge(j) = mid(j)
  4245. else
  4246. start(j) = 1 + mid(j)
  4247. edge(j) = var_shape(j,i) - mid(j)
  4248. end if
  4249. if (edge(j) .gt. 0) then
  4250. stride(j) = 1+roll(edge(j))
  4251. else
  4252. stride(j) = 1
  4253. end if
  4254. sstride(j) = stride(j)
  4255. nstarts = nstarts * stride(j)
  4256. 6 continue
  4257. do 7, m = 1, nstarts
  4258. err = index2indexes(m, var_rank(i), sstride, index)
  4259. if (err .ne. 0)
  4260. + call error('error in index2indexes')
  4261. nels = 1
  4262. do 8, j = 1, var_rank(i)
  4263. count(j) = 1 + (edge(j) - index(j)) / stride(j)
  4264. nels = nels * count(j)
  4265. index(j) = index(j) + start(j) - 1
  4266. 8 continue
  4267. !/* Random choice of forward or backward */
  4268. C/* TODO
  4269. C if ( roll(2) ) {
  4270. C for (j = 1 j .lt. var_rank(i) j++) {
  4271. C index(j) += (count(j) - 1) * stride(j)
  4272. C stride(j) = -stride(j)
  4273. C }
  4274. C }
  4275. C*/
  4276. allInExtRange = .true.
  4277. do 9, j = 1, nels
  4278. err = index2indexes(j, var_rank(i), count,
  4279. + index2)
  4280. if (err .ne. 0)
  4281. + call error('error in index2indexes')
  4282. do 10, d = 1, var_rank(i)
  4283. index2(d) = index(d) +
  4284. + (index2(d)-1) * stride(d)
  4285. 10 continue
  4286. value(j) = hash_int(var_type(i),
  4287. + var_rank(i),
  4288. + index2, NFT_INT)
  4289. val = value(j)
  4290. allInExtRange = allInExtRange .and.
  4291. + inRange3(val, var_type(i),
  4292. + NFT_INT)
  4293. 9 continue
  4294. err = nf_put_vars_int(ncid, i, index,
  4295. + count, stride,
  4296. + value)
  4297. if (canConvert) then
  4298. if (allInExtRange) then
  4299. if (err .ne. 0)
  4300. + call error(nf_strerror(err))
  4301. else
  4302. if (err .ne. NF_ERANGE)
  4303. + call errore('range error: ', err)
  4304. end if
  4305. else
  4306. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  4307. + call errore('wrong type: ', err)
  4308. end if
  4309. 7 continue
  4310. 5 continue
  4311. 1 continue
  4312. err = nf_close(ncid)
  4313. if (err .ne. 0)
  4314. + call errore('nf_close: ', err)
  4315. call check_vars_int(scratch)
  4316. err = nf_delete(scratch)
  4317. if (err .ne. 0)
  4318. + call errorc('delete of scratch file failed:',
  4319. + scratch)
  4320. end
  4321. subroutine test_nf_put_vars_real()
  4322. implicit none
  4323. #include "tests.inc"
  4324. integer ncid
  4325. integer d
  4326. integer i
  4327. integer j
  4328. integer k
  4329. integer m
  4330. integer err
  4331. integer nels
  4332. integer nslabs
  4333. integer nstarts !/* number of different starts */
  4334. integer start(MAX_RANK)
  4335. integer edge(MAX_RANK)
  4336. integer index(MAX_RANK)
  4337. integer index2(MAX_RANK)
  4338. integer mid(MAX_RANK)
  4339. integer count(MAX_RANK)
  4340. integer sstride(MAX_RANK)
  4341. integer stride(MAX_RANK)
  4342. logical canConvert !/* Both text or both numeric */
  4343. logical allInExtRange !/* all values within external range? */
  4344. real value(MAX_NELS)
  4345. doubleprecision val
  4346. integer udshift
  4347. err = nf_create(scratch, NF_CLOBBER, ncid)
  4348. if (err .ne. 0) then
  4349. call errore('nf_create: ', err)
  4350. return
  4351. end if
  4352. call def_dims(ncid)
  4353. call def_vars(ncid)
  4354. err = nf_enddef(ncid)
  4355. if (err .ne. 0)
  4356. + call errore('nf_enddef: ', err)
  4357. do 1, i = 1, NVARS
  4358. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  4359. + (NFT_REAL .eq. NFT_TEXT)
  4360. if (.not.(var_rank(i) .le. MAX_RANK))
  4361. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  4362. if (.not.(var_nels(i) .le. MAX_NELS))
  4363. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  4364. do 2, j = 1, var_rank(i)
  4365. start(j) = 1
  4366. edge(j) = 1
  4367. stride(j) = 1
  4368. 2 continue
  4369. err = nf_put_vars_real(BAD_ID, i, start,
  4370. + edge, stride, value)
  4371. if (err .ne. NF_EBADID)
  4372. + call errore('bad ncid: ', err)
  4373. err = nf_put_vars_real(ncid, BAD_VARID, start,
  4374. + edge, stride,
  4375. + value)
  4376. if (err .ne. NF_ENOTVAR)
  4377. + call errore('bad var id: ', err)
  4378. do 3, j = 1, var_rank(i)
  4379. if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim
  4380. start(j) = var_shape(j,i) + 2
  4381. err = nf_put_vars_real(ncid, i, start,
  4382. + edge, stride,
  4383. + value)
  4384. if (.not. canConvert) then
  4385. if (err .ne. NF_ECHAR)
  4386. + call errore('conversion: ', err)
  4387. else
  4388. if (err .ne. NF_EINVALCOORDS)
  4389. + call errore('bad start: ', err)
  4390. endif
  4391. start(j) = 1
  4392. edge(j) = var_shape(j,i) + 1
  4393. err = nf_put_vars_real(ncid, i, start,
  4394. + edge, stride,
  4395. + value)
  4396. if (.not. canConvert) then
  4397. if (err .ne. NF_ECHAR)
  4398. + call errore('conversion: ', err)
  4399. else
  4400. if (err .ne. NF_EEDGE)
  4401. + call errore('bad edge: ', err)
  4402. endif
  4403. edge(j) = 1
  4404. stride(j) = 0
  4405. err = nf_put_vars_real(ncid, i, start,
  4406. + edge, stride,
  4407. + value)
  4408. if (.not. canConvert) then
  4409. if (err .ne. NF_ECHAR)
  4410. + call errore('conversion: ', err)
  4411. else
  4412. if (err .ne. NF_ESTRIDE)
  4413. + call errore('bad stride: ', err)
  4414. endif
  4415. stride(j) = 1
  4416. end if
  4417. 3 continue
  4418. !/* Choose a random point dividing each dim into 2 parts */
  4419. !/* Put 2^rank (nslabs) slabs so defined */
  4420. nslabs = 1
  4421. do 4, j = 1, var_rank(i)
  4422. mid(j) = roll( var_shape(j,i) )
  4423. nslabs = nslabs * 2
  4424. 4 continue
  4425. !/* bits of k determine whether to put lower or upper part of dim */
  4426. !/* choose random stride from 1 to edge */
  4427. do 5, k = 1, nslabs
  4428. nstarts = 1
  4429. do 6, j = 1, var_rank(i)
  4430. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  4431. start(j) = 1
  4432. edge(j) = mid(j)
  4433. else
  4434. start(j) = 1 + mid(j)
  4435. edge(j) = var_shape(j,i) - mid(j)
  4436. end if
  4437. if (edge(j) .gt. 0) then
  4438. stride(j) = 1+roll(edge(j))
  4439. else
  4440. stride(j) = 1
  4441. end if
  4442. sstride(j) = stride(j)
  4443. nstarts = nstarts * stride(j)
  4444. 6 continue
  4445. do 7, m = 1, nstarts
  4446. err = index2indexes(m, var_rank(i), sstride, index)
  4447. if (err .ne. 0)
  4448. + call error('error in index2indexes')
  4449. nels = 1
  4450. do 8, j = 1, var_rank(i)
  4451. count(j) = 1 + (edge(j) - index(j)) / stride(j)
  4452. nels = nels * count(j)
  4453. index(j) = index(j) + start(j) - 1
  4454. 8 continue
  4455. !/* Random choice of forward or backward */
  4456. C/* TODO
  4457. C if ( roll(2) ) {
  4458. C for (j = 1 j .lt. var_rank(i) j++) {
  4459. C index(j) += (count(j) - 1) * stride(j)
  4460. C stride(j) = -stride(j)
  4461. C }
  4462. C }
  4463. C*/
  4464. allInExtRange = .true.
  4465. do 9, j = 1, nels
  4466. err = index2indexes(j, var_rank(i), count,
  4467. + index2)
  4468. if (err .ne. 0)
  4469. + call error('error in index2indexes')
  4470. do 10, d = 1, var_rank(i)
  4471. index2(d) = index(d) +
  4472. + (index2(d)-1) * stride(d)
  4473. 10 continue
  4474. value(j) = hash_real(var_type(i),
  4475. + var_rank(i),
  4476. + index2, NFT_REAL)
  4477. val = value(j)
  4478. allInExtRange = allInExtRange .and.
  4479. + inRange3(val, var_type(i),
  4480. + NFT_REAL)
  4481. 9 continue
  4482. err = nf_put_vars_real(ncid, i, index,
  4483. + count, stride,
  4484. + value)
  4485. if (canConvert) then
  4486. if (allInExtRange) then
  4487. if (err .ne. 0)
  4488. + call error(nf_strerror(err))
  4489. else
  4490. if (err .ne. NF_ERANGE)
  4491. + call errore('range error: ', err)
  4492. end if
  4493. else
  4494. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  4495. + call errore('wrong type: ', err)
  4496. end if
  4497. 7 continue
  4498. 5 continue
  4499. 1 continue
  4500. err = nf_close(ncid)
  4501. if (err .ne. 0)
  4502. + call errore('nf_close: ', err)
  4503. call check_vars_real(scratch)
  4504. err = nf_delete(scratch)
  4505. if (err .ne. 0)
  4506. + call errorc('delete of scratch file failed:',
  4507. + scratch)
  4508. end
  4509. subroutine test_nf_put_vars_double()
  4510. implicit none
  4511. #include "tests.inc"
  4512. integer ncid
  4513. integer d
  4514. integer i
  4515. integer j
  4516. integer k
  4517. integer m
  4518. integer err
  4519. integer nels
  4520. integer nslabs
  4521. integer nstarts !/* number of different starts */
  4522. integer start(MAX_RANK)
  4523. integer edge(MAX_RANK)
  4524. integer index(MAX_RANK)
  4525. integer index2(MAX_RANK)
  4526. integer mid(MAX_RANK)
  4527. integer count(MAX_RANK)
  4528. integer sstride(MAX_RANK)
  4529. integer stride(MAX_RANK)
  4530. logical canConvert !/* Both text or both numeric */
  4531. logical allInExtRange !/* all values within external range? */
  4532. doubleprecision value(MAX_NELS)
  4533. doubleprecision val
  4534. integer udshift
  4535. err = nf_create(scratch, NF_CLOBBER, ncid)
  4536. if (err .ne. 0) then
  4537. call errore('nf_create: ', err)
  4538. return
  4539. end if
  4540. call def_dims(ncid)
  4541. call def_vars(ncid)
  4542. err = nf_enddef(ncid)
  4543. if (err .ne. 0)
  4544. + call errore('nf_enddef: ', err)
  4545. do 1, i = 1, NVARS
  4546. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  4547. + (NFT_DOUBLE .eq. NFT_TEXT)
  4548. if (.not.(var_rank(i) .le. MAX_RANK))
  4549. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  4550. if (.not.(var_nels(i) .le. MAX_NELS))
  4551. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  4552. do 2, j = 1, var_rank(i)
  4553. start(j) = 1
  4554. edge(j) = 1
  4555. stride(j) = 1
  4556. 2 continue
  4557. err = nf_put_vars_double(BAD_ID, i, start,
  4558. + edge, stride, value)
  4559. if (err .ne. NF_EBADID)
  4560. + call errore('bad ncid: ', err)
  4561. err = nf_put_vars_double(ncid, BAD_VARID, start,
  4562. + edge, stride,
  4563. + value)
  4564. if (err .ne. NF_ENOTVAR)
  4565. + call errore('bad var id: ', err)
  4566. do 3, j = 1, var_rank(i)
  4567. if (var_dimid(j,i) .ne. RECDIM) then ! skip record dim
  4568. start(j) = var_shape(j,i) + 2
  4569. err = nf_put_vars_double(ncid, i, start,
  4570. + edge, stride,
  4571. + value)
  4572. if (.not. canConvert) then
  4573. if (err .ne. NF_ECHAR)
  4574. + call errore('conversion: ', err)
  4575. else
  4576. if (err .ne. NF_EINVALCOORDS)
  4577. + call errore('bad start: ', err)
  4578. endif
  4579. start(j) = 1
  4580. edge(j) = var_shape(j,i) + 1
  4581. err = nf_put_vars_double(ncid, i, start,
  4582. + edge, stride,
  4583. + value)
  4584. if (.not. canConvert) then
  4585. if (err .ne. NF_ECHAR)
  4586. + call errore('conversion: ', err)
  4587. else
  4588. if (err .ne. NF_EEDGE)
  4589. + call errore('bad edge: ', err)
  4590. endif
  4591. edge(j) = 1
  4592. stride(j) = 0
  4593. err = nf_put_vars_double(ncid, i, start,
  4594. + edge, stride,
  4595. + value)
  4596. if (.not. canConvert) then
  4597. if (err .ne. NF_ECHAR)
  4598. + call errore('conversion: ', err)
  4599. else
  4600. if (err .ne. NF_ESTRIDE)
  4601. + call errore('bad stride: ', err)
  4602. endif
  4603. stride(j) = 1
  4604. end if
  4605. 3 continue
  4606. !/* Choose a random point dividing each dim into 2 parts */
  4607. !/* Put 2^rank (nslabs) slabs so defined */
  4608. nslabs = 1
  4609. do 4, j = 1, var_rank(i)
  4610. mid(j) = roll( var_shape(j,i) )
  4611. nslabs = nslabs * 2
  4612. 4 continue
  4613. !/* bits of k determine whether to put lower or upper part of dim */
  4614. !/* choose random stride from 1 to edge */
  4615. do 5, k = 1, nslabs
  4616. nstarts = 1
  4617. do 6, j = 1, var_rank(i)
  4618. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  4619. start(j) = 1
  4620. edge(j) = mid(j)
  4621. else
  4622. start(j) = 1 + mid(j)
  4623. edge(j) = var_shape(j,i) - mid(j)
  4624. end if
  4625. if (edge(j) .gt. 0) then
  4626. stride(j) = 1+roll(edge(j))
  4627. else
  4628. stride(j) = 1
  4629. end if
  4630. sstride(j) = stride(j)
  4631. nstarts = nstarts * stride(j)
  4632. 6 continue
  4633. do 7, m = 1, nstarts
  4634. err = index2indexes(m, var_rank(i), sstride, index)
  4635. if (err .ne. 0)
  4636. + call error('error in index2indexes')
  4637. nels = 1
  4638. do 8, j = 1, var_rank(i)
  4639. count(j) = 1 + (edge(j) - index(j)) / stride(j)
  4640. nels = nels * count(j)
  4641. index(j) = index(j) + start(j) - 1
  4642. 8 continue
  4643. !/* Random choice of forward or backward */
  4644. C/* TODO
  4645. C if ( roll(2) ) {
  4646. C for (j = 1 j .lt. var_rank(i) j++) {
  4647. C index(j) += (count(j) - 1) * stride(j)
  4648. C stride(j) = -stride(j)
  4649. C }
  4650. C }
  4651. C*/
  4652. allInExtRange = .true.
  4653. do 9, j = 1, nels
  4654. err = index2indexes(j, var_rank(i), count,
  4655. + index2)
  4656. if (err .ne. 0)
  4657. + call error('error in index2indexes')
  4658. do 10, d = 1, var_rank(i)
  4659. index2(d) = index(d) +
  4660. + (index2(d)-1) * stride(d)
  4661. 10 continue
  4662. value(j) = hash_double(var_type(i),
  4663. + var_rank(i),
  4664. + index2, NFT_DOUBLE)
  4665. val = value(j)
  4666. allInExtRange = allInExtRange .and.
  4667. + inRange3(val, var_type(i),
  4668. + NFT_DOUBLE)
  4669. 9 continue
  4670. err = nf_put_vars_double(ncid, i, index,
  4671. + count, stride,
  4672. + value)
  4673. if (canConvert) then
  4674. if (allInExtRange) then
  4675. if (err .ne. 0)
  4676. + call error(nf_strerror(err))
  4677. else
  4678. if (err .ne. NF_ERANGE)
  4679. + call errore('range error: ', err)
  4680. end if
  4681. else
  4682. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  4683. + call errore('wrong type: ', err)
  4684. end if
  4685. 7 continue
  4686. 5 continue
  4687. 1 continue
  4688. err = nf_close(ncid)
  4689. if (err .ne. 0)
  4690. + call errore('nf_close: ', err)
  4691. call check_vars_double(scratch)
  4692. err = nf_delete(scratch)
  4693. if (err .ne. 0)
  4694. + call errorc('delete of scratch file failed:',
  4695. + scratch)
  4696. end
  4697. subroutine test_nf_put_varm_text()
  4698. implicit none
  4699. #include "tests.inc"
  4700. integer ncid
  4701. integer d
  4702. integer i
  4703. integer j
  4704. integer k
  4705. integer m
  4706. integer err
  4707. integer nels
  4708. integer nslabs
  4709. integer nstarts !/* number of different starts */
  4710. integer start(MAX_RANK)
  4711. integer edge(MAX_RANK)
  4712. integer index(MAX_RANK)
  4713. integer index2(MAX_RANK)
  4714. integer mid(MAX_RANK)
  4715. integer count(MAX_RANK)
  4716. integer sstride(MAX_RANK)
  4717. integer stride(MAX_RANK)
  4718. integer imap(MAX_RANK)
  4719. logical canConvert !/* Both text or both numeric */
  4720. logical allInExtRange !/* all values within external range? */
  4721. character value(MAX_NELS)
  4722. doubleprecision val
  4723. integer udshift
  4724. err = nf_create(scratch, NF_CLOBBER, ncid)
  4725. if (err .ne. 0) then
  4726. call errore('nf_create: ', err)
  4727. return
  4728. end if
  4729. call def_dims(ncid)
  4730. call def_vars(ncid)
  4731. err = nf_enddef(ncid)
  4732. if (err .ne. 0)
  4733. + call errore('nf_enddef: ', err)
  4734. do 1, i = 1, NVARS
  4735. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  4736. + (NFT_TEXT .eq. NFT_TEXT)
  4737. if (.not.(var_rank(i) .le. MAX_RANK))
  4738. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  4739. if (.not.(var_nels(i) .le. MAX_NELS))
  4740. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  4741. do 2, j = 1, var_rank(i)
  4742. start(j) = 1
  4743. edge(j) = 1
  4744. stride(j) = 1
  4745. imap(j) = 1
  4746. 2 continue
  4747. err = nf_put_varm_text(BAD_ID, i, start,
  4748. + edge, stride, imap,
  4749. + value)
  4750. if (err .ne. NF_EBADID)
  4751. + call errore('bad ncid: ', err)
  4752. err = nf_put_varm_text(ncid, BAD_VARID, start,
  4753. + edge, stride,
  4754. + imap, value)
  4755. if (err .ne. NF_ENOTVAR)
  4756. + call errore('bad var id: ', err)
  4757. do 3, j = 1, var_rank(i)
  4758. if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
  4759. start(j) = var_shape(j,i) + 2
  4760. err = nf_put_varm_text(ncid, i, start,
  4761. + edge, stride,
  4762. + imap, value)
  4763. if (.not. canConvert) then
  4764. if (err .ne. NF_ECHAR)
  4765. + call errore('conversion: ', err)
  4766. else
  4767. if (err .ne. NF_EINVALCOORDS)
  4768. + call errore('bad start: ', err)
  4769. endif
  4770. start(j) = 1
  4771. edge(j) = var_shape(j,i) + 1
  4772. err = nf_put_varm_text(ncid, i, start,
  4773. + edge, stride,
  4774. + imap, value)
  4775. if (.not. canConvert) then
  4776. if (err .ne. NF_ECHAR)
  4777. + call errore('conversion: ', err)
  4778. else
  4779. if (err .ne. NF_EEDGE)
  4780. + call errore('bad edge: ', err)
  4781. endif
  4782. edge(j) = 1
  4783. stride(j) = 0
  4784. err = nf_put_varm_text(ncid, i, start,
  4785. + edge, stride,
  4786. + imap, value)
  4787. if (.not. canConvert) then
  4788. if (err .ne. NF_ECHAR)
  4789. + call errore('conversion: ', err)
  4790. else
  4791. if (err .ne. NF_ESTRIDE)
  4792. + call errore('bad stride: ', err)
  4793. endif
  4794. stride(j) = 1
  4795. end if
  4796. 3 continue
  4797. !/* Choose a random point dividing each dim into 2 parts */
  4798. !/* Put 2^rank (nslabs) slabs so defined */
  4799. nslabs = 1
  4800. do 4, j = 1, var_rank(i)
  4801. mid(j) = roll( var_shape(j,i) )
  4802. nslabs = nslabs * 2
  4803. 4 continue
  4804. !/* bits of k determine whether to put lower or upper part of dim */
  4805. !/* choose random stride from 1 to edge */
  4806. do 5, k = 1, nslabs
  4807. nstarts = 1
  4808. do 6, j = 1, var_rank(i)
  4809. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  4810. start(j) = 1
  4811. edge(j) = mid(j)
  4812. else
  4813. start(j) = 1 + mid(j)
  4814. edge(j) = var_shape(j,i) - mid(j)
  4815. end if
  4816. if (edge(j) .gt. 0) then
  4817. stride(j) = 1+roll(edge(j))
  4818. else
  4819. stride(j) = 1
  4820. end if
  4821. sstride(j) = stride(j)
  4822. nstarts = nstarts * stride(j)
  4823. 6 continue
  4824. do 7, m = 1, nstarts
  4825. err = index2indexes(m, var_rank(i), sstride, index)
  4826. if (err .ne. 0)
  4827. + call error('error in index2indexes')
  4828. nels = 1
  4829. do 8, j = 1, var_rank(i)
  4830. count(j) = 1 + (edge(j) - index(j)) / stride(j)
  4831. nels = nels * count(j)
  4832. index(j) = index(j) + start(j) - 1
  4833. 8 continue
  4834. !/* Random choice of forward or backward */
  4835. C/* TODO
  4836. C if ( roll(2) ) then
  4837. C do 9, j = 1, var_rank(i)
  4838. C index(j) = index(j) +
  4839. C + (count(j) - 1) * stride(j)
  4840. C stride(j) = -stride(j)
  4841. C9 continue
  4842. C end if
  4843. C*/
  4844. if (var_rank(i) .gt. 0) then
  4845. imap(1) = 1
  4846. do 10, j = 2, var_rank(i)
  4847. imap(j) = imap(j-1) * count(j-1)
  4848. 10 continue
  4849. end if
  4850. allInExtRange = .true.
  4851. do 11 j = 1, nels
  4852. err = index2indexes(j, var_rank(i), count,
  4853. + index2)
  4854. if (err .ne. 0)
  4855. + call error('error in index2indexes')
  4856. do 12, d = 1, var_rank(i)
  4857. index2(d) = index(d) +
  4858. + (index2(d)-1) * stride(d)
  4859. 12 continue
  4860. value(j) = char(int(hash_text(var_type(i),
  4861. + var_rank(i),
  4862. + index2, NFT_TEXT)))
  4863. val = ichar(value(j))
  4864. allInExtRange = allInExtRange .and.
  4865. + inRange3(val, var_type(i),
  4866. + NFT_TEXT)
  4867. 11 continue
  4868. err = nf_put_varm_text(ncid,i,index,count,
  4869. + stride,imap,
  4870. + value)
  4871. if (canConvert) then
  4872. if (allInExtRange) then
  4873. if (err .ne. 0)
  4874. + call error(nf_strerror(err))
  4875. else
  4876. if (err .ne. NF_ERANGE)
  4877. + call errore('range error: ', err)
  4878. end if
  4879. else
  4880. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  4881. + call errore('wrong type: ', err)
  4882. end if
  4883. 7 continue
  4884. 5 continue
  4885. 1 continue
  4886. err = nf_close(ncid)
  4887. if (err .ne. 0)
  4888. + call errore('nf_close: ', err)
  4889. call check_vars_text(scratch)
  4890. err = nf_delete(scratch)
  4891. if (err .ne. 0)
  4892. + call errorc('delete of scratch file failed:',
  4893. + scratch)
  4894. end
  4895. #ifdef NF_INT1_T
  4896. subroutine test_nf_put_varm_int1()
  4897. implicit none
  4898. #include "tests.inc"
  4899. integer ncid
  4900. integer d
  4901. integer i
  4902. integer j
  4903. integer k
  4904. integer m
  4905. integer err
  4906. integer nels
  4907. integer nslabs
  4908. integer nstarts !/* number of different starts */
  4909. integer start(MAX_RANK)
  4910. integer edge(MAX_RANK)
  4911. integer index(MAX_RANK)
  4912. integer index2(MAX_RANK)
  4913. integer mid(MAX_RANK)
  4914. integer count(MAX_RANK)
  4915. integer sstride(MAX_RANK)
  4916. integer stride(MAX_RANK)
  4917. integer imap(MAX_RANK)
  4918. logical canConvert !/* Both text or both numeric */
  4919. logical allInExtRange !/* all values within external range? */
  4920. NF_INT1_T value(MAX_NELS)
  4921. doubleprecision val
  4922. integer udshift
  4923. err = nf_create(scratch, NF_CLOBBER, ncid)
  4924. if (err .ne. 0) then
  4925. call errore('nf_create: ', err)
  4926. return
  4927. end if
  4928. call def_dims(ncid)
  4929. call def_vars(ncid)
  4930. err = nf_enddef(ncid)
  4931. if (err .ne. 0)
  4932. + call errore('nf_enddef: ', err)
  4933. do 1, i = 1, NVARS
  4934. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  4935. + (NFT_INT1 .eq. NFT_TEXT)
  4936. if (.not.(var_rank(i) .le. MAX_RANK))
  4937. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  4938. if (.not.(var_nels(i) .le. MAX_NELS))
  4939. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  4940. do 2, j = 1, var_rank(i)
  4941. start(j) = 1
  4942. edge(j) = 1
  4943. stride(j) = 1
  4944. imap(j) = 1
  4945. 2 continue
  4946. err = nf_put_varm_int1(BAD_ID, i, start,
  4947. + edge, stride, imap,
  4948. + value)
  4949. if (err .ne. NF_EBADID)
  4950. + call errore('bad ncid: ', err)
  4951. err = nf_put_varm_int1(ncid, BAD_VARID, start,
  4952. + edge, stride,
  4953. + imap, value)
  4954. if (err .ne. NF_ENOTVAR)
  4955. + call errore('bad var id: ', err)
  4956. do 3, j = 1, var_rank(i)
  4957. if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
  4958. start(j) = var_shape(j,i) + 2
  4959. err = nf_put_varm_int1(ncid, i, start,
  4960. + edge, stride,
  4961. + imap, value)
  4962. if (.not. canConvert) then
  4963. if (err .ne. NF_ECHAR)
  4964. + call errore('conversion: ', err)
  4965. else
  4966. if (err .ne. NF_EINVALCOORDS)
  4967. + call errore('bad start: ', err)
  4968. endif
  4969. start(j) = 1
  4970. edge(j) = var_shape(j,i) + 1
  4971. err = nf_put_varm_int1(ncid, i, start,
  4972. + edge, stride,
  4973. + imap, value)
  4974. if (.not. canConvert) then
  4975. if (err .ne. NF_ECHAR)
  4976. + call errore('conversion: ', err)
  4977. else
  4978. if (err .ne. NF_EEDGE)
  4979. + call errore('bad edge: ', err)
  4980. endif
  4981. edge(j) = 1
  4982. stride(j) = 0
  4983. err = nf_put_varm_int1(ncid, i, start,
  4984. + edge, stride,
  4985. + imap, value)
  4986. if (.not. canConvert) then
  4987. if (err .ne. NF_ECHAR)
  4988. + call errore('conversion: ', err)
  4989. else
  4990. if (err .ne. NF_ESTRIDE)
  4991. + call errore('bad stride: ', err)
  4992. endif
  4993. stride(j) = 1
  4994. end if
  4995. 3 continue
  4996. !/* Choose a random point dividing each dim into 2 parts */
  4997. !/* Put 2^rank (nslabs) slabs so defined */
  4998. nslabs = 1
  4999. do 4, j = 1, var_rank(i)
  5000. mid(j) = roll( var_shape(j,i) )
  5001. nslabs = nslabs * 2
  5002. 4 continue
  5003. !/* bits of k determine whether to put lower or upper part of dim */
  5004. !/* choose random stride from 1 to edge */
  5005. do 5, k = 1, nslabs
  5006. nstarts = 1
  5007. do 6, j = 1, var_rank(i)
  5008. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  5009. start(j) = 1
  5010. edge(j) = mid(j)
  5011. else
  5012. start(j) = 1 + mid(j)
  5013. edge(j) = var_shape(j,i) - mid(j)
  5014. end if
  5015. if (edge(j) .gt. 0) then
  5016. stride(j) = 1+roll(edge(j))
  5017. else
  5018. stride(j) = 1
  5019. end if
  5020. sstride(j) = stride(j)
  5021. nstarts = nstarts * stride(j)
  5022. 6 continue
  5023. do 7, m = 1, nstarts
  5024. err = index2indexes(m, var_rank(i), sstride, index)
  5025. if (err .ne. 0)
  5026. + call error('error in index2indexes')
  5027. nels = 1
  5028. do 8, j = 1, var_rank(i)
  5029. count(j) = 1 + (edge(j) - index(j)) / stride(j)
  5030. nels = nels * count(j)
  5031. index(j) = index(j) + start(j) - 1
  5032. 8 continue
  5033. !/* Random choice of forward or backward */
  5034. C/* TODO
  5035. C if ( roll(2) ) then
  5036. C do 9, j = 1, var_rank(i)
  5037. C index(j) = index(j) +
  5038. C + (count(j) - 1) * stride(j)
  5039. C stride(j) = -stride(j)
  5040. C9 continue
  5041. C end if
  5042. C*/
  5043. if (var_rank(i) .gt. 0) then
  5044. imap(1) = 1
  5045. do 10, j = 2, var_rank(i)
  5046. imap(j) = imap(j-1) * count(j-1)
  5047. 10 continue
  5048. end if
  5049. allInExtRange = .true.
  5050. do 11 j = 1, nels
  5051. err = index2indexes(j, var_rank(i), count,
  5052. + index2)
  5053. if (err .ne. 0)
  5054. + call error('error in index2indexes')
  5055. do 12, d = 1, var_rank(i)
  5056. index2(d) = index(d) +
  5057. + (index2(d)-1) * stride(d)
  5058. 12 continue
  5059. value(j) = hash_int1(var_type(i),
  5060. + var_rank(i),
  5061. + index2, NFT_INT1)
  5062. val = value(j)
  5063. allInExtRange = allInExtRange .and.
  5064. + inRange3(val, var_type(i),
  5065. + NFT_INT1)
  5066. 11 continue
  5067. err = nf_put_varm_int1(ncid,i,index,count,
  5068. + stride,imap,
  5069. + value)
  5070. if (canConvert) then
  5071. if (allInExtRange) then
  5072. if (err .ne. 0)
  5073. + call error(nf_strerror(err))
  5074. else
  5075. if (err .ne. NF_ERANGE)
  5076. + call errore('range error: ', err)
  5077. end if
  5078. else
  5079. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  5080. + call errore('wrong type: ', err)
  5081. end if
  5082. 7 continue
  5083. 5 continue
  5084. 1 continue
  5085. err = nf_close(ncid)
  5086. if (err .ne. 0)
  5087. + call errore('nf_close: ', err)
  5088. call check_vars_int1(scratch)
  5089. err = nf_delete(scratch)
  5090. if (err .ne. 0)
  5091. + call errorc('delete of scratch file failed:',
  5092. + scratch)
  5093. end
  5094. #endif
  5095. #ifdef NF_INT2_T
  5096. subroutine test_nf_put_varm_int2()
  5097. implicit none
  5098. #include "tests.inc"
  5099. integer ncid
  5100. integer d
  5101. integer i
  5102. integer j
  5103. integer k
  5104. integer m
  5105. integer err
  5106. integer nels
  5107. integer nslabs
  5108. integer nstarts !/* number of different starts */
  5109. integer start(MAX_RANK)
  5110. integer edge(MAX_RANK)
  5111. integer index(MAX_RANK)
  5112. integer index2(MAX_RANK)
  5113. integer mid(MAX_RANK)
  5114. integer count(MAX_RANK)
  5115. integer sstride(MAX_RANK)
  5116. integer stride(MAX_RANK)
  5117. integer imap(MAX_RANK)
  5118. logical canConvert !/* Both text or both numeric */
  5119. logical allInExtRange !/* all values within external range? */
  5120. NF_INT2_T value(MAX_NELS)
  5121. doubleprecision val
  5122. integer udshift
  5123. err = nf_create(scratch, NF_CLOBBER, ncid)
  5124. if (err .ne. 0) then
  5125. call errore('nf_create: ', err)
  5126. return
  5127. end if
  5128. call def_dims(ncid)
  5129. call def_vars(ncid)
  5130. err = nf_enddef(ncid)
  5131. if (err .ne. 0)
  5132. + call errore('nf_enddef: ', err)
  5133. do 1, i = 1, NVARS
  5134. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  5135. + (NFT_INT2 .eq. NFT_TEXT)
  5136. if (.not.(var_rank(i) .le. MAX_RANK))
  5137. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  5138. if (.not.(var_nels(i) .le. MAX_NELS))
  5139. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  5140. do 2, j = 1, var_rank(i)
  5141. start(j) = 1
  5142. edge(j) = 1
  5143. stride(j) = 1
  5144. imap(j) = 1
  5145. 2 continue
  5146. err = nf_put_varm_int2(BAD_ID, i, start,
  5147. + edge, stride, imap,
  5148. + value)
  5149. if (err .ne. NF_EBADID)
  5150. + call errore('bad ncid: ', err)
  5151. err = nf_put_varm_int2(ncid, BAD_VARID, start,
  5152. + edge, stride,
  5153. + imap, value)
  5154. if (err .ne. NF_ENOTVAR)
  5155. + call errore('bad var id: ', err)
  5156. do 3, j = 1, var_rank(i)
  5157. if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
  5158. start(j) = var_shape(j,i) + 2
  5159. err = nf_put_varm_int2(ncid, i, start,
  5160. + edge, stride,
  5161. + imap, value)
  5162. if (.not. canConvert) then
  5163. if (err .ne. NF_ECHAR)
  5164. + call errore('conversion: ', err)
  5165. else
  5166. if (err .ne. NF_EINVALCOORDS)
  5167. + call errore('bad start: ', err)
  5168. endif
  5169. start(j) = 1
  5170. edge(j) = var_shape(j,i) + 1
  5171. err = nf_put_varm_int2(ncid, i, start,
  5172. + edge, stride,
  5173. + imap, value)
  5174. if (.not. canConvert) then
  5175. if (err .ne. NF_ECHAR)
  5176. + call errore('conversion: ', err)
  5177. else
  5178. if (err .ne. NF_EEDGE)
  5179. + call errore('bad edge: ', err)
  5180. endif
  5181. edge(j) = 1
  5182. stride(j) = 0
  5183. err = nf_put_varm_int2(ncid, i, start,
  5184. + edge, stride,
  5185. + imap, value)
  5186. if (.not. canConvert) then
  5187. if (err .ne. NF_ECHAR)
  5188. + call errore('conversion: ', err)
  5189. else
  5190. if (err .ne. NF_ESTRIDE)
  5191. + call errore('bad stride: ', err)
  5192. endif
  5193. stride(j) = 1
  5194. end if
  5195. 3 continue
  5196. !/* Choose a random point dividing each dim into 2 parts */
  5197. !/* Put 2^rank (nslabs) slabs so defined */
  5198. nslabs = 1
  5199. do 4, j = 1, var_rank(i)
  5200. mid(j) = roll( var_shape(j,i) )
  5201. nslabs = nslabs * 2
  5202. 4 continue
  5203. !/* bits of k determine whether to put lower or upper part of dim */
  5204. !/* choose random stride from 1 to edge */
  5205. do 5, k = 1, nslabs
  5206. nstarts = 1
  5207. do 6, j = 1, var_rank(i)
  5208. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  5209. start(j) = 1
  5210. edge(j) = mid(j)
  5211. else
  5212. start(j) = 1 + mid(j)
  5213. edge(j) = var_shape(j,i) - mid(j)
  5214. end if
  5215. if (edge(j) .gt. 0) then
  5216. stride(j) = 1+roll(edge(j))
  5217. else
  5218. stride(j) = 1
  5219. end if
  5220. sstride(j) = stride(j)
  5221. nstarts = nstarts * stride(j)
  5222. 6 continue
  5223. do 7, m = 1, nstarts
  5224. err = index2indexes(m, var_rank(i), sstride, index)
  5225. if (err .ne. 0)
  5226. + call error('error in index2indexes')
  5227. nels = 1
  5228. do 8, j = 1, var_rank(i)
  5229. count(j) = 1 + (edge(j) - index(j)) / stride(j)
  5230. nels = nels * count(j)
  5231. index(j) = index(j) + start(j) - 1
  5232. 8 continue
  5233. !/* Random choice of forward or backward */
  5234. C/* TODO
  5235. C if ( roll(2) ) then
  5236. C do 9, j = 1, var_rank(i)
  5237. C index(j) = index(j) +
  5238. C + (count(j) - 1) * stride(j)
  5239. C stride(j) = -stride(j)
  5240. C9 continue
  5241. C end if
  5242. C*/
  5243. if (var_rank(i) .gt. 0) then
  5244. imap(1) = 1
  5245. do 10, j = 2, var_rank(i)
  5246. imap(j) = imap(j-1) * count(j-1)
  5247. 10 continue
  5248. end if
  5249. allInExtRange = .true.
  5250. do 11 j = 1, nels
  5251. err = index2indexes(j, var_rank(i), count,
  5252. + index2)
  5253. if (err .ne. 0)
  5254. + call error('error in index2indexes')
  5255. do 12, d = 1, var_rank(i)
  5256. index2(d) = index(d) +
  5257. + (index2(d)-1) * stride(d)
  5258. 12 continue
  5259. value(j) = hash_int2(var_type(i),
  5260. + var_rank(i),
  5261. + index2, NFT_INT2)
  5262. val = value(j)
  5263. allInExtRange = allInExtRange .and.
  5264. + inRange3(val, var_type(i),
  5265. + NFT_INT2)
  5266. 11 continue
  5267. err = nf_put_varm_int2(ncid,i,index,count,
  5268. + stride,imap,
  5269. + value)
  5270. if (canConvert) then
  5271. if (allInExtRange) then
  5272. if (err .ne. 0)
  5273. + call error(nf_strerror(err))
  5274. else
  5275. if (err .ne. NF_ERANGE)
  5276. + call errore('range error: ', err)
  5277. end if
  5278. else
  5279. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  5280. + call errore('wrong type: ', err)
  5281. end if
  5282. 7 continue
  5283. 5 continue
  5284. 1 continue
  5285. err = nf_close(ncid)
  5286. if (err .ne. 0)
  5287. + call errore('nf_close: ', err)
  5288. call check_vars_int2(scratch)
  5289. err = nf_delete(scratch)
  5290. if (err .ne. 0)
  5291. + call errorc('delete of scratch file failed:',
  5292. + scratch)
  5293. end
  5294. #endif
  5295. subroutine test_nf_put_varm_int()
  5296. implicit none
  5297. #include "tests.inc"
  5298. integer ncid
  5299. integer d
  5300. integer i
  5301. integer j
  5302. integer k
  5303. integer m
  5304. integer err
  5305. integer nels
  5306. integer nslabs
  5307. integer nstarts !/* number of different starts */
  5308. integer start(MAX_RANK)
  5309. integer edge(MAX_RANK)
  5310. integer index(MAX_RANK)
  5311. integer index2(MAX_RANK)
  5312. integer mid(MAX_RANK)
  5313. integer count(MAX_RANK)
  5314. integer sstride(MAX_RANK)
  5315. integer stride(MAX_RANK)
  5316. integer imap(MAX_RANK)
  5317. logical canConvert !/* Both text or both numeric */
  5318. logical allInExtRange !/* all values within external range? */
  5319. integer value(MAX_NELS)
  5320. doubleprecision val
  5321. integer udshift
  5322. err = nf_create(scratch, NF_CLOBBER, ncid)
  5323. if (err .ne. 0) then
  5324. call errore('nf_create: ', err)
  5325. return
  5326. end if
  5327. call def_dims(ncid)
  5328. call def_vars(ncid)
  5329. err = nf_enddef(ncid)
  5330. if (err .ne. 0)
  5331. + call errore('nf_enddef: ', err)
  5332. do 1, i = 1, NVARS
  5333. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  5334. + (NFT_INT .eq. NFT_TEXT)
  5335. if (.not.(var_rank(i) .le. MAX_RANK))
  5336. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  5337. if (.not.(var_nels(i) .le. MAX_NELS))
  5338. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  5339. do 2, j = 1, var_rank(i)
  5340. start(j) = 1
  5341. edge(j) = 1
  5342. stride(j) = 1
  5343. imap(j) = 1
  5344. 2 continue
  5345. err = nf_put_varm_int(BAD_ID, i, start,
  5346. + edge, stride, imap,
  5347. + value)
  5348. if (err .ne. NF_EBADID)
  5349. + call errore('bad ncid: ', err)
  5350. err = nf_put_varm_int(ncid, BAD_VARID, start,
  5351. + edge, stride,
  5352. + imap, value)
  5353. if (err .ne. NF_ENOTVAR)
  5354. + call errore('bad var id: ', err)
  5355. do 3, j = 1, var_rank(i)
  5356. if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
  5357. start(j) = var_shape(j,i) + 2
  5358. err = nf_put_varm_int(ncid, i, start,
  5359. + edge, stride,
  5360. + imap, value)
  5361. if (.not. canConvert) then
  5362. if (err .ne. NF_ECHAR)
  5363. + call errore('conversion: ', err)
  5364. else
  5365. if (err .ne. NF_EINVALCOORDS)
  5366. + call errore('bad start: ', err)
  5367. endif
  5368. start(j) = 1
  5369. edge(j) = var_shape(j,i) + 1
  5370. err = nf_put_varm_int(ncid, i, start,
  5371. + edge, stride,
  5372. + imap, value)
  5373. if (.not. canConvert) then
  5374. if (err .ne. NF_ECHAR)
  5375. + call errore('conversion: ', err)
  5376. else
  5377. if (err .ne. NF_EEDGE)
  5378. + call errore('bad edge: ', err)
  5379. endif
  5380. edge(j) = 1
  5381. stride(j) = 0
  5382. err = nf_put_varm_int(ncid, i, start,
  5383. + edge, stride,
  5384. + imap, value)
  5385. if (.not. canConvert) then
  5386. if (err .ne. NF_ECHAR)
  5387. + call errore('conversion: ', err)
  5388. else
  5389. if (err .ne. NF_ESTRIDE)
  5390. + call errore('bad stride: ', err)
  5391. endif
  5392. stride(j) = 1
  5393. end if
  5394. 3 continue
  5395. !/* Choose a random point dividing each dim into 2 parts */
  5396. !/* Put 2^rank (nslabs) slabs so defined */
  5397. nslabs = 1
  5398. do 4, j = 1, var_rank(i)
  5399. mid(j) = roll( var_shape(j,i) )
  5400. nslabs = nslabs * 2
  5401. 4 continue
  5402. !/* bits of k determine whether to put lower or upper part of dim */
  5403. !/* choose random stride from 1 to edge */
  5404. do 5, k = 1, nslabs
  5405. nstarts = 1
  5406. do 6, j = 1, var_rank(i)
  5407. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  5408. start(j) = 1
  5409. edge(j) = mid(j)
  5410. else
  5411. start(j) = 1 + mid(j)
  5412. edge(j) = var_shape(j,i) - mid(j)
  5413. end if
  5414. if (edge(j) .gt. 0) then
  5415. stride(j) = 1+roll(edge(j))
  5416. else
  5417. stride(j) = 1
  5418. end if
  5419. sstride(j) = stride(j)
  5420. nstarts = nstarts * stride(j)
  5421. 6 continue
  5422. do 7, m = 1, nstarts
  5423. err = index2indexes(m, var_rank(i), sstride, index)
  5424. if (err .ne. 0)
  5425. + call error('error in index2indexes')
  5426. nels = 1
  5427. do 8, j = 1, var_rank(i)
  5428. count(j) = 1 + (edge(j) - index(j)) / stride(j)
  5429. nels = nels * count(j)
  5430. index(j) = index(j) + start(j) - 1
  5431. 8 continue
  5432. !/* Random choice of forward or backward */
  5433. C/* TODO
  5434. C if ( roll(2) ) then
  5435. C do 9, j = 1, var_rank(i)
  5436. C index(j) = index(j) +
  5437. C + (count(j) - 1) * stride(j)
  5438. C stride(j) = -stride(j)
  5439. C9 continue
  5440. C end if
  5441. C*/
  5442. if (var_rank(i) .gt. 0) then
  5443. imap(1) = 1
  5444. do 10, j = 2, var_rank(i)
  5445. imap(j) = imap(j-1) * count(j-1)
  5446. 10 continue
  5447. end if
  5448. allInExtRange = .true.
  5449. do 11 j = 1, nels
  5450. err = index2indexes(j, var_rank(i), count,
  5451. + index2)
  5452. if (err .ne. 0)
  5453. + call error('error in index2indexes')
  5454. do 12, d = 1, var_rank(i)
  5455. index2(d) = index(d) +
  5456. + (index2(d)-1) * stride(d)
  5457. 12 continue
  5458. value(j) = hash_int(var_type(i),
  5459. + var_rank(i),
  5460. + index2, NFT_INT)
  5461. val = value(j)
  5462. allInExtRange = allInExtRange .and.
  5463. + inRange3(val, var_type(i),
  5464. + NFT_INT)
  5465. 11 continue
  5466. err = nf_put_varm_int(ncid,i,index,count,
  5467. + stride,imap,
  5468. + value)
  5469. if (canConvert) then
  5470. if (allInExtRange) then
  5471. if (err .ne. 0)
  5472. + call error(nf_strerror(err))
  5473. else
  5474. if (err .ne. NF_ERANGE)
  5475. + call errore('range error: ', err)
  5476. end if
  5477. else
  5478. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  5479. + call errore('wrong type: ', err)
  5480. end if
  5481. 7 continue
  5482. 5 continue
  5483. 1 continue
  5484. err = nf_close(ncid)
  5485. if (err .ne. 0)
  5486. + call errore('nf_close: ', err)
  5487. call check_vars_int(scratch)
  5488. err = nf_delete(scratch)
  5489. if (err .ne. 0)
  5490. + call errorc('delete of scratch file failed:',
  5491. + scratch)
  5492. end
  5493. subroutine test_nf_put_varm_real()
  5494. implicit none
  5495. #include "tests.inc"
  5496. integer ncid
  5497. integer d
  5498. integer i
  5499. integer j
  5500. integer k
  5501. integer m
  5502. integer err
  5503. integer nels
  5504. integer nslabs
  5505. integer nstarts !/* number of different starts */
  5506. integer start(MAX_RANK)
  5507. integer edge(MAX_RANK)
  5508. integer index(MAX_RANK)
  5509. integer index2(MAX_RANK)
  5510. integer mid(MAX_RANK)
  5511. integer count(MAX_RANK)
  5512. integer sstride(MAX_RANK)
  5513. integer stride(MAX_RANK)
  5514. integer imap(MAX_RANK)
  5515. logical canConvert !/* Both text or both numeric */
  5516. logical allInExtRange !/* all values within external range? */
  5517. real value(MAX_NELS)
  5518. doubleprecision val
  5519. integer udshift
  5520. err = nf_create(scratch, NF_CLOBBER, ncid)
  5521. if (err .ne. 0) then
  5522. call errore('nf_create: ', err)
  5523. return
  5524. end if
  5525. call def_dims(ncid)
  5526. call def_vars(ncid)
  5527. err = nf_enddef(ncid)
  5528. if (err .ne. 0)
  5529. + call errore('nf_enddef: ', err)
  5530. do 1, i = 1, NVARS
  5531. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  5532. + (NFT_REAL .eq. NFT_TEXT)
  5533. if (.not.(var_rank(i) .le. MAX_RANK))
  5534. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  5535. if (.not.(var_nels(i) .le. MAX_NELS))
  5536. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  5537. do 2, j = 1, var_rank(i)
  5538. start(j) = 1
  5539. edge(j) = 1
  5540. stride(j) = 1
  5541. imap(j) = 1
  5542. 2 continue
  5543. err = nf_put_varm_real(BAD_ID, i, start,
  5544. + edge, stride, imap,
  5545. + value)
  5546. if (err .ne. NF_EBADID)
  5547. + call errore('bad ncid: ', err)
  5548. err = nf_put_varm_real(ncid, BAD_VARID, start,
  5549. + edge, stride,
  5550. + imap, value)
  5551. if (err .ne. NF_ENOTVAR)
  5552. + call errore('bad var id: ', err)
  5553. do 3, j = 1, var_rank(i)
  5554. if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
  5555. start(j) = var_shape(j,i) + 2
  5556. err = nf_put_varm_real(ncid, i, start,
  5557. + edge, stride,
  5558. + imap, value)
  5559. if (.not. canConvert) then
  5560. if (err .ne. NF_ECHAR)
  5561. + call errore('conversion: ', err)
  5562. else
  5563. if (err .ne. NF_EINVALCOORDS)
  5564. + call errore('bad start: ', err)
  5565. endif
  5566. start(j) = 1
  5567. edge(j) = var_shape(j,i) + 1
  5568. err = nf_put_varm_real(ncid, i, start,
  5569. + edge, stride,
  5570. + imap, value)
  5571. if (.not. canConvert) then
  5572. if (err .ne. NF_ECHAR)
  5573. + call errore('conversion: ', err)
  5574. else
  5575. if (err .ne. NF_EEDGE)
  5576. + call errore('bad edge: ', err)
  5577. endif
  5578. edge(j) = 1
  5579. stride(j) = 0
  5580. err = nf_put_varm_real(ncid, i, start,
  5581. + edge, stride,
  5582. + imap, value)
  5583. if (.not. canConvert) then
  5584. if (err .ne. NF_ECHAR)
  5585. + call errore('conversion: ', err)
  5586. else
  5587. if (err .ne. NF_ESTRIDE)
  5588. + call errore('bad stride: ', err)
  5589. endif
  5590. stride(j) = 1
  5591. end if
  5592. 3 continue
  5593. !/* Choose a random point dividing each dim into 2 parts */
  5594. !/* Put 2^rank (nslabs) slabs so defined */
  5595. nslabs = 1
  5596. do 4, j = 1, var_rank(i)
  5597. mid(j) = roll( var_shape(j,i) )
  5598. nslabs = nslabs * 2
  5599. 4 continue
  5600. !/* bits of k determine whether to put lower or upper part of dim */
  5601. !/* choose random stride from 1 to edge */
  5602. do 5, k = 1, nslabs
  5603. nstarts = 1
  5604. do 6, j = 1, var_rank(i)
  5605. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  5606. start(j) = 1
  5607. edge(j) = mid(j)
  5608. else
  5609. start(j) = 1 + mid(j)
  5610. edge(j) = var_shape(j,i) - mid(j)
  5611. end if
  5612. if (edge(j) .gt. 0) then
  5613. stride(j) = 1+roll(edge(j))
  5614. else
  5615. stride(j) = 1
  5616. end if
  5617. sstride(j) = stride(j)
  5618. nstarts = nstarts * stride(j)
  5619. 6 continue
  5620. do 7, m = 1, nstarts
  5621. err = index2indexes(m, var_rank(i), sstride, index)
  5622. if (err .ne. 0)
  5623. + call error('error in index2indexes')
  5624. nels = 1
  5625. do 8, j = 1, var_rank(i)
  5626. count(j) = 1 + (edge(j) - index(j)) / stride(j)
  5627. nels = nels * count(j)
  5628. index(j) = index(j) + start(j) - 1
  5629. 8 continue
  5630. !/* Random choice of forward or backward */
  5631. C/* TODO
  5632. C if ( roll(2) ) then
  5633. C do 9, j = 1, var_rank(i)
  5634. C index(j) = index(j) +
  5635. C + (count(j) - 1) * stride(j)
  5636. C stride(j) = -stride(j)
  5637. C9 continue
  5638. C end if
  5639. C*/
  5640. if (var_rank(i) .gt. 0) then
  5641. imap(1) = 1
  5642. do 10, j = 2, var_rank(i)
  5643. imap(j) = imap(j-1) * count(j-1)
  5644. 10 continue
  5645. end if
  5646. allInExtRange = .true.
  5647. do 11 j = 1, nels
  5648. err = index2indexes(j, var_rank(i), count,
  5649. + index2)
  5650. if (err .ne. 0)
  5651. + call error('error in index2indexes')
  5652. do 12, d = 1, var_rank(i)
  5653. index2(d) = index(d) +
  5654. + (index2(d)-1) * stride(d)
  5655. 12 continue
  5656. value(j) = hash_real(var_type(i),
  5657. + var_rank(i),
  5658. + index2, NFT_REAL)
  5659. val = value(j)
  5660. allInExtRange = allInExtRange .and.
  5661. + inRange3(val, var_type(i),
  5662. + NFT_REAL)
  5663. 11 continue
  5664. err = nf_put_varm_real(ncid,i,index,count,
  5665. + stride,imap,
  5666. + value)
  5667. if (canConvert) then
  5668. if (allInExtRange) then
  5669. if (err .ne. 0)
  5670. + call error(nf_strerror(err))
  5671. else
  5672. if (err .ne. NF_ERANGE)
  5673. + call errore('range error: ', err)
  5674. end if
  5675. else
  5676. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  5677. + call errore('wrong type: ', err)
  5678. end if
  5679. 7 continue
  5680. 5 continue
  5681. 1 continue
  5682. err = nf_close(ncid)
  5683. if (err .ne. 0)
  5684. + call errore('nf_close: ', err)
  5685. call check_vars_real(scratch)
  5686. err = nf_delete(scratch)
  5687. if (err .ne. 0)
  5688. + call errorc('delete of scratch file failed:',
  5689. + scratch)
  5690. end
  5691. subroutine test_nf_put_varm_double()
  5692. implicit none
  5693. #include "tests.inc"
  5694. integer ncid
  5695. integer d
  5696. integer i
  5697. integer j
  5698. integer k
  5699. integer m
  5700. integer err
  5701. integer nels
  5702. integer nslabs
  5703. integer nstarts !/* number of different starts */
  5704. integer start(MAX_RANK)
  5705. integer edge(MAX_RANK)
  5706. integer index(MAX_RANK)
  5707. integer index2(MAX_RANK)
  5708. integer mid(MAX_RANK)
  5709. integer count(MAX_RANK)
  5710. integer sstride(MAX_RANK)
  5711. integer stride(MAX_RANK)
  5712. integer imap(MAX_RANK)
  5713. logical canConvert !/* Both text or both numeric */
  5714. logical allInExtRange !/* all values within external range? */
  5715. doubleprecision value(MAX_NELS)
  5716. doubleprecision val
  5717. integer udshift
  5718. err = nf_create(scratch, NF_CLOBBER, ncid)
  5719. if (err .ne. 0) then
  5720. call errore('nf_create: ', err)
  5721. return
  5722. end if
  5723. call def_dims(ncid)
  5724. call def_vars(ncid)
  5725. err = nf_enddef(ncid)
  5726. if (err .ne. 0)
  5727. + call errore('nf_enddef: ', err)
  5728. do 1, i = 1, NVARS
  5729. canConvert = (var_type(i) .eq. NF_CHAR) .eqv.
  5730. + (NFT_DOUBLE .eq. NFT_TEXT)
  5731. if (.not.(var_rank(i) .le. MAX_RANK))
  5732. + stop 'assert(var_rank(i) .le. MAX_RANK)'
  5733. if (.not.(var_nels(i) .le. MAX_NELS))
  5734. + stop 'assert(var_nels(i) .le. MAX_NELS)'
  5735. do 2, j = 1, var_rank(i)
  5736. start(j) = 1
  5737. edge(j) = 1
  5738. stride(j) = 1
  5739. imap(j) = 1
  5740. 2 continue
  5741. err = nf_put_varm_double(BAD_ID, i, start,
  5742. + edge, stride, imap,
  5743. + value)
  5744. if (err .ne. NF_EBADID)
  5745. + call errore('bad ncid: ', err)
  5746. err = nf_put_varm_double(ncid, BAD_VARID, start,
  5747. + edge, stride,
  5748. + imap, value)
  5749. if (err .ne. NF_ENOTVAR)
  5750. + call errore('bad var id: ', err)
  5751. do 3, j = 1, var_rank(i)
  5752. if (var_dimid(j,i) .ne. RECDIM) then !/* skip record dim */
  5753. start(j) = var_shape(j,i) + 2
  5754. err = nf_put_varm_double(ncid, i, start,
  5755. + edge, stride,
  5756. + imap, value)
  5757. if (.not. canConvert) then
  5758. if (err .ne. NF_ECHAR)
  5759. + call errore('conversion: ', err)
  5760. else
  5761. if (err .ne. NF_EINVALCOORDS)
  5762. + call errore('bad start: ', err)
  5763. endif
  5764. start(j) = 1
  5765. edge(j) = var_shape(j,i) + 1
  5766. err = nf_put_varm_double(ncid, i, start,
  5767. + edge, stride,
  5768. + imap, value)
  5769. if (.not. canConvert) then
  5770. if (err .ne. NF_ECHAR)
  5771. + call errore('conversion: ', err)
  5772. else
  5773. if (err .ne. NF_EEDGE)
  5774. + call errore('bad edge: ', err)
  5775. endif
  5776. edge(j) = 1
  5777. stride(j) = 0
  5778. err = nf_put_varm_double(ncid, i, start,
  5779. + edge, stride,
  5780. + imap, value)
  5781. if (.not. canConvert) then
  5782. if (err .ne. NF_ECHAR)
  5783. + call errore('conversion: ', err)
  5784. else
  5785. if (err .ne. NF_ESTRIDE)
  5786. + call errore('bad stride: ', err)
  5787. endif
  5788. stride(j) = 1
  5789. end if
  5790. 3 continue
  5791. !/* Choose a random point dividing each dim into 2 parts */
  5792. !/* Put 2^rank (nslabs) slabs so defined */
  5793. nslabs = 1
  5794. do 4, j = 1, var_rank(i)
  5795. mid(j) = roll( var_shape(j,i) )
  5796. nslabs = nslabs * 2
  5797. 4 continue
  5798. !/* bits of k determine whether to put lower or upper part of dim */
  5799. !/* choose random stride from 1 to edge */
  5800. do 5, k = 1, nslabs
  5801. nstarts = 1
  5802. do 6, j = 1, var_rank(i)
  5803. if (mod(udshift(k-1, -(j-1)), 2) .eq. 1) then
  5804. start(j) = 1
  5805. edge(j) = mid(j)
  5806. else
  5807. start(j) = 1 + mid(j)
  5808. edge(j) = var_shape(j,i) - mid(j)
  5809. end if
  5810. if (edge(j) .gt. 0) then
  5811. stride(j) = 1+roll(edge(j))
  5812. else
  5813. stride(j) = 1
  5814. end if
  5815. sstride(j) = stride(j)
  5816. nstarts = nstarts * stride(j)
  5817. 6 continue
  5818. do 7, m = 1, nstarts
  5819. err = index2indexes(m, var_rank(i), sstride, index)
  5820. if (err .ne. 0)
  5821. + call error('error in index2indexes')
  5822. nels = 1
  5823. do 8, j = 1, var_rank(i)
  5824. count(j) = 1 + (edge(j) - index(j)) / stride(j)
  5825. nels = nels * count(j)
  5826. index(j) = index(j) + start(j) - 1
  5827. 8 continue
  5828. !/* Random choice of forward or backward */
  5829. C/* TODO
  5830. C if ( roll(2) ) then
  5831. C do 9, j = 1, var_rank(i)
  5832. C index(j) = index(j) +
  5833. C + (count(j) - 1) * stride(j)
  5834. C stride(j) = -stride(j)
  5835. C9 continue
  5836. C end if
  5837. C*/
  5838. if (var_rank(i) .gt. 0) then
  5839. imap(1) = 1
  5840. do 10, j = 2, var_rank(i)
  5841. imap(j) = imap(j-1) * count(j-1)
  5842. 10 continue
  5843. end if
  5844. allInExtRange = .true.
  5845. do 11 j = 1, nels
  5846. err = index2indexes(j, var_rank(i), count,
  5847. + index2)
  5848. if (err .ne. 0)
  5849. + call error('error in index2indexes')
  5850. do 12, d = 1, var_rank(i)
  5851. index2(d) = index(d) +
  5852. + (index2(d)-1) * stride(d)
  5853. 12 continue
  5854. value(j) = hash_double(var_type(i),
  5855. + var_rank(i),
  5856. + index2, NFT_DOUBLE)
  5857. val = value(j)
  5858. allInExtRange = allInExtRange .and.
  5859. + inRange3(val, var_type(i),
  5860. + NFT_DOUBLE)
  5861. 11 continue
  5862. err = nf_put_varm_double(ncid,i,index,count,
  5863. + stride,imap,
  5864. + value)
  5865. if (canConvert) then
  5866. if (allInExtRange) then
  5867. if (err .ne. 0)
  5868. + call error(nf_strerror(err))
  5869. else
  5870. if (err .ne. NF_ERANGE)
  5871. + call errore('range error: ', err)
  5872. end if
  5873. else
  5874. if (nels .gt. 0 .and. err .ne. NF_ECHAR)
  5875. + call errore('wrong type: ', err)
  5876. end if
  5877. 7 continue
  5878. 5 continue
  5879. 1 continue
  5880. err = nf_close(ncid)
  5881. if (err .ne. 0)
  5882. + call errore('nf_close: ', err)
  5883. call check_vars_double(scratch)
  5884. err = nf_delete(scratch)
  5885. if (err .ne. 0)
  5886. + call errorc('delete of scratch file failed:',
  5887. + scratch)
  5888. end
  5889. subroutine test_nf_put_att_text()
  5890. implicit none
  5891. #include "tests.inc"
  5892. integer ncid
  5893. integer i
  5894. integer j
  5895. integer k
  5896. integer err
  5897. character value(MAX_NELS)
  5898. err = nf_create(scratch, NF_NOCLOBBER, ncid)
  5899. if (err .ne. 0) then
  5900. call errore('NF_create: ', err)
  5901. return
  5902. end if
  5903. call def_dims(ncid)
  5904. call def_vars(ncid)
  5905. do 1, i = 0, NVARS
  5906. do 2, j = 1, NATTS(i)
  5907. if (ATT_TYPE(j,i) .eq. NF_CHAR) then
  5908. if (.not.(ATT_LEN(j,i) .le. MAX_NELS))
  5909. + stop 'assert(ATT_LEN(j,i) .le. MAX_NELS)'
  5910. err = nf_put_att_text(BAD_ID, i,
  5911. + ATT_NAME(j,i), ATT_LEN(j,i), value)
  5912. if (err .ne. NF_EBADID)
  5913. + call errore('bad ncid: ', err)
  5914. err = nf_put_att_text(ncid, BAD_VARID,
  5915. + ATT_NAME(j,i),
  5916. + ATT_LEN(j,i), value)
  5917. if (err .ne. NF_ENOTVAR)
  5918. + call errore('bad var id: ', err)
  5919. do 3, k = 1, ATT_LEN(j,i)
  5920. value(k) = char(int(hash(ATT_TYPE(j,i), -1, k)))
  5921. 3 continue
  5922. err = nf_put_att_text(ncid, i, ATT_NAME(j,i),
  5923. + ATT_LEN(j,i), value)
  5924. if (err .ne. 0)
  5925. + call error(NF_strerror(err))
  5926. end if
  5927. 2 continue
  5928. 1 continue
  5929. call check_atts_text(ncid)
  5930. err = NF_close(ncid)
  5931. if (err .ne. 0)
  5932. + call errore('NF_close: ', err)
  5933. err = nf_delete(scratch)
  5934. if (err .ne. 0)
  5935. + call errorc('delete of scratch file failed:',
  5936. + scratch)
  5937. end
  5938. #ifdef NF_INT1_T
  5939. subroutine test_nf_put_att_int1()
  5940. implicit none
  5941. #include "tests.inc"
  5942. integer ncid
  5943. integer i
  5944. integer j
  5945. integer k
  5946. integer ndx(1)
  5947. integer err
  5948. NF_INT1_T value(MAX_NELS)
  5949. logical allInExtRange !/* all values within external range? */
  5950. doubleprecision val
  5951. err = nf_create(scratch, NF_NOCLOBBER, ncid)
  5952. if (err .ne. 0) then
  5953. call errore('nf_create: ', err)
  5954. return
  5955. end if
  5956. call def_dims(ncid)
  5957. call def_vars(ncid)
  5958. do 1, i = 0, NVARS
  5959. do 2, j = 1, NATTS(i)
  5960. if (.not.(ATT_TYPE(j,i) .eq. NF_CHAR)) then
  5961. if (.not.((ATT_LEN(j,i) .le. MAX_NELS)))
  5962. + stop 'assert(ATT_LEN(j,i) .le. MAX_NELS)'
  5963. err = nf_put_att_int1(BAD_ID, i,
  5964. + ATT_NAME(j,i),
  5965. + ATT_TYPE(j,i),
  5966. + ATT_LEN(j,i), value)
  5967. if (err .ne. NF_EBADID)
  5968. + call errore('bad ncid: ', err)
  5969. err = nf_put_att_int1(ncid, BAD_VARID,
  5970. + ATT_NAME(j,i),
  5971. + ATT_TYPE(j,i), ATT_LEN(j,i), value)
  5972. if (err .ne. NF_ENOTVAR)
  5973. + call errore('bad var id: ', err)
  5974. err = nf_put_att_int1(ncid, i,
  5975. + ATT_NAME(j,i), BAD_TYPE,
  5976. + ATT_LEN(j,i), value)
  5977. if (err .ne. NF_EBADTYPE)
  5978. + call errore('bad type: ', err)
  5979. allInExtRange = .true.
  5980. do 3, k = 1, ATT_LEN(j,i)
  5981. ndx(1) = k
  5982. value(k) = hash_int1(ATT_TYPE(j,i), -1, ndx,
  5983. + NFT_INT1)
  5984. val = value(k)
  5985. allInExtRange = allInExtRange .and.
  5986. + inRange3(val, ATT_TYPE(j,i),
  5987. + NFT_INT1)
  5988. 3 continue
  5989. err = nf_put_att_int1(ncid, i, ATT_NAME(j,i),
  5990. + ATT_TYPE(j,i), ATT_LEN(j,i),
  5991. + value)
  5992. if (allInExtRange) then
  5993. if (err .ne. 0)
  5994. + call error(nf_strerror(err))
  5995. else
  5996. if (err .ne. NF_ERANGE)
  5997. + call errore('range error: ', err)
  5998. end if
  5999. end if
  6000. 2 continue
  6001. 1 continue
  6002. call check_atts_int1(ncid)
  6003. err = nf_close(ncid)
  6004. if (err .ne. 0)
  6005. + call errore('nf_close: ', err)
  6006. err = nf_delete(scratch)
  6007. if (err .ne. 0)
  6008. + call errorc('delete of scratch file failed:',
  6009. + scratch)
  6010. end
  6011. #endif
  6012. #ifdef NF_INT2_T
  6013. subroutine test_nf_put_att_int2()
  6014. implicit none
  6015. #include "tests.inc"
  6016. integer ncid
  6017. integer i
  6018. integer j
  6019. integer k
  6020. integer ndx(1)
  6021. integer err
  6022. NF_INT2_T value(MAX_NELS)
  6023. logical allInExtRange !/* all values within external range? */
  6024. doubleprecision val
  6025. err = nf_create(scratch, NF_NOCLOBBER, ncid)
  6026. if (err .ne. 0) then
  6027. call errore('nf_create: ', err)
  6028. return
  6029. end if
  6030. call def_dims(ncid)
  6031. call def_vars(ncid)
  6032. do 1, i = 0, NVARS
  6033. do 2, j = 1, NATTS(i)
  6034. if (.not.(ATT_TYPE(j,i) .eq. NF_CHAR)) then
  6035. if (.not.((ATT_LEN(j,i) .le. MAX_NELS)))
  6036. + stop 'assert(ATT_LEN(j,i) .le. MAX_NELS)'
  6037. err = nf_put_att_int2(BAD_ID, i,
  6038. + ATT_NAME(j,i),
  6039. + ATT_TYPE(j,i),
  6040. + ATT_LEN(j,i), value)
  6041. if (err .ne. NF_EBADID)
  6042. + call errore('bad ncid: ', err)
  6043. err = nf_put_att_int2(ncid, BAD_VARID,
  6044. + ATT_NAME(j,i),
  6045. + ATT_TYPE(j,i), ATT_LEN(j,i), value)
  6046. if (err .ne. NF_ENOTVAR)
  6047. + call errore('bad var id: ', err)
  6048. err = nf_put_att_int2(ncid, i,
  6049. + ATT_NAME(j,i), BAD_TYPE,
  6050. + ATT_LEN(j,i), value)
  6051. if (err .ne. NF_EBADTYPE)
  6052. + call errore('bad type: ', err)
  6053. allInExtRange = .true.
  6054. do 3, k = 1, ATT_LEN(j,i)
  6055. ndx(1) = k
  6056. value(k) = hash_int2(ATT_TYPE(j,i), -1, ndx,
  6057. + NFT_INT2)
  6058. val = value(k)
  6059. allInExtRange = allInExtRange .and.
  6060. + inRange3(val, ATT_TYPE(j,i),
  6061. + NFT_INT2)
  6062. 3 continue
  6063. err = nf_put_att_int2(ncid, i, ATT_NAME(j,i),
  6064. + ATT_TYPE(j,i), ATT_LEN(j,i),
  6065. + value)
  6066. if (allInExtRange) then
  6067. if (err .ne. 0)
  6068. + call error(nf_strerror(err))
  6069. else
  6070. if (err .ne. NF_ERANGE)
  6071. + call errore('range error: ', err)
  6072. end if
  6073. end if
  6074. 2 continue
  6075. 1 continue
  6076. call check_atts_int2(ncid)
  6077. err = nf_close(ncid)
  6078. if (err .ne. 0)
  6079. + call errore('nf_close: ', err)
  6080. err = nf_delete(scratch)
  6081. if (err .ne. 0)
  6082. + call errorc('delete of scratch file failed:',
  6083. + scratch)
  6084. end
  6085. #endif
  6086. subroutine test_nf_put_att_int()
  6087. implicit none
  6088. #include "tests.inc"
  6089. integer ncid
  6090. integer i
  6091. integer j
  6092. integer k
  6093. integer ndx(1)
  6094. integer err
  6095. integer value(MAX_NELS)
  6096. logical allInExtRange !/* all values within external range? */
  6097. doubleprecision val
  6098. err = nf_create(scratch, NF_NOCLOBBER, ncid)
  6099. if (err .ne. 0) then
  6100. call errore('nf_create: ', err)
  6101. return
  6102. end if
  6103. call def_dims(ncid)
  6104. call def_vars(ncid)
  6105. do 1, i = 0, NVARS
  6106. do 2, j = 1, NATTS(i)
  6107. if (.not.(ATT_TYPE(j,i) .eq. NF_CHAR)) then
  6108. if (.not.((ATT_LEN(j,i) .le. MAX_NELS)))
  6109. + stop 'assert(ATT_LEN(j,i) .le. MAX_NELS)'
  6110. err = nf_put_att_int(BAD_ID, i,
  6111. + ATT_NAME(j,i),
  6112. + ATT_TYPE(j,i),
  6113. + ATT_LEN(j,i), value)
  6114. if (err .ne. NF_EBADID)
  6115. + call errore('bad ncid: ', err)
  6116. err = nf_put_att_int(ncid, BAD_VARID,
  6117. + ATT_NAME(j,i),
  6118. + ATT_TYPE(j,i), ATT_LEN(j,i), value)
  6119. if (err .ne. NF_ENOTVAR)
  6120. + call errore('bad var id: ', err)
  6121. err = nf_put_att_int(ncid, i,
  6122. + ATT_NAME(j,i), BAD_TYPE,
  6123. + ATT_LEN(j,i), value)
  6124. if (err .ne. NF_EBADTYPE)
  6125. + call errore('bad type: ', err)
  6126. allInExtRange = .true.
  6127. do 3, k = 1, ATT_LEN(j,i)
  6128. ndx(1) = k
  6129. value(k) = hash_int(ATT_TYPE(j,i), -1, ndx,
  6130. + NFT_INT)
  6131. val = value(k)
  6132. allInExtRange = allInExtRange .and.
  6133. + inRange3(val, ATT_TYPE(j,i),
  6134. + NFT_INT)
  6135. 3 continue
  6136. err = nf_put_att_int(ncid, i, ATT_NAME(j,i),
  6137. + ATT_TYPE(j,i), ATT_LEN(j,i),
  6138. + value)
  6139. if (allInExtRange) then
  6140. if (err .ne. 0)
  6141. + call error(nf_strerror(err))
  6142. else
  6143. if (err .ne. NF_ERANGE)
  6144. + call errore('range error: ', err)
  6145. end if
  6146. end if
  6147. 2 continue
  6148. 1 continue
  6149. call check_atts_int(ncid)
  6150. err = nf_close(ncid)
  6151. if (err .ne. 0)
  6152. + call errore('nf_close: ', err)
  6153. err = nf_delete(scratch)
  6154. if (err .ne. 0)
  6155. + call errorc('delete of scratch file failed:',
  6156. + scratch)
  6157. end
  6158. subroutine test_nf_put_att_real()
  6159. implicit none
  6160. #include "tests.inc"
  6161. integer ncid
  6162. integer i
  6163. integer j
  6164. integer k
  6165. integer ndx(1)
  6166. integer err
  6167. real value(MAX_NELS)
  6168. logical allInExtRange !/* all values within external range? */
  6169. doubleprecision val
  6170. err = nf_create(scratch, NF_NOCLOBBER, ncid)
  6171. if (err .ne. 0) then
  6172. call errore('nf_create: ', err)
  6173. return
  6174. end if
  6175. call def_dims(ncid)
  6176. call def_vars(ncid)
  6177. do 1, i = 0, NVARS
  6178. do 2, j = 1, NATTS(i)
  6179. if (.not.(ATT_TYPE(j,i) .eq. NF_CHAR)) then
  6180. if (.not.((ATT_LEN(j,i) .le. MAX_NELS)))
  6181. + stop 'assert(ATT_LEN(j,i) .le. MAX_NELS)'
  6182. err = nf_put_att_real(BAD_ID, i,
  6183. + ATT_NAME(j,i),
  6184. + ATT_TYPE(j,i),
  6185. + ATT_LEN(j,i), value)
  6186. if (err .ne. NF_EBADID)
  6187. + call errore('bad ncid: ', err)
  6188. err = nf_put_att_real(ncid, BAD_VARID,
  6189. + ATT_NAME(j,i),
  6190. + ATT_TYPE(j,i), ATT_LEN(j,i), value)
  6191. if (err .ne. NF_ENOTVAR)
  6192. + call errore('bad var id: ', err)
  6193. err = nf_put_att_real(ncid, i,
  6194. + ATT_NAME(j,i), BAD_TYPE,
  6195. + ATT_LEN(j,i), value)
  6196. if (err .ne. NF_EBADTYPE)
  6197. + call errore('bad type: ', err)
  6198. allInExtRange = .true.
  6199. do 3, k = 1, ATT_LEN(j,i)
  6200. ndx(1) = k
  6201. value(k) = hash_real(ATT_TYPE(j,i), -1, ndx,
  6202. + NFT_REAL)
  6203. val = value(k)
  6204. allInExtRange = allInExtRange .and.
  6205. + inRange3(val, ATT_TYPE(j,i),
  6206. + NFT_REAL)
  6207. 3 continue
  6208. err = nf_put_att_real(ncid, i, ATT_NAME(j,i),
  6209. + ATT_TYPE(j,i), ATT_LEN(j,i),
  6210. + value)
  6211. if (allInExtRange) then
  6212. if (err .ne. 0)
  6213. + call error(nf_strerror(err))
  6214. else
  6215. if (err .ne. NF_ERANGE)
  6216. + call errore('range error: ', err)
  6217. end if
  6218. end if
  6219. 2 continue
  6220. 1 continue
  6221. call check_atts_real(ncid)
  6222. err = nf_close(ncid)
  6223. if (err .ne. 0)
  6224. + call errore('nf_close: ', err)
  6225. err = nf_delete(scratch)
  6226. if (err .ne. 0)
  6227. + call errorc('delete of scratch file failed:',
  6228. + scratch)
  6229. end
  6230. subroutine test_nf_put_att_double()
  6231. implicit none
  6232. #include "tests.inc"
  6233. integer ncid
  6234. integer i
  6235. integer j
  6236. integer k
  6237. integer ndx(1)
  6238. integer err
  6239. doubleprecision value(MAX_NELS)
  6240. logical allInExtRange !/* all values within external range? */
  6241. doubleprecision val
  6242. err = nf_create(scratch, NF_NOCLOBBER, ncid)
  6243. if (err .ne. 0) then
  6244. call errore('nf_create: ', err)
  6245. return
  6246. end if
  6247. call def_dims(ncid)
  6248. call def_vars(ncid)
  6249. do 1, i = 0, NVARS
  6250. do 2, j = 1, NATTS(i)
  6251. if (.not.(ATT_TYPE(j,i) .eq. NF_CHAR)) then
  6252. if (.not.((ATT_LEN(j,i) .le. MAX_NELS)))
  6253. + stop 'assert(ATT_LEN(j,i) .le. MAX_NELS)'
  6254. err = nf_put_att_double(BAD_ID, i,
  6255. + ATT_NAME(j,i),
  6256. + ATT_TYPE(j,i),
  6257. + ATT_LEN(j,i), value)
  6258. if (err .ne. NF_EBADID)
  6259. + call errore('bad ncid: ', err)
  6260. err = nf_put_att_double(ncid, BAD_VARID,
  6261. + ATT_NAME(j,i),
  6262. + ATT_TYPE(j,i), ATT_LEN(j,i), value)
  6263. if (err .ne. NF_ENOTVAR)
  6264. + call errore('bad var id: ', err)
  6265. err = nf_put_att_double(ncid, i,
  6266. + ATT_NAME(j,i), BAD_TYPE,
  6267. + ATT_LEN(j,i), value)
  6268. if (err .ne. NF_EBADTYPE)
  6269. + call errore('bad type: ', err)
  6270. allInExtRange = .true.
  6271. do 3, k = 1, ATT_LEN(j,i)
  6272. ndx(1) = k
  6273. value(k) = hash_double(ATT_TYPE(j,i), -1, ndx,
  6274. + NFT_DOUBLE)
  6275. val = value(k)
  6276. allInExtRange = allInExtRange .and.
  6277. + inRange3(val, ATT_TYPE(j,i),
  6278. + NFT_DOUBLE)
  6279. 3 continue
  6280. err = nf_put_att_double(ncid, i, ATT_NAME(j,i),
  6281. + ATT_TYPE(j,i), ATT_LEN(j,i),
  6282. + value)
  6283. if (allInExtRange) then
  6284. if (err .ne. 0)
  6285. + call error(nf_strerror(err))
  6286. else
  6287. if (err .ne. NF_ERANGE)
  6288. + call errore('range error: ', err)
  6289. end if
  6290. end if
  6291. 2 continue
  6292. 1 continue
  6293. call check_atts_double(ncid)
  6294. err = nf_close(ncid)
  6295. if (err .ne. 0)
  6296. + call errore('nf_close: ', err)
  6297. err = nf_delete(scratch)
  6298. if (err .ne. 0)
  6299. + call errorc('delete of scratch file failed:',
  6300. + scratch)
  6301. end