pkg/mnc/mnc_utils.F

4de8f8c098 Ed H*0001 #include "MNC_OPTIONS.h"
                0002
b6432c788b Jean*0003 C--  File mnc_utils.F:
                0004 C--   Contents
                0005 C--   o MNC_HANDLE_ERR
                0006 C--   o MNC_GET_IND
                0007 C--   o MNC_GET_NEXT_EMPTY_IND
                0008 C--   o MNC_GET_FVINDS
                0009 C--   o MNC_CHK_VTYP_R_NCVAR
                0010 C--   o MNC_PSNCM
                0011
e9b72f2bd9 Ed H*0012 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0013 CBOP 1
1b5fb69d21 Ed H*0014 C     !ROUTINE: MNC_HANDLE_ERR
e9b72f2bd9 Ed H*0015
1b5fb69d21 Ed H*0016 C     !INTERFACE:
3f2ea2a4ed Ed H*0017       SUBROUTINE MNC_HANDLE_ERR( status, msg, myThid )
4de8f8c098 Ed H*0018
1b5fb69d21 Ed H*0019 C     !DESCRIPTION:
e6bb5b2cc3 Ed H*0020 C     Convenience function for handling all MNC and NetCDF library
                0021 C     errors.
b6432c788b Jean*0022
1b5fb69d21 Ed H*0023 C     !USES:
4de8f8c098 Ed H*0024       implicit none
                0025 #include "EEPARAMS.h"
853ee6565e Jean*0026 #include "netcdf.inc"
4de8f8c098 Ed H*0027
1b5fb69d21 Ed H*0028 C     !DESCRIPTION:
                0029 C     Create an MNC grid within a NetCDF file context.
b6432c788b Jean*0030
1b5fb69d21 Ed H*0031 C     !USES:
4de8f8c098 Ed H*0032       INTEGER  myThid, status
                0033       character*(*) msg
e6bb5b2cc3 Ed H*0034 CEOP
4de8f8c098 Ed H*0035
1b5fb69d21 Ed H*0036 C     !LOCAL VARIABLES:
                0037       integer i,lenm
                0038       character*(MAX_LEN_MBUF) msgbuf
e6bb5b2cc3 Ed H*0039
376f4203f6 Ed H*0040 C     Functions
                0041       integer ILNBLNK
                0042
aaaebf9470 Ed H*0043       DO i = 1,MAX_LEN_MBUF
                0044         msgbuf(i:i) = ' '
                0045       ENDDO
4de8f8c098 Ed H*0046
                0047       IF ( status .NE. NF_NOERR ) THEN
b21ef32c29 Ed H*0048         write(msgbuf,'(2a)') 'NetCDF ERROR: '
376f4203f6 Ed H*0049         lenm = ILNBLNK(msgbuf)
aaaebf9470 Ed H*0050         print *, msgbuf(1:lenm)
376f4203f6 Ed H*0051         CALL print_error(msgbuf(1:lenm), mythid)
b21ef32c29 Ed H*0052         print *, '==='
                0053         print *, NF_STRERROR(status)
                0054         print *, '==='
677d07a6b5 Mart*0055         lenm = ILNBLNK(msg)
                0056         lenm = MIN(lenm,MAX_LEN_MBUF-11)
                0057         write(msgbuf,'(2a)') 'MNC ERROR: ', msg(1:lenm)
376f4203f6 Ed H*0058         lenm = ILNBLNK(msgbuf)
aaaebf9470 Ed H*0059         print *, msgbuf(1:lenm)
376f4203f6 Ed H*0060         CALL print_error(msgbuf(1:lenm), mythid)
f0d64e7eb4 Gael*0061         STOP 'ABNORMAL END: S/R MNC_HANDLE_ERR'
4de8f8c098 Ed H*0062       ENDIF
a27dc5c859 Ed H*0063       RETURN
4de8f8c098 Ed H*0064       END
                0065
e9b72f2bd9 Ed H*0066 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0067 CBOP 1
1b5fb69d21 Ed H*0068 C     !ROUTINE: MNC_GET_IND
e9b72f2bd9 Ed H*0069
1b5fb69d21 Ed H*0070 C     !INTERFACE:
4de8f8c098 Ed H*0071       SUBROUTINE MNC_GET_IND(
                0072      I     NT,
                0073      I     aname,
                0074      I     name_list,
3f2ea2a4ed Ed H*0075      O     ind,
                0076      I     myThid )
4de8f8c098 Ed H*0077
1b5fb69d21 Ed H*0078 C     !DESCRIPTION:
                0079 C     Get the index of the specified name.
b6432c788b Jean*0080
1b5fb69d21 Ed H*0081 C     !USES:
4de8f8c098 Ed H*0082       implicit none
                0083 #include "EEPARAMS.h"
                0084
