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

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

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

revision 1.1 by edhill, Tue Jan 27 05:47:32 2004 UTC revision 1.23 by edhill, Fri Dec 17 04:50:05 2004 UTC
# Line 4  C $Name$ Line 4  C $Name$
4  #include "MNC_OPTIONS.h"  #include "MNC_OPTIONS.h"
5                
6  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7    CBOP 0
8    C     !ROUTINE: MNC_CW_ADD_GNAME
9    
10  C       SUBROUTINE MNC_CW_W_RL(  C     !INTERFACE:
11  C      I     myThid, myIter,        SUBROUTINE MNC_CW_ADD_GNAME(
 C      I     filebn,  
 C      I     bi,bj,  
 C      I     Gtype,  
 C      I     Rtype,  
 C      I     vname,  
 C      I     var )  
   
 C       implicit none  
 C #include "netcdf.inc"  
 C #include "mnc_common.h"  
 C #include "EEPARAMS.h"  
   
 C C     Arguments  
 C       integer myThid, myIter, bi,bj  
 C       character*(*) filebn, Gtype  
 C       character*(2) Rtype  
 C       _RL var*(*)  
   
         
   
 C       RETURN  
 C       END  
   
 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
   
       SUBROUTINE MNC_CW_ADD_NAME(  
      I     myThid,  
12       I     name,       I     name,
13       I     ndim,       I     ndim,
14       I     dlens,       I     dlens,
15       I     dnames,       I     dnames,
16       I     inds_beg, inds_end )       I     inds_beg, inds_end,
17         I     myThid )
18    
19    C     !DESCRIPTION:
20    C     Add a grid name to the MNC convenience wrapper layer.
21          
22    C     !USES:
23        implicit none        implicit none
24  #include "mnc_common.h"  #include "mnc_common.h"
25  #include "EEPARAMS.h"  #include "EEPARAMS.h"
26    
27  C     Functions  C     !INPUT PARAMETERS:
       integer IFNBLNK, ILNBLNK  
   
 C     Arguments  
