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

Annotation of /MITgcm/pkg/mnc/mnc_dim.F

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

Revision 1.7 - (hide annotations) (download)
Fri Mar 19 03:28:36 2004 UTC (20 years, 2 months ago) by edhill
Branch: MAIN
Changes since 1.6: +14 -14 lines 
 o edit all MNC subroutines so that myThid is the _last_ argument
1 edhill 1.7 C $Header: /u/u3/gcmpack/MITgcm/pkg/mnc/mnc_dim.F,v 1.6 2004/02/05 00:13:47 edhill Exp $
2 edhill 1.1 C $Name: $
3    
4     #include "MNC_OPTIONS.h"
5    
6 edhill 1.4 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7 edhill 1.1
8     SUBROUTINE MNC_DIM_INIT(
9 edhill 1.2 I fname,
10 edhill 1.1 I dname,
11 edhill 1.7 I dlen,
12     I myThid )
13 edhill 1.1
14 edhill 1.3 C Arguments
15     integer myThid, dlen
16     character*(*) fname, dname
17    
18 edhill 1.7 CALL MNC_DIM_INIT_ALL(fname, dname, dlen, 'Y', myThid)
19 edhill 1.3
20     RETURN
21     END
22    
23    
24 edhill 1.4 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
25 edhill 1.3
26     SUBROUTINE MNC_DIM_INIT_ALL(
27     I fname,
28     I dname,
29     I dlen,
30 edhill 1.7 I doWrite,
31     I myThid )
32 edhill 1.3
33 edhill 1.1 implicit none
34 edhill 1.3 #include "netcdf.inc"
35 edhill 1.1 #include "mnc_common.h"
36     #include "EEPARAMS.h"
37    
38     C Arguments
39 edhill 1.3 integer myThid, dlen
40     character*(*) fname, dname
41     character*(1) doWrite
42 edhill 1.1
43     C Functions
44 edhill 1.3 integer ILNBLNK, IFNBLNK
45 edhill 1.1
46     C Local Variables
47 edhill 1.3 integer i,j, indf,indd, n,nf, dnf,dnl, ntmp, idd, err, tlen
48 edhill 1.1 character*(MAX_LEN_MBUF) msgbuf
49    
50 edhill 1.2 nf = ILNBLNK(fname)
51 edhill 1.3
52     dnf = IFNBLNK(dname)
53     dnl = ILNBLNK(dname)
54 edhill 1.2
55     C Verify that the file exists
56 edhill 1.7 CALL MNC_GET_IND(MNC_MAX_ID, fname, mnc_f_names, indf, myThid)
57 edhill 1.2 IF ( indf .LT. 1 ) THEN
58     write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname(1:nf),
59     & ''' does not exist'
60 edhill 1.1 CALL print_error( msgbuf, mythid )
61 edhill 1.2 stop 'ABNORMAL END: S/R MNC_DIM_INIT'
62 edhill 1.1 ENDIF
63 edhill 1.2
64     C Verify that the dim is not currently defined within the file
65     n = mnc_f_alld(indf,1)
66     DO i = 1,n
67 edhill 1.5 j = mnc_f_alld(indf,i+1)
68 edhill 1.3 ntmp = ILNBLNK(mnc_d_names(j))
69     IF ((ntmp .EQ. (dnl-dnf+1))
70 edhill 1.5 & .AND. (dname(dnf:dnl) .EQ. mnc_d_names(j)(1:ntmp))) THEN
71     IF (mnc_d_size(j) .NE. dlen) THEN
72     IF ((mnc_d_size(j) .GT. 0) .OR. (dlen .GT. 0)) THEN
73     write(msgbuf,'(5a)') 'MNC ERROR: dimension ''',
74     & dname(dnf:dnl), ''' already exists within file ''',
75     & fname(1:nf), ''' and its size cannot be changed'
76     CALL print_error(msgbuf, mythid)
77     stop 'ABNORMAL END: S/R MNC_DIM_INIT'
78     ELSE
79     C Its OK, the names are the same and both are specifying the
80     C unlimited dimension
81     RETURN
82     ENDIF
83     ELSE
84     C Its OK, the names and sizes are identical
85     RETURN
86     ENDIF
87 edhill 1.2 ENDIF
88     ENDDO
89    
90 edhill 1.7 CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_d_names, indd, myThid)
91 edhill 1.1
92 edhill 1.3 C Create the dim within the file
93     IF (doWrite(1:1) .EQ. 'Y') THEN
94    
95     tlen = dlen
96     IF (dlen .LT. 1) tlen = NF_UNLIMITED
97    
98 edhill 1.7 CALL MNC_FILE_REDEF(fname, myThid)
99 edhill 1.3 err = NF_DEF_DIM(mnc_f_info(indf,2), dname(dnf:dnl), tlen, idd)
100     write(msgbuf,'(5a)') 'MNC_DIM_INIT ERROR: cannot create ',
101     & 'dim ''', dname(dnf:dnl), ''' in file ''', fname(1:nf)
102 edhill 1.7 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
103 edhill 1.3
104 edhill 1.1 ENDIF
105    
106     C Add to tables
107 edhill 1.3 mnc_d_names(indd)(1:(dnl-dnf+1)) = dname(dnf:dnl)
108 edhill 1.2 mnc_d_size(indd) = dlen
109 edhill 1.3 mnc_d_ids(indd) = idd
110 edhill 1.2 mnc_f_alld(indf,1) = n + 1
111     mnc_f_alld(indf,n+2) = indd
112 edhill 1.1
113     RETURN
114     END
115 edhill 1.6
116     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
117    
118     SUBROUTINE MNC_DIM_UNLIM_SIZE(
119     I fname,
120 edhill 1.7 I unlim_sz,
121     I myThid )
122 edhill 1.6
123     implicit none
124     #include "netcdf.inc"
125     #include "mnc_common.h"
126     #include "EEPARAMS.h"
127    
128     C Arguments
129     integer myThid, unlim_sz
130     character*(*) fname
131    
132     C Functions
133     integer ILNBLNK, IFNBLNK
134    
135     C Local Variables
136     integer i,j, nf, indf, fid, unlimid, err
137     character*(MAX_LEN_MBUF) msgbuf
138    
139     nf = ILNBLNK(fname)
140    
141     C Verify that the file exists
142 edhill 1.7 CALL MNC_GET_IND(MNC_MAX_ID, fname, mnc_f_names, indf, myThid)
143 edhill 1.6 IF (indf .LT. 1) THEN
144     write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname(1:nf),
145     & ''' does not exist'
146     CALL print_error(msgbuf, mythid)
147     stop 'ABNORMAL END: S/R MNC_DIM_UNLIM_SIZE'
148     ENDIF
149     fid = mnc_f_info(indf,2)
150    
151     C Find the unlimited dim and its current size
152     unlim_sz = -1
153     DO i = 1,mnc_f_alld(indf,1)
154     j = mnc_f_alld(indf,i+1)
155     IF (mnc_d_size(j) .EQ. -1) THEN
156     unlimid = mnc_d_ids(j)
157     err = NF_INQ_DIMLEN(fid, unlimid, unlim_sz)
158     write(msgbuf,'(3a)') 'MNC_DIM_UNLIM_SIZE ERROR: cannot ',
159     & 'determine unlimited dim size in file ''', fname(1:nf)
160 edhill 1.7 CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
161 edhill 1.6 RETURN
162     ENDIF
163     ENDDO
164    
165     RETURN
166     END
167    
168    
169     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
170 edhill 1.1
  ViewVC Help
Powered by ViewVC 1.1.22