NetCDF-Fortran  4.4.3
nf_attio.F90
1 #include "nfconfig.inc"
2 !---------- Routines to put/get attribute data of various data types ----------
3 
4 ! Replacement for fort-attio.c
5 
6 ! Written by: Richard Weed, Ph.D.
7 ! Center for Advanced Vehicular Systems
8 ! Mississippi State University
9 ! rweed@cavs.msstate.edu
10 
11 
12 ! License (and other Lawyer Language)
13 
14 ! This software is released under the Apache 2.0 Open Source License. The
15 ! full text of the License can be viewed at :
16 !
17 ! http:www.apache.org/licenses/LICENSE-2.0.html
18 !
19 ! The author grants to the University Center for Atmospheric Research
20 ! (UCAR), Boulder, CO, USA the right to revise and extend the software
21 ! without restriction. However, the author retains all copyrights and
22 ! intellectual property rights explicitly stated in or implied by the
23 ! Apache license
24 
25 ! Version 1.: Sept. 2005 - Initial Cray X1 version
26 ! Version 2.: May 2006 - Updated to support g95
27 ! Version 3.: April 2009 - Updated to Netcdf 4.0.1
28 ! Version 4.: April 2010 - Updated to Netcdf 4.1.1
29 ! Version 5.: Feb. 2013 - bug fixes for fortran 4.4
30 
31 !--------------------------------- nf_put_att_text ---------------------------
32  Function nf_put_att_text(ncid, varid, name, nlen, text) RESULT(status)
33 
34 ! Write variable or global attribute text string to dataset ncid
35 
36  USE netcdf_nc_interfaces
37 
38  Implicit NONE
39 
40  Integer, Intent(IN) :: ncid, varid, nlen
41  Character(LEN=*), Intent(IN) :: name, text
42 
43  Integer :: status
44 
45  Integer(KIND=C_INT) :: cncid, cvarid, cstatus
46  Integer(KIND=C_SIZE_T) :: cnlen
47  Character(LEN=(LEN(name)+1)) :: cname
48  Integer :: ie
49 
50  cncid = ncid
51  cvarid = varid -1 ! Subtract 1 to get C varid
52  cnlen = nlen
53 
54  cname = addcnullchar(name, ie)
55 
56  cstatus = nc_put_att_text(cncid, cvarid, cname(1:ie+1), cnlen, &
57  text)
58 
59  status = cstatus
60 
61  End Function nf_put_att_text
62 !--------------------------------- nf_put_att_text_a ------------------------
63  Function nf_put_att_text_a(ncid, varid, name, nlen, text) RESULT(status)
64 
65 ! New routine to support passing an array of single characters
66 ! Write variable or global attribute array of characters to dataset ncid
67 
68  USE netcdf_nc_interfaces
69 
70  Implicit NONE
71 
72  Integer, Intent(IN) :: ncid, varid, nlen
73  Character(LEN=*), Intent(IN) :: name
74  Character(LEN=1), Intent(IN) :: text(*)
75 
76  Integer :: status
77 
78  Integer(KIND=C_INT) :: cncid, cvarid, cstatus
79  Integer(KIND=C_SIZE_T) :: cnlen
80  Character(LEN=(LEN(name)+1)) :: cname
81  Integer :: ie
82 
83  cncid = ncid
84  cvarid = varid -1 ! Subtract 1 to get C varid
85  cnlen = nlen
86 
87  cname = addcnullchar(name, ie)
88 
89  cstatus = nc_put_att_text(cncid, cvarid, cname(1:ie+1), cnlen, &
90  text)
91 
92  status = cstatus
93 
94  End Function nf_put_att_text_a
95 !--------------------------------- nf_put_att_int1 -------------------------
96  Function nf_put_att_int1(ncid, varid, name, xtype, nlen, i1vals) &
97  result(status)
98 
99 ! Write variable or global attribute byte data to dataset ncid
100 
101  USE netcdf_nc_interfaces
102 
103  Implicit NONE
104 
105  Integer, Intent(IN) :: ncid, varid, nlen, xtype
106 
107  Character(LEN=*), Intent(IN) :: name
108  Integer(KIND=NFINT1), Intent(IN) :: i1vals(*)
109 
110  Integer :: status
111 
112  Integer(KIND=C_INT) :: cncid, cvarid, cstatus, cxtype
113  Integer(KIND=C_SIZE_T) :: cnlen
114  Character(LEN=(LEN(name)+1)) :: cname
115  Integer :: ie
116 
117  If (c_signed_char < 0) Then ! schar not supported by processor
118  status = nc_ebadtype
119  RETURN
120  EndIf
121 
122  cncid = ncid
123  cvarid = varid -1 ! Subtract 1 to get C varid
124  cnlen = nlen
125  cxtype = xtype
126 
127 ! Check for C null char on name and add one
128 
129  cname = addcnullchar(name, ie)
130 
131 #if NF_INT1_IS_C_SIGNED_CHAR
132  cstatus = nc_put_att_schar(cncid, cvarid, cname(1:ie+1), &
133  cxtype, cnlen, i1vals)
134 #elif NF_INT1_IS_C_SHORT
135  cstatus = nc_put_att_short(cncid, cvarid, cname(1:ie+1), &
136  cxtype, cnlen, i1vals)
137 #elif NF_INT1_IS_C_INT
138  cstatus = nc_put_att_int(cncid, cvarid, cname(1:ie+1), &
139  cxtype, cnlen, i1vals)
140 #elif NF_INT1_IS_C_LONG
141  cstatus = nc_put_att_long(cncid, cvarid, cname(1:ie+1), &
142  cxtype, cnlen, i1vals)
143 #endif
144  status = cstatus
145 
146  End Function nf_put_att_int1
147 !--------------------------------- nf_put_att_int2 -------------------------
148  Function nf_put_att_int2(ncid, varid, name, xtype, nlen, i2vals) &
149  result(status)
150 
151 ! Write variable or global attribute 16 bit integer data to dataset ncid
152 
153  USE netcdf_nc_interfaces
154 
155  Implicit NONE
156 
157  Integer, Intent(IN) :: ncid, varid, nlen, xtype
158 
159  Character(LEN=*), Intent(IN) :: name
160  Integer(KIND=NFINT2), Intent(IN) :: i2vals(*)
161 
162  Integer :: status
163 
164  Integer(KIND=C_INT) :: cncid, cvarid, cstatus, cxtype
165  Integer(KIND=C_SIZE_T) :: cnlen
166  Character(LEN=(LEN(name)+1)) :: cname
167  Integer :: ie
168 
169  If (c_short < 0) Then ! short not supported by processor
170  status = nc_ebadtype
171  Return
172  EndIf
173 
174  cncid = ncid
175  cvarid = varid -1 ! Subtract 1 to get C varid
176  cnlen = nlen
177  cxtype = xtype
178 
179  cname = addcnullchar(name, ie)
180 
181 #if NF_INT2_IS_C_SHORT
182  cstatus = nc_put_att_short(cncid, cvarid, cname(1:ie+1), &
183  cxtype, cnlen, i2vals)
184 #elif NF_INT2_IS_C_INT
185  cstatus = nc_put_att_int(cncid, cvarid, cname(1:ie+1), &
186  cxtype, cnlen, i2vals)
187 #elif NF_INT2_IS_C_LONG
188  cstatus = nc_put_att_long(cncid, cvarid, cname(1:ie+1), &
189  cxtype, cnlen, i2vals)
190 #endif
191  status = cstatus
192 
193  End Function nf_put_att_int2
194 !--------------------------------- nf_put_att_int --------------------------
195  Function nf_put_att_int(ncid, varid, name, xtype, nlen, ivals) &
196  result(status)
197 
198 ! Write variable or global attribute default integer data to dataset ncid
199 
200  USE netcdf_nc_interfaces
201 
202  Implicit NONE
203 
204  Integer, Intent(IN) :: ncid, varid, nlen, xtype
205 
206  Character(LEN=*), Intent(IN) :: name
207  Integer(NFINT), Intent(IN) :: ivals(*)
208 
209  Integer :: status
210 
211  Integer(KIND=C_INT) :: cncid, cvarid, cstatus, cxtype
212  Integer(KIND=C_SIZE_T) :: cnlen
213  Character(LEN=(LEN(name)+1)) :: cname
214  Integer :: ie
215 
216  cncid = ncid
217  cvarid = varid -1 ! Subtract 1 to get C varid
218  cnlen = nlen
219  cxtype = xtype
220 
221 ! Check for C null char and add one if missing
222 
223  cname = addcnullchar(name, ie)
224 
225 #if NF_INT_IS_C_INT
226  cstatus = nc_put_att_int(cncid, cvarid, cname(1:ie+1), &
227  cxtype, cnlen, ivals)
228 #elif NF_INT_IS_C_LONG
229  cstatus = nc_put_att_long(cncid, cvarid, cname(1:ie+1), &
230  cxtype, cnlen, ivals)
231 #endif
232  status = cstatus
233 
234  End Function nf_put_att_int
235 !--------------------------------- nf_put_att_real -------------------------
236  Function nf_put_att_real(ncid, varid, name, xtype, nlen, rvals) &
237  result(status)
238 
239 ! Write variable or global attribute Real(RK4) data to dataset ncid
240 
241  USE netcdf_nc_interfaces
242 
243  Implicit NONE
244 
245  Integer, Intent(IN) :: ncid, varid, nlen, xtype
246 
247  Character(LEN=*), Intent(IN) :: name
248  Real(NFREAL), Intent(IN) :: rvals(*)
249 
250  Integer :: status
251 
252  Integer(KIND=C_INT) :: cncid, cvarid, cstatus, cxtype
253  Integer(KIND=C_SIZE_T) :: cnlen
254  Character(LEN=(LEN(name)+1)) :: cname
255  Integer :: ie
256 
257  cncid = ncid
258  cvarid = varid -1 ! Subtract 1 to get C varid
259  cnlen = nlen
260  cxtype = xtype
261 
262 ! Check for C null char and add one if missing
263 
264  cname = addcnullchar(name, ie)
265 
266 #if NF_REAL_IS_C_DOUBLE
267  cstatus = nc_put_att_double(cncid, cvarid, cname(1:ie+1), &
268  cxtype, cnlen, rvals)
269 #else
270  cstatus = nc_put_att_float(cncid, cvarid, cname(1:ie+1), &
271  cxtype, cnlen, rvals)
272 #endif
273  status = cstatus
274 
275  End Function nf_put_att_real
276 !--------------------------------- nf_put_att_double -----------------------
277  Function nf_put_att_double(ncid, varid, name, xtype, nlen, dvals) &
278  result(status)
279 
280 ! Write variable or global attribute Real(RK8) to dataset ncid
281 
282  USE netcdf_nc_interfaces
283 
284  Implicit NONE
285 
286  Integer, Intent(IN) :: ncid, varid, nlen, xtype
287 
288  Character(LEN=*), Intent(IN) :: name
289  Real(RK8), Intent(IN) :: dvals(*)
290 
291  Integer :: status
292 
293  Integer(KIND=C_INT) :: cncid, cvarid, cstatus, cxtype
294  Integer(KIND=C_SIZE_T) :: cnlen
295  Character(LEN=(LEN(name)+1)) :: cname
296  Integer :: ie
297 
298  cncid = ncid
299  cvarid = varid -1 ! Subtract 1 to get C varid
300  cnlen = nlen
301  cxtype = xtype
302 
303 ! Check for C null char and add one if missing
304 
305  cname = addcnullchar(name, ie)
306 
307  cstatus = nc_put_att_double(cncid, cvarid, cname(1:ie+1), &
308  cxtype, cnlen, dvals)
309 
310  status = cstatus
311 
312  End Function nf_put_att_double
313 !--------------------------------- nf_get_att_text -----------------------
314  Function nf_get_att_text(ncid, varid, name, text) RESULT(status)
315 
316 ! Read variable or global attribute character string from dataset ncid
317 
318  USE netcdf_nc_interfaces
319 
320  Implicit NONE
321 
322  Integer, Intent(IN) :: ncid, varid
323  Character(LEN=*), Intent(IN) :: name
324  Character(LEN=*), Intent(OUT) :: text
325 
326  Integer :: status
327 
328  Integer(KIND=C_INT) :: cncid, cvarid, cstatus
329  Character(LEN=(LEN(name)+1)) :: cname
330  Integer :: ie
331 
332  cncid = ncid
333  cvarid = varid -1 ! Subtract 1 to get C varid
334  text = repeat(" ", len(text))
335 
336 ! Check for C null char and add one if missing
337 
338  cname = addcnullchar(name, ie)
339 
340  cstatus = nc_get_att_text(cncid, cvarid, cname(1:ie+1), text)
341 
342  status = cstatus
343 
344  End Function nf_get_att_text
345 !--------------------------------- nf_get_att_text_a -----------------------
346  Function nf_get_att_text_a(ncid, varid, name, text) RESULT(status)
347 
348 ! New routine to support passing an array of single characters
349 ! Read variable or global attribute array of characters from dataset ncid
350 
351  USE netcdf_nc_interfaces
352 
353  Implicit NONE
354 
355  Integer, Intent(IN) :: ncid, varid
356  Character(LEN=*), Intent(IN) :: name
357  Character(LEN=1), Intent(OUT) :: text(*)
358 
359  Integer :: status
360 
361  Integer(KIND=C_INT) :: cncid, cvarid, cstatus
362  Character(LEN=(LEN(name)+1)) :: cname
363  Integer :: ie
364 
365  cncid = ncid
366  cvarid = varid -1 ! Subtract 1 to get C varid
367 
368 ! Check for C null char and add one if missing
369 
370  cname = addcnullchar(name, ie)
371 
372  cstatus = nc_get_att_text(cncid, cvarid, cname(1:ie+1), text)
373 
374  status = cstatus
375 
376  End Function nf_get_att_text_a
377 !--------------------------------- nf_get_att_int1 -------------------------
378  Function nf_get_att_int1(ncid, varid, name, i1vals) RESULT(status)
379 
380 ! Read variable or global attribute BYTE integer data from dataset ncid
381 
382  USE netcdf_nc_interfaces
383 
384  Implicit NONE
385 
386  Integer, Intent(IN) :: ncid, varid
387  Character(LEN=*), Intent(IN) :: name
388  Integer(KIND=NFINT1), Intent(OUT) :: i1vals(*)
389 
390  Integer :: status
391 
392  Integer(KIND=C_INT) :: cncid, cvarid, cstatus
393  Character(LEN=(LEN(name)+1)) :: cname
394  Integer :: ie
395 
396  If (c_signed_char < 0) Then ! schar not supported by processor
397  status = nc_ebadtype
398  RETURN
399  EndIf
400 
401  cncid = ncid
402  cvarid = varid -1 ! Subtract 1 to get C varid
403 
404 ! Check for C null char and add one if missing
405 
406  cname = addcnullchar(name, ie)
407 
408 #if NF_INT1_IS_C_SIGNED_CHAR
409  cstatus = nc_get_att_schar(cncid, cvarid, cname(1:ie+1), i1vals)
410 #elif NF_INT1_IS_C_SHORT
411  cstatus = nc_get_att_short(cncid, cvarid, cname(1:ie+1), i1vals)
412 #elif NF_INT1_IS_C_INT
413  cstatus = nc_get_att_int(cncid, cvarid, cname(1:ie+1), i1vals)
414 #elif NF_INT1_IS_C_LONG
415  cstatus = nc_get_att_long(cncid, cvarid, cname(1:ie+1), i1vals)
416 #endif
417  status = cstatus
418 
419  End Function nf_get_att_int1
420 !--------------------------------- nf_get_att_int2 --------------------------
421  Function nf_get_att_int2(ncid, varid, name, i2vals) RESULT(status)
422 
423 ! Read variable or global attribute 16 bit integer data from dataset ncid
424 
425  USE netcdf_nc_interfaces
426 
427  Implicit NONE
428 
429  Integer, Intent(IN) :: ncid, varid
430  Character(LEN=*), Intent(IN) :: name
431  Integer(KIND=NFINT2), Intent(OUT) :: i2vals(*)
432 
433  Integer :: status
434 
435  Integer(KIND=C_INT) :: cncid, cvarid, cstatus
436  Character(LEN=(LEN(name)+1)) :: cname
437  Integer :: ie
438 
439  If (c_short < 0) Then ! short not supported by processor
440  status = nc_ebadtype
441  RETURN
442  EndIf
443 
444  cncid = ncid
445  cvarid = varid -1 ! Subtract 1 to get C varid
446 
447 ! Check for C null char and add one if missing
448 
449  cname = addcnullchar(name, ie)
450 
451 #if NF_INT2_IS_C_SHORT
452  cstatus = nc_get_att_short(cncid, cvarid, cname(1:ie+1), i2vals)
453 #elif NF_INT2_IS_C_INT
454  cstatus = nc_get_att_int(cncid, cvarid, cname(1:ie+1), i2vals)
455 #elif NF_INT2_IS_C_LONG
456  cstatus = nc_get_att_long(cncid, cvarid, cname(1:ie+1), i2vals)
457 #endif
458  status = cstatus
459 
460  End Function nf_get_att_int2
461 !--------------------------------- nf_get_att_int ---------------------------
462  Function nf_get_att_int(ncid, varid, name, ivals) RESULT(status)
463 
464 ! Read variable or global attribute default Integer data from dataset ncid
465 
466  USE netcdf_nc_interfaces
467 
468  Implicit NONE
469 
470  Integer, Intent(IN) :: ncid, varid
471  Character(LEN=*), Intent(IN) :: name
472  Integer(NFINT), Intent(OUT) :: ivals(*)
473 
474  Integer :: status
475 
476  Integer(KIND=C_INT) :: cncid, cvarid, cstatus
477  Character(LEN=(LEN(name)+1)) :: cname
478  Integer :: ie
479 
480  cncid = ncid
481  cvarid = varid -1 ! Subtract 1 to get C varid
482 
483 ! Check for C null char and add one if missing
484 
485  cname = addcnullchar(name, ie)
486 
487 #if NF_INT_IS_C_INT
488  cstatus = nc_get_att_int(cncid, cvarid, cname(1:ie+1), ivals)
489 #elif NF_INT_IS_C_LONG
490  cstatus = nc_get_att_long(cncid, cvarid, cname(1:ie+1), ivals)
491 #endif
492  status = cstatus
493 
494  End Function nf_get_att_int
495 !--------------------------------- nf_get_att_real -------------------------
496  Function nf_get_att_real(ncid, varid, name, rvals) RESULT(status)
497 
498 ! Read variable or global attribute Real(RK4) data from dataset ncid
499 
500  USE netcdf_nc_interfaces
501 
502  Implicit NONE
503 
504  Integer, Intent(IN) :: ncid, varid
505  Character(LEN=*), Intent(IN) :: name
506  Real(NFREAL), Intent(OUT) :: rvals(*)
507 
508  Integer :: status
509 
510  Integer(KIND=C_INT) :: cncid, cvarid, cstatus
511  Character(LEN=(LEN(name)+1)) :: cname
512  Integer :: ie
513 
514  cncid = ncid
515  cvarid = varid -1 ! Subtract 1 to get C varid
516 
517 ! Check for C null char and add one if missing
518 
519  cname = addcnullchar(name, ie)
520 
521 #if NF_REAL_IS_C_DOUBLE
522  cstatus = nc_get_att_double(cncid, cvarid, cname(1:ie+1), rvals)
523 #else
524  cstatus = nc_get_att_float(cncid, cvarid, cname(1:ie+1), rvals)
525 #endif
526  status = cstatus
527 
528  End Function nf_get_att_real
529 !--------------------------------- nf_get_att_double -----------------------
530  Function nf_get_att_double(ncid, varid, name, dvals) RESULT(status)
531 
532 ! Read variable or global attribute Real(RK8) data from dataset ncid
533 
534  USE netcdf_nc_interfaces
535 
536  Implicit NONE
537 
538  Integer, Intent(IN) :: ncid, varid
539  Character(LEN=*), Intent(IN) :: name
540  Real(RK8), Intent(OUT) :: dvals(*)
541 
542  Integer :: status
543 
544  Integer(KIND=C_INT) :: cncid, cvarid, cstatus
545  Character(LEN=(LEN(name)+1)) :: cname
546  Integer :: ie
547 
548  cncid = ncid
549  cvarid = varid -1 ! Subtract 1 to get C varid
550 
551 ! Check for C null char and add one if missing
552 
553  cname = addcnullchar(name, ie)
554 
555  cstatus = nc_get_att_double(cncid, cvarid, cname(1:ie+1), dvals)
556 
557  status = cstatus
558 
559  End Function nf_get_att_double
module procedure interfaces for utility routines

Return to the Main Unidata NetCDF page.
Generated on Sun Mar 27 2016 13:46:12 for NetCDF-Fortran. NetCDF is a Unidata library.