1b5fb69d21 Ed H*0085 C     !INPUT PARAMETERS:
75987013ac Ed H*0086       integer myThid, nt
4de8f8c098 Ed H*0087       character*(*) aname
                0088       character*(*) name_list(NT)
e6bb5b2cc3 Ed H*0089 CEOP
4de8f8c098 Ed H*0090
1b5fb69d21 Ed H*0091 C     !LOCAL VARIABLES:
a7ffe10af7 Ed H*0092       integer n, i, nf, ind, lenm
4de8f8c098 Ed H*0093       character*(MAX_LEN_MBUF) msgbuf
e6bb5b2cc3 Ed H*0094
1b5fb69d21 Ed H*0095 C     Functions
                0096       integer ILNBLNK
4de8f8c098 Ed H*0097
                0098 C     Check that aname contains a valid name
                0099       n = ILNBLNK( aname )
                0100       IF ( n .LT. 1 ) THEN
                0101         write(msgbuf,'(a)')
                0102      &       'MNC_GET_IND: an invalid (empty) name was specified'
a7ffe10af7 Ed H*0103         lenm = ILNBLNK(msgbuf)
                0104         CALL print_error(msgbuf(1:lenm), myThid)
                0105         stop 'ABNORMAL END: S/R MNC_GET_IND'
4de8f8c098 Ed H*0106       ENDIF
                0107
                0108 C     Search for the index
                0109       DO i=1,NT
                0110         nf = ILNBLNK( name_list(i) )
                0111         IF ( nf .EQ. n ) THEN
                0112           IF ( name_list(i)(1:n) .EQ. aname(1:n) ) THEN
                0113             ind = i
                0114             GOTO 10
                0115           ENDIF
                0116         ENDIF
                0117       ENDDO
                0118       ind = -1
                0119  10   CONTINUE
                0120       RETURN
                0121       END
                0122
e9b72f2bd9 Ed H*0123 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0124 CBOP 1
1b5fb69d21 Ed H*0125 C     !ROUTINE: MNC_GET_NEXT_EMPTY_IND
e9b72f2bd9 Ed H*0126
1b5fb69d21 Ed H*0127 C     !INTERFACE:
4de8f8c098 Ed H*0128       SUBROUTINE MNC_GET_NEXT_EMPTY_IND(
                0129      I     NT,
                0130      I     name_list,
9705a0d5c6 Ed H*0131      I     var_symb,
3f2ea2a4ed Ed H*0132      O     ind,
                0133      I     myThid )
4de8f8c098 Ed H*0134
1b5fb69d21 Ed H*0135 C     !DESCRIPTION:
                0136 C     Get the index of the next empty entry.
b6432c788b Jean*0137
1b5fb69d21 Ed H*0138 C     !USES:
4de8f8c098 Ed H*0139       implicit none
                0140 #include "EEPARAMS.h"
                0141
1b5fb69d21 Ed H*0142 C     !INPUT PARAMETERS:
75987013ac Ed H*0143       integer myThid, nt
4de8f8c098 Ed H*0144       character*(*) name_list(NT)
9705a0d5c6 Ed H*0145       character*(*) var_symb
e6bb5b2cc3 Ed H*0146 CEOP
4de8f8c098 Ed H*0147
1b5fb69d21 Ed H*0148 C     !LOCAL VARIABLES:
                0149       integer n, i, ind
                0150       character*(MAX_LEN_MBUF) msgbuf
e6bb5b2cc3 Ed H*0151
4de8f8c098 Ed H*0152 C     Functions
                0153       integer ILNBLNK
                0154
                0155
                0156 C     Search for the index
                0157       DO i=1,NT
                0158         n = ILNBLNK( name_list(i) )
                0159         IF ( n .EQ. 0 ) THEN
                0160           ind = i
                0161           GOTO 10
                0162         ENDIF
                0163       ENDDO
                0164
                0165 C     If this is code is reached, we have exceeded the array size
                0166       write(msgbuf,'(a,i6,a)')
