pkg/mnc/mnc_grid.F

4de8f8c098 Ed H*0001 #include "MNC_OPTIONS.h"
                0002
e9b72f2bd9 Ed H*0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0004 CBOP 1
1b5fb69d21 Ed H*0005 C     !ROUTINE: MNC_GRID_INIT
4de8f8c098 Ed H*0006
1b5fb69d21 Ed H*0007 C     !INTERFACE:
4de8f8c098 Ed H*0008       SUBROUTINE MNC_GRID_INIT(
                0009      I     fname,
                0010      I     gname,
                0011      I     ndim,
3f2ea2a4ed Ed H*0012      I     dnames,
                0013      I     myThid )
4de8f8c098 Ed H*0014
1b5fb69d21 Ed H*0015 C     !DESCRIPTION:
                0016 C     Create an MNC grid within a NetCDF file context.
                0017
                0018 C     !USES:
4de8f8c098 Ed H*0019       implicit none
                0020
1b5fb69d21 Ed H*0021 C     !INPUT PARAMETERS:
75987013ac Ed H*0022       integer myThid, ndim
                0023       character*(*) fname,gname
                0024       character*(*) dnames(ndim)
e6bb5b2cc3 Ed H*0025 CEOP
75987013ac Ed H*0026
1b5fb69d21 Ed H*0027 C     !LOCAL VARIABLES:
75987013ac Ed H*0028       integer ind
                0029
3f2ea2a4ed Ed H*0030       CALL MNC_GRID_INIT_ALL(fname, gname, ndim, dnames, ind, myThid)
75987013ac Ed H*0031
                0032       RETURN
                0033       END
                0034
e9b72f2bd9 Ed H*0035 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0036 CBOP 1
1b5fb69d21 Ed H*0037 C     !ROUTINE: MNC_GRID_INIT_ALL
75987013ac Ed H*0038
1b5fb69d21 Ed H*0039 C     !INTERFACE:
75987013ac Ed H*0040       SUBROUTINE MNC_GRID_INIT_ALL(
                0041      I     fname,
                0042      I     gname,
                0043      I     ndim,
                0044      I     dnames,
3f2ea2a4ed Ed H*0045      O     ind,
                0046      I     myThid )
75987013ac Ed H*0047
1b5fb69d21 Ed H*0048 C     !DESCRIPTION:
357126def9 Ed H*0049 C     Initialize a new conceptual (MNC inner layer) grid within a NetCDF
                0050 C     file context.  If the requested grid name already exists, then
                0051 C     verify that it has exactly the same number of dimensions, each
                0052 C     with exactly the same size and report a fatal error if not.  This
                0053 C     is a necessary check since the MNC inner layer does not support
                0054 C     grid name re--definition.
                0055
1b5fb69d21 Ed H*0056 C     !USES:
75987013ac Ed H*0057       implicit none
07155994b8 Mart*0058 #include "MNC_COMMON.h"
75987013ac Ed H*0059 #include "EEPARAMS.h"
853ee6565e Jean*0060 #include "netcdf.inc"
75987013ac Ed H*0061
1b5fb69d21 Ed H*0062 C     !INPUT PARAMETERS:
75987013ac Ed H*0063       integer myThid, ndim, ind
a7ffe10af7 Ed H*0064       character*(*) fname,gname
a27dc5c859 Ed H*0065       character*(*) dnames(ndim)
e6bb5b2cc3 Ed H*0066 CEOP
4de8f8c098 Ed H*0067
1b5fb69d21 Ed H*0068 C     !LOCAL VARIABLES:
b11e5981be Ed H*0069       integer i,j,k,ii,jj,kk, n,nf, indf,indg,indd, fid, ngrid
                0070       integer ng_ind,lg_ind, ds_last, ndim_file, igr,ig1,ig2
