File indexing completed on 2018-03-02 18:42:02 UTC
view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
4de8f8c098 Ed H*0001 #include "MNC_OPTIONS.h"
0002
b6432c788b Jean*0003
0004
0005
0006
0007
0008
0009
0010
0011
e9b72f2bd9 Ed H*0012
e6bb5b2cc3 Ed H*0013
1b5fb69d21 Ed H*0014
e9b72f2bd9 Ed H*0015
1b5fb69d21 Ed H*0016
3f2ea2a4ed Ed H*0017 SUBROUTINE MNC_HANDLE_ERR( status, msg, myThid )
4de8f8c098 Ed H*0018
1b5fb69d21 Ed H*0019
e6bb5b2cc3 Ed H*0020
0021
b6432c788b Jean*0022
1b5fb69d21 Ed H*0023
4de8f8c098 Ed H*0024 implicit none
0025 #include "EEPARAMS.h"
853ee6565e Jean*0026 #include "netcdf.inc"
4de8f8c098 Ed H*0027
1b5fb69d21 Ed H*0028
0029
b6432c788b Jean*0030
1b5fb69d21 Ed H*0031
4de8f8c098 Ed H*0032 INTEGER myThid, status
0033 character*(*) msg
e6bb5b2cc3 Ed H*0034
4de8f8c098 Ed H*0035
1b5fb69d21 Ed H*0036
0037 integer i,lenm
0038 character*(MAX_LEN_MBUF) msgbuf
e6bb5b2cc3 Ed H*0039
376f4203f6 Ed H*0040
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
e6bb5b2cc3 Ed H*0067
1b5fb69d21 Ed H*0068
e9b72f2bd9 Ed H*0069
1b5fb69d21 Ed H*0070
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
0079
b6432c788b Jean*0080
1b5fb69d21 Ed H*0081
4de8f8c098 Ed H*0082 implicit none
0083 #include "EEPARAMS.h"
0084
1b5fb69d21 Ed H*0085
75987013ac Ed H*0086 integer myThid, nt
4de8f8c098 Ed H*0087 character*(*) aname
0088 character*(*) name_list(NT)
e6bb5b2cc3 Ed H*0089
4de8f8c098 Ed H*0090
1b5fb69d21 Ed H*0091
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
0096 integer ILNBLNK
4de8f8c098 Ed H*0097
0098
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
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
e6bb5b2cc3 Ed H*0124
1b5fb69d21 Ed H*0125
e9b72f2bd9 Ed H*0126
1b5fb69d21 Ed H*0127
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
0136
b6432c788b Jean*0137
1b5fb69d21 Ed H*0138
4de8f8c098 Ed H*0139 implicit none
0140 #include "EEPARAMS.h"
0141
1b5fb69d21 Ed H*0142
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
4de8f8c098 Ed H*0147
1b5fb69d21 Ed H*0148
0149 integer n, i, ind
0150 character*(MAX_LEN_MBUF) msgbuf
e6bb5b2cc3 Ed H*0151
4de8f8c098 Ed H*0152
0153 integer ILNBLNK
0154
0155
0156
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
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
e6bb5b2cc3 Ed H*0182
1b5fb69d21 Ed H*0183
376f4203f6 Ed H*0184
1b5fb69d21 Ed H*0185
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
0194
b6432c788b Jean*0195
1b5fb69d21 Ed H*0196
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
376f4203f6 Ed H*0202 INTEGER myThid, fid, indf, ind_fv_ids
0203 character*(*) fname
0204 character*(*) vname
e6bb5b2cc3 Ed H*0205
376f4203f6 Ed H*0206
1b5fb69d21 Ed H*0207
0208 integer i,j,k, n, lenv
e6bb5b2cc3 Ed H*0209
376f4203f6 Ed H*0210
0211 integer ILNBLNK
0212
0213
0214 lenv = ILNBLNK(vname)
0215
0216
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
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
8ae258cf2c Ed H*0243
a906dd2a24 Ed H*0244
0245
0246
0247
8ae258cf2c Ed H*0248
a906dd2a24 Ed H*0249
0250
0251
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
a906dd2a24 Ed H*0266 INTEGER myThid, ind_vt, indf, ind_fv_ids, indu, ires
0267
0268
0269 integer ILNBLNK
8ae258cf2c Ed H*0270
0271
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
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
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
0318 ires = 1
0319
0320 RETURN
0321 END
0322
0323
5bc9611487 Ed H*0324
0325
0326
0327
0328 SUBROUTINE MNC_PSNCM(
0329 O ostring,
0330 I ival, n )
0331
0332
0333
0334
0335
0336 IMPLICIT NONE
0337
0338
0339
0340 CHARACTER*(*) ostring
0341 INTEGER ival, n
0342
0343
0344
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
0364 RETURN
0365 END
0366
0367
0368