28        integer myThid, ndim        integer myThid, ndim
29        character*(*) name        character*(*) name
30        integer dlens(*), inds_beg(*), inds_end(*)        integer dlens(*), inds_beg(*), inds_end(*)
31        character*(*) dnames(*)        character*(*) dnames(*)
32    CEOP
33    
34  C     Local Variables  C     !LOCAL VARIABLES:
35        integer i, nnf,nnl, indg        integer i, nnf,nnl, indg
36        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
37    
38    C     Functions
39          integer IFNBLNK, ILNBLNK
40    
41        nnf = IFNBLNK(name)        nnf = IFNBLNK(name)
42        nnl = ILNBLNK(name)        nnl = ILNBLNK(name)
43    
44  C     Check that this name is not already defined  C     Check that this name is not already defined
45        CALL MNC_GET_IND(myThid, MNC_MAX_ID, name, mnc_cw_names, indg)        CALL MNC_GET_IND(MNC_MAX_ID, name, mnc_cw_gname, indg, myThid)
46        IF (indg .GT. 0) THEN        IF (indg .GT. 0) THEN
47          write(msgbuf,'(3a)') 'MNC_CW_ADD_NAME ERROR: ''', name,          write(msgbuf,'(3a)') 'MNC_CW_ADD_GNAME ERROR: ''', name,
48       &       ''' is already defined'       &       ''' is already defined'
49          CALL print_error(msgbuf, mythid)          CALL print_error(msgbuf, mythid)
50          stop 'ABNORMAL END: S/R MNC_CW_ADD_NAME'          stop 'ABNORMAL END: S/R MNC_CW_ADD_GNAME'
51        ENDIF        ENDIF
52        CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_cw_names,        CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_gname,
53       &     indg)       &     indg, myThid)
54    
55        mnc_cw_names(indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)        mnc_cw_gname(indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
56        mnc_cw_names(indg)(1:(nnl-nnf+1)) = name(nnf:nnl)        mnc_cw_gname(indg)(1:(nnl-nnf+1)) = name(nnf:nnl)
57        mnc_cw_ndim(indg) = ndim        mnc_cw_ndim(indg) = ndim
58    
59        DO i = 1,ndim        DO i = 1,ndim
# Line 88  C     Check that this name is not alread Line 69  C     Check that this name is not alread
69        RETURN        RETURN
70        END        END
71    
   
72  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
73    CBOP 0
74    C     !ROUTINE: MNC_CW_DEL_GNAME
75    
76        SUBROUTINE MNC_CW_INIT(  C     !INTERFACE:
77       I     myThid,        SUBROUTINE MNC_CW_DEL_GNAME(
78       I     sNx,sNy, OLx,OLy, nSx,nSy, nPx,nPy, Nr )       I     name,
79         I     myThid )
80    
81    C     !DESCRIPTION:
82    C     Delete a grid name from the MNC convenience wrapper layer.
83          
84    C     !USES:
85        implicit none        implicit none
86  #include "mnc_common.h"  #include "mnc_common.h"
87  #include "EEPARAMS.h"  #include "EEPARAMS.h"
88    
89  C     Arguments  C     !INPUT PARAMETERS:
90        integer myThid        integer myThid
91        integer sNx,sNy, OLx,OLy, nSx,nSy, nPx,nPy, Nr        character*(*) name
92    CEOP
93    
94    C     !LOCAL VARIABLES:
95          integer nnf,nnl, indg
96    
97  C     Functions  C     Functions
98        integer IFNBLNK, ILNBLNK        integer IFNBLNK, ILNBLNK
99    
100  C     Local Variables        nnf = IFNBLNK(name)
101        integer CW_MAX_LOC        nnl = ILNBLNK(name)
       parameter ( CW_MAX_LOC = 5 )  
       integer i, ihorz,ihsub,ivert,itime,ihalo, is, n,ntot  
       integer ndim  
       character*(MAX_LEN_MBUF) msgbuf  
       character*(MNC_MAX_CHAR) name  
       character*(MNC_MAX_CHAR) dn(CW_MAX_LOC)  
       character*(5) horz_dat(CW_MAX_LOC), hsub_dat(CW_MAX_LOC),  
      &     vert_dat(CW_MAX_LOC), time_dat(CW_MAX_LOC),  
      &     halo_dat(CW_MAX_LOC)  
       integer dim(CW_MAX_LOC), ib(CW_MAX_LOC), ie(CW_MAX_LOC)  
   
 C     ......12345....12345....12345....12345....12345...  
       data horz_dat /  
      &     '-    ', 'U    ', 'V    ', 'Cen  ', 'Cor  '  /  
       data hsub_dat /  
      &     'xy   ', 'x    ', 'y    ', '-    ', '     '  /  
       data vert_dat /  
      &     '-    ', 'C    ', 'I    ', '     ', '     '  /  
       data time_dat /  
      &     '-    ', 't    ', '     ', '     ', '     '  /  
       data halo_dat /  
      &     'Hn   ', 'Hy   ', '     ', '     ', '     '  /  
   
   
       DO ihorz = 1,5  
         DO is = 1,3  
   
 C         Loop just ONCE if the Horiz component is "-"  
           ihsub = is  
           IF (ihorz .EQ. 1) THEN  
             IF (is .EQ. 1) THEN  
               ihsub = 4  
             ELSE  
               GOTO 10  
             ENDIF  
           ENDIF  
   
           DO ivert = 1,3  
             DO itime = 1,2  
               DO ihalo = 1,2  
   
 C               horiz and hsub  
                 name(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)  
                 n = ILNBLNK(horz_dat(ihorz))  
                 name(1:n) = horz_dat(ihorz)(1:n)  
                 ntot = n + 1                
                 name(ntot:ntot) = '_'  
                 n = ILNBLNK(hsub_dat(ihsub))  
                 name((ntot+1):(ntot+n)) = hsub_dat(ihsub)(1:n)  
                 ntot = ntot + n  
   
 C               vert, time, and halo  
                 write(name((ntot+1):(ntot+7)), '(5a1,a2)') '_',  
      &               vert_dat(ivert)(1:1), '_',  
      &               time_dat(itime)(1:1), '_',  
      &               halo_dat(ihalo)(1:2)  
   
                 ndim = 0  
                 DO i = 1,CW_MAX_LOC  
                   dn(i)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)  
                   dim(i) = 0  
                 ENDDO  
   
 C               Horizontal dimensions  
                 IF (halo_dat(ihalo)(1:5) .EQ. 'Hn   ') THEN  
   
                   IF (hsub_dat(ihsub)(1:1) .EQ. 'x') THEN  
                     ndim = ndim + 1  
                     IF ( (horz_dat(ihorz)(1:3) .EQ. 'Cen')  
      &                   .OR. (horz_dat(ihorz)(1:1) .EQ. 'V') ) THEN  
                       dn(ndim)(1:1) = 'X'  
                       dim(ndim) = sNx + 2*OLx  
                       ib(ndim)  = OLx + 1  
                       ie(ndim)  = OLx + sNx  
                     ENDIF  
                     IF ( (horz_dat(ihorz)(1:3) .EQ. 'Cor')  
      &                   .OR. (horz_dat(ihorz)(1:1) .EQ. 'U') ) THEN  
                       dn(ndim)(1:3) = 'Xp1'  
                       dim(ndim) = sNx + 2*OLx  
                       ib(ndim)  = OLx + 1  
                       ie(ndim)  = OLx + sNx + 1  
                     ENDIF  
                   ENDIF  
                   IF ((hsub_dat(ihsub)(1:1) .EQ. 'y')  
      &                 .OR. (hsub_dat(ihsub)(2:2) .EQ. 'y')) THEN  
                     ndim = ndim + 1  
                     IF ( (horz_dat(ihorz)(1:3) .EQ. 'Cen')  
      &                   .OR. (horz_dat(ihorz)(1:1) .EQ. 'U') ) THEN  
                       dn(ndim)(1:1) = 'Y'  
                       dim(ndim) = sNy + 2*OLy  
                       ib(ndim)  = OLy + 1  
                       ie(ndim)  = OLy + sNy  
                     ENDIF  
                     IF ( (horz_dat(ihorz)(1:3) .EQ. 'Cor')  
      &                   .OR. (horz_dat(ihorz)(1:1) .EQ. 'V') ) THEN  
                       dn(ndim)(1:3) = 'Yp1'  
                       dim(ndim) = sNy + 2*OLy  
                       ib(ndim)  = OLy + 1  
                       ie(ndim)  = OLy + sNy + 1  
                     ENDIF  
                   ENDIF  
   
                 ELSEIF (halo_dat(ihalo)(1:5) .EQ. 'Hy   ') THEN  
   
                   IF (hsub_dat(ihsub)(1:1) .EQ. 'x') THEN  
                     ndim = ndim + 1  
                     dn(ndim)(1:3) = 'Xwh'  
                     dim(ndim) = sNx + 2*OLx  
                     ib(ndim)  = 1  
                     ie(ndim)  = sNx + 2*OLx  
                   ENDIF  
                   IF ((hsub_dat(ihsub)(1:1) .EQ. 'y')  
      &                 .OR. (hsub_dat(ihsub)(2:2) .EQ. 'y')) THEN  
                     ndim = ndim + 1  
                     dn(ndim)(1:3) = 'Ywh'  
                     dim(ndim) = sNy + 2*OLy  
                     ib(ndim)  = 1  
                     ie(ndim)  = sNx + 2*OLx  
                   ENDIF  
   
                 ENDIF  
   
 C               Vertical dimension  
                 IF (vert_dat(ivert)(1:1) .EQ. 'C') THEN  
                   ndim = ndim + 1  
                   dn(ndim)(1:1) = 'Z'  
                   dim(ndim) = Nr  
                   ib(ndim)  = 1  
                   ie(ndim)  = Nr  
                 ENDIF  
                 IF (vert_dat(ivert)(1:1) .EQ. 'I') THEN  
                   ndim = ndim + 1  
                   dn(ndim)(1:3) = 'Zp1'  
                   dim(ndim) = Nr + 1  
                   ib(ndim)  = 1  
                   ie(ndim)  = Nr + 1  
                 ENDIF  
   
 C               Time dimension  
                 IF (time_dat(itime)(1:1) .EQ. 't') THEN  
                   ndim = ndim + 1  
                   dn(ndim)(1:1) = 'T'  
                   dim(ndim) = -1  
                   ib(ndim)  = 1  
                   ie(ndim)  = 1  
                 ENDIF  
   
                 write(*,*) name(1:15), ndim, ' : ', (dim(i), i=1,5)  
   
                 IF (ndim .GT. 0) THEN  
                   CALL MNC_CW_ADD_NAME(myThid, name, ndim,  
      &                 dim, dn, ib, ie)  
                 ENDIF  