b6432c788b Jean*0167      &     'MNC_GET_NEXT_EMPTY_IND: array size ', nt,
0264008da5 Ed H*0168      &     ' exceeded'
4de8f8c098 Ed H*0169       CALL print_error( msgbuf, myThid )
9705a0d5c6 Ed H*0170       n = ILNBLNK( var_symb )
                0171       write(msgbuf,'(a,a,a)')
                0172      &     'MNC_GET_NEXT_EMPTY_IND: occurred within the ''',
                0173      &     var_symb(1:n), ''' array'
                0174       CALL print_error( msgbuf, myThid )
4de8f8c098 Ed H*0175       stop 'ABNORMAL END: S/R MNC_GET_NEXT_EMPTY_IND'
                0176
                0177  10   CONTINUE
                0178       RETURN
                0179       END
                0180
e9b72f2bd9 Ed H*0181 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
e6bb5b2cc3 Ed H*0182 CBOP 1
1b5fb69d21 Ed H*0183 C     !ROUTINE: MNC_GET_FVINDS
376f4203f6 Ed H*0184
1b5fb69d21 Ed H*0185 C     !INTERFACE:
b6432c788b Jean*0186       SUBROUTINE MNC_GET_FVINDS(
                0187      I     fname,
                0188      I     vname,
                0189      O     indf,
3f2ea2a4ed Ed H*0190      O     ind_fv_ids,
                0191      I     myThid )
376f4203f6 Ed H*0192
1b5fb69d21 Ed H*0193 C     !DESCRIPTION:
                0194 C     Get the variable indicies.
b6432c788b Jean*0195
1b5fb69d21 Ed H*0196 C     !USES:
376f4203f6 Ed H*0197       implicit none
07155994b8 Mart*0198 #include "MNC_COMMON.h"
853ee6565e Jean*0199 #include "netcdf.inc"
376f4203f6 Ed H*0200
1b5fb69d21 Ed H*0201 C     !INPUT PARAMETERS:
376f4203f6 Ed H*0202       INTEGER  myThid, fid, indf, ind_fv_ids
                0203       character*(*) fname
                0204       character*(*) vname
e6bb5b2cc3 Ed H*0205 CEOP
376f4203f6 Ed H*0206
1b5fb69d21 Ed H*0207 C     !LOCAL VARIABLES:
                0208       integer i,j,k, n, lenv
e6bb5b2cc3 Ed H*0209
376f4203f6 Ed H*0210 C     Functions
                0211       integer ILNBLNK
                0212
                0213 C     Strip trailing spaces
                0214       lenv = ILNBLNK(vname)
                0215
                0216 C     Check that the file exists
ef92f00980 Ed H*0217       CALL MNC_GET_IND(MNC_MAX_FID, fname, mnc_f_names, indf, myThid)
376f4203f6 Ed H*0218       IF (indf .LT. 1) THEN
                0219         ind_fv_ids = -1
                0220         RETURN
                0221       ENDIF
                0222       fid = mnc_f_info(indf,2)
                0223
                0224 C     Find the vID
75987013ac Ed H*0225       DO i = 1,mnc_fv_ids(indf,1)
                0226         k = 2 + 3*(i - 1)
376f4203f6 Ed H*0227         j = mnc_fv_ids(indf,k)
                0228         n = ILNBLNK(mnc_v_names(j))
869f67edd8 Jean*0229         IF ( n.EQ.lenv ) THEN
                0230          IF ( mnc_v_names(j)(1:n).EQ.vname(1:n) ) THEN
376f4203f6 Ed H*0231           ind_fv_ids = k
                0232           GOTO 10
869f67edd8 Jean*0233          ENDIF
376f4203f6 Ed H*0234         ENDIF
                0235       ENDDO
                0236       ind_fv_ids = -1
                0237  10   CONTINUE
                0238
                0239       RETURN
                0240       END
                0241
e9b72f2bd9 Ed H*0242 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
8ae258cf2c Ed H*0243
a906dd2a24 Ed H*0244 C     Here, we determine whether the dimensions (sizes) of a specific
                0245 C     variable within the MNC low-level look-up tables matches the
                0246 C     dimensions of a Variable Type defined within the upper-level CW
                0247 C     layer.
8ae258cf2c Ed H*0248 C
a906dd2a24 Ed H*0249 C     Return values:
                0250 C     .  YES  ==>  ires > 0
                0251 C     .  NO   ==>  ires < 0
8ae258cf2c Ed H*0252
b6432c788b Jean*0253       SUBROUTINE MNC_CHK_VTYP_R_NCVAR(
                0254      I     ind_vt,
8ae258cf2c Ed H*0255      I     indf,
b6432c788b Jean*0256      I     ind_fv_ids,
                0257      I     indu,
3f2ea2a4ed Ed H*0258      O     ires,
                0259      I     myThid )
8ae258cf2c Ed H*0260
                0261       implicit none
07155994b8 Mart*0262 #include "MNC_COMMON.h"
a906dd2a24 Ed H*0263 #include "EEPARAMS.h"
8ae258cf2c Ed H*0264
                0265 C     Arguments
a906dd2a24 Ed H*0266       INTEGER  myThid, ind_vt, indf, ind_fv_ids, indu, ires
                0267
                0268 C     Functions
                0269       integer ILNBLNK
8ae258cf2c Ed H*0270
                0271 C     Locals
b6432c788b Jean*0272       integer  ii,k, ind_cw_g, ig,ids,ide,nint, indd, nk
a906dd2a24 Ed H*0273       integer  ndim_vt, ncgt,ncvr,ncvf, npb, sz_min
                0274       character*(MAX_LEN_MBUF) pbuf, msgbuf
8ae258cf2c Ed H*0275
                0276       ires = -1
                0277
a906dd2a24 Ed H*0278 C     grid indicies for the internal (as-read-from-the-file) data
8ae258cf2c Ed H*0279       ig = mnc_fv_ids(indf,ind_fv_ids+2)
                0280       ids = mnc_f_info(indf,ig+1)
                0281       ide = mnc_f_info(indf,ig+2)
                0282       nint = ids - ide + 1
                0283
a906dd2a24 Ed H*0284       ind_cw_g = mnc_cw_vgind(ind_vt)
                0285       ncgt = ILNBLNK(mnc_cw_gname(ind_cw_g))
                0286       ncvr = ILNBLNK(mnc_v_names(mnc_fv_ids(indf,ind_fv_ids)))
                0287       ncvf = ILNBLNK(mnc_f_names(indf))
                0288       write(pbuf,'(7a)') 'MNC_CHK_VTYP_R_NCVAR WARNING: var ''',
                0289      &     mnc_v_names(mnc_fv_ids(indf,ind_fv_ids))(1:ncvr),