357126def9 Ed H*0071       integer ngt, ngn
4de8f8c098 Ed H*0072       character*(MAX_LEN_MBUF) msgbuf
9705a0d5c6 Ed H*0073       character*(MNC_MAX_PATH) file_name
e6bb5b2cc3 Ed H*0074
1b5fb69d21 Ed H*0075 C     Functions
                0076       integer ILNBLNK
4de8f8c098 Ed H*0077
a27dc5c859 Ed H*0078 C     Get the file ID and indicies
9705a0d5c6 Ed H*0079       DO i =1,MNC_MAX_PATH
                0080         file_name(i:i) = ' '
                0081       ENDDO
dad4143247 Ed H*0082       nf = ILNBLNK(fname)
9705a0d5c6 Ed H*0083       IF (nf .GT. MNC_MAX_PATH) nf = MNC_MAX_PATH
dad4143247 Ed H*0084       file_name(1:nf) = fname(1:nf)
ef92f00980 Ed H*0085       CALL MNC_GET_IND(MNC_MAX_FID,file_name,mnc_f_names,indf,myThid)
a27dc5c859 Ed H*0086       IF (indf .LT. 1) THEN
dad4143247 Ed H*0087         write(msgbuf,'(3a)') 'MNC ERROR: file ''', file_name(1:nf),
                0088      &       ''' does not exist'
4de8f8c098 Ed H*0089         CALL print_error( msgbuf, mythid )
a27dc5c859 Ed H*0090         stop 'ABNORMAL END: S/R MNC_GRID_INIT'
                0091       ENDIF
                0092       fid = mnc_f_info(indf,2)
                0093       ngrid = mnc_f_info(indf,3)
                0094       ng_ind = 4 + 3*ngrid
                0095       IF (ngrid .EQ. 0) THEN
907e360dab Ed H*0096         ds_last = 0
a27dc5c859 Ed H*0097       ELSE
a7ffe10af7 Ed H*0098         lg_ind = 4 + 3*(ngrid - 1)
                0099         ds_last = mnc_f_info(indf,(lg_ind+2))
4de8f8c098 Ed H*0100       ENDIF
                0101
907e360dab Ed H*0102 C     Check for sufficient space in memory
                0103       i = ds_last + ndim
                0104       j = 3 + 3*(ngrid + 1)
                0105       IF ((i .GE. MNC_MAX_INFO) .OR. (j .GE. MNC_MAX_INFO)) THEN
efcf8593ff Ed H*0106         write(msgbuf,'(2a)') 'MNC_GRID_INIT_ALL ERROR: insufficient',
                0107      &       ' space--please increase MNC_MAX_INFO'
a27dc5c859 Ed H*0108         CALL print_error( msgbuf, mythid )
efcf8593ff Ed H*0109         stop 'ABNORMAL END: S/R MNC_GRID_INIT_ALL'
a27dc5c859 Ed H*0110       ENDIF
4de8f8c098 Ed H*0111
75987013ac Ed H*0112 C     Enter DEFINE mode
3f2ea2a4ed Ed H*0113       CALL MNC_FILE_REDEF(fname, myThid)
75987013ac Ed H*0114
357126def9 Ed H*0115       ngn = ILNBLNK(gname)
                0116
b11e5981be Ed H*0117 C     Check for grid re-definition
                0118       DO igr = 1,mnc_f_info(indf,3)
1386b8d67c Ed H*0119         ii = 4 + 3*(igr - 1)
357126def9 Ed H*0120         ngt = ILNBLNK(mnc_g_names(mnc_f_info(indf,ii)))
                0121         IF ( (ngt .EQ. ngn)
                0122      &       .AND. (mnc_g_names(mnc_f_info(indf,ii))(1:ngt)
                0123      &       .EQ. gname(1:ngn)) ) THEN
                0124
b11e5981be Ed H*0125           ig1 = mnc_f_info(indf,ii+1)
                0126           ig2 = mnc_f_info(indf,ii+2)
                0127
                0128 C         Check if different number of dims
                0129           IF (ndim .NE. (ig2-ig1+1)) THEN
ef92f00980 Ed H*0130             kk = ILNBLNK( mnc_f_names(indf) )
                0131             write(msgbuf,'(6a)') 'MNC ERROR: grid ''', gname(1:ngn),
