Newer
Older
WAUTELET Philippe
committed
USE MODD_IO_ll, ONLY: TFILE_ELT
USE MODD_NETCDF, ONLY: DIMCDF, IDCDF_KIND
USE MODD_PARAMETERS, ONLY: NLFIMAXCOMMENTLENGTH, NMNHNAMELGTMAX
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
WAUTELET Philippe
committed
USE mode_options
WAUTELET Philippe
committed
USE NETCDF
INTEGER,PARAMETER :: MAXRAW=10
WAUTELET Philippe
committed
INTEGER,PARAMETER :: MAXLEN=512
WAUTELET Philippe
committed
WAUTELET Philippe
committed
INTEGER,PARAMETER :: FM_FIELD_SIZE = 32
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
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
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
WAUTELET Philippe
committed
INTEGER :: NSIZE = 0 ! Size of the variable (in number of elements)
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
WAUTELET Philippe
committed
INTEGER, SAVE :: IDIMX = 0
INTEGER, SAVE :: IDIMY = 0
INTEGER, SAVE :: IDIMZ = 0
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, outfiles, nbvar_infile, nbvar_tbr, nbvar_calc, nbvar_tbw, tpreclist, kbuflen, options)
WAUTELET Philippe
committed
USE MODD_DIM_n, ONLY: NIMAX_ll, NJMAX_ll, NKMAX
USE MODD_PARAMETERS, ONLY: JPHEXT, JPVEXT
WAUTELET Philippe
committed
WAUTELET Philippe
committed
USE MODE_NETCDF, ONLY: IO_GUESS_DIMIDS_NC4
WAUTELET Philippe
committed
TYPE(filelist_struct), INTENT(IN) :: outfiles
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
WAUTELET Philippe
committed
INTEGER :: ji,jj, kcdf_id, kcdf_id2, itype
WAUTELET Philippe
committed
INTEGER :: ndb, nde, ndey, idx, idx_out, idx_var, maxvar
INTEGER :: idims, idimtmp, jdim, status
WAUTELET Philippe
committed
INTEGER :: ich, leng
INTEGER :: comment_size, fsize, sizemax
CHARACTER(LEN=FM_FIELD_SIZE) :: yrecfm, YDATENAME
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 (options(OPTSPLIT)%set) THEN
idx_out = 0
ELSE
idx_out = 1
END IF
WAUTELET Philippe
committed
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
WAUTELET Philippe
committed
PRINT *,'MESONH 3D, 2D articles DIMENSIONS used :'
PRINT *,'DIMX =',IDIMX
PRINT *,'DIMY =',IDIMY
PRINT *,'DIMZ =',IDIMZ ! IDIMZ may be equal to 0 (PGD files)
sizemax = 0
! 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),ileng,ipos)
IF (iresp2 == 0 .AND. ileng /= 0) THEN
tpreclist(ji)%found = .true.
tpreclist(ji)%NSIZE = ileng - 2 - NLFIMAXCOMMENTLENGTH
END IF
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
WAUTELET Philippe
committed
!In that case, the 1st part of the variable is in the 1st split file with a 0001 suffix
WAUTELET Philippe
committed
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
tpreclist(ji)%NSIZE = (ileng - 2 - NLFIMAXCOMMENTLENGTH) * IDIMZ
ileng = tpreclist(ji)%NSIZE + 2 + NLFIMAXCOMMENTLENGTH
WAUTELET Philippe
committed
END IF
leng = ileng
ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
WAUTELET Philippe
committed
status = NF90_INQ_VARID(kcdf_id,trim(yrecfm),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
WAUTELET Philippe
committed
!In that case, the 1st part of the variable is in the 1st split file with a 0001 suffix
WAUTELET Philippe
committed
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')
WAUTELET Philippe
committed
!Split variables are Z-split
WAUTELET Philippe
committed
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)
WAUTELET Philippe
committed
leng = leng + NLFIMAXCOMMENTLENGTH
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
WAUTELET Philippe
committed
tpreclist(ji)%name = trim(yrecfm)
WAUTELET Philippe
committed
tpreclist(ji)%NSIZE = ileng - 2 - NLFIMAXCOMMENTLENGTH
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
371
372
373
374
375
376
377
!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
WAUTELET Philippe
committed
tpreclist(ji)%NSIZE = leng
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)
WAUTELET Philippe
committed
sizemax = sizemax + NLFIMAXCOMMENTLENGTH
WAUTELET Philippe
committed
! Check if variable is in TFIELDLIST and populate corresponding metadata
DO ji=1,maxvar
IF (options(OPTSPLIT)%set .AND. tpreclist(ji)%tbw) idx_out = idx_out + 1
IF (.NOT.tpreclist(ji)%found .OR. tpreclist(ji)%calc ) CYCLE
WAUTELET Philippe
committed
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
442
!
!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))
WAUTELET Philippe
committed
! Determine TDIMS
CALL IO_GUESS_DIMIDS_NC4(outfiles%tfiles(idx_out)%TFILE,tpreclist(ji)%TFIELD,&
tpreclist(ji)%NSIZE,tpreclist(ji)%TDIMS,IRESP)
WAUTELET Philippe
committed
IF (IRESP/=0) THEN
CALL PRINT_MSG(NVERB_WARNING,'IO','parse_infiles','can not guess dimensions for '//tpreclist(ji)%TFIELD%CMNHNAME// &
' => ignored')
tpreclist(ji)%tbw = .FALSE.
tpreclist(ji)%tbr = .FALSE.
tpreclist(ji)%found = .FALSE.
CYCLE
END IF
WAUTELET Philippe
committed
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
IF (nbvar_calc>0) THEN
!Calculated variables
WAUTELET Philippe
committed
!Done after previous loop to reuse metadata from component variables
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
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
!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))
tpreclist(ji)%TDIMS = tpreclist(idx_var)%TDIMS
!
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
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)
USE MODD_TYPE_DATE
WAUTELET Philippe
committed
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(KIND=8),DIMENSION(:),ALLOCATABLE :: iwork
WAUTELET Philippe
committed
INTEGER :: idx, ji,jj
INTEGER :: kcdf_id
WAUTELET Philippe
committed
INTEGER :: ndims
WAUTELET Philippe
committed
INTEGER :: IID, IRESP2
INTEGER :: src
INTEGER :: level
INTEGER(KIND=LFI_INT) :: iresp,ilu,ileng,ipos
WAUTELET Philippe
committed
INTEGER,DIMENSION(3) :: start
WAUTELET Philippe
committed
INTEGER,DIMENSION(:),ALLOCATABLE :: itab
LOGICAL,DIMENSION(:),ALLOCATABLE :: gtab
WAUTELET Philippe
committed
REAL,DIMENSION(:),ALLOCATABLE :: xtab
REAL,DIMENSION(:), ALLOCATABLE :: XTAB1D, XTAB1D2
REAL,DIMENSION(:,:), ALLOCATABLE :: XTAB2D, XTAB2D2
REAL,DIMENSION(:,:,:), ALLOCATABLE :: XTAB3D, XTAB3D2
REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: XTAB4D, XTAB4D2
WAUTELET Philippe
committed
CHARACTER(LEN=:), ALLOCATABLE :: ytab
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
!
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
WAUTELET Philippe
committed
CALL LFINFO(iresp,ilu,trim(tpreclist(ji)%name),ileng,ipos)
CALL LFILEC(iresp,ilu,trim(tpreclist(ji)%name),iwork,ileng)
WAUTELET Philippe
committed
itab(1:tpreclist(ji)%NSIZE) = iwork(3+iwork(2):3+iwork(2)+tpreclist(ji)%NSIZE-1)
WAUTELET Philippe
committed
CALL LFINFO(iresp,ilu,trim(tpreclist(src)%name),ileng,ipos)
CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name),iwork,ileng)
WAUTELET Philippe
committed
itab(1:tpreclist(ji)%NSIZE) = iwork(3+iwork(2):3+iwork(2)+tpreclist(ji)%NSIZE-1)
tpreclist(ji)%TDIMS = tpreclist(src)%TDIMS !Dimensions of calculated variable are the same as its sources
DO jj=2,tpreclist(ji)%NSRC
WAUTELET Philippe
committed
CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name),iwork,ileng)
!PW: TODO: check same dimensions
WAUTELET Philippe
committed
itab(1:tpreclist(ji)%NSIZE) = itab(1:tpreclist(ji)%NSIZE) + iwork(3+iwork(2):3+iwork(2)+tpreclist(ji)%NSIZE-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:tpreclist(ji)%NSIZE))
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
WAUTELET Philippe
committed
CASE (TYPELOG)
IF (infiles%files(1)%format == LFI_FORMAT) THEN
IF (.NOT.tpreclist(ji)%calc) THEN
WAUTELET Philippe
committed
CALL LFINFO(iresp,ilu,trim(tpreclist(ji)%name),ileng,ipos)
CALL LFILEC(iresp,ilu,trim(tpreclist(ji)%name),iwork,ileng)
WAUTELET Philippe
committed
IF (iwork(2) /= NLFIMAXCOMMENTLENGTH) THEN
CALL PRINT_MSG(NVERB_ERROR,'IO','fill_ncdf','unexpected comment size for '//tpreclist(ji)%TFIELD%CMNHNAME// &
WAUTELET Philippe
committed
' => ignored')
CYCLE
END IF
WAUTELET Philippe
committed
itab(1:tpreclist(ji)%NSIZE) = iwork(3+iwork(2):3+iwork(2)+tpreclist(ji)%NSIZE-1)
WAUTELET Philippe
committed
ELSE
src=tpreclist(ji)%src(1)
WAUTELET Philippe
committed
CALL LFINFO(iresp,ilu,trim(tpreclist(src)%name),ileng,ipos)
CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name),iwork,ileng)
WAUTELET Philippe
committed
tpreclist(ji)%TDIMS = tpreclist(src)%TDIMS
itab(1:tpreclist(ji)%NSIZE) = iwork(3+iwork(2):3+iwork(2)+tpreclist(ji)%NSIZE-1)
WAUTELET Philippe
committed
jj = 2
DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
src=tpreclist(ji)%src(jj)
WAUTELET Philippe
committed
CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name),iwork,ileng)
!PW: TODO: check same dimensions
WAUTELET Philippe
committed
itab(1:tpreclist(ji)%NSIZE) = itab(1:tpreclist(ji)%NSIZE) + iwork(3+iwork(2):3+iwork(2)+tpreclist(ji)%NSIZE-1)
WAUTELET Philippe
committed
jj=jj+1
END DO
ENDIF
WAUTELET Philippe
committed
DO JJ=1,tpreclist(ji)%NSIZE
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)
WAUTELET Philippe
committed
status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,itab(1:tpreclist(ji)%NSIZE),count=(/tpreclist(ji)%NSIZE/))
WAUTELET Philippe
committed
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
WAUTELET Philippe
committed
END IF
CASE (TYPEREAL)
IDIMLEN(1:ndims) = tpreclist(ji)%TDIMS(1:ndims)%LEN
IF (.NOT.tpreclist(ji)%calc) THEN
ISRC = 1
src = ji
ELSE
ISRC = tpreclist(ji)%NSRC
src = tpreclist(ji)%src(1)
END IF
WAUTELET Philippe
committed
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
SELECT CASE(ndims)
CASE (0)
ALLOCATE(XTAB1D(1))
IF (tpreclist(ji)%calc) ALLOCATE(XTAB1D2(1))
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE,tpreclist(src)%TFIELD,XTAB1D(1))
CASE (1)
ALLOCATE(XTAB1D(IDIMLEN(1)))
IF (tpreclist(ji)%calc) ALLOCATE(XTAB1D2(IDIMLEN(1)))
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE,tpreclist(src)%TFIELD,XTAB1D)
CASE (2)
ALLOCATE(XTAB2D(IDIMLEN(1),IDIMLEN(2)))
IF (tpreclist(ji)%calc) ALLOCATE(XTAB2D2(IDIMLEN(1),IDIMLEN(2)))
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE,tpreclist(src)%TFIELD,XTAB2D)
CASE (3)
ALLOCATE(XTAB3D(IDIMLEN(1),IDIMLEN(2),IDIMLEN(3)))
IF (tpreclist(ji)%calc) ALLOCATE(XTAB3D2(IDIMLEN(1),IDIMLEN(2),IDIMLEN(3)))
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE,tpreclist(src)%TFIELD,XTAB3D)
CASE (4)
ALLOCATE(XTAB4D(IDIMLEN(1),IDIMLEN(2),IDIMLEN(3),IDIMLEN(4)))
IF (tpreclist(ji)%calc) ALLOCATE(XTAB4D2(IDIMLEN(1),IDIMLEN(2),IDIMLEN(3),IDIMLEN(4)))
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE,tpreclist(src)%TFIELD,XTAB4D)
CASE DEFAULT
CALL PRINT_MSG(NVERB_FATAL,'IO','fill_ncdf','number of dimensions not supported for '//TRIM(tpreclist(src)%name))
END SELECT
DO JJ=2,ISRC
src = tpreclist(ji)%src(jj)
SELECT CASE(ndims)
CASE (0)
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE,tpreclist(src)%TFIELD,XTAB1D2(1))
XTAB1D(1) = XTAB1D(1) + XTAB1D2(1)
CASE (1)
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE,tpreclist(src)%TFIELD,XTAB1D2)
XTAB1D(:) = XTAB1D(:) + XTAB1D2(:)
CASE (2)
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE,tpreclist(src)%TFIELD,XTAB2D2)
XTAB2D(:,:) = XTAB2D(:,:) + XTAB2D2(:,:)
CASE (3)
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE,tpreclist(src)%TFIELD,XTAB3D2)
XTAB3D(:,:,:) = XTAB3D(:,:,:) + XTAB3D2(:,:,:)
CASE (4)
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE,tpreclist(src)%TFIELD,XTAB4D2)
XTAB4D(:,:,:,:) = XTAB4D(:,:,:,:) + XTAB4D2(:,:,:,:)
END SELECT
END DO
SELECT CASE(ndims)
CASE (0)
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,XTAB1D(1))
DEALLOCATE(XTAB1D)
IF (tpreclist(ji)%calc) DEALLOCATE(XTAB1D2)
CASE (1)
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,XTAB1D)
DEALLOCATE(XTAB1D)
IF (tpreclist(ji)%calc) DEALLOCATE(XTAB1D2)
CASE (2)
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,XTAB2D)
DEALLOCATE(XTAB2D)
IF (tpreclist(ji)%calc) DEALLOCATE(XTAB2D2)
CASE (3)
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,XTAB3D)
DEALLOCATE(XTAB3D)
IF (tpreclist(ji)%calc) DEALLOCATE(XTAB3D2)
CASE (4)
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,XTAB4D)
DEALLOCATE(XTAB4D)
IF (tpreclist(ji)%calc) DEALLOCATE(XTAB4D2)
END SELECT
WAUTELET Philippe
committed
CASE (TYPECHAR)
WAUTELET Philippe
committed
IF (ndims/=0) CALL PRINT_MSG(NVERB_FATAL,'IO','fill_ncdf','only ndims=0 is supported for TYPECHAR')
IF (infiles%files(1)%format == LFI_FORMAT) THEN
WAUTELET Philippe
committed
CALL LFINFO(iresp,ilu,trim(tpreclist(ji)%name),ileng,ipos)
CALL LFILEC(iresp,ilu,trim(tpreclist(ji)%name),iwork,ileng)
WAUTELET Philippe
committed
! ALLOCATE(ytab(tpreclist(ji)%NSIZE))
allocate(character(len=tpreclist(ji)%NSIZE)::ytab)
DO jj=1,tpreclist(ji)%NSIZE
WAUTELET Philippe
committed
! ytab(jj) = CHAR(ich)
ytab(jj:jj) = CHAR(ich)
WAUTELET Philippe
committed
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,trim(ytab))
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
if (idims/=1) 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
allocate(character(len=IDIMLEN(1))::ytab)
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE, tpreclist(ji)%TFIELD,ytab)
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,ytab)
DEALLOCATE(ytab)
CASE (TYPEDATE)
IF (ndims/=0) CALL PRINT_MSG(NVERB_FATAL,'IO','fill_ncdf','only ndims=0 is supported for TYPEDATE')
!PW: TODO: tpreclist(ji)%TFIELD%CMNHNAME => tpreclist(ji)%TFIELD
CALL IO_READ_FIELD (infiles%tfiles(1)%TFILE, tpreclist(ji)%TFIELD%CMNHNAME,TZDATE)
CALL IO_WRITE_FIELD(outfiles%tfiles(idx)%TFILE,tpreclist(ji)%TFIELD,TZDATE)
CALL PRINT_MSG(NVERB_FATAL,'IO','fill_ncdf','invalid datatype')
WAUTELET Philippe
committed
if (options(OPTSPLIT)%set) idx = idx + 1
DEALLOCATE(iwork)
END SUBROUTINE fill_ncdf
WAUTELET Philippe
committed
SUBROUTINE build_lfi(infiles,outfiles,tpreclist,knaf,kbuflen)
TYPE(filelist_struct), INTENT(IN) :: infiles, outfiles
TYPE(workfield), DIMENSION(:), INTENT(IN) :: tpreclist
WAUTELET Philippe
committed
INTEGER, INTENT(IN) :: knaf
INTEGER :: kcdf_id, status
INTEGER :: ivar,ji,jj,ndims
WAUTELET Philippe
committed
INTEGER,DIMENSION(3) :: idims
INTEGER(KIND=8), DIMENSION(:), POINTER :: iwork
INTEGER(KIND=8), DIMENSION(:), POINTER :: idata
WAUTELET Philippe
committed
REAL(KIND=8), DIMENSION(:,:,:), ALLOCATABLE :: xtab3d
INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: itab3d
CHARACTER, DIMENSION(:), ALLOCATABLE :: ytab
CHARACTER(LEN=FM_FIELD_SIZE) :: yrecfm
INTEGER :: iartlen, idlen, icomlen
INTEGER(KIND=LFI_INT) :: iresp,ilu,iartlen8
ilu = outfiles%files(1)%lun_id
kcdf_id = infiles%files(1)%lun_id
! Un article LFI est compose de :
! - 1 entier identifiant le numero de grille
! - 1 entier contenant la taille du commentaire
! - le commentaire code en entier 64 bits
! - les donnees proprement dites
PRINT *,'Taille buffer = ',2+kbuflen
ALLOCATE(iwork(2+kbuflen))
WAUTELET Philippe
committed
DO ivar=1,knaf
IF (.NOT.tpreclist(ivar)%tbw) CYCLE
WAUTELET Philippe
committed
icomlen = LEN(tpreclist(ivar)%TFIELD%CCOMMENT)
WAUTELET Philippe
committed
IF (icomlen > NLFIMAXCOMMENTLENGTH) THEN
PRINT *,'ERROR: comment length is too big. Please increase NLFIMAXCOMMENTLENGTH'
WAUTELET Philippe
committed
STOP
END IF
! traitement Grille et Commentaire
WAUTELET Philippe
committed
iwork(1) = tpreclist(ivar)%TFIELD%NGRID
iwork(2) = icomlen
DO jj=1,iwork(2)
WAUTELET Philippe
committed
iwork(2+jj)=ICHAR(tpreclist(ivar)%TFIELD%CCOMMENT(jj:jj))
WAUTELET Philippe
committed
stop
WAUTELET Philippe
committed
! Attention restoration des '%' dans le nom des champs LFI
yrecfm = str_replace(tpreclist(ivar)%name,'__','%')
! et des '.'
yrecfm = str_replace(yrecfm,'--','.')