102    
103                ENDDO  C     Check that this name is not already defined
104              ENDDO        CALL MNC_GET_IND(MNC_MAX_ID, name, mnc_cw_gname, indg, myThid)
105            ENDDO        IF (indg .LT. 1) THEN
106            RETURN
107          ENDIF
108    
109          mnc_cw_gname(indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
110          mnc_cw_ndim(indg) = 0
111    
112          RETURN
113          END
114    
115   10       CONTINUE  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
116    CBOP 1
117    C     !ROUTINE: MNC_CW_DUMP
118    
119    C     !INTERFACE:
120          SUBROUTINE MNC_CW_DUMP( myThid )
121    
122    C     !DESCRIPTION:
123    C     Write a condensed view of the current state of the MNC look-up
124    C     tables for the convenience wrapper section.
125          
126    C     !USES:
127          implicit none
128    #include "mnc_common.h"
129    #include "SIZE.h"
130    #include "EEPARAMS.h"
131    #include "PARAMS.h"
132    
133    C     !INPUT PARAMETERS:
134          integer myThid
135    CEOP
136    
137    C     !LOCAL VARIABLES:
138          integer i,j, ntot
139          integer NBLNK
140          parameter ( NBLNK = 150 )
141          character s1*(NBLNK), blnk*(NBLNK)
142    
143          _BEGIN_MASTER(myThid)
144          
145          DO i = 1,NBLNK
146            blnk(i:i) = ' '
147          ENDDO
148          
149          s1(1:NBLNK) = blnk(1:NBLNK)
150          write(s1,'(a5,a)') 'MNC: ',
151         &     'The currently defined Grid Types are:'
152          CALL PRINT_MESSAGE(
153         &     s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
154          ntot = 0
155          DO j = 1,MNC_MAX_ID
156            IF (mnc_cw_gname(j)(1:MNC_MAX_CHAR)
157         &       .NE. mnc_blank_name(1:MNC_MAX_CHAR)) THEN
158              
159              ntot = ntot + 1
160              s1(1:NBLNK) = blnk(1:NBLNK)
161              write(s1,'(a5,2i5,a3,a20,i3,a3,5i4,a4,5i4,a4,5i4,6a8)')
162         &         'MNC: ',
163         &         j, ntot, ' : ', mnc_cw_gname(j)(1:20), mnc_cw_ndim(j),
164         &         ' : ', (mnc_cw_dims(i,j), i=1,5),
165         &         '  | ', (mnc_cw_is(i,j), i=1,5),
166         &         '  | ', (mnc_cw_ie(i,j), i=1,5),
167         &         '  | ', (mnc_cw_dn(i,j)(1:7), i=1,5)
168              CALL PRINT_MESSAGE(
169         &         s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
170              
171            ENDIF
172          ENDDO
173          
174          s1(1:NBLNK) = blnk(1:NBLNK)
175          write(s1,'(a5,a)') 'MNC: ',
176         &     'The currently defined Variable Types are:'
177          CALL PRINT_MESSAGE(
178         &     s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
179          ntot = 0
180          DO j = 1,MNC_MAX_ID
181            IF (mnc_cw_vname(j)(1:MNC_MAX_CHAR)
182         &       .NE. mnc_blank_name(1:MNC_MAX_CHAR)) THEN
183              
184              ntot = ntot + 1
185              s1(1:NBLNK) = blnk(1:NBLNK)
186              write(s1,'(a5,2i5,a3,a25,a3,i4)') 'MNC: ',
187         &         j, ntot, ' | ',
188         &         mnc_cw_vname(j)(1:20), ' | ', mnc_cw_vgind(j)
189              CALL PRINT_MESSAGE(
190         &         s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
191              
192              DO i = 1,mnc_cw_vnat(1,j)
193                s1(1:NBLNK) = blnk(1:NBLNK)
194                write(s1,'(a5,a14,i4,a3,a25,a3,a55)')
195         &           'MNC: ','      text_at:',i,
196         &           ' : ', mnc_cw_vtnm(i,j)(1:25), ' : ',
197         &           mnc_cw_vtat(i,j)(1:55)
198                CALL PRINT_MESSAGE(
199         &           s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
200              ENDDO
201              DO i = 1,mnc_cw_vnat(2,j)
202                s1(1:NBLNK) = blnk(1:NBLNK)
203                write(s1,'(a5,a14,i4,a3,a25,a3,i20)')
204         &           'MNC: ','      int__at:',i,
205         &           ' : ', mnc_cw_vinm(i,j)(1:25), ' : ',
206         &           mnc_cw_viat(i,j)
207                CALL PRINT_MESSAGE(
208         &           s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
209              ENDDO
210              DO i = 1,mnc_cw_vnat(3,j)
211                s1(1:NBLNK) = blnk(1:NBLNK)
212                write(s1,'(a5,a14,i4,a3,a25,a3,f25.10)')
213         &           'MNC: ','      dbl__at:',i,
214         &           ' : ', mnc_cw_vdnm(i,j)(1:25), ' : ',
215         &           mnc_cw_vdat(i,j)
216                CALL PRINT_MESSAGE(
217         &           s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
218          ENDDO          ENDDO
219            
220            ENDIF
221        ENDDO        ENDDO
222          IF (ntot .EQ. 0) THEN
223            s1(1:NBLNK) = blnk(1:NBLNK)
224            write(s1,'(a)') 'MNC:    None defined!'
225            CALL PRINT_MESSAGE(
226         &       s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
227          ENDIF
228                
229          _END_MASTER(myThid)
230    
231          RETURN
232          END
233    
234    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
235    CBOP 0
236    C     !ROUTINE: MNC_CW_APPEND_VNAME
237    
238    C     !INTERFACE:
239          SUBROUTINE MNC_CW_APPEND_VNAME(
240         I     vname,
241         I     gname,
242         I     bi_dim, bj_dim,
243         I     myThid )
244    
245    C     !DESCRIPTION:
246    C     If it is not yet defined within the MNC CW layer, append a
247    C     variable type.  Calls MNC\_CW\_ADD\_VNAME().
248      
249    C     !USES:
250          implicit none
251    #include "mnc_common.h"
252    
253    C     !INPUT PARAMETERS:
254          integer myThid, bi_dim, bj_dim
255          character*(*) vname, gname
256    CEOP
257    
258    C     !LOCAL VARIABLES:
259          integer indv
260    
261    C     Check whether vname is defined
262          CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid)
263          IF (indv .LT. 1) THEN
264            CALL MNC_CW_ADD_VNAME(vname, gname, bi_dim, bj_dim, myThid)
265          ENDIF
266    
267    
268          RETURN
269          END
270    
271    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
272    CBOP 0
273    C     !ROUTINE: MNC_CW_ADD_VNAME
274    
275    C     !INTERFACE:
276          SUBROUTINE MNC_CW_ADD_VNAME(
277         I     vname,
278         I     gname,
279         I     bi_dim, bj_dim,
280         I     myThid )
281    
282    C     !DESCRIPTION:
283    C     Add a variable type to the MNC CW layer.  The variable type is an
284    C     association between a variable type name and the following items:
285    C     \begin{center}
286    C       \begin{tabular}[h]{|ll|}\hline
287    C         \textbf{Item}  & \textbf{Purpose}  \\\hline
288    C         grid type  &  defines the in-memory arrangement  \\
289    C         \texttt{bi,bj} dimensions  &  tiling indices, if present  \\\hline
290    C       \end{tabular}
291    C     \end{center}
292      
293    C     !USES:
294          implicit none
295    #include "mnc_common.h"
296    #include "EEPARAMS.h"
297    
298    C     !INPUT PARAMETERS:
299          integer myThid, bi_dim, bj_dim
300          character*(*) vname, gname
301    CEOP
302    
303    C     !LOCAL VARIABLES:
304          integer i, nvf,nvl, ngf,ngl, indv,indg
305          character*(MAX_LEN_MBUF) msgbuf
306    
307    C     Functions
308          integer IFNBLNK, ILNBLNK
309    
310          nvf = IFNBLNK(vname)
311          nvl = ILNBLNK(vname)
312          ngf = IFNBLNK(gname)
313          ngl = ILNBLNK(gname)
314    
315    C     Check that this vname is not already defined
316          CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid)
317          IF (indv .GT. 0) THEN
318            write(msgbuf,'(3a)') 'MNC_CW_ADD_VNAME ERROR: ''',
319         &       vname(nvf:nvl), ''' is already defined'
320            CALL print_error(msgbuf, mythid)
321            stop 'ABNORMAL END: S/R MNC_CW_ADD_VNAME'
322          ENDIF
323          CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_vname,
324         &     indv, myThid)
325    
326    C     Check that gname exists
327          CALL MNC_GET_IND(MNC_MAX_ID, gname, mnc_cw_gname, indg, myThid)
328          IF (indg .LT. 1) THEN
329            write(msgbuf,'(3a)') 'MNC_CW_ADD_VNAME ERROR: ''',
330         &       gname(ngf:ngl), ''' is not defined'
331            CALL print_error(msgbuf, mythid)
332            stop 'ABNORMAL END: S/R MNC_CW_ADD_VNAME'
333          ENDIF
334    
335          mnc_cw_vname(indv)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
336          mnc_cw_vname(indv)(1:(nvl-nvf+1)) = vname(nvf:nvl)
337          mnc_cw_vgind(indv) = indg
338          DO i = 1,3
339            mnc_cw_vnat(i,indv) = 0
340          ENDDO
341          mnc_cw_vbij(1,indv) = bi_dim
342          mnc_cw_vbij(2,indv) = bj_dim
343    
344    #ifdef MNC_DEBUG_GTYPE
345          CALL MNC_CW_ADD_VATTR_TEXT(vname,1,'mitgcm_grid',gname, myThid)
346    #endif
347    
348          RETURN
349          END
350    
351    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
352    CBOP 0
353    C     !ROUTINE: MNC_CW_DEL_VNAME
354    
355    C     !INTERFACE:
356          SUBROUTINE MNC_CW_DEL_VNAME(
357         I     vname,
358         I     myThid )
359    
360    C     !DESCRIPTION:
361    C     Delete a variable type from the MNC CW layer.
362      
363    C     !USES:
364          implicit none
365    #include "mnc_common.h"
366    #include "EEPARAMS.h"
367    
368    C     !INPUT PARAMETERS:
369          integer myThid
370          character*(*) vname
371    CEOP
372    
373    C     !LOCAL VARIABLES:
374          integer i, indv
375    
376    C     Check that this vname is not already defined
377          CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid)
378          IF (indv .LT. 1) THEN
379            RETURN
380          ENDIF
381    
382          mnc_cw_vname(indv)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
383          mnc_cw_vgind(indv) = 0
384          DO i = 1,3
385            mnc_cw_vnat(i,indv) = 0
386          ENDDO
387    
388          RETURN
389          END
390    
391    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
392    CBOP
393    C     !ROUTINE: MNC_CW_ADD_VATTR_TEXT
394    C     !INTERFACE:
395          SUBROUTINE MNC_CW_ADD_VATTR_TEXT(
396         I     vname, tname, tval,
397         I     myThid )
398    
399    C     !DESCRIPTION:
400    C     Add a text attribute
401          
402    C     !USES:
403          implicit none
404    
405    C     !INPUT PARAMETERS:
406          integer myThid
407          character*(*) vname, tname, tval
408          integer ival
409          REAL*8 dval
410    CEOP
411          ival = 0
412          dval = 0.0D0
413          CALL MNC_CW_ADD_VATTR_ANY(vname, 1,
414         &     tname, ' ', ' ', tval, ival, dval, myThid )
415          RETURN
416          END
417    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
418    CBOP
419    C     !ROUTINE: MNC_CW_ADD_VATTR_INT
420    C     !INTERFACE:
421          SUBROUTINE MNC_CW_ADD_VATTR_INT(
422         I     vname, iname, ival,
423         I     myThid )
424    
425    C     !DESCRIPTION:
426    C     Add integer attribute
427    
428    C     !USES:
429          implicit none
430    
431    C     !INPUT PARAMETERS:
432          integer myThid
433          character*(*) vname, iname
434          integer ival
435          REAL*8 dval
436    CEOP
437          dval = 0.0D0
438          CALL MNC_CW_ADD_VATTR_ANY(vname, 2,
439         &     ' ', iname, ' ', ' ', ival, dval, myThid )
440          RETURN
441          END
442    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
443    CBOP
444    C !ROUTINE: MNC_CW_ADD_VATTR_DBL
445    C !INTERFACE:
446          SUBROUTINE MNC_CW_ADD_VATTR_DBL(
447         I     vname, dname, dval,
448         I     myThid )
449    
450    C     !DESCRIPTION:
451    C     Add double-precision real attribute
452    
453    C     !USES:
454          implicit none
455    
456    C     !INPUT PARAMETERS:
457          integer myThid
458          character*(*) vname, dname
459          integer ival
460          REAL*8 dval
461    CEOP
462          ival = 0
463          CALL MNC_CW_ADD_VATTR_ANY(vname, 3,
464         &     ' ', ' ', dname, ' ', ival, dval, myThid )
465          RETURN
466          END
467    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
468    CBOP 1
469    C     !ROUTINE: MNC_CW_ADD_VATTR_ANY
470    
471    C     !INTERFACE:
472          SUBROUTINE MNC_CW_ADD_VATTR_ANY(
473         I     vname,
474         I     atype,
475         I     tname, iname, dname,
476         I     tval,  ival,  dval,
477         I     myThid )
478    
479    C     !DESCRIPTION:
480    
481    C     !USES:
482          implicit none
483    #include "mnc_common.h"
484    #include "EEPARAMS.h"
485    
486    C     !INPUT PARAMETERS:
487          integer myThid
488          integer atype
489          character*(*) vname
490          character*(*) tname, iname, dname
491          character*(*) tval
492          integer ival
493          REAL*8 dval
494    CEOP
495    
496    C     !LOCAL VARIABLES:
497          integer n, nvf,nvl, n1,n2, indv
498          character*(MAX_LEN_MBUF) msgbuf
499    
500    C     Functions
501          integer IFNBLNK, ILNBLNK
502    
503          nvf = IFNBLNK(vname)
504          nvl = ILNBLNK(vname)
505    
506    C     Check that vname is defined
507          CALL MNC_GET_IND(MNC_MAX_ID, vname, mnc_cw_vname, indv, myThid)
508          IF (indv .LT. 1) THEN
509            write(msgbuf,'(3a)') 'MNC_CW_ADD_VATTR_ANY ERROR: ''',
510         &       vname(nvf:nvl), ''' is not defined'
511            CALL print_error(msgbuf, mythid)
512            stop 'ABNORMAL END: S/R MNC_CW_ADD_VATTR_ANY'
513          ENDIF
514    
515          IF (atype .EQ. 1) THEN
516    C       Text Attribute
517            n = mnc_cw_vnat(1,indv) + 1
518            n1 = IFNBLNK(tname)
519            n2 = ILNBLNK(tname)
520    C       write(*,*) atype,tname(n1:n2)
521            mnc_cw_vtnm(n,indv)(1:MNC_MAX_CHAR) =
522         &       mnc_blank_name(1:MNC_MAX_CHAR)
523            mnc_cw_vtnm(n,indv)(1:(n2-n1+1)) = tname(n1:n2)
524            n1 = IFNBLNK(tval)
525            n2 = ILNBLNK(tval)
526            IF ((n1 .EQ. 0) .OR. (n2 .EQ. 0)) THEN
527              mnc_cw_vtat(n,indv)(1:MNC_MAX_CHAR) =
528         &         mnc_blank_name(1:MNC_MAX_CHAR)          
529              mnc_cw_vnat(1,indv) = n
530            ELSE
531              mnc_cw_vtat(n,indv)(1:MNC_MAX_CHAR) =
532         &         mnc_blank_name(1:MNC_MAX_CHAR)
533              mnc_cw_vtat(n,indv)(1:(n2-n1+1)) = tval(n1:n2)
534              mnc_cw_vnat(1,indv) = n
535            ENDIF
536          ENDIF
537            
538          IF (atype .EQ. 2) THEN
539    C       Integer Attribute
540            n = mnc_cw_vnat(2,indv) + 1
541            n1 = IFNBLNK(iname)
542            n2 = ILNBLNK(iname)
543    C       write(*,*) atype,iname(n1:n2)
544            mnc_cw_vinm(n,indv)(1:(n2-n1+1)) = iname(n1:n2)
545            mnc_cw_viat(n,indv) = ival
546            mnc_cw_vnat(2,indv) = n
547          ENDIF
548    
549          IF (atype .EQ. 3) THEN
550    C       Double Attribute
551            n = mnc_cw_vnat(3,indv) + 1
552            n1 = IFNBLNK(dname)
553            n2 = ILNBLNK(dname)
554    C       write(*,*) atype,dname(n1:n2)
555            mnc_cw_vdnm(n,indv)(1:(n2-n1+1)) = dname(n1:n2)
556            mnc_cw_vdat(n,indv) = dval
557            mnc_cw_vnat(3,indv) = n
558          ENDIF
559          
560          RETURN
561          END
562    
563    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
564    CBOP 1
565    C     !ROUTINE: MNC_CW_GET_TILE_NUM
566    
567    C     !INTERFACE:
568          SUBROUTINE MNC_CW_GET_TILE_NUM(
569         I     bi, bj,
570         O     uniq_tnum,
571         I     myThid )
572    
573    C     !DESCRIPTION:
574    
575    C     !USES:
576          implicit none
577    #include "EEPARAMS.h"
578    #include "SIZE.h"
579    #ifdef ALLOW_EXCH2
580    #include "W2_EXCH2_TOPOLOGY.h"
581    #include "W2_EXCH2_PARAMS.h"
582    #endif
583    
584    C     !INPUT PARAMETERS:
585          integer myThid, bi,bj, uniq_tnum
586    CEOP
587    
588    C     !LOCAL VARIABLES:
589          integer iG,jG
590    
591          iG = 0
592          jG = 0
593    
594    #ifdef ALLOW_EXCH2
595    
596          uniq_tnum = W2_myTileList(bi)
597    
598    #else
599    
600    C     Global tile number for simple (non-cube) domains
601          iG = bi+(myXGlobalLo-1)/sNx
602          jG = bj+(myYGlobalLo-1)/sNy
603    
604          uniq_tnum = (jG - 1)*(nPx*nSx) + iG
605    
606    #endif
607    
608    CEH3      write(*,*) 'iG,jG,uniq_tnum :', iG,jG,uniq_tnum
609    
610          RETURN
611          END
612    
613    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
614    CBOP 1
615    C     !ROUTINE: MNC_CW_FILE_AORC
616          
617    C     !INTERFACE:
618          SUBROUTINE MNC_CW_FILE_AORC(
619         I     fname,
620         O     indf,
621         I     lbi, lbj, uniq_tnum,
622         I     myThid )
623    
624    C     !DESCRIPTION:
625    C     Open a NetCDF file, appending to the file if it already exists
626    C     and, if not, creating a new file.
627    
628    C     !USES:
629          implicit none
630    #include "netcdf.inc"
631    #include "mnc_common.h"
632    #include "EEPARAMS.h"
633    
634    C     !INPUT PARAMETERS:
635          integer myThid, indf, lbi, lbj, uniq_tnum
636          character*(*) fname
637    CEOP
638    
639    C     !LOCAL VARIABLES:
640          integer ierr
641    
642    C     Check if the file is already open
643          CALL MNC_GET_IND(MNC_MAX_ID, fname, mnc_f_names, indf, myThid)
644          IF (indf .GT. 0) THEN
645            RETURN
646          ENDIF
647    
648    C     Try to open an existing file
649          CALL MNC_FILE_TRY_READ(fname, ierr, indf, myThid)
650          IF (ierr .NE. NF_NOERR) THEN
651    C       Try to create a new one
652            CALL MNC_FILE_OPEN(fname, 0, indf, myThid)
653          ENDIF
654    
655    C     Add the global attributes
656          CALL MNC_CW_SET_GATTR(fname, lbi,lbj, uniq_tnum, myThid)
657    
658        RETURN        RETURN
659        END        END
660    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.23
  ViewVC Help
Powered by ViewVC 1.1.22