/[MITgcm]/MITgcm/pkg/mnc/mnc_var.F
ViewVC logotype

Diff of /MITgcm/pkg/mnc/mnc_var.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.1 by edhill, Mon Jan 5 06:20:08 2004 UTC revision 1.14 by edhill, Mon Mar 29 03:33:52 2004 UTC
# Line 3  C $Name$ Line 3  C $Name$
3                
4  #include "MNC_OPTIONS.h"  #include "MNC_OPTIONS.h"
5                
6  C==================================================================  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7    CBOP
8    C     !ROUTINE: MNC_VAR_INIT_DBL
9    
10    C     !INTERFACE:
11        SUBROUTINE MNC_VAR_INIT_DBL(        SUBROUTINE MNC_VAR_INIT_DBL(
      I     myThid,  
12       I     fname,       I     fname,
13       I     gname,       I     gname,
14       I     vname,       I     vname,
15       I     fillval )       I     myThid )
16    
17    C     !DESCRIPTION:
18    C     Create a double-precision real variable within a NetCDF file
19    C     context.
20          
21    C     !USES:
22          implicit none
23    #include "netcdf.inc"
24    
25    C     !INPUT PARAMETERS:
26          integer myThid
27          character*(*) fname,gname,vname
28    CEOP
29    
30          CALL MNC_VAR_INIT_ANY(fname,gname,vname, NF_DOUBLE, myThid)
31          RETURN
32          END
33    
34    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
35    CBOP
36    C     !ROUTINE: MNC_VAR_INIT_REAL
37    
38    C     !INTERFACE:
39          SUBROUTINE MNC_VAR_INIT_REAL(
40         I     fname,
41         I     gname,
42         I     vname,
43         I     myThid )
44    
45    C     !DESCRIPTION:
46    C     Create a single-precision real variable within a NetCDF file
47    C     context.
48          
49    C     !USES:
50          implicit none
51    #include "netcdf.inc"
52    
53    C     !INPUT PARAMETERS:
54          integer myThid
55          character*(*) fname,gname,vname
56    CEOP
57    
58          CALL MNC_VAR_INIT_ANY(fname,gname,vname, NF_FLOAT, myThid)
59          RETURN
60          END
61    
62    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
63    CBOP
64    C     !ROUTINE: MNC_VAR_INIT_INT
65    
66    C     !INTERFACE:
67          SUBROUTINE MNC_VAR_INIT_INT(
68         I     fname,
69         I     gname,
70         I     vname,
71         I     myThid )
72    
73    C     !DESCRIPTION:
74    C     Create an integer variable within a NetCDF file context.
75      
76    C     !USES:
77        implicit none        implicit none
78    #include "netcdf.inc"
79    
80    C     !INPUT PARAMETERS:
81          integer myThid
82          character*(*) fname,gname,vname
83    CEOP
84    
85          CALL MNC_VAR_INIT_ANY(fname,gname,vname, NF_INT, myThid)
86          RETURN
87          END
88    
89    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
90    CBOP
91    C     !ROUTINE: MNC_VAR_INIT_ANY
92    
93    C     !INTERFACE:
94          SUBROUTINE MNC_VAR_INIT_ANY(
95         I     fname,
96         I     gname,
97         I     vname,
98         I     vtype,
99         I     myThid )
100    
101    C     !DESCRIPTION:
102    C     General function for creating variables within a NetCDF file
103    C     context.
104          
105    C     !USES:
106          implicit none
107    #include "netcdf.inc"
108  #include "mnc_common.h"  #include "mnc_common.h"
109  #include "EEPARAMS.h"  #include "EEPARAMS.h"
110    
111    C     !INPUT PARAMETERS:
112          integer myThid
113          character*(*) fname,gname,vname
114          integer vtype
115    
116    C     !LOCAL VARIABLES:
117          integer i,j,k, n, indf,indv, fid, nd, ngrid, is,ie, err
118          integer vid, nv, ind_g_finfo, needed, nvar
119          character*(MAX_LEN_MBUF) msgbuf
120          integer ids(20)
121          integer lenf,leng,lenv
122    CEOP
123    C     Functions
124          integer ILNBLNK
125    
126    C     Strip trailing spaces
127          lenf = ILNBLNK(fname)
128          leng = ILNBLNK(gname)
129          lenv = ILNBLNK(vname)
130    
131    C     Check that the file is open
132          CALL MNC_GET_IND(MNC_MAX_ID, fname, mnc_f_names, indf, myThid)
133          IF (indf .LT. 1) THEN
134            write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname,
135         &       ''' must be opened first'
136            CALL print_error(msgbuf, mythid)
137            stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
138          ENDIF
139          fid = mnc_f_info(indf,2)
140    
141    C     Check for sufficient storage space in mnc_fv_ids
142          needed = 1 + 3*(mnc_fv_ids(indf,1) + 1)
143          IF (needed .GE. MNC_MAX_INFO) THEN
144            write(msgbuf,'(2a,i7,a)') 'MNC ERROR: MNC_MAX_INFO exceeded',
145         &       ': please increase it to ', 2*MNC_MAX_INFO,
146         &       ' in the file ''pkg/mnc/mnc_common.h'''
147            CALL print_error(msgbuf, mythid)
148            stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
149          ENDIF
150    
151    C     Get the grid information
152          ngrid = mnc_f_info(indf,3)
153          IF (ngrid .LT. 1) THEN
154            write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname(1:lenf),
155         &       ''' contains NO grids'
156            CALL print_error(msgbuf, mythid)
157            stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
158          ENDIF
159          DO i = 1,ngrid
160            j = 4 + (i-1)*3
161            k = mnc_f_info(indf,j)
162            n = ILNBLNK(mnc_g_names(k))
163            IF ((leng .EQ. n)
164         &       .AND. (mnc_g_names(k)(1:n) .EQ. gname(1:n))) THEN
165              ind_g_finfo = j
166              is = mnc_f_info(indf,(j+1))
167              ie = mnc_f_info(indf,(j+2))
168              nd = 0
169              DO k = is,ie
170                nd = nd + 1
171                ids(nd) = mnc_d_ids(mnc_fd_ind(indf,k))
172              ENDDO
173              GOTO 10
174            ENDIF
175          ENDDO
176          write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
177         &     ''' does not contain grid ''', gname(1:leng), ''''
178          CALL print_error(msgbuf, mythid)
179          stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
180     10   CONTINUE
181    
182    C     Check if the variable is already defined
183          nvar = mnc_fv_ids(indf,1)
184          DO i = 1,nvar
185            j = 2 + 3*(i-1)
186            IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vname) THEN
187              k = mnc_f_info(indf,mnc_fv_ids(indf,j+2))
188              IF (mnc_g_names(k) .NE. gname) THEN
189                write(msgbuf,'(5a)') 'MNC ERROR: variable ''',
190         &           vname(1:lenv), ''' is already defined in file ''',
191         &           fname(1:lenf), ''' but using a different grid shape'
192                CALL print_error(msgbuf, mythid)
193                stop 'ABNORMAL END: S/R MNC_VAR_INIT_ANY'
194              ELSE
195    C           Its OK, the variable and grid names are the same
196                RETURN
197              ENDIF
198            ENDIF
199          ENDDO
200    
201    C     Add the variable definition
202          CALL MNC_FILE_REDEF(fname, myThid)
203          err = NF_DEF_VAR(fid, vname, vtype, nd, ids, vid)
204          write(msgbuf,'(5a)') 'defining variable ''', vname(1:lenv),
205         &     ''' in file ''', fname(1:lenf), ''''
206          CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
207    
208    C     Success, so save the variable info
209          CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID,mnc_v_names,indv, myThid)
210          mnc_v_names(indv)(1:lenv) = vname(1:lenv)
211          nv = mnc_fv_ids(indf,1)
212          i = 2 + nv*3
213          mnc_fv_ids(indf,i)   = indv
214          mnc_fv_ids(indf,i+1) = vid
215          mnc_fv_ids(indf,i+2) = ind_g_finfo
216          mnc_fv_ids(indf,1) = nv + 1
217    
218          RETURN
219          END
220    
221    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
222    CBOP
223    C     !ROUTINE: MNC_VAR_ADD_ATTR_STR
224    
225    C     !INTERFACE:
226          SUBROUTINE MNC_VAR_ADD_ATTR_STR(
227         I     fname,
228         I     vname,
229         I     atname,
230         I     sval,
231         I     myThid )
232    
233    C     !DESCRIPTION:
234    C     Subroutine for adding a character string attribute to a NetCDF
235    C     file.
236          
237    C     !USES:
238          implicit none
239    
240    C     !INPUT PARAMETERS:
241          integer myThid
242          character*(*) fname,vname,atname,sval
243    CEOP
244    
245          CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname,
246         &     1, sval, 0, 0.0D0, 0.0, 0, myThid)
247          RETURN
248          END
249    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
250    CBOP
251    C     !ROUTINE: MNC_VAR_ADD_ATTR_DBL
252    
253    C     !INTERFACE:
254          SUBROUTINE MNC_VAR_ADD_ATTR_DBL(
255         I     fname,
256         I     vname,
257         I     atname,
258         I     nv,
259         I     dval,
260         I     myThid )
261    
262    C     !DESCRIPTION:
263    C     Subroutine for adding a double-precision real attribute to a
264    C     NetCDF file.
265      
266    C     !USES:
267          implicit none
268    
269    C     !INPUT PARAMETERS:
270          integer myThid,nv
271          character*(*) fname,vname,atname
272          REAL*8 dval(*)
273    CEOP
274    
275          CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname,
276         &     2, ' ', nv, dval, 0.0, 0, myThid)
277          RETURN
278          END
279    
280    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
281    CBOP
282    C     !ROUTINE:
283    
284    C     !INTERFACE:
285          SUBROUTINE MNC_VAR_ADD_ATTR_REAL(
286         I     fname,
287         I     vname,
288         I     atname,
289         I     nv,
290         I     rval,
291         I     myThid )
292    
293    C     !DESCRIPTION:
294    C     Subroutine for adding a single-precision real attribute to a
295    C     NetCDF file.
296      
297    C     !USES:
298          implicit none
299    
300    C     !INPUT PARAMETERS:
301          integer myThid,nv
302          character*(*) fname,vname,atname
303          REAL*4 rval(*)
304    CEOP
305    
306          CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname,
307         &     3, ' ', nv, 0.0D0, rval, 0, myThid)
308          RETURN
309          END
310    
311    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
312    CBOP
313    C     !ROUTINE: MNC_VAR_ADD_ATTR_INT
314    
315    C     !INTERFACE:
316          SUBROUTINE MNC_VAR_ADD_ATTR_INT(
317         I     fname,
318         I     vname,
319         I     atname,
320         I     nv,
321         I     ival,
322         I     myThid )
323    
324    C     !DESCRIPTION:
325    C     Subroutine for adding an integer attribute to a
326    C     NetCDF file.
327          
328    C     !USES:
329          implicit none
330    
331    C     !INPUT PARAMETERS:
332          integer myThid,nv
333          character*(*) fname,vname,atname
334          integer ival(*)
335    CEOP
336    
337          CALL MNC_VAR_ADD_ATTR_ANY(fname,vname,atname,
338         &     4, ' ', nv, 0.0D0, 0.0, ival, myThid)
339          RETURN
340          END
341    
342    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
343    CBOP
344    C     !ROUTINE: MNC_VAR_ADD_ATTR_ANY
345    
346    C     !INTERFACE:
347          SUBROUTINE MNC_VAR_ADD_ATTR_ANY(
348         I     fname,
349         I     vname,
350         I     atname,
351         I     atype, cs,len,dv,rv,iv,
352         I     myThid )
353    
354    C     !DESCRIPTION:
355    C     General subroutine for adding attributes to a NetCDF file.
356          
357    C     !USES:
358          implicit none
359    #include "netcdf.inc"
360    #include "mnc_common.h"
361    #include "EEPARAMS.h"
362    
363    C     !INPUT PARAMETERS:
364          integer myThid,atype,len
365          character*(*) fname,vname,atname
366          character*(*) cs
367          REAL*8 dv(*)
368          REAL*4 rv(*)
369          integer iv(*)
370    
371    C     !LOCAL VARIABLES:
372          integer n, indf,ind_fv_ids, fid,vid, err
373          character*(MAX_LEN_MBUF) msgbuf
374          integer lenf,lenv,lenat,lens
375    CEOP
376    C     Functions
377          integer ILNBLNK
378    
379    C     Strip trailing spaces
380          lenf = ILNBLNK(fname)
381          lenv = ILNBLNK(vname)
382          lenat = ILNBLNK(atname)
383          lens = ILNBLNK(cs)
384    
385          CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)
386          IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
387            write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
388         &       ''' is not open or does not contain variable ''',
389         &       vname(1:lenv), ''''
390            CALL print_error(msgbuf, mythid)
391            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
392          ENDIF
393          fid = mnc_f_info(indf,2)
394          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
395    
396    C     Set the attribute
397          CALL MNC_FILE_REDEF(fname, myThid)
398          IF (atype .EQ. 1) THEN
399            err = NF_PUT_ATT_TEXT(fid, vid, atname, lens, cs)
400          ELSEIF (atype .EQ. 2) THEN
401            err = NF_PUT_ATT_DOUBLE(fid, vid, atname, NF_DOUBLE, len, dv)
402          ELSEIF (atype .EQ. 3) THEN
403            err = NF_PUT_ATT_REAL(fid, vid, atname, NF_FLOAT, len, rv)
404          ELSEIF (atype .EQ. 4) THEN
405            err = NF_PUT_ATT_INT(fid, vid, atname, NF_INT, len, iv)
406          ELSE
407            write(msgbuf,'(a,i10,a)') 'MNC ERROR: atype = ''', atype,
408         &       ''' is invalid--must be: [1-4]'
409            n = ILNBLNK(msgbuf)
410            CALL print_error(msgbuf(1:n), mythid)
411            stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_ANY'
412          ENDIF
413          write(msgbuf,'(5a)') 'adding attribute ''', atname(1:lenat),
414         &     ''' to file ''', fname(1:lenf), ''''
415          CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
416    
417          RETURN
418          END
419    
420    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
421    
422          SUBROUTINE MNC_VAR_WRITE_DBL(
423         I     fname,
424         I     vname,
425         I     var,
426         I     myThid )
427    
428          implicit none
429    C     Arguments
430          integer myThid
431          character*(*) fname,vname
432          REAL*8 var(*)
433    
434          CALL MNC_VAR_WRITE_ANY(fname,vname,1,0,var,0.0,0, myThid)
435          RETURN
436          END
437    
438    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
439    
440          SUBROUTINE MNC_VAR_WRITE_REAL(
441         I     fname,
442         I     vname,
443         I     var,
444         I     myThid )
445    
446          implicit none
447    C     Arguments
448          integer myThid
449          character*(*) fname,vname
450          REAL*4 var(*)
451    
452          CALL MNC_VAR_WRITE_ANY(fname,vname,2,0,0.0D0,var,0, myThid)
453          RETURN
454          END
455    
456    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
457    
458          SUBROUTINE MNC_VAR_WRITE_INT(
459         I     fname,
460         I     vname,
461         I     var,
462         I     myThid )
463    
464          implicit none
465  C     Arguments  C     Arguments
466        integer myThid        integer myThid
467        character*(*) fname        character*(*) fname,vname
468        character*(*) gname        integer var(*)
469        character*(*) vname  
470        _RL fillval        CALL MNC_VAR_WRITE_ANY(fname,vname,3,0,0.0D0,0.0,var, myThid)
471          RETURN
472          END
473    
474    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
475    
476          SUBROUTINE MNC_VAR_APPEND_DBL(
477         I     fname,
478         I     vname,
479         I     var,
480         I     append,
481         I     myThid )
482    
483          implicit none
484    C     Arguments
485          integer myThid, append
486          character*(*) fname,vname
487          REAL*8 var(*)
488    
489          CALL MNC_VAR_WRITE_ANY(fname,vname,1,append,var,0.0,0, myThid)
490          RETURN
491          END
492    
493    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
494    
495          SUBROUTINE MNC_VAR_APPEND_REAL(
496         I     fname,
497         I     vname,
498         I     var,
499         I     append,
500         I     myThid )
501    
502          implicit none
503    C     Arguments
504          integer myThid, append
505          character*(*) fname,vname
506          REAL*4 var(*)
507    
508          CALL MNC_VAR_WRITE_ANY(fname,vname,2,append,0.0D0,var,0,myThid)
509          RETURN
510          END
511    
512    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
513    
514          SUBROUTINE MNC_VAR_APPEND_INT(
515         I     fname,
516         I     vname,
517         I     var,
518         I     append,
519         I     myThid )
520    
521          implicit none
522    C     Arguments
523          integer myThid, append
524          character*(*) fname,vname
525          integer var(*)
526    
527          CALL MNC_VAR_WRITE_ANY(fname,vname,3,append,0.0D0,0.0,var,myThid)
528          RETURN
529          END
530    
531    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
532    
533          SUBROUTINE MNC_VAR_WRITE_ANY(
534         I     fname,
535         I     vname,
536         I     vtype,
537         I     append,
538         I     dv,
539         I     rv,
540         I     iv,
541         I     myThid )
542    
543          implicit none
544    #include "netcdf.inc"
545    #include "mnc_common.h"
546    #include "EEPARAMS.h"
547    
548    C     Arguments
549          integer myThid, vtype
550          character*(*) fname,vname
551          REAL*8 dv(*)
552          REAL*4 rv(*)
553          integer iv(*)
554          integer append
555    
556  C     Functions  C     Functions
557        integer ILNBLNK        integer ILNBLNK
558    
559  C     Local Variables  C     Local Variables
560        integer i, ind, fid        integer i,j,k, n, indf,ind_fv_ids, fid,vid,did, ig, err, ds,de
561        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
562          integer lenf,lenv, lend
563          integer vstart(100), vcount(100)
564    
565    C     Strip trailing spaces
566          lenf = ILNBLNK(fname)
567          lenv = ILNBLNK(vname)
568    
569  C     Is the file open?        CALL MNC_GET_FVINDS(fname, vname, indf, ind_fv_ids, myThid)
570        CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, ind)        IF ((indf .LT. 1).OR.(ind_fv_ids .LT. 1)) THEN
571        IF ( ind .GT. 0 ) THEN          write(msgbuf,'(5a)') 'MNC ERROR: file ''', fname(1:lenf),
572          write(msgbuf,'(3a)') 'MNC ERROR: file ''',       &       ''' is not open or does not contain variable ''',
573       &       fname, ''' must be opened first'       &       vname(1:lenv), ''''
574          CALL print_error( msgbuf, mythid )          CALL print_error(msgbuf, mythid)
575          stop 'ABNORMAL END: S/R MNC_FILE_ADD_ATTR_INT'          stop 'ABNORMAL END: S/R MNC_VAR_ADD_ATTR_STR'
576        ENDIF        ENDIF
577        fid = mnc_f_info(ind,2)        fid = mnc_f_info(indf,2)
578          vid = mnc_fv_ids(indf,(ind_fv_ids+1))
579    
580    C     Get the lengths from the dim IDs
581          ig = mnc_fv_ids(indf,(ind_fv_ids+2))
582          ds = mnc_f_info(indf,ig+1)
583          de = mnc_f_info(indf,ig+2)
584          k = 0
585          DO i = ds,de
586            k = k + 1
587            vstart(k) = 1
588            vcount(k) = mnc_d_size( mnc_fd_ind(indf,i) )
589          ENDDO
590    
591    C     Check for the unlimited dimension
592          j = mnc_d_size( mnc_fd_ind(indf,de) )
593          IF (j .LT. 1) THEN
594            did = mnc_d_ids( mnc_fd_ind(indf,de) )
595            err = NF_INQ_DIMLEN(fid, did, lend)
596            write(msgbuf,'(a)') 'reading current length of unlimited dim'
597            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
598            IF (append .GT. 0) THEN
599              lend = lend + append
600            ENDIF
601            IF (lend .LT. 1) lend = 1
602            vstart(k) = lend
603            vcount(k) = 1
604          ENDIF
605    
606          CALL MNC_FILE_ENDDEF(fname, myThid)
607          IF (vtype .EQ. 1) THEN
608            err = NF_PUT_VARA_DOUBLE(fid, vid, vstart, vcount, dv)
609          ELSEIF (vtype .EQ. 2) THEN
610            err = NF_PUT_VARA_REAL(fid, vid, vstart, vcount, rv)
611          ELSEIF (vtype .EQ. 3) THEN
612            err = NF_PUT_VARA_INT(fid, vid, vstart, vcount, iv)
613          ELSE
614            write(msgbuf,'(a,i10,a)') 'MNC ERROR: vtype = ''', vtype,
615         &       ''' is invalid--must be: [1|2|3]'
616            n = ILNBLNK(msgbuf)
617            CALL print_error(msgbuf(1:n), mythid)
618            stop 'ABNORMAL END: S/R MNC_VAR_WRITE_ALL'
619          ENDIF  
620          write(msgbuf,'(5a)') 'writing variable ''', vname(1:lenv),
621         &     ''' to file ''', fname(1:lenf), ''''
622          CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
623    
624          RETURN
625        END        END
626    
627    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
628    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.14
  ViewVC Help
Powered by ViewVC 1.1.22