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

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

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

revision 1.1 by edhill, Tue Jan 6 23:19:27 2004 UTC revision 1.3 by edhill, Sun Jan 25 00:22:57 2004 UTC
# Line 7  C======================================= Line 7  C=======================================
7    
8        SUBROUTINE MNC_DIM_INIT(        SUBROUTINE MNC_DIM_INIT(
9       I     myThid,       I     myThid,
10         I     fname,
11       I     dname,       I     dname,
      I     dunits,  
12       I     dlen )       I     dlen )
13    
       implicit none  
 #include "mnc_common.h"  
 #include "EEPARAMS.h"  
   
14  C     Arguments  C     Arguments
15        integer myThid        integer myThid, dlen
16        character*(*) dname        character*(*) fname, dname
       character*(*) dunits  
       integer dlen  
   
 C     Functions  
       integer ILNBLNK  
   
 C     Local Variables  
       integer ind, n1,n2  
       character*(MAX_LEN_MBUF) msgbuf  
17    
18  C     Check that dname is not already used        CALL MNC_DIM_INIT_ALL(myThid, fname, dname, dlen, 'Y')
       CALL MNC_GET_IND(myThid, MNC_MAX_ID, dname, mnc_d_names, ind)  
       IF ( ind .GT. 0 ) THEN  
         write(msgbuf,'(3a)') 'MNC ERROR: dimension ''',  
      &       dname, ''' already exists--cannot declare it twice'  
         CALL print_error( msgbuf, mythid )  
         stop 'ABNORMAL END: S/R MNC_DIM_INT'  
       ENDIF  
         
       CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_d_names, ind)  
   
 C     Check that the dimension name fits in the table  
       n1 = ILNBLNK(dname)  
       IF ( n1 .GT. MNC_MAX_CHAR) THEN  
         n1 = MNC_MAX_CHAR  
         write(msgbuf,'(a)') 'MNC WARNING: dimension name too long'  
         CALL print_error(msgbuf, mythid)  
       ENDIF  
       n2 = ILNBLNK(dunits)  
       IF ( n2 .GT. MNC_MAX_CHAR) THEN  
         n2 = MNC_MAX_CHAR  
         write(msgbuf,'(a)') 'MNC WARNING: dimension units too long'  
         CALL print_error(msgbuf, mythid)  
       ENDIF  
   
 C     Add to tables  
       mnc_d_names(ind)(1:n1) = dname(1:n1)  
       mnc_d_units(ind)(1:n2) = dunits(1:n2)  
       mnc_d_size(ind) = dlen  
19    
20        RETURN        RETURN
21        END        END
22    
23    
24  C==================================================================  C==================================================================
25    
26        SUBROUTINE MNC_DIM_REMOVE(        SUBROUTINE MNC_DIM_INIT_ALL(
27       I     myThid,       I     myThid,
28       I     dname )       I     fname,
29         I     dname,
30         I     dlen,
31         I     doWrite )
32    
33        implicit none        implicit none
34    #include "netcdf.inc"
35  #include "mnc_common.h"  #include "mnc_common.h"
36  #include "EEPARAMS.h"  #include "EEPARAMS.h"
37    
38  C     Arguments  C     Arguments
39        integer myThid        integer myThid, dlen
40        character*(*) dname        character*(*) fname, dname
41          character*(1) doWrite
42    
43  C     Functions  C     Functions
44        integer ILNBLNK        integer ILNBLNK, IFNBLNK
45    
46  C     Local Variables  C     Local Variables
47        integer ind, n        integer i,j, indf,indd, n,nf, dnf,dnl, ntmp, idd, err, tlen
48        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
49    
50  C     Check that dname is not already used        nf = ILNBLNK(fname)
51        CALL MNC_GET_IND(myThid, MNC_MAX_ID, dname, mnc_d_names, ind)  
52        IF ( ind .GT. 0 ) THEN        dnf = IFNBLNK(dname)
53          mnc_d_names(ind)(1:MNC_MAX_CHAR) =        dnl = ILNBLNK(dname)
54       &       mnc_blank_name(1:MNC_MAX_CHAR)  
55    C     Verify that the file exists
56          CALL MNC_GET_IND(myThid, MNC_MAX_ID, fname, mnc_f_names, indf)
57          IF ( indf .LT. 1 ) THEN
58            write(msgbuf,'(3a)') 'MNC ERROR: file ''', fname(1:nf),
59         &       ''' does not exist'
60            CALL print_error( msgbuf, mythid )
61            stop 'ABNORMAL END: S/R MNC_DIM_INIT'
62        ENDIF        ENDIF
63    
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            ntmp = ILNBLNK(mnc_d_names(j))
68            j = mnc_f_alld(indf,i+1)
69            IF ((ntmp .EQ. (dnl-dnf+1))
70         &       .AND. (dname(dnf:dnl) .EQ. mnc_d_names(j)(1:n))) THEN
71              write(msgbuf,'(5a)') 'MNC ERROR: dimension ''',
72         &         dname(dnf:dnl),
73         &         ''' already exists within file ''', fname(1:nf),
74         &         ''' and cannot be re-initalized'
75              CALL print_error( msgbuf, mythid )
76              stop 'ABNORMAL END: S/R MNC_DIM_INIT'
77            ENDIF
78          ENDDO
79    
80          CALL MNC_GET_NEXT_EMPTY_IND(myThid, MNC_MAX_ID, mnc_d_names, indd)
81    
82    C     Create the dim within the file
83          IF (doWrite(1:1) .EQ. 'Y') THEN
84    
85            tlen = dlen
86            IF (dlen .LT. 1)  tlen = NF_UNLIMITED
87    
88            CALL MNC_FILE_REDEF(myThid, fname)
89            err = NF_DEF_DIM(mnc_f_info(indf,2), dname(dnf:dnl), tlen, idd)
90            write(msgbuf,'(5a)') 'MNC_DIM_INIT ERROR: cannot create ',
91         &       'dim ''', dname(dnf:dnl), ''' in file ''', fname(1:nf)
92            CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
93    
94          ENDIF
95    
96    C     Add to tables
97          mnc_d_names(indd)(1:(dnl-dnf+1)) = dname(dnf:dnl)
98          mnc_d_size(indd) = dlen
99          mnc_d_ids(indd) = idd
100          mnc_f_alld(indf,1) = n + 1
101          mnc_f_alld(indf,n+2) = indd
102    
103        RETURN        RETURN
104        END        END
105    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.3
  ViewVC Help
Powered by ViewVC 1.1.22