PageRenderTime 69ms CodeModel.GetById 31ms RepoModel.GetById 1ms app.codeStats 0ms

/other/netcdf_write_matrix/src/nf_test/ftest.F

https://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 1455 lines | 811 code | 154 blank | 490 comment | 269 complexity | da01d2cda1b49bdc602d740c02f1bd18 MD5 | raw file
Possible License(s): AGPL-1.0
  1. !********************************************************************
  2. ! Copyright 1993, UCAR/Unidata
  3. ! See netcdf/COPYRIGHT file for copying and redistribution conditions.
  4. ! $Id: ftest.F,v 1.8 2006/01/03 13:53:08 ed Exp $
  5. !********************************************************************
  6. #include "../fortran/nfconfig.inc"
  7. !
  8. ! program to test the netCDF-2 Fortran API
  9. !
  10. program ftest
  11. #include "../fortran/netcdf.inc"
  12. ! name of first test cdf
  13. character*31 name
  14. ! name of second test cdf
  15. character*31 name2
  16. ! Returned error code.
  17. integer iret
  18. ! netCDF ID
  19. integer ncid
  20. ! ID of dimension lat
  21. integer latdim
  22. ! ID of dimension lon
  23. integer londim
  24. ! ID of dimension level
  25. integer leveldim
  26. ! ID of dimension time
  27. integer timedim
  28. ! ID of dimension len
  29. integer lendim
  30. ! Count the errors.
  31. integer nfails
  32. ! variable used to control error-handling behavior
  33. integer ncopts
  34. integer dimsiz(MAXNCDIM)
  35. ! allowable roundoff
  36. common /dims/timedim, latdim, londim, leveldim, lendim,
  37. + dimsiz
  38. data name/'test.nc'/
  39. data name2/'copy.nc'/
  40. 100 format('*** Testing ', a, ' ...')
  41. ! set error-handling to verbose and non-fatal
  42. ncopts = NCVERBOS
  43. call ncpopt(ncopts)
  44. ! This will be a count of how many failures we experience.
  45. nfails = 0
  46. ! create a netCDF named 'test.nc'
  47. write(*,100) 'nccre'
  48. ncid = nccre(name, NCCLOB, iret)
  49. if (ncid .eq. -1) then nfails = nfails + 1
  50. ! test ncddef
  51. write(*,100) 'ncddef'
  52. call tncddef(ncid, nfails)
  53. ! test ncvdef
  54. write(*,100) 'ncvdef'
  55. call tncvdef(ncid, nfails)
  56. ! test ncapt
  57. write(*, 100) 'ncapt, ncaptc'
  58. call tncapt(ncid, nfails)
  59. ! close 'test.nc'
  60. write(*, 100) 'ncclos'
  61. call ncclos(ncid, iret)
  62. if (ncid .eq. -1) then nfails = nfails + 1
  63. ! test ncvpt1
  64. write(*, 100) 'ncvpt1'
  65. call tncvpt1(name, nfails)
  66. ! test ncvgt1
  67. write(*, 100) 'ncvgt1'
  68. call tncvgt1(name, nfails)
  69. ! test ncvpt
  70. write(*, 100) 'ncvpt'
  71. call tncvpt(name, nfails)
  72. ! test ncinq
  73. write(*, 100) 'ncopn, ncinq, ncdinq, ncvinq, ncanam, ncainq'
  74. call tncinq(name, nfails)
  75. ! test ncvgt
  76. write(*, 100) 'ncvgt, ncvgtc'
  77. call tncvgt(name, nfails)
  78. ! test ncagt
  79. write(*, 100) 'ncagt, ncagtc'
  80. call tncagt(name, nfails)
  81. ! test ncredf
  82. write(*, 100) 'ncredf, ncdren, ncvren, ncaren, ncendf'
  83. call tncredf(name, nfails)
  84. call tncinq(name, nfails)
  85. ! test ncacpy
  86. write(*, 100) 'ncacpy'
  87. call tncacpy(name, name2, nfails)
  88. ! test ncadel
  89. write(*, 100) 'ncadel'
  90. call tncadel(name2, nfails)
  91. ! test fill values
  92. write(*, 100) 'fill values'
  93. call tfills(nfails)
  94. print *,'Total number of failures: ', nfails
  95. if (nfails .eq. 0)
  96. + call udexit(0)
  97. call udexit(1)
  98. end
  99. !
  100. ! subroutine to test ncacpy
  101. !
  102. subroutine tncacpy(iname, oname, nfails)
  103. character*31 iname, oname
  104. #include "../fortran/netcdf.inc"
  105. integer ndims, nvars, natts, recdim, iret
  106. character*31 vname, attnam
  107. integer attype, attlen
  108. integer vartyp, nvdims, vdims(MAXVDIMS), nvatts
  109. integer lenstr
  110. ! existing netCDF id
  111. integer incdf
  112. ! netCDF id of the output netCDF file to which the attribute
  113. ! will be copied
  114. integer outcdf
  115. integer mattlen
  116. parameter (mattlen = 80)
  117. character*80 charval
  118. doubleprecision doubval(2)
  119. real flval(2)
  120. integer lngval(2)
  121. NCSHORT_T shval(2)
  122. integer i, j, k
  123. character*31 varnam, attname(2,7), gattnam(2)
  124. NCBYTE_T bytval(2)
  125. common /atts/attname, gattnam
  126. NCSHORT_T svalidrg(2)
  127. real rvalidrg(2)
  128. integer lvalidrg(2)
  129. doubleprecision dvalidrg(2)
  130. NCBYTE_T bvalidrg(2)
  131. character*31 gavalue(2), cavalue(2)
  132. real epsilon
  133. data bvalidrg/-127,127/
  134. data svalidrg/-100,100/
  135. data lvalidrg/0,360/
  136. data rvalidrg/0.0, 5000.0/
  137. data dvalidrg/0D0,500D0/
  138. data gavalue/'NWS', '88/10/25 12:00:00'/
  139. data cavalue/'test string', 'a'/
  140. data lenstr/80/
  141. data epsilon /.000001/
  142. incdf = ncopn(iname, NCNOWRIT, iret)
  143. if (iret .ne. 0) nfails = nfails + 1
  144. outcdf = nccre(oname, NCCLOB, iret)
  145. if (iret .ne. 0) nfails = nfails + 1
  146. call tncddef(outcdf, nfails)
  147. call tncvdef(outcdf, nfails)
  148. call ncinq (incdf, ndims, nvars, natts, recdim, iret)
  149. if (iret .ne. 0) nfails = nfails + 1
  150. do 5 j = 1, natts
  151. call ncanam (incdf, NCGLOBAL, j, attnam, iret)
  152. if (iret .ne. 0) nfails = nfails + 1
  153. call ncacpy (incdf, NCGLOBAL, attnam, outcdf, NCGLOBAL, iret)
  154. if (iret .ne. 0) nfails = nfails + 1
  155. 5 continue
  156. do 10 i = 1, nvars
  157. call ncvinq (incdf, i, vname, vartyp, nvdims,
  158. + vdims, nvatts, iret)
  159. if (iret .ne. 0) nfails = nfails + 1
  160. do 20 k = 1, nvatts
  161. call ncanam (incdf, i, k, attnam, iret)
  162. if (iret .ne. 0) nfails = nfails + 1
  163. call ncacpy (incdf, i, attnam, outcdf, i, iret)
  164. if (iret .ne. 0) nfails = nfails + 1
  165. 20 continue
  166. 10 continue
  167. !
  168. ! get global attributes first
  169. !
  170. do 100 i = 1, natts
  171. call ncanam (outcdf, NCGLOBAL, i, attnam, iret)
  172. if (iret .ne. 0) nfails = nfails + 1
  173. call ncainq (outcdf, NCGLOBAL, attnam, attype, attlen,
  174. + iret)
  175. if (iret .ne. 0) nfails = nfails + 1
  176. if (attlen .gt. mattlen) then
  177. write (*,*) 'global attribute too big!', attlen, mattlen
  178. stop 'Stopped'
  179. else if (attype .eq. NCBYTE) then
  180. call ncagt (outcdf, NCBYTE, attnam, bytval, iret)
  181. if (iret .ne. 0) nfails = nfails + 1
  182. else if (attype .eq. NCCHAR) then
  183. call ncagtc (outcdf, NCGLOBAL, attnam, charval,
  184. + lenstr, iret)
  185. if (iret .ne. 0) nfails = nfails + 1
  186. if (attnam .ne. gattnam(i)) write(*,*) 'error in ncagt G'
  187. if (charval .ne. gavalue(i))
  188. + write(*,*) 'error in ncagt G2', lenstr, charval, gavalue(i)
  189. charval = ' '
  190. else if (attype .eq. NCSHORT) then
  191. call ncagt (outcdf, NCGLOBAL, attnam, shval, iret)
  192. if (iret .ne. 0) nfails = nfails + 1
  193. else if (attype .eq. NCLONG) then
  194. call ncagt (outcdf, NCGLOBAL, attnam, lngval, iret)
  195. if (iret .ne. 0) nfails = nfails + 1
  196. else if (attype .eq. NCFLOAT) then
  197. call ncagt (outcdf, NCGLOBAL, attnam, flval, iret)
  198. if (iret .ne. 0) nfails = nfails + 1
  199. else
  200. call ncagt (outcdf, NCGLOBAL, attnam, doubval,iret)
  201. if (iret .ne. 0) nfails = nfails + 1
  202. end if
  203. 100 continue
  204. !
  205. ! get variable attributes
  206. !
  207. do 200 i = 1, nvars
  208. call ncvinq (outcdf, i, varnam, vartyp, nvdims, vdims,
  209. + nvatts, iret)
  210. if (iret .ne. 0) nfails = nfails + 1
  211. do 250 j = 1, nvatts
  212. call ncanam (outcdf, i, j, attnam, iret)
  213. if (iret .ne. 0) nfails = nfails + 1
  214. call ncainq (outcdf, i, attnam, attype, attlen,
  215. + iret)
  216. if (iret .ne. 0) nfails = nfails + 1
  217. if (attlen .gt. mattlen) then
  218. write (*,*) 'variable ', i, 'attribute too big !'
  219. stop 'Stopped'
  220. else
  221. if (attype .eq. NCBYTE) then
  222. call ncagt (outcdf, i, attnam, bytval,
  223. + iret)
  224. if (iret .ne. 0) nfails = nfails + 1
  225. if (attnam .ne. attname(j,i))
  226. + write(*,*) 'error in ncagt BYTE N'
  227. if (bytval(j) .ne. bvalidrg(j)) write(*,*)
  228. + 'ncacpy: byte ', bytval(j), ' .ne. ', bvalidrg(j)
  229. else if (attype .eq. NCCHAR) then
  230. call ncagtc (outcdf, i, attnam, charval,
  231. + lenstr, iret)
  232. if (iret .ne. 0) nfails = nfails + 1
  233. if (attnam .ne. attname(j,i))
  234. + write(*,*) 'error in ncagt CHAR N'
  235. if (charval .ne. cavalue(j))
  236. + write(*,*) 'error in ncagt'
  237. charval = ' '
  238. else if (attype .eq. NCSHORT) then
  239. call ncagt (outcdf, i, attnam, shval,
  240. + iret)
  241. if (iret .ne. 0) nfails = nfails + 1
  242. if (attnam .ne. attname(j,i))
  243. + write(*,*) 'error in ncagt SHORT N'
  244. if (shval(j) .ne. svalidrg(j)) then
  245. write(*,*) 'error in ncagt SHORT'
  246. end if
  247. else if (attype .eq. NCLONG) then
  248. call ncagt (outcdf, i, attnam, lngval,
  249. + iret)
  250. if (iret .ne. 0) nfails = nfails + 1
  251. if (attnam .ne. attname(j,i))
  252. + write(*,*) 'error in ncagt LONG N'
  253. if (lngval(j) .ne. lvalidrg(j))
  254. + write(*,*) 'error in ncagt LONG'
  255. else if (attype .eq. NCFLOAT) then
  256. call ncagt (outcdf, i, attnam, flval,
  257. + iret)
  258. if (iret .ne. 0) nfails = nfails + 1
  259. if (attnam .ne. attname(j,i))
  260. + write(*,*) 'error in ncagt FLOAT N'
  261. if (flval(j) .ne. rvalidrg(j))
  262. + write(*,*) 'error in ncagt FLOAT'
  263. else if (attype .eq. NCDOUBLE) then
  264. call ncagt (outcdf, i, attnam, doubval,
  265. + iret)
  266. if (iret .ne. 0) nfails = nfails + 1
  267. if (attnam .ne. attname(j,i))
  268. + write(*,*) 'error in ncagt DOUBLE N'
  269. if ( abs(doubval(j) - dvalidrg(j)) .gt. epsilon)
  270. + write(*,*) 'error in ncagt DOUBLE'
  271. end if
  272. end if
  273. 250 continue
  274. 200 continue
  275. call ncclos(incdf, iret)
  276. if (iret .ne. 0) nfails = nfails + 1
  277. call ncclos(outcdf, iret)
  278. if (iret .ne. 0) nfails = nfails + 1
  279. return
  280. end
  281. !
  282. ! subroutine to test ncadel
  283. !
  284. subroutine tncadel (cdfname, nfails)
  285. character*31 cdfname
  286. #include "../fortran/netcdf.inc"
  287. integer bid, sid, lid, fid, did, cid, chid
  288. common /vars/bid, sid, lid, fid, did, cid, chid
  289. integer ncid, iret, i, j
  290. integer ndims, nvars, natts, recdim
  291. integer vartyp, nvdims, vdims(MAXVDIMS), nvatts
  292. character*31 varnam, attnam
  293. ncid = ncopn(cdfname, NCWRITE, iret)
  294. if (iret .ne. 0) nfails = nfails + 1
  295. ! put cdf in define mode
  296. call ncredf (ncid,iret)
  297. if (iret .ne. 0) nfails = nfails + 1
  298. ! get number of global attributes
  299. call ncinq (ncid, ndims, nvars, natts, recdim, iret)
  300. if (iret .ne. 0) nfails = nfails + 1
  301. do 10 i = natts, 1, -1
  302. ! get name of global attribute
  303. call ncanam (ncid, NCGLOBAL, i, attnam, iret)
  304. if (iret .ne. 0) nfails = nfails + 1
  305. ! delete global attribute
  306. call ncadel (ncid, NCGLOBAL, attnam, iret)
  307. if (iret .ne. 0) nfails = nfails + 1
  308. 10 continue
  309. do 100 i = 1, nvars
  310. ! get number of variable attributes
  311. call ncvinq (ncid, i, varnam, vartyp, nvdims, vdims,
  312. + nvatts, iret)
  313. if (iret .ne. 0) nfails = nfails + 1
  314. do 200 j = nvatts, 1, -1
  315. call ncanam (ncid, i, j, attnam, iret)
  316. if (iret .ne. 0) nfails = nfails + 1
  317. call ncadel (ncid, i, attnam, iret)
  318. if (iret .ne. 0) nfails = nfails + 1
  319. 200 continue
  320. 100 continue
  321. call ncinq (ncid, ndims, nvars, natts, recdim, iret)
  322. if (iret .ne. 0) nfails = nfails + 1
  323. if (natts .ne. 0) write(*,*) 'error in ncadel'
  324. ! put netCDF into data mode
  325. call ncendf (ncid, iret)
  326. if (iret .ne. 0) nfails = nfails + 1
  327. call ncclos (ncid, iret)
  328. if (iret .ne. 0) nfails = nfails + 1
  329. return
  330. end
  331. !
  332. ! subroutine to test ncagt and ncagtc
  333. subroutine tncagt(cdfname, nfails)
  334. #include "../fortran/netcdf.inc"
  335. character*31 cdfname
  336. ! maximum length of an attribute
  337. integer mattlen
  338. parameter (mattlen = 80)
  339. integer ncid, ndims, nvars, natts, recdim
  340. integer bid, sid, lid, fid, did, cid, chid
  341. common /vars/bid, sid, lid, fid, did, cid, chid
  342. integer i, j
  343. integer attype, attlen, lenstr, iret
  344. character*31 attnam
  345. character*80 charval
  346. doubleprecision doubval(2)
  347. real flval(2)
  348. integer lngval(2)
  349. NCSHORT_T shval(2)
  350. NCBYTE_T bytval(2)
  351. integer vartyp, nvdims, vdims(MAXVDIMS), nvatts
  352. character*31 varnam, attname(2,7), gattnam(2)
  353. common /atts/attname, gattnam
  354. NCSHORT_T svalidrg(2)
  355. real rvalidrg(2)
  356. integer lvalidrg(2)
  357. doubleprecision dvalidrg(2)
  358. NCBYTE_T bvalidrg(2)
  359. character*31 gavalue(2), cavalue(2)
  360. real epsilon
  361. data bvalidrg/-127,127/
  362. data svalidrg/-100,100/
  363. data lvalidrg/0,360/
  364. data rvalidrg/0.0, 5000.0/
  365. data dvalidrg/0D0,500D0/
  366. data gavalue/'NWS', '88/10/25 12:00:00'/
  367. data cavalue/'test string', 'a'/
  368. data lenstr/80/
  369. data epsilon /.000001/
  370. ncid = ncopn (cdfname, NCNOWRIT, iret)
  371. if (iret .ne. 0) nfails = nfails + 1
  372. call ncinq (ncid, ndims, nvars, natts, recdim, iret)
  373. if (iret .ne. 0) nfails = nfails + 1
  374. !
  375. ! get global attributes first
  376. !
  377. do 10 i = 1, natts
  378. ! get name of attribute
  379. call ncanam (ncid, NCGLOBAL, i, attnam, iret)
  380. if (iret .ne. 0) nfails = nfails + 1
  381. ! get attribute type and length
  382. call ncainq (ncid, NCGLOBAL, attnam, attype, attlen,
  383. + iret)
  384. if (iret .ne. 0) nfails = nfails + 1
  385. if (attlen .gt. mattlen) then
  386. write (*,*) 'global attribute too big!'
  387. stop 'Stopped'
  388. else if (attype .eq. NCBYTE) then
  389. call ncagt (ncid, NCBYTE, attnam, bytval, iret)
  390. if (iret .ne. 0) nfails = nfails + 1
  391. else if (attype .eq. NCCHAR) then
  392. call ncagtc (ncid, NCGLOBAL, attnam, charval,
  393. + lenstr, iret)
  394. if (iret .ne. 0) nfails = nfails + 1
  395. if (attnam .ne. gattnam(i)) write(*,*) 'error in ncagt'
  396. if (charval .ne. gavalue(i)) write(*,*) 'error in ncagt'
  397. charval = ' '
  398. else if (attype .eq. NCSHORT) then
  399. call ncagt (ncid, NCGLOBAL, attnam, shval, iret)
  400. if (iret .ne. 0) nfails = nfails + 1
  401. else if (attype .eq. NCLONG) then
  402. call ncagt (ncid, NCGLOBAL, attnam, lngval, iret)
  403. if (iret .ne. 0) nfails = nfails + 1
  404. else if (attype .eq. NCFLOAT) then
  405. call ncagt (ncid, NCGLOBAL, attnam, flval, iret)
  406. if (iret .ne. 0) nfails = nfails + 1
  407. else
  408. call ncagt (ncid, NCGLOBAL, attnam, doubval,iret)
  409. if (iret .ne. 0) nfails = nfails + 1
  410. end if
  411. 10 continue
  412. !
  413. ! get variable attributes
  414. !
  415. do 20 i = 1, nvars
  416. call ncvinq (ncid, i, varnam, vartyp, nvdims, vdims,
  417. + nvatts, iret)
  418. if (iret .ne. 0) nfails = nfails + 1
  419. do 25 j = 1, nvatts
  420. call ncanam (ncid, i, j, attnam, iret)
  421. if (iret .ne. 0) nfails = nfails + 1
  422. call ncainq (ncid, i, attnam, attype, attlen,
  423. + iret)
  424. if (iret .ne. 0) nfails = nfails + 1
  425. if (attlen .gt. mattlen) then
  426. write (*,*) 'variable ', i, 'attribute too big !'
  427. stop 'Stopped'
  428. else
  429. if (attype .eq. NCBYTE) then
  430. call ncagt (ncid, i, attnam, bytval,
  431. + iret)
  432. if (iret .ne. 0) nfails = nfails + 1
  433. if (attnam .ne. attname(j,i))
  434. + write(*,*) 'error in ncagt BYTE name'
  435. if (bytval(j) .ne. bvalidrg(j)) write(*,*)
  436. + 'ncacpy: byte ', bytval(j), ' .ne. ', bvalidrg(j)
  437. else if (attype .eq. NCCHAR) then
  438. call ncagtc (ncid, i, attnam, charval,
  439. + lenstr, iret)
  440. if (iret .ne. 0) nfails = nfails + 1
  441. if (attnam .ne. attname(j,i))
  442. + write(*,*) 'error in ncagt CHAR name'
  443. if (charval .ne. cavalue(j))
  444. + write(*,*) 'error in ncagt CHAR name'
  445. charval = ' '
  446. else if (attype .eq. NCSHORT) then
  447. call ncagt (ncid, i, attnam, shval,
  448. + iret)
  449. if (iret .ne. 0) nfails = nfails + 1
  450. if (attnam .ne. attname(j,i))
  451. + write(*,*) 'error in ncagt SHORT name'
  452. if (shval(j) .ne. svalidrg(j)) then
  453. write(*,*) 'error in ncagt SHORT'
  454. end if
  455. else if (attype .eq. NCLONG) then
  456. call ncagt (ncid, i, attnam, lngval,
  457. + iret)
  458. if (iret .ne. 0) nfails = nfails + 1
  459. if (attnam .ne. attname(j,i))
  460. + write(*,*) 'error in ncagt LONG name'
  461. if (lngval(j) .ne. lvalidrg(j))
  462. + write(*,*) 'error in ncagt LONG'
  463. else if (attype .eq. NCFLOAT) then
  464. call ncagt (ncid, i, attnam, flval,
  465. + iret)
  466. if (iret .ne. 0) nfails = nfails + 1
  467. if (attnam .ne. attname(j,i))
  468. + write(*,*) 'error in ncagt FLOAT name'
  469. if (flval(j) .ne. rvalidrg(j))
  470. + write(*,*) 'error in ncagt FLOAT'
  471. else if (attype .eq. NCDOUBLE) then
  472. call ncagt (ncid, i, attnam, doubval,
  473. + iret)
  474. if (iret .ne. 0) nfails = nfails + 1
  475. if (attnam .ne. attname(j,i))
  476. + write(*,*) 'error in ncagt DOUBLE name'
  477. if ( abs(doubval(j) - dvalidrg(j)) .gt. epsilon)
  478. + write(*,*) 'error in ncagt DOUBLE'
  479. end if
  480. end if
  481. 25 continue
  482. 20 continue
  483. call ncclos(ncid, iret)
  484. if (iret .ne. 0) nfails = nfails + 1
  485. return
  486. end
  487. !
  488. ! subroutine to test ncapt
  489. !
  490. subroutine tncapt (ncid, nfails)
  491. #include "../fortran/netcdf.inc"
  492. integer ncid, iret
  493. ! attribute vectors
  494. NCSHORT_T svalidrg(2)
  495. real rvalidrg(2)
  496. integer lvalidrg(2)
  497. doubleprecision dvalidrg(2)
  498. NCBYTE_T bvalidrg(2)
  499. ! variable ids
  500. integer bid, sid, lid, fid, did, cid, chid
  501. common /vars/bid, sid, lid, fid, did, cid, chid
  502. ! assign attributes
  503. !
  504. ! byte
  505. !
  506. bvalidrg(1) = -127
  507. bvalidrg(2) = 127
  508. call ncapt (ncid, bid, 'validrange', NCBYTE, 2,
  509. +bvalidrg, iret)
  510. if (iret .ne. 0) nfails = nfails + 1
  511. !
  512. ! short
  513. !
  514. svalidrg(1) = -100
  515. svalidrg(2) = 100
  516. call ncapt (ncid, sid, 'validrange', NCSHORT, 2,
  517. +svalidrg, iret)
  518. if (iret .ne. 0) nfails = nfails + 1
  519. !
  520. ! long
  521. !
  522. lvalidrg(1) = 0
  523. lvalidrg(2) = 360
  524. call ncapt (ncid, lid, 'validrange', NCLONG, 2,
  525. +lvalidrg, iret)
  526. if (iret .ne. 0) nfails = nfails + 1
  527. !
  528. ! float
  529. !
  530. rvalidrg(1) = 0.0
  531. rvalidrg(2) = 5000.0
  532. call ncapt (ncid, fid, 'validrange', NCFLOAT, 2,
  533. +rvalidrg, iret)
  534. if (iret .ne. 0) nfails = nfails + 1
  535. !
  536. ! double
  537. !
  538. dvalidrg(1) = 0D0
  539. dvalidrg(2) = 500D0
  540. call ncapt (ncid, did, 'validrange', NCDOUBLE, 2,
  541. +dvalidrg, iret)
  542. if (iret .ne. 0) nfails = nfails + 1
  543. !
  544. ! global
  545. !
  546. call ncaptc (ncid, NCGLOBAL, 'source', NCCHAR, 3,
  547. +'NWS', iret)
  548. if (iret .ne. 0) nfails = nfails + 1
  549. call ncaptc (ncid, NCGLOBAL, 'basetime', NCCHAR, 17,
  550. +'88/10/25 12:00:00', iret)
  551. if (iret .ne. 0) nfails = nfails + 1
  552. !
  553. ! char
  554. !
  555. call ncaptc (ncid, chid, 'longname', NCCHAR, 11,
  556. +'test string', iret)
  557. if (iret .ne. 0) nfails = nfails + 1
  558. call ncaptc (ncid, chid, 'id', NCCHAR, 1,
  559. +'a', iret)
  560. if (iret .ne. 0) nfails = nfails + 1
  561. return
  562. end
  563. !
  564. ! initialize variables in labelled common blocks
  565. !
  566. block data
  567. common /cdims/ dimnam
  568. common /dims/timedim, latdim, londim, leveldim, lendim,
  569. + dimsiz
  570. common /varn/varnam
  571. common /atts/attname, gattnam
  572. integer latdim, londim, leveldim, timedim, lendim
  573. ! should include 'netcdf.inc' for MAXNCDIM, but it has EXTERNAL
  574. ! declaration, which is not permitted in a BLOCK DATA unit.
  575. integer dimsiz(1024)
  576. character*31 dimnam(1024)
  577. character*31 varnam(7)
  578. character*31 attname(2,7)
  579. character*31 gattnam(2)
  580. data dimnam /'time', 'lat', 'lon', 'level',
  581. + 'length', 1019*'0'/
  582. data dimsiz /4, 5, 5, 4, 80, 1019*0/
  583. data varnam/'bytev', 'shortv', 'longv', 'floatv', 'doublev',
  584. + 'chv', 'cv'/
  585. data attname/'validrange', '0', 'validrange', '0', 'validrange',
  586. + '0', 'validrange', '0', 'validrange', '0', 'longname', 'id',
  587. + '0', '0'/
  588. data gattnam/'source','basetime'/
  589. end
  590. !
  591. ! subroutine to test ncddef
  592. !
  593. subroutine tncddef(ncid, nfails)
  594. #include "../fortran/netcdf.inc"
  595. integer ncid
  596. ! sizes of dimensions of 'test.nc' and 'copy.nc'
  597. integer ndims
  598. parameter(ndims=5)
  599. ! dimension ids
  600. integer latdim, londim, leveldim, timedim, lendim
  601. integer iret
  602. ! function to define a netCDF dimension
  603. integer dimsiz(MAXNCDIM)
  604. character*31 dimnam(MAXNCDIM)
  605. common /dims/timedim, latdim, londim, leveldim, lendim,
  606. + dimsiz
  607. common /cdims/ dimnam
  608. ! define dimensions
  609. timedim = ncddef(ncid, dimnam(1), NCUNLIM, iret)
  610. if (iret .ne. 0) nfails = nfails + 1
  611. latdim = ncddef(ncid, dimnam(2), dimsiz(2), iret)
  612. if (iret .ne. 0) nfails = nfails + 1
  613. londim = ncddef(ncid, dimnam(3), dimsiz(3), iret)
  614. if (iret .ne. 0) nfails = nfails + 1
  615. leveldim = ncddef(ncid, dimnam(4), dimsiz(4), iret)
  616. if (iret .ne. 0) nfails = nfails + 1
  617. lendim = ncddef(ncid, dimnam(5), dimsiz(5), iret)
  618. if (iret .ne. 0) nfails = nfails + 1
  619. return
  620. end
  621. !
  622. ! subroutine to test ncinq, ncdinq, ncdid, ncvinq, ncanam
  623. ! and ncainq
  624. !
  625. subroutine tncinq(cdfname, nfails)
  626. #include "../fortran/netcdf.inc"
  627. character*31 cdfname
  628. ! netCDF id
  629. integer ncid
  630. ! returned number of dimensions
  631. integer ndims
  632. ! returned number of variables
  633. integer nvars
  634. ! returned number of global attributes
  635. integer natts
  636. ! returned id of the unlimited dimension
  637. integer recdim
  638. ! returned error code
  639. integer iret
  640. ! returned name of record dimension
  641. character*31 recnam
  642. ! returned size of record dimension
  643. integer recsiz
  644. ! loop control variables
  645. integer i, j, k
  646. ! returned size of dimension
  647. integer dsize
  648. ! returned dimension ID
  649. integer dimid
  650. ! returned dimension name
  651. character*31 dname
  652. ! returned variable name
  653. character*31 vname
  654. ! returned attribute name
  655. character*31 attnam
  656. ! returned netCDF datatype of variable
  657. integer vartyp
  658. ! returned number of variable dimensions
  659. integer nvdims
  660. ! returned number of variable attributes
  661. integer nvatts
  662. ! returned vector of nvdims dimension IDS corresponding to the
  663. ! variable dimensions
  664. integer vdims(MAXNCDIM)
  665. ! returned attribute length
  666. integer attlen
  667. ! returned attribute type
  668. integer attype
  669. character*31 dimnam(MAXNCDIM)
  670. character*31 varnam(7)
  671. character*31 attname(2,7)
  672. character*31 gattnam(2)
  673. integer vdlist(5,7), vtyp(7), vndims(7), vnatts(7)
  674. integer attyp(2,7),atlen(2,7),gattyp(2),gatlen(2)
  675. integer timedim,latdim,londim,leveldim,lendim
  676. integer dimsiz(MAXNCDIM)
  677. common /dims/timedim, latdim, londim, leveldim, lendim,
  678. + dimsiz
  679. common /varn/varnam
  680. common /atts/attname, gattnam
  681. common /cdims/ dimnam
  682. data vdlist/1,0,0,0,0,1,0,0,0,0,2,0,0,0,0,4,3,2,1,0,4,3,2,1,0,
  683. + 5,1,0,0,0,1,0,0,0,0/
  684. data vtyp/NCBYTE, NCSHORT, NCLONG, NCFLOAT, NCDOUBLE, NCCHAR,
  685. + NCCHAR/
  686. data vndims/1,1,1,4,4,2,1/
  687. data vnatts/1,1,1,1,1,2,0/
  688. data attyp/NCBYTE, 0, NCSHORT, 0, NCLONG, 0, NCFLOAT, 0,
  689. + NCDOUBLE, 0, NCCHAR, NCCHAR, 0, 0/
  690. data atlen/2,0,2,0,2,0,2,0,2,0,11,1, 0, 0/
  691. data gattyp/NCCHAR,NCCHAR/
  692. data gatlen/3,17/
  693. ncid = ncopn (cdfname, NCNOWRIT, iret)
  694. call ncinq (ncid, ndims, nvars, natts, recdim, iret)
  695. if (iret .ne. 0) nfails = nfails + 1
  696. if (ndims .ne. 5) write(*,*) 'error in ncinq or ncddef'
  697. if (nvars .ne. 7) write(*,*) 'error in ncinq or ncvdef'
  698. if (natts .ne. 2) write(*,*) 'error in ncinq or ncapt'
  699. call ncdinq (ncid, recdim, recnam, recsiz, iret)
  700. if (iret .ne. 0) nfails = nfails + 1
  701. if (recnam .ne. 'time') write(*,*) 'error: bad recdim from ncinq'
  702. !
  703. ! dimensions
  704. !
  705. do 10 i = 1, ndims
  706. call ncdinq (ncid, i, dname, dsize, iret)
  707. if (iret .ne. 0) nfails = nfails + 1
  708. if (dname .ne. dimnam(i))
  709. + write(*,*) 'error in ncdinq or ncddef, dname=', dname
  710. if (dsize .ne. dimsiz(i))
  711. + write(*,*) 'error in ncdinq or ncddef, dsize=',dsize
  712. dimid = ncdid (ncid, dname, iret)
  713. if (dimid .ne. i) write(*,*)
  714. + 'error in ncdinq or ncddef, dimid=', dimid
  715. 10 continue
  716. !
  717. ! variables
  718. !
  719. do 30 i = 1, nvars
  720. call ncvinq (ncid, i, vname, vartyp, nvdims,
  721. + vdims, nvatts, iret)
  722. if (iret .ne. 0) nfails = nfails + 1
  723. if (vname .ne. varnam(i))
  724. + write(*,*) 'error: from ncvinq, wrong name returned: ',
  725. + vname, ' .ne. ', varnam(i)
  726. if (vartyp .ne. vtyp(i))
  727. + write(*,*) 'error: from ncvinq, wrong type returned: ',
  728. + vartyp, ' .ne. ', vtyp(i)
  729. if (nvdims .ne. vndims(i))
  730. + write(*,*) 'error: from ncvinq, wrong num dims returned: ',
  731. + vdims, ' .ne. ', vndims(i)
  732. do 35 j = 1, nvdims
  733. if (vdims(j) .ne. vdlist(j,i))
  734. + write(*,*) 'error: from ncvinq wrong dimids: ',
  735. + vdims(j), ' .ne. ', vdlist(j,i)
  736. 35 continue
  737. if (nvatts .ne. vnatts(i))
  738. + write(*,*) 'error in ncvinq or ncvdef'
  739. !
  740. ! attributes
  741. !
  742. do 45 k = 1, nvatts
  743. call ncanam (ncid, i, k, attnam, iret)
  744. if (iret .ne. 0) nfails = nfails + 1
  745. call ncainq (ncid, i, attnam, attype, attlen, iret)
  746. if (iret .ne. 0) nfails = nfails + 1
  747. if (attnam .ne. attname(k,i))
  748. + write(*,*) 'error in ncanam or ncapt'
  749. if (attype .ne. attyp(k,i))
  750. + write(*,*) 'error in ncainq or ncapt'
  751. if (attlen .ne. atlen(k,i))
  752. + write(*,*) 'error in ncainq or ncapt'
  753. 45 continue
  754. 30 continue
  755. do 40 i = 1, natts
  756. call ncanam (ncid, NCGLOBAL, i, attnam, iret)
  757. if (iret .ne. 0) nfails = nfails + 1
  758. call ncainq (ncid, NCGLOBAL, attnam, attype, attlen, iret)
  759. if (iret .ne. 0) nfails = nfails + 1
  760. if (attnam .ne. gattnam(i))
  761. + write(*,*) 'error in ncanam or ncapt'
  762. if (attype .ne. gattyp(i))
  763. + write(*,*) 'error in ncainq or ncapt'
  764. if (attlen .ne. gatlen(i))
  765. + write(*,*) 'error in ncainq or ncapt'
  766. 40 continue
  767. call ncclos(ncid, iret)
  768. if (iret .ne. 0) nfails = nfails + 1
  769. return
  770. end
  771. ! subroutine to test ncredf, ncdren, ncvren, ncaren, and
  772. ! ncendf
  773. subroutine tncredf(cdfname, nfails)
  774. #include "../fortran/netcdf.inc"
  775. character*31 cdfname
  776. character*31 attname(2,7)
  777. character*31 gattnam(2)
  778. common /atts/attname, gattnam
  779. common /cdims/ dimnam
  780. character*31 dimnam(MAXNCDIM)
  781. character*31 varnam(7)
  782. common /varn/varnam
  783. integer ncid, iret, latid, varid
  784. dimnam(2) = 'latitude'
  785. varnam(4) = 'realv'
  786. attname(1,6) = 'stringname'
  787. gattnam(1) = 'agency'
  788. ncid = ncopn(cdfname, NCWRITE, iret)
  789. if (iret .ne. 0) nfails = nfails + 1
  790. call ncredf(ncid, iret)
  791. if (iret .ne. 0) nfails = nfails + 1
  792. latid = ncdid(ncid, 'lat', iret)
  793. call ncdren(ncid, latid, 'latitude', iret)
  794. if (iret .ne. 0) nfails = nfails + 1
  795. varid = ncvid(ncid, 'floatv', iret)
  796. call ncvren(ncid, varid, 'realv', iret)
  797. if (iret .ne. 0) nfails = nfails + 1
  798. varid = ncvid(ncid, 'chv', iret)
  799. if (iret .ne. 0) nfails = nfails + 1
  800. call ncaren(ncid, varid, 'longname', 'stringname', iret)
  801. if (iret .ne. 0) nfails = nfails + 1
  802. call ncaren(ncid, NCGLOBAL, 'source', 'agency', iret)
  803. if (iret .ne. 0) nfails = nfails + 1
  804. call ncendf(ncid, iret)
  805. if (iret .ne. 0) nfails = nfails + 1
  806. call ncclos(ncid, iret)
  807. if (iret .ne. 0) nfails = nfails + 1
  808. return
  809. end
  810. !
  811. ! subroutine to test ncvdef
  812. !
  813. subroutine tncvdef(ncid, nfails)
  814. #include "../fortran/netcdf.inc"
  815. integer ncid
  816. ! function to define a netCDF variable
  817. integer dimsiz(MAXNCDIM)
  818. integer latdim, londim, leveldim, timedim, lendim
  819. common /dims/timedim, latdim, londim, leveldim, lendim,
  820. + dimsiz
  821. ! variable ids
  822. integer bid, sid, lid, fid, did, cid, chid
  823. common /vars/bid, sid, lid, fid, did, cid, chid
  824. ! variable shapes
  825. integer bdims(1), fdims(4), ddims(4), ldims(1), sdims(1)
  826. integer chdims(2), cdims(1)
  827. integer iret
  828. !
  829. ! define variables
  830. !
  831. ! byte
  832. !
  833. bdims(1) = timedim
  834. bid = ncvdef(ncid, 'bytev', NCBYTE, 1, bdims, iret)
  835. if (iret .ne. 0) nfails = nfails + 1
  836. !
  837. ! short
  838. !
  839. sdims(1) = timedim
  840. sid = ncvdef (ncid, 'shortv', NCSHORT, 1, sdims, iret)
  841. if (iret .ne. 0) nfails = nfails + 1
  842. !
  843. ! long
  844. !
  845. ldims(1) = latdim
  846. lid = ncvdef (ncid, 'longv', NCLONG, 1, ldims, iret)
  847. if (iret .ne. 0) nfails = nfails + 1
  848. !
  849. ! float
  850. !
  851. fdims(4) = timedim
  852. fdims(1) = leveldim
  853. fdims(2) = londim
  854. fdims(3) = latdim
  855. fid = ncvdef (ncid, 'floatv', NCFLOAT, 4, fdims, iret)
  856. if (iret .ne. 0) nfails = nfails + 1
  857. !
  858. ! double
  859. !
  860. ddims(4) = timedim
  861. ddims(1) = leveldim
  862. ddims(2) = londim
  863. ddims(3) = latdim
  864. did = ncvdef (ncid, 'doublev', NCDOUBLE, 4, ddims, iret)
  865. if (iret .ne. 0) nfails = nfails + 1
  866. !
  867. ! char
  868. !
  869. chdims(2) = timedim
  870. chdims(1) = lendim
  871. chid = ncvdef (ncid, 'chv', NCCHAR, 2, chdims, iret)
  872. if (iret .ne. 0) nfails = nfails + 1
  873. cdims(1) = timedim
  874. cid = ncvdef (ncid, 'cv', NCCHAR, 1, cdims, iret)
  875. if (iret .ne. 0) nfails = nfails + 1
  876. return
  877. end
  878. !
  879. ! subroutine to test ncvgt and ncvgtc
  880. !
  881. subroutine tncvgt(cdfname, nfails)
  882. #include "../fortran/netcdf.inc"
  883. character*31 cdfname
  884. integer ndims, times, lats, lons, levels, lenstr
  885. parameter (times=4, lats=5, lons=5, levels=4)
  886. integer start(4), count(4)
  887. integer ncid, iret, i, m
  888. integer latdim, londim, leveldim, timedim, lendim
  889. integer dimsiz(MAXNCDIM)
  890. common /dims/timedim, latdim, londim, leveldim, lendim,
  891. + dimsiz
  892. integer bid, sid, lid, fid, did, cid, chid
  893. common /vars/bid, sid, lid, fid, did, cid, chid
  894. integer itime, ilev, ilat, ilon
  895. ! arrays of data values to be read
  896. NCBYTE_T barray(times), byval(times)
  897. NCSHORT_T sarray(times), shval(times)
  898. integer larray(lats)
  899. real farray(levels, lats, lons, times)
  900. doubleprecision darray(levels, lats, lons, times)
  901. ! character array of data values to be read
  902. character*31 string
  903. character*31 varnam
  904. integer nvars, natts, recdim
  905. integer vartyp, nvdims, vdims(MAXVDIMS), nvatts
  906. data start/1,1,1,1/
  907. data count/levels, lats, lons, times/
  908. data byval /97, 98, 99, 100/
  909. data shval /10, 11, 12, 13/
  910. ncid = ncopn (cdfname, NCWRITE, iret)
  911. if (iret .ne. 0) nfails = nfails + 1
  912. ! get number of variables in netCDF
  913. call ncinq (ncid, ndims, nvars, natts, recdim, iret)
  914. if (iret .ne. 0) nfails = nfails + 1
  915. do 5 m = 1, nvars-1
  916. ! get variable name, datatype, number of dimensions
  917. ! vector of dimension ids, and number of variable attributes
  918. call ncvinq (ncid, m, varnam, vartyp, nvdims, vdims,
  919. + nvatts, iret)
  920. if (iret .ne. 0) nfails = nfails + 1
  921. if (vartyp .eq. NCBYTE) then
  922. !
  923. ! byte
  924. !
  925. count(1) = times
  926. call ncvgt (ncid, m, start, count, barray, iret)
  927. if (iret .ne. 0) nfails = nfails + 1
  928. do 10 i = 1, times
  929. if (barray(i) .ne. byval(i)) then
  930. write(*,*) 'ncvgt of bytes, got ', barray(i), ' .ne. '
  931. + , byval(i)
  932. end if
  933. 10 continue
  934. else if (vartyp .eq. NCSHORT) then
  935. !
  936. ! short
  937. !
  938. count(1) = times
  939. call ncvgt (ncid, m, start, count, sarray, iret)
  940. if (iret .ne. 0) nfails = nfails + 1
  941. do 20 i = 1, times
  942. if (sarray(i) .ne. shval(i)) then
  943. write(*,*) 'ncvgt of short, got ', sarray(i), ' .ne. '
  944. + , shval(i)
  945. end if
  946. 20 continue
  947. else if (vartyp .eq. NCLONG) then
  948. !
  949. ! long
  950. !
  951. count(1) = lats
  952. call ncvgt (ncid, m, start, count, larray, iret)
  953. if (iret .ne. 0) nfails = nfails + 1
  954. do 30 i = 1, lats
  955. if (larray(i) .ne. 1000) then
  956. write(*,*) 'long error in ncvgt'
  957. end if
  958. 30 continue
  959. else if (vartyp .eq. NCFLOAT) then
  960. !
  961. ! float
  962. !
  963. count(1) = levels
  964. call ncvgt (ncid, m, start, count, farray, iret)
  965. if (iret .ne. 0) nfails = nfails + 1
  966. i = 0
  967. do 40 itime = 1,times
  968. do 41 ilon = 1, lons
  969. do 42 ilat = 1, lats
  970. do 43 ilev = 1, levels
  971. i = i + 1
  972. if (farray(ilev, ilat, ilon, itime) .ne.
  973. + real(i)) then
  974. write (*,*) 'float error in ncvgt'
  975. end if
  976. 43 continue
  977. 42 continue
  978. 41 continue
  979. 40 continue
  980. else if (vartyp .eq. NCDOUBLE) then
  981. !
  982. ! double
  983. !
  984. count(1) = levels
  985. call ncvgt (ncid, m, start, count, darray, iret)
  986. if (iret .ne. 0) nfails = nfails + 1
  987. i = 0
  988. do 50 itime = 1, times
  989. do 51 ilon = 1, lons
  990. do 52 ilat = 1, lats
  991. do 53 ilev = 1, levels
  992. i = i + 1
  993. if (darray(ilev, ilat, ilon, itime) .ne.
  994. + real (i)) then
  995. write(*,*) 'double error in ncvgt:', i,
  996. + darray(ilev, ilat, ilon, itime), '.ne.',
  997. + real (i)
  998. end if
  999. 53 continue
  1000. 52 continue
  1001. 51 continue
  1002. 50 continue
  1003. else
  1004. !
  1005. ! char
  1006. !
  1007. count(1) = 3
  1008. count(2) = 4
  1009. lenstr = 31
  1010. call ncvgtc (ncid, m, start, count, string, lenstr, iret)
  1011. if (iret .ne. 0) nfails = nfails + 1
  1012. if (string .ne. 'testhikin of') then
  1013. write(*,*) 'error in ncvgt, returned string =', string
  1014. end if
  1015. end if
  1016. 5 continue
  1017. call ncclos(ncid, iret)
  1018. if (iret .ne. 0) nfails = nfails + 1
  1019. return
  1020. end
  1021. subroutine tncvgt1(cdfname, nfails)
  1022. #include "../fortran/netcdf.inc"
  1023. character*31 cdfname
  1024. integer ncid, iret
  1025. integer latdim, londim, leveldim, timedim, lendim
  1026. integer dimsiz(MAXNCDIM)
  1027. common /dims/timedim, latdim, londim, leveldim, lendim,
  1028. + dimsiz
  1029. integer bindx(1), sindx(1), lindx(1), findx(4), dindx(4), cindx(1)
  1030. integer bid, sid, lid, fid, did, cid, chid
  1031. common /vars/bid, sid, lid, fid, did, cid, chid
  1032. NCBYTE_T bvalue
  1033. NCSHORT_T svalue
  1034. integer lvalue
  1035. real fvalue
  1036. doubleprecision dvalue
  1037. character*1 c
  1038. real epsilon
  1039. doubleprecision onethird
  1040. data epsilon /.000001/
  1041. data lindx/1/, bindx/1/, sindx/1/, findx/1,1,1,1/
  1042. +dindx/1,1,1,1/, cindx/1/
  1043. data onethird/0.3333333333D0/
  1044. ncid = ncopn (cdfname, NCNOWRIT, iret)
  1045. if (iret .ne. 0) nfails = nfails + 1
  1046. !
  1047. ! test ncvgt1 for byte
  1048. !
  1049. call ncvgt1 (ncid, bid, bindx, bvalue, iret)
  1050. if (iret .ne. 0) nfails = nfails + 1
  1051. if (bvalue .ne. ichar('z')) write(*,*) 'error in ncvgt1 byte:',
  1052. + bvalue, ' .ne.', ichar('z')
  1053. !
  1054. ! test ncvgt1 for short
  1055. !
  1056. call ncvgt1 (ncid, sid, sindx, svalue, iret)
  1057. if (iret .ne. 0) nfails = nfails + 1
  1058. if (svalue .ne. 10) write(*,*) 'error in ncvgt1 short:',
  1059. + svalue, ' .ne.', 10
  1060. !
  1061. ! test ncvgt1 for long
  1062. !
  1063. call ncvgt1 (ncid, lid, lindx, lvalue, iret)
  1064. if (iret .ne. 0) nfails = nfails + 1
  1065. if (lvalue .ne. 1000) write(*,*) 'error in ncvgt1 long:',
  1066. + lvalue, ' .ne.', 1000
  1067. !
  1068. ! test ncvgt1 for float
  1069. !
  1070. call ncvgt1 (ncid, fid, findx, fvalue, iret)
  1071. if (iret .ne. 0) nfails = nfails + 1
  1072. if (abs(fvalue - 3.14159) .gt. epsilon)
  1073. + write(*,*) 'error in ncvgt 1 float:', fvalue,
  1074. + ' not close to', 3.14159
  1075. !
  1076. ! test ncvgt1 for double
  1077. !
  1078. call ncvgt1 (ncid, did, dindx, dvalue, iret)
  1079. if (iret .ne. 0) nfails = nfails + 1
  1080. if (abs(dvalue - onethird) .gt. epsilon) write(*,*)
  1081. + 'error in ncvgt1 double:', dvalue, ' not close to',
  1082. + onethird
  1083. !
  1084. ! test ncvg1c for char
  1085. !
  1086. call ncvg1c (ncid, cid, cindx, c, iret)
  1087. if (iret .ne. 0) nfails = nfails + 1
  1088. if (c .ne. 'a') write(*,*) 'error in ncvg1c'
  1089. call ncclos(ncid, iret)
  1090. if (iret .ne. 0) nfails = nfails + 1
  1091. return
  1092. end
  1093. !
  1094. ! subroutine to test ncvpt and ncvptc
  1095. !
  1096. subroutine tncvpt(cdfname, nfails)
  1097. #include "../fortran/netcdf.inc"
  1098. character*31 cdfname
  1099. ! size of dimensions
  1100. integer times, lats, lons, levels
  1101. parameter (times=4, lats=5, lons=5, levels=4)
  1102. integer ncid, iret
  1103. ! loop control variables
  1104. integer itime, ilev, ilon, ilat, i
  1105. integer latdim, londim, leveldim, timedim, lendim
  1106. integer dimsiz(MAXNCDIM)
  1107. common /dims/timedim, latdim, londim, leveldim, lendim,
  1108. + dimsiz
  1109. integer lenstr
  1110. integer bid, sid, lid, fid, did, cid, chid
  1111. common /vars/bid, sid, lid, fid, did, cid, chid
  1112. ! vector of integers specifying the corner of the hypercube
  1113. ! where the first of the data values will be written
  1114. integer start(4)
  1115. ! vector of integers specifying the edge lengths from the
  1116. ! corner of the hypercube where the first of the data values
  1117. ! will be written
  1118. integer count(4)
  1119. ! arrays of data values to be written
  1120. NCBYTE_T barray(times)
  1121. NCSHORT_T sarray(times)
  1122. integer larray(lats)
  1123. real farray(levels, lats, lons, times)
  1124. doubleprecision darray(levels, lats, lons, times)
  1125. character*31 string
  1126. data start/1,1,1,1/
  1127. data count/levels, lats, lons, times/
  1128. data barray /97, 98, 99, 100/
  1129. data sarray /10, 11, 12, 13/
  1130. ncid = ncopn (cdfname, NCWRITE, iret)
  1131. if (iret .ne. 0) nfails = nfails + 1
  1132. !
  1133. ! byte
  1134. !
  1135. count(1) = times
  1136. call ncvpt (ncid, bid, start, count, barray, iret)
  1137. if (iret .ne. 0) nfails = nfails + 1
  1138. !
  1139. ! short
  1140. !
  1141. count(1) = times
  1142. call ncvpt (ncid, sid, start, count, sarray, iret)
  1143. if (iret .ne. 0) nfails = nfails + 1
  1144. !
  1145. ! long
  1146. !
  1147. do 30 i = 1,lats
  1148. larray(i) = 1000
  1149. 30 continue
  1150. count(1) = lats
  1151. call ncvpt (ncid, lid, start, count, larray, iret)
  1152. if (iret .ne. 0) nfails = nfails + 1
  1153. !
  1154. ! float
  1155. !
  1156. i = 0
  1157. do 40 itime = 1,times
  1158. do 41 ilon = 1, lons
  1159. do 42 ilat = 1, lats
  1160. do 43 ilev = 1, levels
  1161. i = i + 1
  1162. farray(ilev, ilat, ilon, itime) = real (i)
  1163. 43 continue
  1164. 42 continue
  1165. 41 continue
  1166. 40 continue
  1167. count(1) = levels
  1168. call ncvpt (ncid, fid, start, count, farray, iret)
  1169. if (iret .ne. 0) nfails = nfails + 1
  1170. !
  1171. ! double
  1172. !
  1173. i = 0
  1174. do 50 itime = 1, times
  1175. do 51 ilon = 1, lons
  1176. do 52 ilat = 1, lats
  1177. do 53 ilev = 1, levels
  1178. i = i + 1
  1179. darray(ilev, ilat, ilon, itime) = real (i)
  1180. 53 continue
  1181. 52 continue
  1182. 51 continue
  1183. 50 continue
  1184. count(1) = levels
  1185. call ncvpt (ncid, did, start, count, darray, iret)
  1186. if (iret .ne. 0) nfails = nfails + 1
  1187. !
  1188. ! char
  1189. !
  1190. start(1) = 1
  1191. start(2) = 1
  1192. count(1) = 4
  1193. count(2) = 4
  1194. lenstr = 31
  1195. string = 'testthiskind of '
  1196. call ncvptc (ncid, chid,start, count, string, lenstr, iret)
  1197. if (iret .ne. 0) nfails = nfails + 1
  1198. call ncclos(ncid, iret)
  1199. if (iret .ne. 0) nfails = nfails + 1
  1200. return
  1201. end
  1202. subroutine tncvpt1(cdfname, nfails)
  1203. #include "../fortran/netcdf.inc"
  1204. character*31 cdfname
  1205. integer iret, ncid
  1206. integer latdim, londim, leveldim, timedim, lendim
  1207. integer dimsiz(MAXNCDIM)
  1208. common /dims/timedim, latdim, londim, leveldim, lendim,
  1209. + dimsiz
  1210. integer bindx(1), sindx(1), lindx(1), findx(4), dindx(4), cindx(1)
  1211. integer lvalue
  1212. NCSHORT_T svalue
  1213. NCBYTE_T bvalue
  1214. doubleprecision onethird
  1215. integer bid, sid, lid, fid, did, cid, chid
  1216. common /vars/bid, sid, lid, fid, did, cid, chid
  1217. data lindx/1/, bindx/1/, sindx/1/, findx/1,1,1,1/
  1218. +dindx/1,1,1,1/, cindx/1/
  1219. data lvalue /1000/
  1220. data svalue/10/
  1221. data onethird/0.3333333333D0/
  1222. bvalue = ichar('z')
  1223. ncid = ncopn (cdfname, NCWRITE, iret)
  1224. if (iret .ne. 0) nfails = nfails + 1
  1225. !
  1226. ! test ncvpt1 for byte
  1227. !
  1228. call ncvpt1 (ncid, bid, bindx, bvalue, iret)
  1229. if (iret .ne. 0) nfails = nfails + 1
  1230. !
  1231. ! test ncvpt1 for short
  1232. !
  1233. call ncvpt1 (ncid, sid, sindx, svalue, iret)
  1234. if (iret .ne. 0) nfails = nfails + 1
  1235. !
  1236. ! test ncvpt1 for long
  1237. !
  1238. call ncvpt1 (ncid, lid, lindx, lvalue, iret)
  1239. if (iret .ne. 0) nfails = nfails + 1
  1240. !
  1241. ! test ncvpt1 for float
  1242. !
  1243. call ncvpt1 (ncid, fid, findx, 3.14159, iret)
  1244. if (iret .ne. 0) nfails = nfails + 1
  1245. !
  1246. ! test ncvpt1 for double
  1247. !
  1248. call ncvpt1 (ncid, did, dindx, onethird, iret)
  1249. if (iret .ne. 0) nfails = nfails + 1
  1250. !
  1251. ! test ncvp1c for char
  1252. !
  1253. call ncvp1c (ncid, cid, cindx, 'a', iret)
  1254. if (iret .ne. 0) nfails = nfails + 1
  1255. call ncclos (ncid, iret)
  1256. if (iret .ne. 0) nfails = nfails + 1
  1257. return
  1258. end
  1259. !
  1260. ! subroutine to test default fill values
  1261. !
  1262. subroutine tfills(nfails)
  1263. #include "../fortran/netcdf.inc"
  1264. integer ncid
  1265. integer bid, sid, lid, fid, did
  1266. integer ix(1)
  1267. integer l
  1268. NCSHORT_T s
  1269. doubleprecision d
  1270. real f
  1271. NCBYTE_T b
  1272. ncid = NCOPN('fills.nc', NCNOWRIT, iret)
  1273. if (iret .ne. 0) nfails = nfails + 1
  1274. bid = ncvid(ncid, 'b', iret)
  1275. if (iret .ne. 0) nfails = nfails + 1
  1276. sid = ncvid(ncid, 's', iret)
  1277. if (iret .ne. 0) nfails = nfails + 1
  1278. lid = ncvid(ncid, 'l', iret)
  1279. if (iret .ne. 0) nfails = nfails + 1
  1280. fid = ncvid(ncid, 'f', iret)
  1281. if (iret .ne. 0) nfails = nfails + 1
  1282. did = ncvid(ncid, 'd', iret)
  1283. if (iret .ne. 0) nfails = nfails + 1
  1284. ix(1) = 2
  1285. call ncvgt1(ncid, bid, ix, b, iret)
  1286. if (iret .ne. 0) nfails = nfails + 1
  1287. call ncvgt1(ncid, sid, ix, s, iret)
  1288. if (iret .ne. 0) nfails = nfails + 1
  1289. call ncvgt1(ncid, lid, ix, l, iret)
  1290. if (iret .ne. 0) nfails = nfails + 1
  1291. call ncvgt1(ncid, fid, ix, f, iret)
  1292. if (iret .ne. 0) nfails = nfails + 1
  1293. call ncvgt1(ncid, did, ix, d, iret)
  1294. if (iret .ne. 0) nfails = nfails + 1
  1295. if (b .ne. FILBYTE) write(*,*) 'error in byte fill value'
  1296. if (d .ne. FILDOUB) write(*,*) 'error in double fill value'
  1297. if (f .ne. FILFLOAT) write(*,*) 'error in float fill value'
  1298. if (l .ne. FILLONG) write(*,*) 'error in long fill value'
  1299. if (s .ne. FILSHORT) write(*,*) 'error in short fill value'
  1300. return
  1301. end