C $Header: /u/gcmpack/MITgcm/pkg/mnc/mnc_utils.F,v 1.25 2017/01/10 20:56:37 gforget Exp $
C $Name: $
#include "MNC_OPTIONS.h"
C-- File mnc_utils.F:
C-- Contents
C-- o MNC_HANDLE_ERR
C-- o MNC_GET_IND
C-- o MNC_GET_NEXT_EMPTY_IND
C-- o MNC_GET_FVINDS
C-- o MNC_CHK_VTYP_R_NCVAR
C-- o MNC_PSNCM
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 "EEPARAMS.h"
#include "netcdf.inc"
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: '
lenm = ILNBLNK(msgbuf)
print *, msgbuf(1:lenm)
CALL PRINT_ERROR(msgbuf(1:lenm), mythid)
print *, '==='
print *, NF_STRERROR(status)
print *, '==='
lenm = ILNBLNK(msg)
lenm = MIN(lenm,MAX_LEN_MBUF-11)
write(msgbuf,'(2a)') 'MNC ERROR: ', msg(1:lenm)
lenm = ILNBLNK(msgbuf)
print *, msgbuf(1:lenm)
CALL PRINT_ERROR(msgbuf(1:lenm), mythid)
STOP 'ABNORMAL END: S/R MNC_HANDLE_ERR'
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,
I var_symb,
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)
character*(*) var_symb
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'
CALL PRINT_ERROR( msgbuf, myThid )
n = ILNBLNK( var_symb )
write(msgbuf,'(a,a,a)')
& 'MNC_GET_NEXT_EMPTY_IND: occurred within the ''',
& var_symb(1:n), ''' array'
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 "MNC_COMMON.h"
#include "netcdf.inc"
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_FID, 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 ) THEN
IF ( mnc_v_names(j)(1:n).EQ.vname(1:n) ) THEN
ind_fv_ids = k
GOTO 10
ENDIF
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, nk
integer ndim_vt, ncgt,ncvr,ncvf, npb, sz_min
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-|--+----|
CBOP 1
C !ROUTINE: MNC_PSNCM
C !INTERFACE:
SUBROUTINE MNC_PSNCM(
O ostring,
I ival, n )
C !DESCRIPTION:
C Print a zero-padded integer to a String with an N-Character
C Minimum length
IMPLICIT NONE
C !INPUT PARAMETERS:
C ostring :: String to contain formatted output
CHARACTER*(*) ostring
INTEGER ival, n
CEOP
C !LOCAL VARIABLES:
INTEGER i, lens, nmin
CHARACTER*(25) tmp
lens = LEN(ostring)
DO i = 1,lens
ostring(i:i) = ' '
ENDDO
WRITE(tmp,'(I25.25)') ival
DO i = 1,25
IF (tmp(i:i) .NE. '0') THEN
nmin = 26 - i
GOTO 200
ENDIF
ENDDO
200 CONTINUE
IF (nmin .LT. n) nmin = n
ostring(1:nmin) = tmp((26-nmin):25)
C
RETURN
END
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|