b11e5981be Ed H*0132      &           ''' was previously defined for file ''',
ef92f00980 Ed H*0133      &           mnc_f_names(indf)(1:kk), ''' with a different ',
b11e5981be Ed H*0134      &           'number of dimensions'
                0135             CALL print_error(msgbuf, mythid)
                0136             stop 'ABNORMAL END: S/R MNC_GRID_INIT'
                0137           ENDIF
                0138
                0139 C         Check if same number of dims but different dim names
                0140           k = 0
                0141           DO jj = ig1,ig2
                0142             k = k + 1
                0143             IF (mnc_d_names(mnc_fd_ind(indf,jj)) .NE. dnames(k)) THEN
ef92f00980 Ed H*0144               kk = ILNBLNK( mnc_f_names(indf) )
                0145               write(msgbuf,'(6a)') 'MNC ERROR: grid ''', gname(1:ngn),
b11e5981be Ed H*0146      &             ''' was previously defined for file ''',
ef92f00980 Ed H*0147      &             mnc_f_names(indf)(1:kk), ''' with a different ',
b11e5981be Ed H*0148      &             'combination of dimensions'
                0149               CALL print_error(msgbuf, mythid)
                0150               stop 'ABNORMAL END: S/R MNC_GRID_INIT'
                0151             ENDIF
                0152           ENDDO
357126def9 Ed H*0153
                0154 C         Reaching this point means that the grid name WAS previously
                0155 C         defined and the number and sizes of the associated dimensions
                0156 C         exactly match so everything is OK and we do not need to create
                0157 C         a new definition for this grid.
                0158           RETURN
a27dc5c859 Ed H*0159
b11e5981be Ed H*0160         ENDIF
                0161       ENDDO
                0162
357126def9 Ed H*0163 C     Reaching this point means the grid was NOT previously defined and
e40d346a32 Ed H*0164 C     we must therefore create a new definition.
3f2ea2a4ed Ed H*0165       CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_g_names,
9705a0d5c6 Ed H*0166      &     'mnc_g_names', indg, myThid)
b11e5981be Ed H*0167       mnc_g_names(indg)(1:MNC_MAX_CHAR) =
                0168      &     mnc_blank_name(1:MNC_MAX_CHAR)
                0169       n = ILNBLNK(gname)
                0170       mnc_g_names(indg)(1:n) = gname(1:n)
                0171
907e360dab Ed H*0172 C     Add the dimensions
4de8f8c098 Ed H*0173       DO i = 1,ndim
                0174
907e360dab Ed H*0175         j = ds_last + i
a27dc5c859 Ed H*0176         n = ILNBLNK(dnames(i))
a7ffe10af7 Ed H*0177
dad4143247 Ed H*0178 C       Search for the dimension ID within the list of dimensions
                0179 C       defined for this file
                0180         ndim_file = mnc_f_alld(indf,1)
                0181         indd = 0
                0182         DO ii = 1,ndim_file
75987013ac Ed H*0183           jj = mnc_f_alld(indf,ii+1)
dad4143247 Ed H*0184           kk = ILNBLNK(mnc_d_names(jj))
                0185           IF ((n .EQ. kk)
75987013ac Ed H*0186      &         .AND. (dnames(i)(1:n) .EQ. mnc_d_names(jj)(1:kk))) THEN
dad4143247 Ed H*0187             indd = jj
b11e5981be Ed H*0188             GOTO 20
dad4143247 Ed H*0189           ENDIF
                0190         ENDDO
b11e5981be Ed H*0191  20     CONTINUE
907e360dab Ed H*0192         IF (indd .LT. 1) THEN
dad4143247 Ed H*0193           write(msgbuf,'(5a)') 'MNC ERROR: dimension ''',
75987013ac Ed H*0194      &         dnames(i)(1:n), ''' does not exist for file ''',
dad4143247 Ed H*0195      &         fname(1:nf), ''''
a27dc5c859 Ed H*0196           CALL print_error( msgbuf, mythid )
                0197           stop 'ABNORMAL END: S/R MNC_GRID_INIT'
                0198         ENDIF
a7ffe10af7 Ed H*0199
907e360dab Ed H*0200         mnc_fd_ind(indf,j) = indd
                0201
4de8f8c098 Ed H*0202       ENDDO
                0203
a27dc5c859 Ed H*0204 C     Grid successfully added, so update file table
                0205       mnc_f_info(indf,ng_ind) = indg
907e360dab Ed H*0206       mnc_f_info(indf,ng_ind+1) = ds_last + 1
                0207       mnc_f_info(indf,ng_ind+2) = ds_last + ndim
a27dc5c859 Ed H*0208       mnc_f_info(indf,3) = ngrid + 1
75987013ac Ed H*0209       ind = indg
a27dc5c859 Ed H*0210
                0211       RETURN
                0212       END
                0213
e9b72f2bd9 Ed H*0214 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0215 CBOP 1
1b5fb69d21 Ed H*0216 C     !ROUTINE: MNC_GRID_GET_DIMIND
a7ffe10af7 Ed H*0217
1b5fb69d21 Ed H*0218 C     !INTERFACE:
a7ffe10af7 Ed H*0219       SUBROUTINE MNC_GRID_GET_DIMIND(
                0220      I     indf,
                0221      I     dname,
3f2ea2a4ed Ed H*0222      O     ind_fg_ids,
                0223      I     myThid )
a7ffe10af7 Ed H*0224
1b5fb69d21 Ed H*0225 C     !DESCRIPTION:
e6bb5b2cc3 Ed H*0226 C     Get the dimension ID (index) for the named dimension.
1b5fb69d21 Ed H*0227
                0228 C     !USES:
a7ffe10af7 Ed H*0229       implicit none
07155994b8 Mart*0230 #include "MNC_COMMON.h"
a7ffe10af7 Ed H*0231
1b5fb69d21 Ed H*0232 C     !INPUT PARAMETERS:
3f2ea2a4ed Ed H*0233       integer indf, ind_fg_ids, myThid
a7ffe10af7 Ed H*0234       character*(*) dname
e6bb5b2cc3 Ed H*0235 CEOP
a7ffe10af7 Ed H*0236
1b5fb69d21 Ed H*0237 C     !LOCAL VARIABLES:
                0238       integer i,j,k,l, n,n1, ngrid, ds,de
e6bb5b2cc3 Ed H*0239
a7ffe10af7 Ed H*0240 C     Functions
                0241       integer ILNBLNK
                0242
                0243
                0244       ind_fg_ids = -1
                0245       n = ILNBLNK(dname)
                0246       ngrid = mnc_f_info(indf,3)
                0247       DO i = 1,ngrid
                0248         j = 4 + 3*(i - 1)
                0249         ds = mnc_f_info(indf,j+1)
                0250         de = mnc_f_info(indf,j+2)
                0251         DO k = ds,de
                0252           l = mnc_fd_ind(indf,k)
                0253           n1 = ILNBLNK(mnc_d_names(l))
                0254           IF ((n .EQ. n1)
                0255      &         .AND. (mnc_d_names(l)(1:n1) .EQ. dname(1:n))) THEN
                0256             ind_fg_ids = k
                0257             RETURN
                0258           ENDIF
                0259         ENDDO
                0260       ENDDO
                0261       RETURN
                0262       END
                0263
e9b72f2bd9 Ed H*0264 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|