Newer
Older
WAUTELET Philippe
committed
USE MODD_IO_ll, ONLY: TFILE_ELT
USE MODD_NETCDF, ONLY: DIMCDF, IDCDF_KIND
WAUTELET Philippe
committed
WAUTELET Philippe
committed
USE MODE_FIELD
WAUTELET Philippe
committed
USE MODE_FIELDTYPE
WAUTELET Philippe
committed
USE MODE_FMREAD
USE MODE_FMWRIT
WAUTELET Philippe
committed
USE mode_options
USE netcdf
INTEGER,PARAMETER :: MAXRAW=10
WAUTELET Philippe
committed
INTEGER,PARAMETER :: MAXLEN=512
WAUTELET Philippe
committed
INTEGER,PARAMETER :: MAXLFICOMMENTLENGTH=100
WAUTELET Philippe
committed
INTEGER,PARAMETER :: UNDEFINED = -1, READING = 1, WRITING = 2
INTEGER,PARAMETER :: UNKNOWN_FORMAT = -1, NETCDF_FORMAT = 1, LFI_FORMAT = 2
TYPE filestruct
INTEGER :: lun_id ! Logical ID of file
INTEGER :: format = UNKNOWN_FORMAT ! NETCDF, LFI
INTEGER :: status = UNDEFINED ! Opened for reading or writing
INTEGER :: var_id ! Position of the variable in the workfield structure
LOGICAL :: opened = .false.
END TYPE filestruct
TYPE filelist_struct
INTEGER :: nbfiles = 0
! TYPE(filestruct),DIMENSION(:),ALLOCATABLE :: files
TYPE(filestruct),DIMENSION(MAXFILES) :: files
WAUTELET Philippe
committed
TYPE(TFILE_ELT),DIMENSION(MAXFILES) :: TFILES
WAUTELET Philippe
committed
WAUTELET Philippe
committed
CHARACTER(LEN=FM_FIELD_SIZE) :: name ! nom du champ
TYPE(dimCDFl2c), POINTER :: dim
INTEGER :: id_in = -1, id_out = -1
LOGICAL :: found ! T if found in the input file
LOGICAL :: calc ! T if computed from other variables
LOGICAL :: tbw ! to be written or not
LOGICAL :: tbr ! to be read or not
WAUTELET Philippe
committed
LOGICAL :: LSPLIT = .FALSE. ! TRUE if variable is split by vertical level
INTEGER :: NSRC = 0 ! Number of variables used to compute the variable (needed only if calc=.true.)
WAUTELET Philippe
committed
INTEGER,DIMENSION(MAXRAW) :: src ! List of variables used to compute the variable (needed only if calc=.true.)
INTEGER :: tgt ! Target: id of the variable that use it (calc variable)
TYPE(TFIELDDATA) :: TFIELD ! Metadata about the field
TYPE(DIMCDF),DIMENSION(:),ALLOCATABLE :: TDIMS ! Dimensions of the field
LOGICAL(KIND=LFI_INT), PARAMETER :: ltrue = .TRUE.
LOGICAL(KIND=LFI_INT), PARAMETER :: lfalse = .FALSE.
WAUTELET Philippe
committed
CHARACTER(LEN=6) :: CPROGRAM_ORIG
CONTAINS
FUNCTION str_replace(hstr, hold, hnew)
CHARACTER(LEN=*) :: hstr, hold, hnew
CHARACTER(LEN=LEN_TRIM(hstr)+MAX(0,LEN(hnew)-LEN(hold))) :: str_replace
INTEGER :: pos
pos = INDEX(hstr,hold)
IF (pos /= 0) THEN
str_replace = hstr(1:pos-1)//hnew//hstr(pos+LEN(hold):)
ELSE
str_replace = hstr
END IF
END FUNCTION str_replace
WAUTELET Philippe
committed
SUBROUTINE parse_infiles(infiles, nbvar_infile, nbvar_tbr, nbvar_calc, nbvar_tbw, tpreclist, kbuflen, options, icurrent_level)
WAUTELET Philippe
committed
USE MODD_DIM_n, ONLY: NIMAX_ll, NJMAX_ll, NKMAX
USE MODD_PARAMETERS, ONLY: JPHEXT, JPVEXT
WAUTELET Philippe
committed
TYPE(filelist_struct), INTENT(IN) :: infiles
INTEGER, INTENT(IN) :: nbvar_infile, nbvar_tbr, nbvar_calc, nbvar_tbw
TYPE(workfield), DIMENSION(:), POINTER :: tpreclist
INTEGER, INTENT(OUT) :: kbuflen
WAUTELET Philippe
committed
TYPE(option),DIMENSION(:), INTENT(IN) :: options
INTEGER, INTENT(IN), OPTIONAL :: icurrent_level
WAUTELET Philippe
committed
INTEGER :: ji,jj, kcdf_id, kcdf_id2, itype
INTEGER :: ndb, nde, ndey, idx, idx_var, maxvar
INTEGER :: idims, idimtmp, jdim, status, var_id
INTEGER :: comment_size, fsize, sizemax
CHARACTER(LEN=FM_FIELD_SIZE) :: yrecfm, YDATENAME
CHARACTER(LEN=4) :: suffix
INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE :: iwork
WAUTELET Philippe
committed
INTEGER :: IID, IRESP
INTEGER(KIND=LFI_INT) :: iresp2,ilu,ileng,ipos
CHARACTER(LEN=FM_FIELD_SIZE) :: var_calc
CHARACTER(LEN=FM_FIELD_SIZE),dimension(MAXRAW) :: var_raw
INTEGER, DIMENSION(10) :: idim_id
INTEGER :: IDXDATE, IDXTIME, IDX1
LOGICAL :: GISDATE, GISTIME
LOGICAL :: GOK
IF (infiles%files(1)%format == LFI_FORMAT) THEN
ilu = infiles%files(1)%lun_id
ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
kcdf_id = infiles%files(1)%lun_id
END IF
WAUTELET Philippe
committed
! update IDIMX,IDIMY,IDIMZ
IDIMX = NIMAX_ll+2*JPHEXT
IDIMY = NJMAX_ll+2*JPHEXT
IDIMZ = NKMAX +2*JPVEXT
GUSEDIM = (IDIMX*IDIMY > 0)
IF (GUSEDIM) THEN
PRINT *,'MESONH 3D, 2D articles DIMENSIONS used :'
PRINT *,'DIMX =',IDIMX
PRINT *,'DIMY =',IDIMY
PRINT *,'DIMZ =',IDIMZ ! IDIMZ may be equal to 0 (PGD files)
ELSE
PRINT *,'BEWARE : ALL MesoNH arrays are handled as 1D arrays !'
END IF
sizemax = 0
IF (present(icurrent_level)) THEN
write(suffix,'(I4.4)') icurrent_level
current_level = icurrent_level
ElSE
suffix=''
current_level = -1
END IF
! Phase 1 : build articles list to convert.
!
! Pour l'instant tous les articles du fichier LFI sont
! convertis. On peut modifier cette phase pour prendre en
! compte un sous-ensemble d'article (liste definie par
WAUTELET Philippe
committed
IF (options(OPTVAR)%set) THEN
ALLOCATE(tpreclist(nbvar_tbr+nbvar_calc))
DO ji=1,nbvar_tbr+nbvar_calc
tpreclist(ji)%found = .FALSE.
tpreclist(ji)%calc = .FALSE. !By default variables are not computed from others
tpreclist(ji)%tbw = .TRUE. !By default variables are written
tpreclist(ji)%tbr = .TRUE. !By default variables are read
tpreclist(ji)%src(:) = -1
tpreclist(ji)%tgt = -1
END DO
! A variable list is provided with -v var1,...
ndb = 1
idx_var = 1
DO ji=1,nbvar_tbw
WAUTELET Philippe
committed
!crash compiler GCC 4.2.0: nde = INDEX(TRIM(options(OPTVAR)%cvalue(ndb:)),',')
nde = INDEX(TRIM(options(OPTVAR)%cvalue(ndb:len(trim(options(OPTVAR)%cvalue)))),',')
IF (nde == 0) nde = LEN( TRIM(options(OPTVAR)%cvalue(ndb:len(trim(options(OPTVAR)%cvalue)))) ) + 1
WAUTELET Philippe
committed
yrecfm = options(OPTVAR)%cvalue(ndb:ndb+nde-2)
!Detect operations on variables (only + is supported now)
ndey = INDEX(TRIM(yrecfm),'=')
idx = 1
IF (ndey /= 0) THEN
var_calc = yrecfm(1:ndey-1)
DO WHILE (ndey /= 0)
IF (idx>MAXRAW) THEN
print *,'Error: MAXRAW exceeded (too many raw variables for 1 computed one)'
STOP
END IF
yrecfm = yrecfm(ndey+1:)
ndey = INDEX(TRIM(yrecfm),'+')
IF (ndey /= 0) THEN
var_raw(idx) = yrecfm(1:ndey-1)
ELSE
var_raw(idx) = TRIM(yrecfm)
END IF
idx = idx + 1
END DO
tpreclist(idx_var)%name = trim(var_calc)
tpreclist(idx_var)%calc = .TRUE.
tpreclist(idx_var)%tbw = .TRUE.
tpreclist(idx_var)%tbr = .FALSE.
tpreclist(idx_var)%NSRC = idx-1
idx_var=idx_var+1
DO jj = 1, idx-1
tpreclist(idx_var-jj)%src(jj) = idx_var
tpreclist(idx_var)%name = trim(var_raw(jj))
tpreclist(idx_var)%calc = .FALSE.
tpreclist(idx_var)%tbw = .FALSE.
tpreclist(idx_var)%tbr = .TRUE.
tpreclist(idx_var)%tgt = idx_var-jj
idx_var=idx_var+1
END DO
ELSE
tpreclist(idx_var)%name = trim(yrecfm)
tpreclist(idx_var)%calc = .FALSE.
tpreclist(idx_var)%tbw = .TRUE.
idx_var=idx_var+1
END IF
ndb = nde+ndb
END DO
DO ji=1,nbvar_tbr+nbvar_calc
IF (tpreclist(ji)%calc) CYCLE
yrecfm = TRIM(tpreclist(ji)%name)
IF (infiles%files(1)%format == LFI_FORMAT) THEN
WAUTELET Philippe
committed
CALL LFINFO(iresp2,ilu,trim(yrecfm)//trim(suffix),ileng,ipos)
IF (iresp2 == 0 .AND. ileng /= 0) tpreclist(ji)%found = .true.
WAUTELET Philippe
committed
IF (iresp2==0 .AND. ileng == 0 .AND. ipos==0 .AND. infiles%TFILES(1)%TFILE%NSUBFILES_IOZ>0) THEN
!Variable not found with no error (iresp2==0 .AND. ileng == 0 .AND. ipos==0)
!If we are merging, maybe it is one of the split variable
!In that case, the 1st part of the variable is in the 1st splitted file with a 0001 suffix
CALL LFINFO(iresp2,infiles%TFILES(1)%TFILE%TFILES_IOZ(1)%TFILE%NLFIFLU,trim(yrecfm)//'0001',ileng,ipos)
IF (iresp2 == 0 .AND. ileng /= 0) THEN
tpreclist(ji)%found = .true.
tpreclist(ji)%LSPLIT = .true.
IF (tpreclist(ji)%tgt > 0) THEN !If this variable is used for a calculated one
tpreclist(tpreclist(ji)%tgt)%LSPLIT = .true.
END IF
END IF
ileng = ileng * IDIMZ !Real size is slightly overestimated due to comment size
END IF
leng = ileng
ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
status = NF90_INQ_VARID(kcdf_id,trim(yrecfm)//trim(suffix),tpreclist(ji)%id_in)
WAUTELET Philippe
committed
IF (status /= NF90_NOERR .AND. infiles%TFILES(1)%TFILE%NSUBFILES_IOZ>0) THEN
!Variable probably not found (other error possible...)
!If we are merging, maybe it is one of the split variable
!In that case, the 1st part of the variable is in the 1st splitted file with a 0001 suffix
kcdf_id2 = infiles%TFILES(1)%TFILE%TFILES_IOZ(1)%TFILE%NNCID
status = NF90_INQ_VARID(kcdf_id2,trim(yrecfm)//'0001',tpreclist(ji)%id_in)
IF (status == NF90_NOERR) THEN
tpreclist(ji)%LSPLIT = .true.
IF (tpreclist(ji)%tgt > 0) THEN !If this variable is used for a calculated one
tpreclist(tpreclist(ji)%tgt)%LSPLIT = .true.
END IF
END IF
ELSE
kcdf_id2 = kcdf_id
ENDIF
!
IF (status == NF90_NOERR) THEN
tpreclist(ji)%found = .true.
WAUTELET Philippe
committed
status = NF90_INQUIRE_VARIABLE(kcdf_id2,tpreclist(ji)%id_in,ndims = idims,dimids = idim_id)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
!TODO:useful?
!DUPLICATED
IF (idims == 0) THEN
! variable scalaire
leng = 1
ELSE
! infos sur dimensions
leng = 1
DO jdim=1,idims
WAUTELET Philippe
committed
status = NF90_INQUIRE_DIMENSION(kcdf_id2,idim_id(jdim),len = idimtmp)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
leng = leng*idimtmp
END DO
WAUTELET Philippe
committed
IF (tpreclist(ji)%LSPLIT) THEN
IF(idims/=2) CALL PRINT_MSG(NVERB_FATAL,'IO','parse_infiles','split variables can only be 3D')
!Split variables are Z-splitted
leng = leng * IDIMZ
END IF
WAUTELET Philippe
committed
!Add maximum comment size (necessary when writing LFI files because the comment is stored with the field)
leng = leng + MAXLFICOMMENTLENGTH
END IF
IF (.NOT.tpreclist(ji)%found) THEN
PRINT *,'Article ',TRIM(yrecfm), ' not found!'
tpreclist(ji)%tbw = .FAlSE.
tpreclist(ji)%tbr = .FAlSE.
ELSE
! PRINT *,'Article ',ji,' : ',TRIM(yrecfm),', longueur = ',ileng
IF (leng > sizemax) sizemax = leng
END IF
maxvar = nbvar_tbr+nbvar_calc
DO ji=1,nbvar_tbr+nbvar_calc
print *,ji,'name=',trim(tpreclist(ji)%name),' calc=',tpreclist(ji)%calc,' tbw=',tpreclist(ji)%tbw,&
' tbr=',tpreclist(ji)%tbr,' found=',tpreclist(ji)%found
END DO
ELSE
! Entire file is converted
ALLOCATE(tpreclist(nbvar_infile))
DO ji=1,nbvar_infile
tpreclist(ji)%calc = .FALSE. !By default variables are not computed from others
tpreclist(ji)%tbw = .TRUE. !By default variables are written
tpreclist(ji)%src(:) = -1
END DO
IF (infiles%files(1)%format == LFI_FORMAT) THEN
WAUTELET Philippe
committed
CALL LFIPOS(iresp2,ilu)
GISDATE = .FALSE.
GISTIME = .FALSE.
YDATENAME = ''
WAUTELET Philippe
committed
CALL LFICAS(iresp2,ilu,yrecfm,ileng,ipos,ladvan)
! PRINT *,'Article ',ji,' : ',TRIM(yrecfm),', longueur = ',ileng
tpreclist(ji)%name = trim(yrecfm)
tpreclist(ji)%found = .TRUE.
IF (ileng > sizemax) sizemax = ileng
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
!Detect if date variable
IDXDATE = INDEX(trim(yrecfm),"%TDATE",.TRUE.)
IDXTIME = INDEX(trim(yrecfm),"%TIME", .TRUE.)
IF (IDXDATE/=0 .AND. IDXTIME/=0) &
CALL PRINT_MSG(NVERB_FATAL,'IO','parse_infiles','field in LFI file with %TDATE and %TIME in name '//TRIM(YRECFM))
IDX = MAX(IDXDATE,IDXTIME)
IF (IDX>0) THEN
IF (LEN_TRIM(YDATENAME) == 0) THEN
!New date name detected
IDX1 = ji
YDATENAME = YRECFM(1:IDX-1)
IF (IDXDATE>0) GISDATE = .TRUE.
IF (IDXTIME>0) GISTIME = .TRUE.
ELSE
!Was already found => other field (date or time) is detected
IF (TRIM(YDATENAME)/=YRECFM(1:IDX-1)) STOP
IF (IDXDATE>0) THEN
IF (.NOT.GISDATE) THEN
GISDATE = .TRUE.
IF (GISTIME) THEN
tpreclist(ji)%name = 'removed_time'
tpreclist(ji)%tbw = .FALSE.
tpreclist(ji)%tbr = .FALSE.
tpreclist(ji)%found = .FALSE.
tpreclist(IDX1)%name = YDATENAME
!
GISDATE = .FALSE.
GISTIME = .FALSE.
YDATENAME = ''
END IF
ELSE
CALL PRINT_MSG(NVERB_FATAL,'IO','parse_infiles','GISDATE is already TRUE for '//TRIM(YDATENAME))
END IF
ELSE IF (IDXTIME>0) THEN
IF (.NOT.GISTIME) THEN
GISTIME = .TRUE.
IF (GISDATE) THEN
tpreclist(ji)%name = 'removed_date'
tpreclist(ji)%tbw = .FALSE.
tpreclist(ji)%tbr = .FALSE.
tpreclist(ji)%found = .FALSE.
tpreclist(IDX1)%name = YDATENAME
!
GISDATE = .FALSE.
GISTIME = .FALSE.
YDATENAME = ''
END IF
ELSE
CALL PRINT_MSG(NVERB_FATAL,'IO','parse_infiles','GISTIME is already TRUE for '//TRIM(YDATENAME))
END IF
END IF
END IF
END IF
ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
DO ji=1,nbvar_infile
tpreclist(ji)%id_in = ji
status = NF90_INQUIRE_VARIABLE(kcdf_id,tpreclist(ji)%id_in, name = tpreclist(ji)%name, ndims = idims, &
dimids = idim_id)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
! PRINT *,'Article ',ji,' : ',TRIM(tpreclist(ji)%name),', longueur = ',ileng
tpreclist(ji)%found = .TRUE.
!TODO:useful?
!DUPLICATED
IF (idims == 0) THEN
! variable scalaire
leng = 1
ELSE
! infos sur dimensions
leng = 1
DO jdim=1,idims
status = NF90_INQUIRE_DIMENSION(kcdf_id,idim_id(jdim),len = idimtmp)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
leng = leng*idimtmp
END DO
END IF
IF (leng > sizemax) sizemax = leng
END DO
WAUTELET Philippe
committed
!Add maximum comment size (necessary when writing LFI files because the comment is stored with the field)
sizemax = sizemax + MAXLFICOMMENTLENGTH
WAUTELET Philippe
committed
! Check if variable is in TFIELDLIST and populate corresponding metadata
DO ji=1,maxvar
IF (.NOT.tpreclist(ji)%found .OR. tpreclist(ji)%calc ) CYCLE
WAUTELET Philippe
committed
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
!
!Do not treat dimension variables (they are automatically added when creating netCDF file)
IF ( tpreclist(ji)%name == 'ni' &
.OR. tpreclist(ji)%name == 'nj' &
.OR. tpreclist(ji)%name == 'ni_u' &
.OR. tpreclist(ji)%name == 'nj_u' &
.OR. tpreclist(ji)%name == 'ni_v' &
.OR. tpreclist(ji)%name == 'nj_v' &
.OR. tpreclist(ji)%name == 'latitude' &
.OR. tpreclist(ji)%name == 'longitude' &
.OR. tpreclist(ji)%name == 'latitude_u' &
.OR. tpreclist(ji)%name == 'longitude_u' &
.OR. tpreclist(ji)%name == 'latitude_v' &
.OR. tpreclist(ji)%name == 'longitude_v' &
.OR. tpreclist(ji)%name == 'latitude_f' &
.OR. tpreclist(ji)%name == 'longitude_f' &
.OR. tpreclist(ji)%name == 'level' &
.OR. tpreclist(ji)%name == 'level_w' ) THEN
tpreclist(ji)%tbw = .FALSE.
tpreclist(ji)%tbr = .FALSE.
tpreclist(ji)%found = .FALSE.
ELSE
CALL FIND_FIELD_ID_FROM_MNHNAME(tpreclist(ji)%name,IID,IRESP)
IF (IRESP==0) THEN
tpreclist(ji)%TFIELD = TFIELDLIST(IID)
ALLOCATE(tpreclist(ji)%TDIMS(tpreclist(ji)%TFIELD%NDIMS))
ELSE !Field not found in list
CALL PRINT_MSG(NVERB_WARNING,'IO','parse_infiles','variable '//TRIM(tpreclist(ji)%name)//' is not known => ignored')
tpreclist(ji)%tbw = .FALSE.
tpreclist(ji)%tbr = .FALSE.
tpreclist(ji)%found = .FALSE.
END IF
END IF
END DO
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
IF (nbvar_calc>0) THEN
!Calculated variables
!Done after previous loop to reuse metadate from component variables
!Derive metadata from its components
!If same value for all components => take it
!If not => nothing or default value
!Check sizes: must be the same for all
DO ji=1,maxvar
IF (.NOT.tpreclist(ji)%calc ) CYCLE
!
tpreclist(ji)%TFIELD%CMNHNAME = tpreclist(ji)%name
tpreclist(ji)%TFIELD%CSTDNAME = ''
tpreclist(ji)%TFIELD%CLONGNAME = tpreclist(ji)%name
!
GOK = .TRUE.
DO jj=1,tpreclist(ji)%NSRC
idx_var = tpreclist(ji)%src(jj)
IF(.NOT.tpreclist(idx_var)%found) THEN
CALL PRINT_MSG(NVERB_WARNING,'IO','parse_infiles','some components for calculated variable ' &
//TRIM(tpreclist(ji)%name)//' are not known => ignored')
tpreclist(ji)%tbw = .FALSE.
tpreclist(ji)%tbr = .FALSE.
tpreclist(ji)%found = .FALSE.
GOK = .FALSE.
EXIT
END IF
END DO
!
IF (GOK) THEN
idx_var = tpreclist(ji)%src(1)
tpreclist(ji)%TFIELD%CUNITS = tpreclist(idx_var)%TFIELD%CUNITS
tpreclist(ji)%TFIELD%CDIR = tpreclist(idx_var)%TFIELD%CDIR
tpreclist(ji)%TFIELD%CLBTYPE = tpreclist(idx_var)%TFIELD%CLBTYPE
tpreclist(ji)%TFIELD%CCOMMENT = TRIM(tpreclist(ji)%name)//'='//TRIM(tpreclist(idx_var)%name)
IF (tpreclist(ji)%NSRC>1) tpreclist(ji)%TFIELD%CCOMMENT = TRIM(tpreclist(ji)%TFIELD%CCOMMENT)//'+'
tpreclist(ji)%TFIELD%NGRID = tpreclist(idx_var)%TFIELD%NGRID
tpreclist(ji)%TFIELD%NTYPE = tpreclist(idx_var)%TFIELD%NTYPE
tpreclist(ji)%TFIELD%NDIMS = tpreclist(idx_var)%TFIELD%NDIMS
#if 0
!PW: TODO?
tpreclist(ji)%TFIELD%NFILLVALUE
tpreclist(ji)%TFIELD%XFILLVALUE
tpreclist(ji)%TFIELD%NVALIDMIN
tpreclist(ji)%TFIELD%NVALIDMAX
tpreclist(ji)%TFIELD%XVALIDMIN
tpreclist(ji)%TFIELD%XVALIDMAX
#endif
DO jj=2,tpreclist(ji)%NSRC
idx_var = tpreclist(ji)%src(jj)
!
IF (tpreclist(ji)%TFIELD%CUNITS /= tpreclist(idx_var)%TFIELD%CUNITS) THEN
CALL PRINT_MSG(NVERB_WARNING,'IO','parse_infiles','CUNITS is not uniform between components of calculated variable '&
//TRIM(tpreclist(ji)%name)//' => CUNITS not set')
tpreclist(ji)%TFIELD%CUNITS = ''
END IF
!
IF (tpreclist(ji)%TFIELD%CDIR /= tpreclist(idx_var)%TFIELD%CDIR) THEN
CALL PRINT_MSG(NVERB_ERROR,'IO','parse_infiles','CDIR is not uniform between components of calculated variable '&
//TRIM(tpreclist(ji)%name)//' => CDIR=--')
tpreclist(ji)%TFIELD%CDIR = '--'
END IF
!
IF (tpreclist(ji)%TFIELD%CLBTYPE /= tpreclist(idx_var)%TFIELD%CLBTYPE) THEN
CALL PRINT_MSG(NVERB_ERROR,'IO','parse_infiles','CLBTYPE is not uniform between components of calculated variable '&
//TRIM(tpreclist(ji)%name)//' => CLBTYPE=NONE')
tpreclist(ji)%TFIELD%CLBTYPE = 'NONE'
END IF
!
tpreclist(ji)%TFIELD%CCOMMENT = TRIM(tpreclist(ji)%TFIELD%CCOMMENT)//TRIM(tpreclist(idx_var)%name)
IF (jj<tpreclist(ji)%NSRC) tpreclist(ji)%TFIELD%CCOMMENT = TRIM(tpreclist(ji)%TFIELD%CCOMMENT)//'+'
!
IF (tpreclist(ji)%TFIELD%NGRID /= tpreclist(idx_var)%TFIELD%NGRID) THEN
CALL PRINT_MSG(NVERB_WARNING,'IO','parse_infiles','NGRID is not uniform between components of calculated variable '&
//TRIM(tpreclist(ji)%name)//' => NGRID=1')
tpreclist(ji)%TFIELD%NGRID = 1
END IF
!
IF (tpreclist(ji)%TFIELD%NTYPE /= tpreclist(idx_var)%TFIELD%NTYPE) THEN
CALL PRINT_MSG(NVERB_FATAL,'IO','parse_infiles','NTYPE is not uniform between components of calculated variable '&
//TRIM(tpreclist(ji)%name))
tpreclist(ji)%TFIELD%NTYPE = TYPEUNDEF
END IF
!
IF (tpreclist(ji)%TFIELD%NDIMS /= tpreclist(idx_var)%TFIELD%NDIMS) THEN
CALL PRINT_MSG(NVERB_FATAL,'IO','parse_infiles','NDIMS is not uniform between components of calculated variable '&
//TRIM(tpreclist(ji)%name))
END IF
END DO
!
ALLOCATE(tpreclist(ji)%TDIMS(tpreclist(ji)%TFIELD%NDIMS))
!
END IF
END DO !ji=1,maxvar
END IF !nbvar_calc>0
WRITE(*,'("Taille maximale du buffer :",f10.3," Mio")') sizemax*8./1048576.
SUBROUTINE HANDLE_ERR(status,line)
INTEGER :: status,line
IF (status /= NF90_NOERR) THEN
PRINT *, 'line ',line,': ',NF90_STRERROR(status)
END IF
END SUBROUTINE HANDLE_ERR
WAUTELET Philippe
committed
SUBROUTINE def_ncdf(outfiles,tpreclist,nbvar,options)
WAUTELET Philippe
committed
USE MODE_NETCDF, ONLY: IO_WRITE_HEADER_NC4
TYPE(filelist_struct), INTENT(IN) :: outfiles
TYPE(workfield),DIMENSION(:),INTENT(INOUT) :: tpreclist
INTEGER, INTENT(IN) :: nbvar
WAUTELET Philippe
committed
TYPE(option),DIMENSION(:), INTENT(IN) :: options
WAUTELET Philippe
committed
INTEGER :: compress_level, status
WAUTELET Philippe
committed
INTEGER :: idx, ji, nbfiles
WAUTELET Philippe
committed
INTEGER :: IID, IRESP
WAUTELET Philippe
committed
TYPE(dimCDFl2c), POINTER :: tzdim
WAUTELET Philippe
committed
INTEGER :: type_float
INTEGER, DIMENSION(10) :: ivdims
CHARACTER(LEN=20) :: ycdfvar
WAUTELET Philippe
committed
WAUTELET Philippe
committed
IF (options(OPTREDUCE)%set) THEN
WAUTELET Philippe
committed
type_float = NF90_REAL
ELSE
type_float = NF90_DOUBLE
END IF
WAUTELET Philippe
committed
DO ji = 1,nbfiles
WAUTELET Philippe
committed
! global attributes
WAUTELET Philippe
committed
CALL IO_WRITE_HEADER_NC4(outfiles%TFILES(ji)%TFILE)
!
! status = NF90_PUT_ATT(kcdf_id,NF90_GLOBAL,'Title',VERSION_ID)
! IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
END DO
END SUBROUTINE def_ncdf
WAUTELET Philippe
committed
SUBROUTINE fill_ncdf(infiles,outfiles,tpreclist,knaf,kbuflen,options,current_level)
USE MODD_TYPE_DATE
WAUTELET Philippe
committed
USE MODE_NETCDF, ONLY: IO_GUESS_DIMIDS_NC4
TYPE(filelist_struct), INTENT(IN) :: infiles, outfiles
TYPE(workfield), DIMENSION(:),INTENT(INOUT) :: tpreclist
INTEGER, INTENT(IN) :: knaf
INTEGER, INTENT(IN) :: kbuflen
TYPE(option),DIMENSION(:), INTENT(IN) :: options
INTEGER, OPTIONAL, INTENT(IN) :: current_level
INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE :: iwork
WAUTELET Philippe
committed
INTEGER :: idx, ji,jj
INTEGER :: kcdf_id
WAUTELET Philippe
committed
! INTEGER :: status
INTEGER :: extent, ndims
WAUTELET Philippe
committed
INTEGER :: IID, IRESP2
INTEGER :: src
INTEGER :: level
INTEGER(KIND=LFI_INT) :: iresp,ilu,ileng,ipos
CHARACTER(LEN=4) :: suffix
WAUTELET Philippe
committed
! INTEGER,DIMENSION(3) :: idims, start
INTEGER,DIMENSION(3) :: start
WAUTELET Philippe
committed
INTEGER,DIMENSION(:),ALLOCATABLE :: itab
LOGICAL,DIMENSION(:),ALLOCATABLE :: gtab
WAUTELET Philippe
committed
REAL,DIMENSION(:),ALLOCATABLE :: xtab
! CHARACTER, DIMENSION(:), ALLOCATABLE :: ytab
CHARACTER(LEN=:), ALLOCATABLE :: ytab
REAL, DIMENSION(:,:), ALLOCATABLE :: xtab2d
REAL, DIMENSION(:,:,:), ALLOCATABLE :: xtab3d, xtab3d2
REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: xtab4d
INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: itab3d, itab3d2
TYPE(DATE_TIME) :: TZDATE
WAUTELET Philippe
committed
WAUTELET Philippe
committed
INTEGER(KIND=IDCDF_KIND) :: STATUS
INTEGER(KIND=IDCDF_KIND) :: INCID
INTEGER(KIND=IDCDF_KIND) :: IVARID
INTEGER(KIND=IDCDF_KIND) :: IDIMS ! number of dimensions
INTEGER(KIND=IDCDF_KIND),DIMENSION(NF90_MAX_VAR_DIMS) :: IVDIMS
INTEGER(KIND=IDCDF_KIND),DIMENSION(NF90_MAX_VAR_DIMS) :: IDIMLEN
IF (infiles%files(1)%format == LFI_FORMAT) ilu = infiles%files(1)%lun_id
IF (present(current_level)) THEN
write(suffix,'(I4.4)') current_level
level = current_level
ElSE
suffix=''
level = 1
END IF
ALLOCATE(iwork(kbuflen))
ALLOCATE(itab(kbuflen))
WAUTELET Philippe
committed
idx = 1
IF (.NOT.tpreclist(ji)%tbw) CYCLE
WAUTELET Philippe
committed
WAUTELET Philippe
committed
ndims = tpreclist(ji)%TFIELD%NDIMS
WAUTELET Philippe
committed
WAUTELET Philippe
committed
SELECT CASE(tpreclist(ji)%TFIELD%NTYPE)
WAUTELET Philippe
committed
CASE (TYPEINT)
IF (infiles%files(1)%format == LFI_FORMAT) THEN
IF (.NOT.tpreclist(ji)%calc) THEN
CALL LFINFO(iresp,ilu,trim(tpreclist(ji)%name)//trim(suffix),ileng,ipos)
CALL LFILEC(iresp,ilu,trim(tpreclist(ji)%name)//trim(suffix),iwork,ileng)
WAUTELET Philippe
committed
extent = ileng - 2 - iwork(2) !iwork(2) = comment length
! Determine TDIMS
WAUTELET Philippe
committed
CALL IO_GUESS_DIMIDS_NC4(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,extent,tpreclist(ji)%TDIMS,IRESP2)
IF (IRESP2/=0) THEN
CALL PRINT_MSG(NVERB_WARNING,'IO','fill_ncdf','can not guess dimensions for '//tpreclist(ji)%TFIELD%CMNHNAME// &
' => ignored')
CYCLE
END IF
itab(1:extent) = iwork(3+iwork(2):3+iwork(2)+extent-1)
ELSE
src=tpreclist(ji)%src(1)
CALL LFINFO(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),ileng,ipos)
CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),iwork,ileng)
WAUTELET Philippe
committed
extent = ileng - 2 - iwork(2) !iwork(2) = comment length
itab(1:extent) = iwork(3+iwork(2):3+iwork(2)+extent-1)
! Determine TDIMS
CALL IO_GUESS_DIMIDS_NC4(outfiles%tfiles(idx)%TFILE,tpreclist(src)%TFIELD,extent,tpreclist(src)%TDIMS,IRESP2)
IF (IRESP2/=0) THEN
CALL PRINT_MSG(NVERB_WARNING,'IO','fill_ncdf','can not guess dimensions for '//tpreclist(src)%TFIELD%CMNHNAME// &
' => ignored')
CALL PRINT_MSG(NVERB_WARNING,'IO','fill_ncdf','can not guess dimensions for '//tpreclist(ji)%TFIELD%CMNHNAME// &
' => ignored')
CYCLE
ELSE
tpreclist(ji)%TDIMS = tpreclist(src)%TDIMS
END IF
DO jj=2,tpreclist(ji)%NSRC
src=tpreclist(ji)%src(jj)
CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),iwork,ileng)
!PW: TODO: check same dimensions
itab(1:extent) = itab(1:extent) + iwork(3+iwork(2):3+iwork(2)+extent-1)
!TODO: works in all cases??? (X, Y, Z dimensions assumed to be ptdimx,y or z)
SELECT CASE(ndims)
CASE (0)
WAUTELET Philippe
committed
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,itab(1))
CASE (1)
WAUTELET Philippe
committed
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,itab(1:extent))
CASE (2)
WAUTELET Philippe
committed
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,reshape(itab,tpreclist(ji)%TDIMS(1:2)%LEN))
! status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,reshape(itab,(/ptdimx%len,ptdimy%len/)), &
! start = (/1,1,level/) )
CASE (3)
WAUTELET Philippe
committed
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,reshape(itab,tpreclist(ji)%TDIMS(1:3)%LEN))
CASE DEFAULT
WAUTELET Philippe
committed
print *,'Error: arrays with ',ndims,' dimensions are not supported'
END SELECT
ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
WAUTELET Philippe
committed
INCID = infiles%TFILES(1)%TFILE%NNCID
STATUS = NF90_INQ_VARID(INCID,tpreclist(ji)%TFIELD%CMNHNAME,IVARID)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
STATUS = NF90_INQUIRE_VARIABLE(INCID, IVARID, NDIMS=IDIMS, DIMIDS=IVDIMS)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
if (ndims/=idims) then
print *,'aieeeeeee'
stop
end if
DO JJ=1,IDIMS
STATUS = NF90_INQUIRE_DIMENSION(infiles%TFILES(1)%TFILE%NNCID, IVDIMS(JJ), LEN=IDIMLEN(JJ))
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
END DO
SELECT CASE(ndims)
CASE (0)
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE, tpreclist(ji)%TFIELD,itab(1))
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,itab(1))
CASE (1)
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE, tpreclist(ji)%TFIELD,itab(1:IDIMLEN(1)))
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,itab(1:IDIMLEN(1)))
CASE (2)
print *,'PW:TODO'
CASE (3)
print *,'PW:TODO'
CASE DEFAULT
WAUTELET Philippe
committed
print *,'Error: arrays with ',ndims,' dimensions are not supported'
WAUTELET Philippe
committed
END SELECT
#if 0
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
ALLOCATE( itab3d(idims(1),idims(2),idims(3)) )
IF (.NOT.tpreclist(ji)%calc) THEN
status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(ji)%id_in,itab3d)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
ELSE
ALLOCATE( itab3d2(idims(1),idims(2),idims(3)) )
src=tpreclist(ji)%src(1)
status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(src)%id_in,itab3d)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
jj = 2
DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
src=tpreclist(ji)%src(jj)
status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(src)%id_in,itab3d2)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
itab3d(:,:,:) = itab3d(:,:,:) + itab3d2(:,:,:)
jj=jj+1
END DO
DEALLOCATE(itab3d2)
END IF
!TODO: not clean, should be done only if merging z-levels
IF (ndims == 2) THEN
start = (/1,1,level/)
ELSE
start = (/1,1,1/)
ENDIF
status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,itab3d,start=start)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
DEALLOCATE(itab3d)
WAUTELET Philippe
committed
#endif
WAUTELET Philippe
committed
CASE (TYPELOG)
IF (infiles%files(1)%format == LFI_FORMAT) THEN
IF (.NOT.tpreclist(ji)%calc) THEN
CALL LFINFO(iresp,ilu,trim(tpreclist(ji)%name)//trim(suffix),ileng,ipos)
CALL LFILEC(iresp,ilu,trim(tpreclist(ji)%name)//trim(suffix),iwork,ileng)
WAUTELET Philippe
committed
extent = ileng - 2 - iwork(2) !iwork(2) = comment length
! Determine TDIMS
WAUTELET Philippe
committed
CALL IO_GUESS_DIMIDS_NC4(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,extent,tpreclist(ji)%TDIMS,IRESP2)
IF (IRESP2/=0) THEN
CALL PRINT_MSG(NVERB_WARNING,'IO','fill_ncdf','can not guess dimensions for '//tpreclist(ji)%TFIELD%CMNHNAME// &
' => ignored')
CYCLE
END IF
WAUTELET Philippe
committed
itab(1:extent) = iwork(3+iwork(2):3+iwork(2)+extent-1)
ELSE
src=tpreclist(ji)%src(1)
CALL LFINFO(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),ileng,ipos)
CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),iwork,ileng)
WAUTELET Philippe
committed
extent = ileng - 2 - iwork(2) !iwork(2) = comment length
! Determine TDIMS
CALL IO_GUESS_DIMIDS_NC4(outfiles%tfiles(idx)%TFILE,tpreclist(src)%TFIELD,extent,tpreclist(src)%TDIMS,IRESP2)
IF (IRESP2/=0) THEN
CALL PRINT_MSG(NVERB_WARNING,'IO','fill_ncdf','can not guess dimensions for '//tpreclist(src)%TFIELD%CMNHNAME// &
' => ignored')
CALL PRINT_MSG(NVERB_WARNING,'IO','fill_ncdf','can not guess dimensions for '//tpreclist(ji)%TFIELD%CMNHNAME// &
' => ignored')
CYCLE
ELSE
tpreclist(ji)%TDIMS = tpreclist(src)%TDIMS
END IF
WAUTELET Philippe
committed
itab(1:extent) = iwork(3+iwork(2):3+iwork(2)+extent-1)
jj = 2
DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
src=tpreclist(ji)%src(jj)
CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),iwork,ileng)
!PW: TODO: check same dimensions
WAUTELET Philippe
committed
itab(1:extent) = itab(1:extent) + iwork(3+iwork(2):3+iwork(2)+extent-1)
jj=jj+1
END DO
ENDIF
DO JJ=1,EXTENT
IF (ITAB(JJ)==0) THEN
GTAB(JJ) = .FALSE.
ELSE
GTAB(JJ) = .TRUE.
END IF
END DO
WAUTELET Philippe
committed
SELECT CASE(ndims)
CASE (0)
WAUTELET Philippe
committed
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,gtab(1))
WAUTELET Philippe
committed
CASE (1)
status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,itab(1:extent),count=(/extent/))
CASE DEFAULT
WAUTELET Philippe
committed
print *,'Error: arrays with ',ndims,' dimensions are not supported'
WAUTELET Philippe
committed
END SELECT
ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
WAUTELET Philippe
committed
INCID = infiles%TFILES(1)%TFILE%NNCID
STATUS = NF90_INQ_VARID(INCID,tpreclist(ji)%TFIELD%CMNHNAME,IVARID)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
STATUS = NF90_INQUIRE_VARIABLE(INCID, IVARID, NDIMS=IDIMS, DIMIDS=IVDIMS)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
if (ndims/=idims) then
print *,'aieeeeeee'
stop
end if
DO JJ=1,IDIMS
STATUS = NF90_INQUIRE_DIMENSION(infiles%TFILES(1)%TFILE%NNCID, IVDIMS(JJ), LEN=IDIMLEN(JJ))
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
END DO
SELECT CASE(ndims)
CASE (0)
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE, tpreclist(ji)%TFIELD,gtab(1))
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,gtab(1))
CASE (1)
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE, tpreclist(ji)%TFIELD,gtab(1:IDIMLEN(1)))
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,gtab(1:IDIMLEN(1)))
CASE (2)
print *,'PW:TODO'
CASE (3)
print *,'PW:TODO'
CASE DEFAULT
WAUTELET Philippe
committed
print *,'Error: arrays with ',ndims,' dimensions are not supported'
WAUTELET Philippe
committed
END SELECT
#if 0
WAUTELET Philippe
committed
ALLOCATE( itab3d(idims(1),idims(2),idims(3)) )
IF (.NOT.tpreclist(ji)%calc) THEN
status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(ji)%id_in,itab3d)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
ELSE
ALLOCATE( itab3d2(idims(1),idims(2),idims(3)) )
src=tpreclist(ji)%src(1)
status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(src)%id_in,itab3d)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
jj = 2
DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
src=tpreclist(ji)%src(jj)
status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(src)%id_in,itab3d2)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
itab3d(:,:,:) = itab3d(:,:,:) + itab3d2(:,:,:)
jj=jj+1
END DO
DEALLOCATE(itab3d2)
END IF
start = (/1,1,1/)
status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,itab3d,start=start)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
DEALLOCATE(itab3d)
WAUTELET Philippe
committed
#endif
WAUTELET Philippe
committed
END IF
CASE (TYPEREAL)
IF (infiles%files(1)%format == LFI_FORMAT) THEN
WAUTELET Philippe
committed
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
IF (.NOT.tpreclist(ji)%LSPLIT) THEN
CALL LFINFO(iresp,ilu,trim(tpreclist(ji)%name)//trim(suffix),ileng,ipos)
CALL LFILEC(iresp,ilu,trim(tpreclist(ji)%name)//trim(suffix),iwork,ileng)
extent = ileng - 2 - iwork(2) !iwork(2) = comment length
! Determine TDIMS
CALL IO_GUESS_DIMIDS_NC4(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,extent,tpreclist(ji)%TDIMS,IRESP2)
IF (IRESP2/=0) THEN
CALL PRINT_MSG(NVERB_WARNING,'IO','fill_ncdf','can not guess dimensions for '//tpreclist(ji)%TFIELD%CMNHNAME// &
' => ignored')
CYCLE
END IF
xtab(1:extent) = TRANSFER(iwork(3+iwork(2):),(/ 0.0_8 /))
ELSE
!We assume that splitted variables are always of size(IDIMX,IDMIY,IDIMZ)
ALLOCATE(xtab3d(IDIMX,IDIMY,IDIMZ))
CALL IO_READ_FIELD(infiles%tfiles(1)%TFILE,tpreclist(ji)%TFIELD,XTAB3D)
extent = IDIMX*IDIMY*IDIMZ
! Determine TDIMS
CALL IO_GUESS_DIMIDS_NC4(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,extent,tpreclist(ji)%TDIMS,IRESP2)
IF (IRESP2/=0) THEN
CALL PRINT_MSG(NVERB_WARNING,'IO','fill_ncdf','can not guess dimensions for '//tpreclist(ji)%TFIELD%CMNHNAME// &
' => ignored')
CYCLE
END IF
xtab(1:extent) = RESHAPE( xtab3d, (/extent/) )
DEALLOCATE(xtab3d)
WAUTELET Philippe
committed
END IF
WAUTELET Philippe
committed
IF (.NOT.tpreclist(ji)%LSPLIT) THEN
CALL LFINFO(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),ileng,ipos)
CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),iwork,ileng)
WAUTELET Philippe
committed
extent = ileng - 2 - iwork(2) !iwork(2) = comment length
! Determine TDIMS
CALL IO_GUESS_DIMIDS_NC4(outfiles%tfiles(idx)%TFILE,tpreclist(src)%TFIELD,extent,tpreclist(src)%TDIMS,IRESP2)
IF (IRESP2/=0) THEN
CALL PRINT_MSG(NVERB_WARNING,'IO','fill_ncdf','can not guess dimensions for '//tpreclist(src)%TFIELD%CMNHNAME// &
' => ignored')
CALL PRINT_MSG(NVERB_WARNING,'IO','fill_ncdf','can not guess dimensions for '//tpreclist(ji)%TFIELD%CMNHNAME// &
' => ignored')
CYCLE
ELSE
tpreclist(ji)%TDIMS = tpreclist(src)%TDIMS
END IF
xtab(1:extent) = TRANSFER(iwork(3+iwork(2):),(/ 0.0_8 /))
jj = 2
DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
src=tpreclist(ji)%src(jj)
CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),iwork,ileng)
!PW: TODO: check same dimensions
WAUTELET Philippe
committed
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
xtab(1:extent) = xtab(1:extent) + TRANSFER(iwork(3+iwork(2):),(/ 0.0_8 /))
jj=jj+1
END DO
ELSE !Split variable
!We assume that splitted variables are always of size(IDIMX,IDMIY,IDIMZ)
ALLOCATE(xtab3d(IDIMX,IDIMY,IDIMZ))
ALLOCATE(xtab3d2(IDIMX,IDIMY,IDIMZ))
CALL IO_READ_FIELD(infiles%tfiles(1)%TFILE,tpreclist(tpreclist(ji)%src(1))%TFIELD,XTAB3D)
extent = IDIMX*IDIMY*IDIMZ
! Determine TDIMS
CALL IO_GUESS_DIMIDS_NC4(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,extent,tpreclist(src)%TDIMS,IRESP2)
IF (IRESP2/=0) THEN
CALL PRINT_MSG(NVERB_WARNING,'IO','fill_ncdf','can not guess dimensions for '//tpreclist(src)%TFIELD%CMNHNAME// &
' => ignored')
CALL PRINT_MSG(NVERB_WARNING,'IO','fill_ncdf','can not guess dimensions for '//tpreclist(ji)%TFIELD%CMNHNAME// &
' => ignored')
CYCLE
ELSE
tpreclist(ji)%TDIMS = tpreclist(src)%TDIMS
END IF
jj = 2
DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
CALL IO_READ_FIELD(infiles%tfiles(1)%TFILE,tpreclist(tpreclist(ji)%src(jj))%TFIELD,XTAB3D2)
XTAB3D(:,:,:) = XTAB3D(:,:,:) + XTAB3D2(:,:,:)
jj=jj+1
END DO
xtab(1:extent) = RESHAPE( xtab3d, (/extent/) )
DEALLOCATE(xtab3d,xtab3d2)
END IF
!TODO: works in all cases??? (X, Y, Z dimensions assumed to be ptdimx,y or z)
SELECT CASE(ndims)
CASE (0)
WAUTELET Philippe
committed
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,xtab(1))
CASE (1)
WAUTELET Philippe
committed
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,xtab(1:extent))
CASE (2)
WAUTELET Philippe
committed
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,reshape(xtab,tpreclist(ji)%TDIMS(1:2)%LEN))
CASE (3)
WAUTELET Philippe
committed
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,reshape(xtab,tpreclist(ji)%TDIMS(1:3)%LEN))
CASE (4)
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,reshape(xtab,tpreclist(ji)%TDIMS(1:4)%LEN))
CASE DEFAULT
WAUTELET Philippe
committed
print *,'Error: arrays with ',ndims,' dimensions are not supported'
END SELECT
ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
WAUTELET Philippe
committed
IF (.NOT.tpreclist(ji)%LSPLIT) THEN
INCID = infiles%TFILES(1)%TFILE%NNCID
STATUS = NF90_INQ_VARID(INCID,tpreclist(ji)%TFIELD%CMNHNAME,IVARID)
WAUTELET Philippe
committed
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
WAUTELET Philippe
committed
STATUS = NF90_INQUIRE_VARIABLE(INCID, IVARID, NDIMS=IDIMS, DIMIDS=IVDIMS)
IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)