C $Header: /u/gcmpack/MITgcm/pkg/mnc/mnc_utils.F,v 1.12 2004/04/02 16:12:48 edhill Exp $
C $Name: $
#include "MNC_OPTIONS.h"
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 1
C !ROUTINE: MNC_HANDLE_ERR
C !INTERFACE:
SUBROUTINE MNC_HANDLE_ERR( status, msg, myThid )
C !DESCRIPTION:
C Convenience function for handling all MNC and NetCDF library
C errors.
C !USES:
implicit none
#include "netcdf.inc"
#include "EEPARAMS.h"
C !DESCRIPTION:
C Create an MNC grid within a NetCDF file context.
C !USES:
INTEGER myThid, status
character*(*) msg
CEOP
C !LOCAL VARIABLES:
integer i,lenm
character*(MAX_LEN_MBUF) msgbuf
C Functions
integer ILNBLNK
DO i = 1,MAX_LEN_MBUF
msgbuf(i:i) = ' '
ENDDO
IF ( status .NE. NF_NOERR ) THEN
write(msgbuf,'(2a)') 'NetCDF ERROR: ', NF_STRERROR(status)
lenm = ILNBLNK(msgbuf)
print *, msgbuf(1:lenm)
CALL PRINT_ERROR(msgbuf(1:lenm), mythid)
write(msgbuf,'(2a)') 'MNC ERROR: ', msg
lenm = ILNBLNK(msgbuf)
print *, msgbuf(1:lenm)
CALL PRINT_ERROR(msgbuf(1:lenm), mythid)
stop 'ABNORMAL END: package MNC'
ENDIF
RETURN
END
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 1
C !ROUTINE: MNC_GET_IND
C !INTERFACE:
SUBROUTINE MNC_GET_IND(
I NT,
I aname,
I name_list,
O ind,
I myThid )
C !DESCRIPTION:
C Get the index of the specified name.
C !USES:
implicit none
#include "EEPARAMS.h"
C !INPUT PARAMETERS:
integer myThid, nt
character*(*) aname
character*(*) name_list(NT)
CEOP
C !LOCAL VARIABLES:
integer n, i, nf, ind, lenm
character*(MAX_LEN_MBUF) msgbuf
C Functions
integer ILNBLNK
C Check that aname contains a valid name
n = ILNBLNK( aname )
IF ( n .LT. 1 ) THEN
write(msgbuf,'(a)')
& 'MNC_GET_IND: an invalid (empty) name was specified'
lenm = ILNBLNK(msgbuf)
CALL PRINT_ERROR(msgbuf(1:lenm), myThid)
stop 'ABNORMAL END: S/R MNC_GET_IND'
ENDIF
C Search for the index
DO i=1,NT
nf = ILNBLNK( name_list(i) )
IF ( nf .EQ. n ) THEN
IF ( name_list(i)(1:n) .EQ. aname(1:n) ) THEN
ind = i
GOTO 10
ENDIF
ENDIF
ENDDO
ind = -1
10 CONTINUE
RETURN
END
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 1
C !ROUTINE: MNC_GET_NEXT_EMPTY_IND
C !INTERFACE:
SUBROUTINE MNC_GET_NEXT_EMPTY_IND(
I NT,
I name_list,
O ind,
I myThid )
C !DESCRIPTION:
C Get the index of the next empty entry.
C !USES:
implicit none
#include "EEPARAMS.h"
C !INPUT PARAMETERS:
integer myThid, nt
character*(*) name_list(NT)
CEOP
C !LOCAL VARIABLES:
integer n, i, ind
character*(MAX_LEN_MBUF) msgbuf
C Functions
integer ILNBLNK
C Search for the index
DO i=1,NT
n = ILNBLNK( name_list(i) )
IF ( n .EQ. 0 ) THEN
ind = i
GOTO 10
ENDIF
ENDDO
C If this is code is reached, we have exceeded the array size
write(msgbuf,'(a,i6,a)')
& 'MNC_GET_NEXT_EMPTY_IND: array size ', nt,
& ' exceeded--try increasing MNC_MAX_ID'
CALL PRINT_ERROR( msgbuf, myThid )
stop 'ABNORMAL END: S/R MNC_GET_NEXT_EMPTY_IND'
10 CONTINUE
RETURN
END
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 1
C !ROUTINE: MNC_GET_FVINDS
C !INTERFACE:
SUBROUTINE MNC_GET_FVINDS(
I fname,
I vname,
O indf,
O ind_fv_ids,
I myThid )
C !DESCRIPTION:
C Get the variable indicies.
C !USES:
implicit none
#include "netcdf.inc"
#include "mnc_common.h"
C !INPUT PARAMETERS:
INTEGER myThid, fid, indf, ind_fv_ids
character*(*) fname
character*(*) vname
CEOP
C !LOCAL VARIABLES:
integer i,j,k, n, lenv
C Functions
integer ILNBLNK
C Strip trailing spaces
lenv = ILNBLNK(vname)
C Check that the file exists
CALL MNC_GET_IND(MNC_MAX_ID, fname, mnc_f_names, indf, myThid)
IF (indf .LT. 1) THEN
ind_fv_ids = -1
RETURN
ENDIF
fid = mnc_f_info(indf,2)
C Find the vID
DO i = 1,mnc_fv_ids(indf,1)
k = 2 + 3*(i - 1)
j = mnc_fv_ids(indf,k)
n = ILNBLNK(mnc_v_names(j))
IF ((n .EQ. lenv)
& .AND. (mnc_v_names(j)(1:n) .EQ. vname(1:n))) THEN
ind_fv_ids = k
GOTO 10
ENDIF
ENDDO
ind_fv_ids = -1
10 CONTINUE
RETURN
END
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
C Here, we determine whether the dimensions (sizes) of a specific
C variable within the MNC low-level look-up tables matches the
C dimensions of a Variable Type defined within the upper-level CW
C layer.
C
C Return values:
C . YES ==> ires > 0
C . NO ==> ires < 0
SUBROUTINE MNC_CHK_VTYP_R_NCVAR(
I ind_vt,
I indf,
I ind_fv_ids,
I indu,
O ires,
I myThid )
implicit none
#include "mnc_common.h"
#include "EEPARAMS.h"
C Arguments
INTEGER myThid, ind_vt, indf, ind_fv_ids, indu, ires
C Functions
integer ILNBLNK
C Locals
integer ii,k, ind_cw_g, ig,ids,ide,nint, indd, cw_len, nk
integer ndim_vt, ncgt,ncvr,ncvf, npb, sz_min
character*1 ch
character*(MAX_LEN_MBUF) pbuf, msgbuf
ires = -1
C grid indicies for the internal (as-read-from-the-file) data
ig = mnc_fv_ids(indf,ind_fv_ids+2)
ids = mnc_f_info(indf,ig+1)
ide = mnc_f_info(indf,ig+2)
nint = ids - ide + 1
ind_cw_g = mnc_cw_vgind(ind_vt)
ncgt = ILNBLNK(mnc_cw_gname(ind_cw_g))
ncvr = ILNBLNK(mnc_v_names(mnc_fv_ids(indf,ind_fv_ids)))
ncvf = ILNBLNK(mnc_f_names(indf))
write(pbuf,'(7a)') 'MNC_CHK_VTYP_R_NCVAR WARNING: var ''',
& mnc_v_names(mnc_fv_ids(indf,ind_fv_ids))(1:ncvr),
& ''' within file ''', mnc_f_names(indf)(1:ncvf),
& ''' does not satisy the size needed by GType ''',
& mnc_cw_gname(ind_cw_g)(1:ncgt), ''''
npb = ILNBLNK(pbuf)
ndim_vt = mnc_cw_ndim(ind_cw_g)
nk = nint
IF (ndim_vt .LT. nk) nk = ndim_vt
IF (nint .NE. ndim_vt) THEN
write(msgbuf,'(2a)') pbuf(1:npb), ' -- too few dims'
CALL PRINT_ERROR(msgbuf, myThid)
ENDIF
C Check that the necessary size exists along each dimension
DO k = 1,nk
ii = ids + (k - 1)
sz_min = mnc_cw_dims(k,ind_cw_g)
IF (sz_min .EQ. -1) sz_min = indu
indd = mnc_fd_ind(indf,ii)
IF (mnc_d_size(indd) .LT. sz_min) THEN
write(msgbuf,'(2a,i3,a,i3,a,i3)') pbuf(1:npb), ': dim #',
& k, ' is too small: ', mnc_d_size(indd), ' vs ',
& mnc_cw_ie(k,ind_cw_g)
CALL PRINT_ERROR(msgbuf, myThid)
RETURN
ENDIF
ENDDO
C Reaching this point means all tests passed
ires = 1
RETURN
END
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|