b6432c788b Jean*0290      &     ''' within file ''', mnc_f_names(indf)(1:ncvf),
a906dd2a24 Ed H*0291      &     ''' does not satisy the size needed by GType ''',
                0292      &     mnc_cw_gname(ind_cw_g)(1:ncgt), ''''
                0293       npb = ILNBLNK(pbuf)
                0294       ndim_vt = mnc_cw_ndim(ind_cw_g)
                0295       nk = nint
                0296       IF (ndim_vt .LT. nk)  nk = ndim_vt
                0297       IF (nint .NE. ndim_vt) THEN
                0298         write(msgbuf,'(2a)') pbuf(1:npb), ' -- too few dims'
                0299         CALL print_error(msgbuf, myThid)
                0300       ENDIF
8ae258cf2c Ed H*0301
a906dd2a24 Ed H*0302 C     Check that the necessary size exists along each dimension
                0303       DO k = 1,nk
                0304         ii = ids + (k - 1)
                0305         sz_min = mnc_cw_dims(k,ind_cw_g)
                0306         IF (sz_min .EQ. -1)  sz_min = indu
                0307         indd = mnc_fd_ind(indf,ii)
                0308         IF (mnc_d_size(indd) .LT. sz_min) THEN
b6432c788b Jean*0309           write(msgbuf,'(2a,i3,a,i3,a,i3)') pbuf(1:npb), ': dim #',
a906dd2a24 Ed H*0310      &         k, ' is too small: ', mnc_d_size(indd), ' vs ',
                0311      &         mnc_cw_ie(k,ind_cw_g)
                0312           CALL print_error(msgbuf, myThid)
                0313           RETURN
                0314         ENDIF
                0315       ENDDO
b6432c788b Jean*0316
8ae258cf2c Ed H*0317 C     Reaching this point means all tests passed
                0318       ires = 1
                0319
                0320       RETURN
                0321       END
                0322
                0323 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
5bc9611487 Ed H*0324 CBOP 1
                0325 C     !ROUTINE: MNC_PSNCM
                0326
                0327 C     !INTERFACE:
                0328       SUBROUTINE MNC_PSNCM(
                0329      O     ostring,
                0330      I     ival, n )
                0331
                0332 C     !DESCRIPTION:
                0333 C     Print a zero-padded integer to a String with an N-Character
                0334 C     Minimum length
                0335
                0336       IMPLICIT NONE
                0337
                0338 C     !INPUT PARAMETERS:
                0339 C     ostring :: String to contain formatted output
                0340       CHARACTER*(*) ostring
                0341       INTEGER ival, n
                0342 CEOP
                0343
                0344 C     !LOCAL VARIABLES:
                0345       INTEGER i, lens, nmin
                0346       CHARACTER*(25) tmp
                0347
                0348       lens = LEN(ostring)
                0349       DO i = 1,lens
                0350         ostring(i:i) = ' '
                0351       ENDDO
                0352       WRITE(tmp,'(I25.25)') ival
9f38e1094b Ed H*0353       DO i = 1,25
                0354         IF (tmp(i:i) .NE. '0') THEN
                0355           nmin = 26 - i
                0356           GOTO 200
                0357         ENDIF
                0358       ENDDO
                0359  200  CONTINUE
5bc9611487 Ed H*0360       IF (nmin .LT. n)  nmin = n
                0361       ostring(1:nmin) = tmp((26-nmin):25)
                0362
                0363 C
                0364       RETURN
                0365       END
                0366
                0367 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0368