73 character (len=255),
parameter:: subcategory=
"volgrid6d_class" 77 type(griddim_def) :: griddim
78 TYPE(datetime),
pointer :: time(:)
79 TYPE(vol7d_timerange),
pointer :: timerange(:)
80 TYPE(vol7d_level),
pointer :: level(:)
81 TYPE(volgrid6d_var),
pointer :: var(:)
82 TYPE(grid_id),
POINTER :: gaid(:,:,:,:)
83 REAL,
POINTER :: voldati(:,:,:,:,:,:)
84 integer :: time_definition
85 integer :: category = 0
90 MODULE PROCEDURE volgrid6d_init
96 MODULE PROCEDURE volgrid6d_delete, volgrid6dv_delete
102 MODULE PROCEDURE volgrid6d_read_from_file
103 MODULE PROCEDURE import_from_gridinfo, import_from_gridinfovv, &
104 volgrid6d_import_from_file
110 MODULE PROCEDURE volgrid6d_write_on_file
111 MODULE PROCEDURE export_to_gridinfo, export_to_gridinfov, export_to_gridinfovv,&
112 volgrid6d_export_to_file
118 MODULE PROCEDURE volgrid6d_transform_compute, volgrid6d_v7d_transform_compute,&
119 v7d_volgrid6d_transform_compute, v7d_v7d_transform_compute
125 MODULE PROCEDURE volgrid6d_transform, volgrid6dv_transform,&
126 volgrid6d_v7d_transform, volgrid6dv_v7d_transform, v7d_volgrid6d_transform, &
131 MODULE PROCEDURE vg6d_wind_rot
135 MODULE PROCEDURE vg6d_wind_unrot
141 MODULE PROCEDURE display_volgrid6d,display_volgrid6dv
156 MODULE PROCEDURE vg6d_rounding, vg6dv_rounding
162 wind_rot,wind_unrot,vg6d_c2a,
display,volgrid6d_alloc,volgrid6d_alloc_vol, &
163 volgrid_get_vol_2d, volgrid_set_vol_2d, volgrid_get_vol_3d, volgrid_set_vol_3d
173 SUBROUTINE volgrid6d_init(this, griddim, time_definition, categoryappend)
174 TYPE(volgrid6d) :: this
175 TYPE(griddim_def),
OPTIONAL :: griddim
176 INTEGER,
INTENT(IN),
OPTIONAL :: time_definition
177 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
179 character(len=512) :: a_name
181 if (
present(categoryappend))
then 182 call l4f_launcher(a_name,a_name_append=trim(subcategory)//
"."//trim(categoryappend))
184 call l4f_launcher(a_name,a_name_append=trim(subcategory))
186 this%category=l4f_category_get(a_name)
192 call init(this%griddim)
194 if (
present(griddim))
then 195 call copy (griddim,this%griddim)
198 CALL vol7d_var_features_init()
200 if(
present(time_definition))
then 201 this%time_definition = time_definition
203 this%time_definition = 0
206 nullify (this%time,this%timerange,this%level,this%var)
207 nullify (this%gaid,this%voldati)
209 END SUBROUTINE volgrid6d_init
222 SUBROUTINE volgrid6d_alloc(this, dim, ntime, nlevel, ntimerange, nvar, ini)
223 TYPE(volgrid6d),
INTENT(inout) :: this
224 TYPE(grid_dim),
INTENT(in),
OPTIONAL :: dim
225 INTEGER,
INTENT(in),
OPTIONAL :: ntime
226 INTEGER,
INTENT(in),
OPTIONAL :: nlevel
227 INTEGER,
INTENT(in),
OPTIONAL :: ntimerange
228 INTEGER,
INTENT(in),
OPTIONAL :: nvar
229 LOGICAL,
INTENT(in),
OPTIONAL :: ini
238 IF (
PRESENT(ini))
THEN 245 if (
present(dim))
call copy (dim,this%griddim%dim)
248 IF (
PRESENT(ntime))
THEN 250 IF (
ASSOCIATED(this%time))
DEALLOCATE(this%time)
254 ALLOCATE(this%time(ntime),stat=stallo)
257 CALL raise_fatal_error()
261 this%time(i) = datetime_miss
268 IF (
PRESENT(nlevel))
THEN 269 IF (nlevel >= 0)
THEN 270 IF (
ASSOCIATED(this%level))
DEALLOCATE(this%level)
274 ALLOCATE(this%level(nlevel),stat=stallo)
277 CALL raise_fatal_error()
286 IF (
PRESENT(ntimerange))
THEN 287 IF (ntimerange >= 0)
THEN 288 IF (
ASSOCIATED(this%timerange))
DEALLOCATE(this%timerange)
292 ALLOCATE(this%timerange(ntimerange),stat=stallo)
295 CALL raise_fatal_error()
304 IF (
PRESENT(nvar))
THEN 306 IF (
ASSOCIATED(this%var))
DEALLOCATE(this%var)
310 ALLOCATE(this%var(nvar),stat=stallo)
313 CALL raise_fatal_error()
317 CALL init(this%var(i))
323 end SUBROUTINE volgrid6d_alloc
334 SUBROUTINE volgrid6d_alloc_vol(this, ini, inivol, decode)
335 TYPE(volgrid6d),
INTENT(inout) :: this
336 LOGICAL,
INTENT(in),
OPTIONAL :: ini
337 LOGICAL,
INTENT(in),
OPTIONAL :: inivol
338 LOGICAL,
INTENT(in),
OPTIONAL :: decode
347 IF (
PRESENT(inivol))
THEN 353 IF (this%griddim%dim%nx > 0 .AND. this%griddim%dim%ny > 0)
THEN 356 IF (.NOT.
ASSOCIATED(this%var))
CALL volgrid6d_alloc(this, nvar=1, ini=ini)
357 IF (.NOT.
ASSOCIATED(this%time))
CALL volgrid6d_alloc(this, ntime=1, ini=ini)
358 IF (.NOT.
ASSOCIATED(this%level))
CALL volgrid6d_alloc(this, nlevel=1, ini=ini)
359 IF (.NOT.
ASSOCIATED(this%timerange))
CALL volgrid6d_alloc(this, ntimerange=1, ini=ini)
361 IF (optio_log(decode))
THEN 362 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 367 ALLOCATE(this%voldati(this%griddim%dim%nx,this%griddim%dim%ny,&
368 SIZE(this%level),
SIZE(this%time), &
369 SIZE(this%timerange),
SIZE(this%var)),stat=stallo)
372 CALL raise_fatal_error()
377 IF (linivol) this%voldati = rmiss
382 IF (.NOT.
ASSOCIATED(this%gaid))
THEN 386 ALLOCATE(this%gaid(
SIZE(this%level),
SIZE(this%time), &
387 SIZE(this%timerange),
SIZE(this%var)),stat=stallo)
390 CALL raise_fatal_error()
404 this%gaid = grid_id_new()
410 &trying to allocate a volume with an invalid or unspecified horizontal grid')
411 CALL raise_fatal_error()
414 END SUBROUTINE volgrid6d_alloc_vol
430 SUBROUTINE volgrid_get_vol_2d(this, ilevel, itime, itimerange, ivar, voldati)
431 TYPE(volgrid6d),
INTENT(in) :: this
432 INTEGER,
INTENT(in) :: ilevel
433 INTEGER,
INTENT(in) :: itime
434 INTEGER,
INTENT(in) :: itimerange
435 INTEGER,
INTENT(in) :: ivar
436 REAL,
POINTER :: voldati(:,:)
438 IF (
ASSOCIATED(this%voldati))
THEN 439 voldati => this%voldati(:,:,ilevel,itime,itimerange,ivar)
442 IF (.NOT.
ASSOCIATED(voldati))
THEN 443 ALLOCATE(voldati(this%griddim%dim%nx,this%griddim%dim%ny))
445 CALL grid_id_decode_data(this%gaid(ilevel,itime,itimerange,ivar), voldati)
448 END SUBROUTINE volgrid_get_vol_2d
464 SUBROUTINE volgrid_get_vol_3d(this, itime, itimerange, ivar, voldati)
465 TYPE(volgrid6d),
INTENT(in) :: this
466 INTEGER,
INTENT(in) :: itime
467 INTEGER,
INTENT(in) :: itimerange
468 INTEGER,
INTENT(in) :: ivar
469 REAL,
POINTER :: voldati(:,:,:)
473 IF (
ASSOCIATED(this%voldati))
THEN 474 voldati => this%voldati(:,:,:,itime,itimerange,ivar)
477 IF (.NOT.
ASSOCIATED(voldati))
THEN 478 ALLOCATE(voldati(this%griddim%dim%nx,this%griddim%dim%ny,
SIZE(this%level)))
480 DO ilevel = 1,
SIZE(this%level)
481 CALL grid_id_decode_data(this%gaid(ilevel,itime,itimerange,ivar), &
486 END SUBROUTINE volgrid_get_vol_3d
500 SUBROUTINE volgrid_set_vol_2d(this, ilevel, itime, itimerange, ivar, voldati)
501 TYPE(volgrid6d),
INTENT(inout) :: this
502 INTEGER,
INTENT(in) :: ilevel
503 INTEGER,
INTENT(in) :: itime
504 INTEGER,
INTENT(in) :: itimerange
505 INTEGER,
INTENT(in) :: ivar
506 REAL,
INTENT(in) :: voldati(:,:)
508 IF (
ASSOCIATED(this%voldati))
THEN 511 CALL grid_id_encode_data(this%gaid(ilevel,itime,itimerange,ivar), voldati)
514 END SUBROUTINE volgrid_set_vol_2d
528 SUBROUTINE volgrid_set_vol_3d(this, itime, itimerange, ivar, voldati)
529 TYPE(volgrid6d),
INTENT(inout) :: this
530 INTEGER,
INTENT(in) :: itime
531 INTEGER,
INTENT(in) :: itimerange
532 INTEGER,
INTENT(in) :: ivar
533 REAL,
INTENT(in) :: voldati(:,:,:)
537 IF (
ASSOCIATED(this%voldati))
THEN 540 DO ilevel = 1,
SIZE(this%level)
541 CALL grid_id_encode_data(this%gaid(ilevel,itime,itimerange,ivar), &
546 END SUBROUTINE volgrid_set_vol_3d
552 SUBROUTINE volgrid6d_delete(this)
555 INTEGER :: i, ii, iii, iiii
561 if (
associated(this%gaid))
then 563 DO i=1 ,
SIZE(this%gaid,1)
564 DO ii=1 ,
SIZE(this%gaid,2)
565 DO iii=1 ,
SIZE(this%gaid,3)
566 DO iiii=1 ,
SIZE(this%gaid,4)
567 CALL delete(this%gaid(i,ii,iii,iiii))
572 DEALLOCATE(this%gaid)
583 if (
associated( this%time ))
deallocate(this%time)
584 if (
associated( this%timerange ))
deallocate(this%timerange)
585 if (
associated( this%level ))
deallocate(this%level)
586 if (
associated( this%var ))
deallocate(this%var)
588 if (
associated(this%voldati))
deallocate(this%voldati)
592 call l4f_category_delete(this%category)
594 END SUBROUTINE volgrid6d_delete
606 subroutine volgrid6d_write_on_file (this,unit,description,filename,filename_auto)
609 integer,
optional,
intent(inout) :: unit
610 character(len=*),
intent(in),
optional :: filename
611 character(len=*),
intent(out),
optional :: filename_auto
612 character(len=*),
INTENT(IN),
optional :: description
615 character(len=254) :: ldescription,arg,lfilename
616 integer :: ntime, ntimerange, nlevel, nvar
618 logical :: opened,exist
630 call date_and_time(values=tarray)
633 if (
present(description))
then 634 ldescription=description
636 ldescription=
"Volgrid6d generated by: "//trim(arg)
639 if (.not.
present(unit))
then 650 lfilename=trim(arg)//
".vg6d" 651 if (
index(arg,
'/',back=.true.) > 0) lfilename=lfilename(
index(arg,
'/',back=.true.)+1 : )
653 if (
present(filename))
then 654 if (filename /=
"")
then 659 if (
present(filename_auto))filename_auto=lfilename
662 inquire(unit=lunit,opened=opened)
663 if (.not. opened)
then 664 inquire(file=lfilename,exist=exist)
665 if (exist)
CALL raise_error(
'file exist; cannot open new file')
666 if (.not.exist)
open (unit=lunit,file=lfilename,form=
"UNFORMATTED")
670 if (
associated(this%time)) ntime=
size(this%time)
671 if (
associated(this%timerange)) ntimerange=
size(this%timerange)
672 if (
associated(this%level)) nlevel=
size(this%level)
673 if (
associated(this%var)) nvar=
size(this%var)
676 write(unit=lunit)ldescription
677 write(unit=lunit)tarray
680 write(unit=lunit) ntime, ntimerange, nlevel, nvar
683 if (
associated(this%time))
call write_unit(this%time, lunit)
684 if (
associated(this%level))
write(unit=lunit)this%level
685 if (
associated(this%timerange))
write(unit=lunit)this%timerange
686 if (
associated(this%var))
write(unit=lunit)this%var
691 if (
associated(this%voldati))
write(unit=lunit)this%voldati
693 if (.not.
present(unit))
close(unit=lunit)
695 end subroutine volgrid6d_write_on_file
704 subroutine volgrid6d_read_from_file (this,unit,filename,description,tarray,filename_auto)
707 integer,
intent(inout),
optional :: unit
708 character(len=*),
INTENT(in),
optional :: filename
709 character(len=*),
intent(out),
optional :: filename_auto
710 character(len=*),
INTENT(out),
optional :: description
711 integer,
intent(out),
optional :: tarray(8)
713 integer :: ntime, ntimerange, nlevel, nvar
715 character(len=254) :: ldescription,lfilename,arg
716 integer :: ltarray(8),lunit
717 logical :: opened,exist
725 if (.not.
present(unit))
then 736 lfilename=trim(arg)//
".vg6d" 737 if (
index(arg,
'/',back=.true.) > 0) lfilename=lfilename(
index(arg,
'/',back=.true.)+1 : )
739 if (
present(filename))
then 740 if (filename /=
"")
then 745 if (
present(filename_auto))filename_auto=lfilename
748 inquire(unit=lunit,opened=opened)
749 if (.not. opened)
then 750 inquire(file=lfilename,exist=exist)
751 IF (.NOT. exist)
CALL raise_fatal_error(
'file '//trim(lfilename)//
' does not exist, cannot open')
752 open (unit=lunit,file=lfilename,form=
"UNFORMATTED")
755 read(unit=lunit)ldescription
756 read(unit=lunit)ltarray
758 call l4f_log(l4f_info,
"Info: reading volgrid6d from file: "//trim(lfilename))
759 call l4f_log(l4f_info,
"Info: description: "//trim(ldescription))
762 if (
present(description))description=ldescription
763 if (
present(tarray))tarray=ltarray
767 read(unit=lunit) ntime, ntimerange, nlevel, nvar
770 call volgrid6d_alloc (this, &
771 ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nvar=nvar)
773 call volgrid6d_alloc_vol (this)
775 if (
associated(this%time))
call read_unit(this%time, lunit)
776 if (
associated(this%level))
read(unit=lunit)this%level
777 if (
associated(this%timerange))
read(unit=lunit)this%timerange
778 if (
associated(this%var))
read(unit=lunit)this%var
783 if (
associated(this%voldati))
read(unit=lunit)this%voldati
785 if (.not.
present(unit))
close(unit=lunit)
787 end subroutine volgrid6d_read_from_file
809 SUBROUTINE import_from_gridinfo(this, gridinfo, force, dup_mode, clone, &
811 TYPE(volgrid6d),
INTENT(inout) :: this
812 TYPE(gridinfo_def),
INTENT(in) :: gridinfo
813 LOGICAL,
INTENT(in),
OPTIONAL :: force
814 INTEGER,
INTENT(in),
OPTIONAL :: dup_mode
815 LOGICAL ,
INTENT(in),
OPTIONAL :: clone
816 LOGICAL,
INTENT(IN),
OPTIONAL :: isanavar
818 CHARACTER(len=255) :: type
819 INTEGER :: itime0, itimerange0, itime1, itimerange1, itime, itimerange, &
820 ilevel, ivar, ldup_mode
822 TYPE(datetime) :: correctedtime
823 REAL,
ALLOCATABLE :: tmpgrid(:,:)
825 IF (
PRESENT(dup_mode))
THEN 831 call get_val(this%griddim,proj_type=type)
834 call l4f_category_log(this%category,l4f_debug,
"import_from_gridinfo: "//trim(type))
837 if (.not.
c_e(type))
then 838 call copy(gridinfo%griddim, this%griddim)
842 CALL volgrid6d_alloc_vol(this, ini=.true.)
844 else if (.not. (this%griddim == gridinfo%griddim ))
then 847 "volgrid and gridinfo grid type or size are different, gridinfo rejected")
854 ilevel =
index(this%level, gridinfo%level)
855 IF (ilevel == 0 .AND. optio_log(force))
THEN 856 ilevel =
index(this%level, vol7d_level_miss)
857 IF (ilevel /= 0) this%level(ilevel) = gridinfo%level
860 IF (ilevel == 0)
THEN 862 "volgrid6d: level not valid for volume, gridinfo rejected")
867 IF (optio_log(isanavar))
THEN 869 itime1 =
SIZE(this%time)
871 itimerange1 =
SIZE(this%timerange)
873 correctedtime = gridinfo%time
874 IF (this%time_definition == 1) correctedtime = correctedtime + &
875 timedelta_new(sec=gridinfo%timerange%p1)
876 itime0 =
index(this%time, correctedtime)
877 IF (itime0 == 0 .AND. optio_log(force))
THEN 878 itime0 =
index(this%time, datetime_miss)
879 IF (itime0 /= 0) this%time(itime0) = correctedtime
881 IF (itime0 == 0)
THEN 883 "volgrid6d: time not valid for volume, gridinfo rejected")
889 itimerange0 =
index(this%timerange,gridinfo%timerange)
890 IF (itimerange0 == 0 .AND. optio_log(force))
THEN 891 itimerange0 =
index(this%timerange, vol7d_timerange_miss)
892 IF (itimerange0 /= 0) this%timerange(itimerange0) = gridinfo%timerange
894 IF (itimerange0 == 0)
THEN 896 "volgrid6d: timerange not valid for volume, gridinfo rejected")
900 itimerange1 = itimerange0
903 ivar =
index(this%var, gridinfo%var)
904 IF (ivar == 0 .AND. optio_log(force))
THEN 905 ivar =
index(this%var, volgrid6d_var_miss)
906 IF (ivar /= 0) this%var(ivar) = gridinfo%var
910 "volgrid6d: var not valid for volume, gridinfo rejected")
915 DO itimerange = itimerange0, itimerange1
916 DO itime = itime0, itime1
917 IF (
ASSOCIATED(this%gaid))
THEN 919 IF (
c_e(this%gaid(ilevel,itime,itimerange,ivar)))
THEN 923 IF (optio_log(
clone))
CALL delete(this%gaid(ilevel,itime,itimerange,ivar))
926 IF (optio_log(
clone))
THEN 927 CALL copy(gridinfo%gaid, this%gaid(ilevel,itime,itimerange,ivar))
932 this%gaid(ilevel,itime,itimerange,ivar) = gridinfo%gaid
935 IF (
ASSOCIATED(this%voldati))
THEN 936 IF (.NOT.dup .OR. ldup_mode == 0)
THEN 937 this%voldati(:,:,ilevel,itime,itimerange,ivar) =
decode_gridinfo(gridinfo)
938 ELSE IF (ldup_mode == 1)
THEN 941 this%voldati(:,:,ilevel,itime,itimerange,ivar) = tmpgrid(:,:)
943 ELSE IF (ldup_mode == 2)
THEN 944 WHERE(.NOT.
c_e(this%voldati(:,:,ilevel,itime,itimerange,ivar)))
945 this%voldati(:,:,ilevel,itime,itimerange,ivar) =
decode_gridinfo(gridinfo)
952 "gaid not allocated, you probably need to call volgrid6d_alloc_vol first")
960 END SUBROUTINE import_from_gridinfo
967 SUBROUTINE export_to_gridinfo(this, gridinfo, itime, itimerange, ilevel, ivar, &
968 gaid_template, clone)
969 TYPE(volgrid6d),
INTENT(in) :: this
970 TYPE(gridinfo_def),
INTENT(inout) :: gridinfo
972 INTEGER :: itimerange
975 TYPE(grid_id),
INTENT(in),
OPTIONAL :: gaid_template
976 LOGICAL,
INTENT(in),
OPTIONAL :: clone
978 TYPE(grid_id) :: gaid
979 LOGICAL :: usetemplate
980 REAL,
POINTER :: voldati(:,:)
981 TYPE(datetime) :: correctedtime
987 IF (.NOT.
c_e(this%gaid(ilevel,itime,itimerange,ivar)))
THEN 989 CALL l4f_category_log(this%category,l4f_debug,
"empty gaid found, skipping export")
994 usetemplate = .false.
995 IF (
PRESENT(gaid_template))
THEN 996 CALL copy(gaid_template, gaid)
998 CALL l4f_category_log(this%category,l4f_debug,
"template cloned to a new gaid")
1000 usetemplate =
c_e(gaid)
1003 IF (.NOT.usetemplate)
THEN 1004 IF (optio_log(
clone))
THEN 1005 CALL copy(this%gaid(ilevel,itime,itimerange,ivar), gaid)
1007 CALL l4f_category_log(this%category,l4f_debug,
"original gaid cloned to a new one")
1010 gaid = this%gaid(ilevel,itime,itimerange,ivar)
1014 IF (this%time_definition == 1)
THEN 1015 correctedtime = this%time(itime) - &
1016 timedelta_new(sec=this%timerange(itimerange)%p1)
1018 correctedtime = this%time(itime)
1021 CALL init(gridinfo,gaid, this%griddim, correctedtime, this%timerange(itimerange), &
1022 this%level(ilevel), this%var(ivar))
1025 CALL export(gridinfo%griddim, gridinfo%gaid)
1027 IF (
ASSOCIATED(this%voldati))
THEN 1028 CALL encode_gridinfo(gridinfo, this%voldati(:,:,ilevel,itime,itimerange,ivar))
1029 ELSE IF (usetemplate)
THEN 1031 CALL volgrid_get_vol_2d(this, ilevel, itime, itimerange, ivar, voldati)
1036 END SUBROUTINE export_to_gridinfo
1056 SUBROUTINE import_from_gridinfovv(this, gridinfov, dup_mode, clone, decode, &
1057 time_definition, anavar, categoryappend)
1058 TYPE(volgrid6d),
POINTER :: this(:)
1059 TYPE(arrayof_gridinfo),
INTENT(in) :: gridinfov
1060 INTEGER,
INTENT(in),
OPTIONAL :: dup_mode
1061 LOGICAL ,
INTENT(in),
OPTIONAL :: clone
1062 LOGICAL,
INTENT(in),
OPTIONAL :: decode
1063 INTEGER,
INTENT(IN),
OPTIONAL :: time_definition
1064 CHARACTER(len=*),
INTENT(IN),
OPTIONAL :: anavar(:)
1065 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1067 INTEGER :: i, j, stallo
1068 INTEGER :: ngrid, ntime, ntimerange, nlevel, nvar
1070 CHARACTER(len=512) :: a_name
1071 TYPE(datetime),
ALLOCATABLE :: correctedtime(:)
1072 LOGICAL,
ALLOCATABLE :: isanavar(:)
1073 TYPE(vol7d_var) :: lvar
1076 if (
present(categoryappend))
then 1077 call l4f_launcher(a_name,a_name_append=trim(subcategory)//
"."//trim(categoryappend))
1079 call l4f_launcher(a_name,a_name_append=trim(subcategory))
1081 category=l4f_category_get(a_name)
1087 ngrid=count_distinct(gridinfov%array(1:gridinfov%arraysize)%griddim,back=.true.)
1089 ' different grid definition(s) found in input data')
1091 ALLOCATE(this(ngrid),stat=stallo)
1092 IF (stallo /= 0)
THEN 1094 CALL raise_fatal_error()
1097 IF (
PRESENT(categoryappend))
THEN 1098 CALL init(this(i), time_definition=time_definition, categoryappend=trim(categoryappend)//
"-vol"//
t2c(i))
1100 CALL init(this(i), time_definition=time_definition, categoryappend=
"vol"//
t2c(i))
1104 this(:)%griddim=pack_distinct(gridinfov%array(1:gridinfov%arraysize)%griddim, &
1108 ALLOCATE(isanavar(gridinfov%arraysize))
1109 isanavar(:) = .false.
1110 IF (
PRESENT(anavar))
THEN 1111 DO i = 1, gridinfov%arraysize
1112 DO j = 1,
SIZE(anavar)
1113 lvar =
convert(gridinfov%array(i)%var)
1114 IF (lvar%btable == anavar(j))
THEN 1115 isanavar(i) = .true.
1121 t2c(gridinfov%arraysize)//
' constant-data messages found in input data')
1125 ALLOCATE(correctedtime(gridinfov%arraysize))
1126 correctedtime(:) = gridinfov%array(1:gridinfov%arraysize)%time
1127 IF (
PRESENT(time_definition))
THEN 1128 IF (time_definition == 1)
THEN 1129 DO i = 1, gridinfov%arraysize
1130 correctedtime(i) = correctedtime(i) + &
1131 timedelta_new(sec=gridinfov%array(i)%timerange%p1)
1137 IF (
PRESENT(anavar))
THEN 1138 j = count((this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1139 .AND. .NOT.isanavar(:))
1142 ' has only constant data, this is not allowed')
1144 CALL raise_fatal_error()
1147 ntime = count_distinct(correctedtime, &
1148 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1149 .AND. .NOT.isanavar(:), back=.true.)
1150 ntimerange = count_distinct(gridinfov%array(1:gridinfov%arraysize)%timerange, &
1151 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1152 .AND. .NOT.isanavar(:), back=.true.)
1153 nlevel = count_distinct(gridinfov%array(1:gridinfov%arraysize)%level, &
1154 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim), &
1156 nvar = count_distinct(gridinfov%array(1:gridinfov%arraysize)%var, &
1157 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim), &
1164 CALL volgrid6d_alloc(this(i),this(i)%griddim%dim,ntime=ntime, &
1165 ntimerange=ntimerange,nlevel=nlevel,nvar=nvar)
1167 this(i)%time = pack_distinct(correctedtime, ntime, &
1168 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1169 .AND. .NOT.isanavar(:), back=.true.)
1170 CALL sort(this(i)%time)
1172 this(i)%timerange = pack_distinct(gridinfov%array( &
1173 1:gridinfov%arraysize)%timerange, ntimerange, &
1174 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1175 .AND. .NOT.isanavar(:), back=.true.)
1176 CALL sort(this(i)%timerange)
1178 this(i)%level=pack_distinct(gridinfov%array(1:gridinfov%arraysize)%level, &
1179 nlevel,mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim), &
1181 CALL sort(this(i)%level)
1183 this(i)%var=pack_distinct(gridinfov%array(1:gridinfov%arraysize)%var, nvar, &
1184 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim), &
1190 CALL volgrid6d_alloc_vol(this(i), decode=decode)
1194 DEALLOCATE(correctedtime)
1196 DO i = 1, gridinfov%arraysize
1201 "to volgrid6d index: "//
t2c(
index(this%griddim, gridinfov%array(i)%griddim)))
1204 CALL import(this(
index(this%griddim, gridinfov%array(i)%griddim)), &
1205 gridinfov%array(i), dup_mode=dup_mode,
clone=
clone, isanavar=isanavar(i))
1210 CALL l4f_category_delete(category)
1212 END SUBROUTINE import_from_gridinfovv
1220 SUBROUTINE export_to_gridinfov(this, gridinfov, gaid_template, clone)
1221 TYPE(volgrid6d),
INTENT(inout) :: this
1222 TYPE(arrayof_gridinfo),
INTENT(inout) :: gridinfov
1223 TYPE(grid_id),
INTENT(in),
OPTIONAL :: gaid_template
1224 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1226 INTEGER :: i ,itime, itimerange, ilevel, ivar
1227 INTEGER :: ntime, ntimerange, nlevel, nvar
1228 TYPE(gridinfo_def) :: gridinfol
1237 CALL dealloc(this%griddim%dim)
1240 ntime=
size(this%time)
1241 ntimerange=
size(this%timerange)
1242 nlevel=
size(this%level)
1246 DO itimerange=1,ntimerange
1250 CALL init(gridinfol)
1251 CALL export(this, gridinfol, itime, itimerange, ilevel, ivar, &
1253 IF (
c_e(gridinfol%gaid))
THEN 1254 CALL insert(gridinfov, gridinfol)
1264 END SUBROUTINE export_to_gridinfov
1272 SUBROUTINE export_to_gridinfovv(this, gridinfov, gaid_template, clone)
1275 TYPE(volgrid6d),
INTENT(inout) :: this(:)
1276 TYPE(arrayof_gridinfo),
INTENT(inout) :: gridinfov
1277 TYPE(grid_id),
INTENT(in),
OPTIONAL :: gaid_template
1278 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1282 DO i = 1,
SIZE(this)
1285 "export_to_gridinfovv grid index: "//
t2c(i))
1290 END SUBROUTINE export_to_gridinfovv
1302 SUBROUTINE volgrid6d_import_from_file(this, filename, dup_mode, decode, &
1303 time_definition, anavar, categoryappend)
1304 TYPE(volgrid6d),
POINTER :: this(:)
1305 CHARACTER(len=*),
INTENT(in) :: filename
1306 INTEGER,
INTENT(in),
OPTIONAL :: dup_mode
1307 LOGICAL,
INTENT(in),
OPTIONAL :: decode
1308 INTEGER,
INTENT(IN),
OPTIONAL :: time_definition
1309 CHARACTER(len=*),
INTENT(IN),
OPTIONAL :: anavar(:)
1310 character(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1312 TYPE(arrayof_gridinfo) :: gridinfo
1314 CHARACTER(len=512) :: a_name
1318 IF (
PRESENT(categoryappend))
THEN 1319 CALL l4f_launcher(a_name,a_name_append= &
1320 trim(subcategory)//
"."//trim(categoryappend))
1322 CALL l4f_launcher(a_name,a_name_append=trim(subcategory))
1324 category=l4f_category_get(a_name)
1326 CALL import(gridinfo, filename=filename, categoryappend=categoryappend)
1328 IF (gridinfo%arraysize > 0)
THEN 1330 CALL import(this, gridinfo, dup_mode=dup_mode,
clone=.true., decode=decode, &
1331 time_definition=time_definition, anavar=anavar, &
1332 categoryappend=categoryappend)
1338 CALL l4f_category_log(category,l4f_info,
"file does not contain gridded data")
1342 CALL l4f_category_delete(category)
1344 END SUBROUTINE volgrid6d_import_from_file
1354 SUBROUTINE volgrid6d_export_to_file(this, filename, gaid_template, categoryappend)
1355 TYPE(volgrid6d) :: this(:)
1356 CHARACTER(len=*),
INTENT(in) :: filename
1357 TYPE(grid_id),
INTENT(in),
OPTIONAL :: gaid_template
1358 character(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1360 TYPE(arrayof_gridinfo) :: gridinfo
1362 CHARACTER(len=512) :: a_name
1364 IF (
PRESENT(categoryappend))
THEN 1365 CALL l4f_launcher(a_name,a_name_append=trim(subcategory)//
"."//trim(categoryappend))
1367 CALL l4f_launcher(a_name,a_name_append=trim(subcategory))
1369 category=l4f_category_get(a_name)
1375 CALL l4f_category_log(category,l4f_info,
"writing volgrid6d to grib file: "//trim(filename))
1378 CALL export(this, gridinfo, gaid_template=gaid_template,
clone=.true.)
1379 IF (gridinfo%arraysize > 0)
THEN 1380 CALL export(gridinfo, filename)
1388 CALL l4f_category_delete(category)
1390 END SUBROUTINE volgrid6d_export_to_file
1396 SUBROUTINE volgrid6dv_delete(this)
1397 TYPE(volgrid6d),
POINTER :: this(:)
1401 IF (
ASSOCIATED(this))
THEN 1402 DO i = 1,
SIZE(this)
1405 "delete volgrid6d vector index: "//trim(
to_char(i)))
1412 END SUBROUTINE volgrid6dv_delete
1416 SUBROUTINE volgrid6d_transform_compute(this, volgrid6d_in, volgrid6d_out, &
1417 lev_out, var_coord_vol, clone)
1418 TYPE(grid_transform),
INTENT(in) :: this
1419 type(volgrid6d),
INTENT(in) :: volgrid6d_in
1420 type(volgrid6d),
INTENT(inout) :: volgrid6d_out
1421 TYPE(vol7d_level),
INTENT(in),
OPTIONAL :: lev_out(:)
1422 INTEGER,
INTENT(in),
OPTIONAL :: var_coord_vol
1423 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1425 INTEGER :: ntime, ntimerange, inlevel, onlevel, nvar, &
1426 itime, itimerange, ilevel, ivar, levshift, levused, lvar_coord_vol, spos
1427 REAL,
POINTER :: voldatiin(:,:,:), voldatiout(:,:,:), coord_3d_in(:,:,:)
1428 TYPE(vol7d_level) :: output_levtype
1432 call l4f_category_log(volgrid6d_in%category,l4f_debug,
"start volgrid6d_transform_compute")
1440 lvar_coord_vol = optio_i(var_coord_vol)
1442 if (
associated(volgrid6d_in%time))
then 1443 ntime=
size(volgrid6d_in%time)
1444 volgrid6d_out%time=volgrid6d_in%time
1447 if (
associated(volgrid6d_in%timerange))
then 1448 ntimerange=
size(volgrid6d_in%timerange)
1449 volgrid6d_out%timerange=volgrid6d_in%timerange
1452 IF (
ASSOCIATED(volgrid6d_in%level))
THEN 1453 inlevel=
SIZE(volgrid6d_in%level)
1455 IF (
PRESENT(lev_out))
THEN 1456 onlevel=
SIZE(lev_out)
1457 volgrid6d_out%level=lev_out
1458 ELSE IF (
ASSOCIATED(volgrid6d_in%level))
THEN 1459 onlevel=
SIZE(volgrid6d_in%level)
1460 volgrid6d_out%level=volgrid6d_in%level
1463 if (
associated(volgrid6d_in%var))
then 1464 nvar=
size(volgrid6d_in%var)
1465 volgrid6d_out%var=volgrid6d_in%var
1468 IF (.NOT.
ASSOCIATED(volgrid6d_in%voldati))
THEN 1469 ALLOCATE(voldatiin(volgrid6d_in%griddim%dim%nx, volgrid6d_in%griddim%dim%ny, &
1472 IF (.NOT.
ASSOCIATED(volgrid6d_out%voldati))
THEN 1473 ALLOCATE(voldatiout(volgrid6d_out%griddim%dim%nx, volgrid6d_out%griddim%dim%ny, &
1477 CALL get_val(this, levshift=levshift, levused=levused)
1479 IF (
c_e(lvar_coord_vol))
THEN 1480 CALL get_val(this%trans, output_levtype=output_levtype)
1481 IF (output_levtype%level1 == 103 .OR. output_levtype%level1 == 108)
THEN 1482 spos = firsttrue(volgrid6d_in%level(:) == vol7d_level_new(1))
1485 'output level '//
t2c(output_levtype%level1)// &
1486 ' requested, but height/press of surface not provided in volume')
1488 IF (.NOT.
c_e(levshift) .AND. .NOT.
c_e(levused))
THEN 1490 'internal inconsistence, levshift and levused undefined when they should be')
1499 DO itimerange=1,ntimerange
1504 volgrid6d_in%gaid(levshift+1:levshift+levused,itime,itimerange,ivar) &
1507 DO ilevel = 1, min(inlevel,onlevel)
1509 IF (
c_e(volgrid6d_in%gaid(ilevel,itime,itimerange,ivar)) .AND. .NOT. &
1510 c_e(volgrid6d_out%gaid(ilevel,itime,itimerange,ivar)))
THEN 1512 IF (optio_log(
clone))
THEN 1513 CALL copy(volgrid6d_in%gaid(ilevel,itime,itimerange,ivar),&
1514 volgrid6d_out%gaid(ilevel,itime,itimerange,ivar))
1517 "cloning gaid, level "//
t2c(ilevel))
1520 volgrid6d_out%gaid(ilevel,itime,itimerange,ivar) = &
1521 volgrid6d_in%gaid(ilevel,itime,itimerange,ivar)
1526 DO ilevel = min(inlevel,onlevel) + 1, onlevel
1527 IF (
c_e(volgrid6d_in%gaid(inlevel,itime,itimerange,ivar)) .AND. .NOT. &
1528 c_e(volgrid6d_out%gaid(ilevel,itime,itimerange,ivar)))
then 1530 CALL copy(volgrid6d_in%gaid(inlevel,itime,itimerange,ivar),&
1531 volgrid6d_out%gaid(ilevel,itime,itimerange,ivar))
1534 "forced cloning gaid, level "//
t2c(inlevel)//
"->"//
t2c(ilevel))
1539 IF (
c_e(lvar_coord_vol))
THEN 1540 NULLIFY(coord_3d_in)
1541 CALL volgrid_get_vol_3d(volgrid6d_in, itime, itimerange, lvar_coord_vol, &
1545 coord_3d_in(:,:,levshift+1:levshift+levused) = rmiss
1547 DO ilevel = levshift+1, levshift+levused
1548 WHERE(
c_e(coord_3d_in(:,:,ilevel)) .AND.
c_e(coord_3d_in(:,:,spos)))
1549 coord_3d_in(:,:,ilevel) = coord_3d_in(:,:,ilevel) - &
1550 coord_3d_in(:,:,spos)
1552 coord_3d_in(:,:,ilevel) = rmiss
1558 CALL volgrid_get_vol_3d(volgrid6d_in, itime, itimerange, ivar, &
1560 IF (
ASSOCIATED(volgrid6d_out%voldati)) &
1561 CALL volgrid_get_vol_3d(volgrid6d_out, itime, itimerange, ivar, &
1563 IF (
c_e(lvar_coord_vol))
THEN 1564 CALL compute(this, voldatiin, voldatiout,
convert(volgrid6d_in%var(ivar)), &
1565 coord_3d_in(:,:,levshift+1:levshift+levused))
1567 CALL compute(this, voldatiin, voldatiout,
convert(volgrid6d_in%var(ivar)))
1569 CALL volgrid_set_vol_3d(volgrid6d_out, itime, itimerange, ivar, &
1575 IF (
c_e(lvar_coord_vol))
THEN 1576 DEALLOCATE(coord_3d_in)
1578 IF (.NOT.
ASSOCIATED(volgrid6d_in%voldati))
THEN 1579 DEALLOCATE(voldatiin)
1581 IF (.NOT.
ASSOCIATED(volgrid6d_out%voldati))
THEN 1582 DEALLOCATE(voldatiout)
1586 END SUBROUTINE volgrid6d_transform_compute
1595 SUBROUTINE volgrid6d_transform(this, griddim, volgrid6d_in, volgrid6d_out, &
1596 lev_out, volgrid6d_coord_in, maskgrid, maskbounds, clone, decode, categoryappend)
1597 TYPE(transform_def),
INTENT(in) :: this
1598 TYPE(griddim_def),
INTENT(in),
OPTIONAL :: griddim
1599 TYPE(volgrid6d),
INTENT(inout) :: volgrid6d_in
1600 TYPE(volgrid6d),
INTENT(out) :: volgrid6d_out
1601 TYPE(vol7d_level),
INTENT(in),
OPTIONAL,
TARGET :: lev_out(:)
1602 TYPE(volgrid6d),
INTENT(in),
OPTIONAL :: volgrid6d_coord_in
1603 REAL,
INTENT(in),
OPTIONAL :: maskgrid(:,:)
1604 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
1605 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1606 LOGICAL,
INTENT(in),
OPTIONAL :: decode
1607 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1609 TYPE(grid_transform) :: grid_trans
1610 TYPE(vol7d_level),
POINTER :: llev_out(:)
1611 TYPE(vol7d_level) :: input_levtype, output_levtype
1612 TYPE(vol7d_var) :: vcoord_var
1613 INTEGER :: i, k, ntime, ntimerange, nlevel, nvar, var_coord_in, var_coord_vol, &
1614 cf_out, nxc, nyc, nxi, nyi, i3, i4, i5, i6, &
1615 ulstart, ulend, spos
1616 REAL,
ALLOCATABLE :: coord_3d_in(:,:,:)
1617 TYPE(geo_proj) :: proj_in, proj_out
1618 CHARACTER(len=80) :: trans_type
1620 LOGICAL,
ALLOCATABLE :: mask_in(:)
1623 call l4f_category_log(volgrid6d_in%category, l4f_debug,
"start volgrid6d_transform")
1631 if (
associated(volgrid6d_in%time)) ntime=
size(volgrid6d_in%time)
1632 if (
associated(volgrid6d_in%timerange)) ntimerange=
size(volgrid6d_in%timerange)
1633 if (
associated(volgrid6d_in%level)) nlevel=
size(volgrid6d_in%level)
1634 if (
associated(volgrid6d_in%var)) nvar=
size(volgrid6d_in%var)
1636 IF (ntime == 0 .OR. ntimerange == 0 .OR. nlevel == 0 .OR. nvar == 0)
THEN 1638 "trying to transform an incomplete volgrid6d object, ntime="//
t2c(ntime)// &
1639 ' ntimerange='//
t2c(ntimerange)//
' nlevel='//
t2c(nlevel)//
' nvar='//
t2c(nvar))
1640 CALL init(volgrid6d_out)
1645 CALL get_val(this, trans_type=trans_type)
1649 IF (
PRESENT(griddim) .AND. (trans_type ==
'inter' .OR. trans_type ==
'boxinter' &
1650 .OR. trans_type ==
'stencilinter'))
THEN 1652 CALL get_val(griddim, component_flag=cf_out,
proj=proj_out)
1654 IF (proj_in /= proj_out)
CALL vg6d_wind_unrot(volgrid6d_in)
1655 ELSE IF (
PRESENT(griddim))
THEN 1656 CALL get_val(griddim, component_flag=cf_out)
1660 var_coord_in = imiss
1661 var_coord_vol = imiss
1662 IF (trans_type ==
'vertint')
THEN 1663 IF (
PRESENT(lev_out))
THEN 1666 IF (
PRESENT(volgrid6d_coord_in))
THEN 1667 IF (
ASSOCIATED(volgrid6d_coord_in%voldati))
THEN 1670 IF (
SIZE(volgrid6d_coord_in%voldati,4) /= 1 .OR. &
1671 SIZE(volgrid6d_coord_in%voldati,5) /= 1)
THEN 1673 'volume providing constant input vertical coordinate must have & 1674 &only 1 time and 1 timerange')
1675 CALL init(volgrid6d_out)
1681 CALL get_val(this, output_levtype=output_levtype)
1683 IF (.NOT.
c_e(vcoord_var))
THEN 1685 'requested output level type '//
t2c(output_levtype%level1)// &
1686 ' does not correspond to any known physical variable for & 1687 &providing vertical coordinate')
1688 CALL init(volgrid6d_out)
1693 DO i = 1,
SIZE(volgrid6d_coord_in%var)
1694 IF (
convert(volgrid6d_coord_in%var(i)) == vcoord_var)
THEN 1700 IF (.NOT.
c_e(var_coord_in))
THEN 1702 'volume providing constant input vertical coordinate contains no & 1703 &variables matching output level type '//
t2c(output_levtype%level1))
1704 CALL init(volgrid6d_out)
1709 'Coordinate for vertint found in coord volume at position '// &
1715 CALL get_val(volgrid6d_coord_in%griddim, nx=nxc, ny=nyc)
1716 CALL get_val(volgrid6d_in%griddim, nx=nxi, ny=nyi)
1717 IF (nxc /= nxi .OR. nyc /= nyi)
THEN 1719 'volume providing constant input vertical coordinate must have & 1720 &the same grid as the input')
1722 'vertical coordinate: '//
t2c(nxc)//
'x'//
t2c(nyc)// &
1723 ', input volume: '//
t2c(nxi)//
'x'//
t2c(nyi))
1724 CALL init(volgrid6d_out)
1730 CALL get_val(this, input_levtype=input_levtype)
1732 (volgrid6d_coord_in%level(:)%level1 == input_levtype%level1) .AND. &
1733 (volgrid6d_coord_in%level(:)%level2 == input_levtype%level2)
1734 ulstart = firsttrue(mask_in)
1735 ulend = lasttrue(mask_in)
1736 IF (ulstart == 0 .OR. ulend == 0)
THEN 1738 'coordinate file does not contain levels of type '// &
1739 t2c(input_levtype%level1)//
'/'//
t2c(input_levtype%level2)// &
1740 ' specified for input data')
1741 CALL init(volgrid6d_out)
1746 coord_3d_in = volgrid6d_coord_in%voldati(:,:,ulstart:ulend,1,1,var_coord_in)
1748 IF (output_levtype%level1 == 103 .OR. &
1749 output_levtype%level1 == 108)
THEN 1750 spos = firsttrue(volgrid6d_coord_in%level(:) == vol7d_level_new(1))
1753 'output level '//
t2c(output_levtype%level1)// &
1754 ' requested, but height/press of surface not provided in coordinate file')
1755 CALL init(volgrid6d_out)
1759 DO k = 1,
SIZE(coord_3d_in,3)
1760 WHERE(
c_e(coord_3d_in(:,:,k)) .AND. &
1761 c_e(volgrid6d_coord_in%voldati(:,:,spos,1,1,var_coord_in)))
1762 coord_3d_in(:,:,k) = coord_3d_in(:,:,k) - &
1763 volgrid6d_coord_in%voldati(:,:,spos,1,1,var_coord_in)
1765 coord_3d_in(:,:,k) = rmiss
1773 IF (.NOT.
c_e(var_coord_in))
THEN 1775 CALL get_val(this, output_levtype=output_levtype)
1777 IF (
c_e(vcoord_var))
THEN 1778 DO i = 1,
SIZE(volgrid6d_in%var)
1779 IF (
convert(volgrid6d_in%var(i)) == vcoord_var)
THEN 1785 IF (
c_e(var_coord_vol))
THEN 1787 'Coordinate for vertint found in input volume at position '// &
1794 CALL init(volgrid6d_out, griddim=volgrid6d_in%griddim, &
1795 time_definition=volgrid6d_in%time_definition, categoryappend=categoryappend)
1796 IF (
c_e(var_coord_in))
THEN 1797 CALL init(grid_trans, this, lev_in=volgrid6d_in%level, lev_out=lev_out, &
1798 coord_3d_in=coord_3d_in, categoryappend=categoryappend)
1800 CALL init(grid_trans, this, lev_in=volgrid6d_in%level, lev_out=lev_out, &
1801 categoryappend=categoryappend)
1804 CALL get_val(grid_trans, output_level_auto=llev_out)
1805 IF (.NOT.
ASSOCIATED(llev_out)) llev_out => lev_out
1806 nlevel =
SIZE(llev_out)
1809 'volgrid6d_transform: vertint requested but lev_out not provided')
1810 CALL init(volgrid6d_out)
1816 CALL init(volgrid6d_out, griddim=griddim, &
1817 time_definition=volgrid6d_in%time_definition, categoryappend=categoryappend)
1818 CALL init(grid_trans, this, in=volgrid6d_in%griddim, out=volgrid6d_out%griddim, &
1819 maskgrid=maskgrid, maskbounds=maskbounds, categoryappend=categoryappend)
1823 IF (
c_e(grid_trans))
THEN 1825 CALL volgrid6d_alloc(volgrid6d_out, ntime=ntime, nlevel=nlevel, &
1826 ntimerange=ntimerange, nvar=nvar)
1828 IF (
PRESENT(decode))
THEN 1831 ldecode =
ASSOCIATED(volgrid6d_in%voldati)
1834 decode_loop:
DO i6 = 1,nvar
1835 DO i5 = 1, ntimerange
1838 IF (
c_e(volgrid6d_in%gaid(i3,i4,i5,i6)))
THEN 1839 ldecode = ldecode .OR. grid_id_readonly(volgrid6d_in%gaid(i3,i4,i5,i6))
1847 IF (
PRESENT(decode))
THEN 1848 IF (ldecode.NEQV.decode)
THEN 1850 'volgrid6d_transform: decode status forced to .TRUE. because driver does not allow copy')
1854 CALL volgrid6d_alloc_vol(volgrid6d_out, decode=ldecode)
1859 IF (trans_type ==
'vertint')
THEN 1862 "volgrid6d_transform: vertint to "//
t2c(nlevel)//
" levels")
1864 CALL compute(grid_trans, volgrid6d_in, volgrid6d_out, lev_out=llev_out, &
1867 CALL compute(grid_trans, volgrid6d_in, volgrid6d_out,
clone=
clone)
1870 IF (cf_out == 0)
THEN 1871 CALL wind_unrot(volgrid6d_out)
1872 ELSE IF (cf_out == 1)
THEN 1873 CALL wind_rot(volgrid6d_out)
1879 'volgrid6d_transform: transformation not valid')
1885 END SUBROUTINE volgrid6d_transform
1896 SUBROUTINE volgrid6dv_transform(this, griddim, volgrid6d_in, volgrid6d_out, &
1897 lev_out, volgrid6d_coord_in, maskgrid, maskbounds, clone, decode, categoryappend)
1898 TYPE(transform_def),
INTENT(in) :: this
1899 TYPE(griddim_def),
INTENT(in),
OPTIONAL :: griddim
1900 TYPE(volgrid6d),
INTENT(inout) :: volgrid6d_in(:)
1901 TYPE(volgrid6d),
POINTER :: volgrid6d_out(:)
1902 TYPE(vol7d_level),
INTENT(in),
OPTIONAL :: lev_out(:)
1903 TYPE(volgrid6d),
INTENT(in),
OPTIONAL :: volgrid6d_coord_in
1904 REAL,
INTENT(in),
OPTIONAL :: maskgrid(:,:)
1905 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
1906 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1907 LOGICAL,
INTENT(in),
OPTIONAL :: decode
1908 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1910 INTEGER :: i, stallo
1913 allocate(volgrid6d_out(
size(volgrid6d_in)),stat=stallo)
1914 if (stallo /= 0)
then 1915 call l4f_log(l4f_fatal,
"allocating memory")
1916 call raise_fatal_error()
1919 do i=1,
size(volgrid6d_in)
1920 call transform(this, griddim, volgrid6d_in(i), volgrid6d_out(i), &
1921 lev_out=lev_out, volgrid6d_coord_in=volgrid6d_coord_in, &
1922 maskgrid=maskgrid, maskbounds=maskbounds, &
1923 clone=
clone, decode=decode, categoryappend=categoryappend)
1926 END SUBROUTINE volgrid6dv_transform
1930 SUBROUTINE volgrid6d_v7d_transform_compute(this, volgrid6d_in, vol7d_out, &
1931 networkname, noconvert)
1932 TYPE(grid_transform),
INTENT(in) :: this
1933 type(volgrid6d),
INTENT(in) :: volgrid6d_in
1934 type(vol7d),
INTENT(inout) :: vol7d_out
1935 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
1936 LOGICAL,
OPTIONAL,
INTENT(in) :: noconvert
1938 INTEGER :: nntime, nana, ntime, ntimerange, nlevel, nvar, stallo
1939 INTEGER :: itime, itimerange, ivar, inetwork
1940 REAL,
ALLOCATABLE :: voldatir_out(:,:,:)
1941 TYPE(conv_func),
POINTER :: c_func(:)
1942 TYPE(datetime),
ALLOCATABLE :: validitytime(:,:)
1943 REAL,
POINTER :: voldatiin(:,:,:)
1946 call l4f_category_log(volgrid6d_in%category,l4f_debug,
"start volgrid6d_v7d_transform_compute")
1955 if (
present(networkname))
then 1956 call init(vol7d_out%network(1),name=networkname)
1958 call init(vol7d_out%network(1),name=
'generic')
1961 if (
associated(volgrid6d_in%timerange))
then 1962 ntimerange=
size(volgrid6d_in%timerange)
1963 vol7d_out%timerange=volgrid6d_in%timerange
1966 if (
associated(volgrid6d_in%time))
then 1967 ntime=
size(volgrid6d_in%time)
1969 if (vol7d_out%time_definition == volgrid6d_in%time_definition)
then 1972 vol7d_out%time=volgrid6d_in%time
1976 allocate (validitytime(ntime,ntimerange),stat=stallo)
1979 call raise_fatal_error()
1983 do itimerange=1,ntimerange
1984 if (vol7d_out%time_definition > volgrid6d_in%time_definition)
then 1985 validitytime(itime,itimerange) = &
1986 volgrid6d_in%time(itime) + timedelta_new(sec=volgrid6d_in%timerange(itimerange)%p1)
1988 validitytime(itime,itimerange) = &
1989 volgrid6d_in%time(itime) - timedelta_new(sec=volgrid6d_in%timerange(itimerange)%p1)
1994 nntime = count_distinct(reshape(validitytime,(/ntime*ntimerange/)), back=.true.)
1995 vol7d_out%time=pack_distinct(reshape(validitytime,(/ntime*ntimerange/)), nntime,back=.true.)
2000 IF (
ASSOCIATED(volgrid6d_in%level))
THEN 2001 nlevel =
SIZE(volgrid6d_in%level)
2002 vol7d_out%level=volgrid6d_in%level
2005 IF (
ASSOCIATED(volgrid6d_in%var))
THEN 2006 nvar =
SIZE(volgrid6d_in%var)
2007 IF (.NOT. optio_log(noconvert))
THEN 2008 CALL vargrib2varbufr(volgrid6d_in%var, vol7d_out%dativar%r, c_func)
2012 nana =
SIZE(vol7d_out%ana)
2015 IF (.NOT.
ASSOCIATED(volgrid6d_in%voldati))
THEN 2016 ALLOCATE(voldatiin(volgrid6d_in%griddim%dim%nx, volgrid6d_in%griddim%dim%ny, &
2020 ALLOCATE(voldatir_out(nana,1,nlevel),stat=stallo)
2021 IF (stallo /= 0)
THEN 2023 CALL raise_fatal_error()
2028 do itimerange=1,ntimerange
2040 CALL volgrid_get_vol_3d(volgrid6d_in, itime, itimerange, ivar, &
2043 CALL compute(this, voldatiin, voldatir_out, vol7d_out%dativar%r(ivar))
2045 if (vol7d_out%time_definition == volgrid6d_in%time_definition)
then 2046 vol7d_out%voldatir(:,itime,:,itimerange,ivar,inetwork) = &
2049 vol7d_out%voldatir(:,
index(vol7d_out%time,validitytime(itime,itimerange)),:,itimerange,ivar,inetwork)=&
2050 reshape(voldatir_out,(/nana,nlevel/))
2065 deallocate(voldatir_out)
2066 IF (.NOT.
ASSOCIATED(volgrid6d_in%voldati))
THEN 2067 DEALLOCATE(voldatiin)
2069 if (
allocated(validitytime))
deallocate(validitytime)
2072 IF (
ASSOCIATED(c_func))
THEN 2074 CALL compute(c_func(ivar), vol7d_out%voldatir(:,:,:,:,ivar,:))
2079 end SUBROUTINE volgrid6d_v7d_transform_compute
2088 SUBROUTINE volgrid6d_v7d_transform(this, volgrid6d_in, vol7d_out, v7d, &
2089 maskgrid, maskbounds, networkname, noconvert, find_index, categoryappend)
2090 TYPE(transform_def),
INTENT(in) :: this
2091 TYPE(volgrid6d),
INTENT(inout) :: volgrid6d_in
2092 TYPE(vol7d),
INTENT(out) :: vol7d_out
2093 TYPE(vol7d),
INTENT(in),
OPTIONAL :: v7d
2094 REAL,
INTENT(in),
OPTIONAL :: maskgrid(:,:)
2095 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
2096 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
2097 LOGICAL,
OPTIONAL,
INTENT(in) :: noconvert
2098 PROCEDURE(basic_find_index),
POINTER,
OPTIONAL :: find_index
2099 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
2101 type(grid_transform) :: grid_trans
2102 INTEGER :: ntime, ntimerange, nlevel, nvar, nana, time_definition, nnetwork, stallo
2103 INTEGER :: itime, itimerange, inetwork
2104 TYPE(datetime),
ALLOCATABLE :: validitytime(:,:)
2105 INTEGER,
ALLOCATABLE :: point_index(:)
2106 TYPE(vol7d) :: v7d_locana
2109 call l4f_category_log(volgrid6d_in%category,l4f_debug,
"start volgrid6d_v7d_transform")
2112 call vg6d_wind_unrot(volgrid6d_in)
2120 call get_val(this,time_definition=time_definition)
2121 if (.not.
c_e(time_definition))
then 2125 IF (
PRESENT(v7d))
THEN 2126 CALL vol7d_copy(v7d, v7d_locana)
2128 CALL init(v7d_locana)
2131 if (
associated(volgrid6d_in%timerange)) ntimerange=
size(volgrid6d_in%timerange)
2133 if (
associated(volgrid6d_in%time))
then 2135 ntime=
size(volgrid6d_in%time)
2137 if (time_definition /= volgrid6d_in%time_definition)
then 2140 allocate (validitytime(ntime,ntimerange),stat=stallo)
2143 call raise_fatal_error()
2147 do itimerange=1,ntimerange
2148 if (time_definition > volgrid6d_in%time_definition)
then 2149 validitytime(itime,itimerange) = &
2150 volgrid6d_in%time(itime) + timedelta_new(sec=volgrid6d_in%timerange(itimerange)%p1)
2152 validitytime(itime,itimerange) = &
2153 volgrid6d_in%time(itime) - timedelta_new(sec=volgrid6d_in%timerange(itimerange)%p1)
2158 ntime = count_distinct(reshape(validitytime,(/ntime*ntimerange/)), back=.true.)
2159 deallocate (validitytime)
2165 if (
associated(volgrid6d_in%level)) nlevel=
size(volgrid6d_in%level)
2166 if (
associated(volgrid6d_in%var)) nvar=
size(volgrid6d_in%var)
2168 CALL init(grid_trans, this, volgrid6d_in%griddim, v7d_locana, &
2169 maskgrid=maskgrid, maskbounds=maskbounds, find_index=find_index, &
2170 categoryappend=categoryappend)
2171 CALL init (vol7d_out,time_definition=time_definition)
2173 IF (
c_e(grid_trans))
THEN 2175 nana=
SIZE(v7d_locana%ana)
2176 CALL vol7d_alloc(vol7d_out, nana=nana, ntime=ntime, nlevel=nlevel, &
2177 ntimerange=ntimerange, ndativarr=nvar, nnetwork=nnetwork)
2178 vol7d_out%ana = v7d_locana%ana
2180 CALL get_val(grid_trans, output_point_index=point_index)
2181 IF (
ALLOCATED(point_index))
THEN 2183 CALL vol7d_alloc(vol7d_out, nanavari=1)
2184 CALL init(vol7d_out%anavar%i(1),
'B01192')
2187 CALL vol7d_alloc_vol(vol7d_out)
2189 IF (
ALLOCATED(point_index))
THEN 2190 DO inetwork = 1, nnetwork
2191 vol7d_out%volanai(:,1,inetwork) = point_index(:)
2194 CALL compute(grid_trans, volgrid6d_in, vol7d_out, networkname, noconvert)
2196 CALL l4f_log(l4f_error,
'vg6d_v7d_transform: transformation not valid')
2204 CALL vol7d_dballe_set_var_du(vol7d_out)
2209 END SUBROUTINE volgrid6d_v7d_transform
2220 SUBROUTINE volgrid6dv_v7d_transform(this, volgrid6d_in, vol7d_out, v7d, &
2221 maskgrid, maskbounds, networkname, noconvert, find_index, categoryappend)
2222 TYPE(transform_def),
INTENT(in) :: this
2223 TYPE(volgrid6d),
INTENT(inout) :: volgrid6d_in(:)
2224 TYPE(vol7d),
INTENT(out) :: vol7d_out
2225 TYPE(vol7d),
INTENT(in),
OPTIONAL :: v7d
2226 REAL,
INTENT(in),
OPTIONAL :: maskgrid(:,:)
2227 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
2228 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
2229 LOGICAL,
OPTIONAL,
INTENT(in) :: noconvert
2230 PROCEDURE(basic_find_index),
POINTER,
OPTIONAL :: find_index
2231 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
2234 TYPE(vol7d) :: v7dtmp
2238 CALL init(vol7d_out)
2240 DO i=1,
SIZE(volgrid6d_in)
2241 CALL transform(this, volgrid6d_in(i), v7dtmp, v7d=v7d, &
2242 maskgrid=maskgrid, maskbounds=maskbounds, &
2243 networkname=networkname, noconvert=noconvert, find_index=find_index, &
2244 categoryappend=categoryappend)
2245 CALL vol7d_append(vol7d_out, v7dtmp)
2248 END SUBROUTINE volgrid6dv_v7d_transform
2252 SUBROUTINE v7d_volgrid6d_transform_compute(this, vol7d_in, volgrid6d_out, networkname, gaid_template)
2253 TYPE(grid_transform),
INTENT(in) :: this
2254 type(vol7d),
INTENT(in) :: vol7d_in
2255 type(volgrid6d),
INTENT(inout) :: volgrid6d_out
2256 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
2257 TYPE(grid_id),
OPTIONAL,
INTENT(in) :: gaid_template
2259 integer :: nana, ntime, ntimerange, nlevel, nvar
2260 INTEGER :: ilevel, itime, itimerange, ivar, inetwork
2262 REAL,
POINTER :: voldatiout(:,:,:)
2263 type(vol7d_network) :: network
2264 TYPE(conv_func),
pointer :: c_func(:)
2268 'start v7d_volgrid6d_transform_compute')
2276 IF (
PRESENT(networkname))
THEN 2277 CALL init(network,name=networkname)
2278 inetwork =
index(vol7d_in%network,network)
2279 IF (inetwork <= 0)
THEN 2281 'network '//trim(networkname)//
' not found, first network will be transformed')
2289 if (
associated(vol7d_in%time))
then 2290 ntime=
size(vol7d_in%time)
2291 volgrid6d_out%time=vol7d_in%time
2294 if (
associated(vol7d_in%timerange))
then 2295 ntimerange=
size(vol7d_in%timerange)
2296 volgrid6d_out%timerange=vol7d_in%timerange
2299 if (
associated(vol7d_in%level))
then 2300 nlevel=
size(vol7d_in%level)
2301 volgrid6d_out%level=vol7d_in%level
2304 if (
associated(vol7d_in%dativar%r))
then 2305 nvar=
size(vol7d_in%dativar%r)
2306 CALL varbufr2vargrib(vol7d_in%dativar%r, volgrid6d_out%var, c_func, gaid_template)
2309 nana=
SIZE(vol7d_in%voldatir, 1)
2311 IF (.NOT.
ASSOCIATED(volgrid6d_out%voldati))
THEN 2312 ALLOCATE(voldatiout(volgrid6d_out%griddim%dim%nx, volgrid6d_out%griddim%dim%ny, &
2317 DO itimerange=1,ntimerange
2321 IF (
PRESENT(gaid_template))
THEN 2322 DO ilevel = 1, nlevel
2323 IF (any(
c_e(vol7d_in%voldatir(:,itime,ilevel,itimerange,ivar,inetwork))))
THEN 2324 CALL copy(gaid_template, volgrid6d_out%gaid(ilevel,itime,itimerange,ivar))
2326 volgrid6d_out%gaid(ilevel,itime,itimerange,ivar) = grid_id_new()
2332 IF (
ASSOCIATED(volgrid6d_out%voldati)) &
2333 CALL volgrid_get_vol_3d(volgrid6d_out, itime, itimerange, ivar, &
2336 CALL compute(this, &
2337 vol7d_in%voldatir(:,itime,:,itimerange,ivar,inetwork), voldatiout, &
2338 vol7d_in%dativar%r(ivar))
2340 IF (
ASSOCIATED(c_func))
THEN 2341 CALL compute(c_func(ivar), voldatiout(:,:,:))
2344 CALL volgrid_set_vol_3d(volgrid6d_out, itime, itimerange, ivar, &
2351 IF (.NOT.
ASSOCIATED(volgrid6d_out%voldati))
THEN 2352 DEALLOCATE(voldatiout)
2354 IF (
ASSOCIATED(c_func))
THEN 2358 END SUBROUTINE v7d_volgrid6d_transform_compute
2367 SUBROUTINE v7d_volgrid6d_transform(this, griddim, vol7d_in, volgrid6d_out, &
2368 networkname, gaid_template, categoryappend)
2369 TYPE(transform_def),
INTENT(in) :: this
2370 TYPE(griddim_def),
INTENT(in),
OPTIONAL :: griddim
2372 TYPE(vol7d),
INTENT(inout) :: vol7d_in
2373 TYPE(volgrid6d),
INTENT(out) :: volgrid6d_out
2374 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
2375 TYPE(grid_id),
OPTIONAL,
INTENT(in) :: gaid_template
2376 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
2378 type(grid_transform) :: grid_trans
2379 integer :: ntime, ntimerange, nlevel, nvar
2385 CALL vol7d_alloc_vol(vol7d_in)
2386 ntime=
SIZE(vol7d_in%time)
2387 ntimerange=
SIZE(vol7d_in%timerange)
2388 nlevel=
SIZE(vol7d_in%level)
2390 if (
associated(vol7d_in%dativar%r)) nvar=
size(vol7d_in%dativar%r)
2393 CALL l4f_log(l4f_error, &
2394 "trying to transform a vol7d object incomplete or without real variables")
2395 CALL init(volgrid6d_out)
2400 CALL init(grid_trans, this, vol7d_in, griddim, categoryappend=categoryappend)
2401 CALL init(volgrid6d_out, griddim, time_definition=vol7d_in%time_definition, &
2402 categoryappend=categoryappend)
2404 IF (
c_e(grid_trans))
THEN 2406 CALL volgrid6d_alloc(volgrid6d_out, griddim%dim, ntime=ntime, nlevel=nlevel, &
2407 ntimerange=ntimerange, nvar=nvar)
2409 CALL volgrid6d_alloc_vol(volgrid6d_out, decode=.true.)
2411 CALL compute(grid_trans, vol7d_in, volgrid6d_out, networkname, gaid_template)
2413 CALL vg6d_wind_rot(volgrid6d_out)
2416 CALL l4f_log(l4f_error,
'v7d_vg6d_transform: transformation not valid')
2422 END SUBROUTINE v7d_volgrid6d_transform
2426 SUBROUTINE v7d_v7d_transform_compute(this, vol7d_in, vol7d_out, lev_out, &
2428 TYPE(grid_transform),
INTENT(in) :: this
2429 type(vol7d),
INTENT(in) :: vol7d_in
2430 type(vol7d),
INTENT(inout) :: vol7d_out
2431 TYPE(vol7d_level),
INTENT(in),
OPTIONAL :: lev_out(:)
2432 INTEGER,
INTENT(in),
OPTIONAL :: var_coord_vol
2434 INTEGER :: itime, itimerange, ilevel, ivar, inetwork, &
2435 levshift, levused, lvar_coord_vol, spos
2436 REAL,
ALLOCATABLE :: coord_3d_in(:,:,:)
2437 TYPE(vol7d_level) :: output_levtype
2439 lvar_coord_vol = optio_i(var_coord_vol)
2440 vol7d_out%time(:) = vol7d_in%time(:)
2441 vol7d_out%timerange(:) = vol7d_in%timerange(:)
2442 IF (
PRESENT(lev_out))
THEN 2443 vol7d_out%level(:) = lev_out(:)
2445 vol7d_out%level(:) = vol7d_in%level(:)
2447 vol7d_out%network(:) = vol7d_in%network(:)
2448 IF (
ASSOCIATED(vol7d_in%dativar%r))
THEN 2449 vol7d_out%dativar%r(:) = vol7d_in%dativar%r(:)
2451 CALL get_val(this, levshift=levshift, levused=levused)
2453 IF (
c_e(lvar_coord_vol))
THEN 2454 CALL get_val(this%trans, output_levtype=output_levtype)
2455 IF (output_levtype%level1 == 103 .OR. output_levtype%level1 == 108)
THEN 2456 spos = firsttrue(vol7d_in%level(:) == vol7d_level_new(1))
2458 CALL l4f_log(l4f_error, &
2459 'output level '//
t2c(output_levtype%level1)// &
2460 ' requested, but height/press of surface not provided in volume')
2462 IF (.NOT.
c_e(levshift) .AND. .NOT.
c_e(levused))
THEN 2463 CALL l4f_log(l4f_error, &
2464 'internal inconsistence, levshift and levused undefined when they should be')
2466 ALLOCATE(coord_3d_in(
SIZE(vol7d_in%ana),1,
SIZE(vol7d_in%level)))
2471 DO inetwork = 1,
SIZE(vol7d_in%network)
2472 DO ivar = 1,
SIZE(vol7d_in%dativar%r)
2473 DO itimerange = 1,
SIZE(vol7d_in%timerange)
2474 DO itime = 1,
SIZE(vol7d_in%time)
2477 IF (
c_e(lvar_coord_vol))
THEN 2480 coord_3d_in(:,:,levshift+1:levshift+levused) = rmiss
2482 DO ilevel = levshift+1, levshift+levused
2483 WHERE(
c_e(vol7d_in%voldatir(:,itime:itime,ilevel,itimerange,lvar_coord_vol,inetwork)) .AND. &
2484 c_e(vol7d_in%voldatir(:,itime:itime,spos,itimerange,lvar_coord_vol,inetwork)))
2485 coord_3d_in(:,:,ilevel) = vol7d_in%voldatir(:,itime:itime,ilevel,itimerange,lvar_coord_vol,inetwork) - &
2486 vol7d_in%voldatir(:,itime:itime,spos,itimerange,lvar_coord_vol,inetwork)
2488 coord_3d_in(:,:,ilevel) = rmiss
2492 CALL compute(this, &
2493 vol7d_in%voldatir(:,itime,:,itimerange,ivar,inetwork), &
2494 vol7d_out%voldatir(:,itime:itime,:,itimerange,ivar,inetwork), &
2495 var=vol7d_in%dativar%r(ivar), &
2496 coord_3d_in=coord_3d_in)
2498 CALL compute(this, &
2499 vol7d_in%voldatir(:,itime,:,itimerange,ivar,inetwork), &
2500 vol7d_out%voldatir(:,itime:itime,:,itimerange,ivar,inetwork), &
2501 var=vol7d_in%dativar%r(ivar), &
2502 coord_3d_in=vol7d_in%voldatir(:,itime:itime,:,itimerange, &
2503 lvar_coord_vol,inetwork))
2506 CALL compute(this, &
2507 vol7d_in%voldatir(:,itime,:,itimerange,ivar,inetwork), &
2508 vol7d_out%voldatir(:,itime:itime,:,itimerange,ivar,inetwork), &
2509 var=vol7d_in%dativar%r(ivar))
2518 END SUBROUTINE v7d_v7d_transform_compute
2528 SUBROUTINE v7d_v7d_transform(this, vol7d_in, vol7d_out, v7d, maskbounds, &
2529 lev_out, vol7d_coord_in, categoryappend)
2530 TYPE(transform_def),
INTENT(in) :: this
2531 TYPE(vol7d),
INTENT(inout) :: vol7d_in
2532 TYPE(vol7d),
INTENT(out) :: vol7d_out
2533 TYPE(vol7d),
INTENT(in),
OPTIONAL :: v7d
2534 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
2535 TYPE(vol7d_level),
INTENT(in),
OPTIONAL,
TARGET :: lev_out(:)
2536 TYPE(vol7d),
INTENT(in),
OPTIONAL :: vol7d_coord_in
2537 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
2539 INTEGER :: nvar, inetwork
2540 TYPE(grid_transform) :: grid_trans
2541 TYPE(vol7d_level),
POINTER :: llev_out(:)
2542 TYPE(vol7d_level) :: input_levtype, output_levtype
2543 TYPE(vol7d_var) :: vcoord_var
2544 REAL,
ALLOCATABLE :: coord_3d_in(:,:,:)
2545 INTEGER :: var_coord_in, var_coord_vol, i, k, ulstart, ulend, spos
2546 INTEGER,
ALLOCATABLE :: point_index(:)
2547 TYPE(vol7d) :: v7d_locana, vol7d_tmpana
2548 CHARACTER(len=80) :: trans_type
2549 LOGICAL,
ALLOCATABLE :: mask_in(:), point_mask(:)
2551 CALL vol7d_alloc_vol(vol7d_in)
2553 IF (
ASSOCIATED(vol7d_in%dativar%r)) nvar=
SIZE(vol7d_in%dativar%r)
2555 CALL init(v7d_locana)
2556 IF (
PRESENT(v7d)) v7d_locana = v7d
2557 CALL init(vol7d_out, time_definition=vol7d_in%time_definition)
2559 CALL get_val(this, trans_type=trans_type)
2561 var_coord_vol = imiss
2562 IF (trans_type ==
'vertint')
THEN 2564 IF (
PRESENT(lev_out))
THEN 2568 IF (
PRESENT(vol7d_coord_in))
THEN 2569 IF (
ASSOCIATED(vol7d_coord_in%voldatir) .AND. &
2570 ASSOCIATED(vol7d_coord_in%dativar%r))
THEN 2573 IF (
SIZE(vol7d_coord_in%voldatir,2) /= 1 .OR. &
2574 SIZE(vol7d_coord_in%voldatir,4) /= 1 .OR. &
2575 SIZE(vol7d_coord_in%voldatir,6) /= 1)
THEN 2576 CALL l4f_log(l4f_error, &
2577 'volume providing constant input vertical coordinate must have & 2578 &only 1 time, 1 timerange and 1 network')
2584 CALL get_val(this, output_levtype=output_levtype)
2586 IF (.NOT.
c_e(vcoord_var))
THEN 2587 CALL l4f_log(l4f_error, &
2588 'requested output level type '//
t2c(output_levtype%level1)// &
2589 ' does not correspond to any known physical variable for & 2590 &providing vertical coordinate')
2595 var_coord_in =
index(vol7d_coord_in%dativar%r, vcoord_var)
2597 IF (var_coord_in <= 0)
THEN 2598 CALL l4f_log(l4f_error, &
2599 'volume providing constant input vertical coordinate contains no & 2600 &real variables matching output level type '//
t2c(output_levtype%level1))
2604 CALL l4f_log(l4f_info, &
2605 'Coordinate for vertint found in coord volume at position '// &
2609 CALL get_val(this, input_levtype=input_levtype)
2611 (vol7d_coord_in%level(:)%level1 == input_levtype%level1) .AND. &
2612 (vol7d_coord_in%level(:)%level2 == input_levtype%level2)
2613 ulstart = firsttrue(mask_in)
2614 ulend = lasttrue(mask_in)
2615 IF (ulstart == 0 .OR. ulend == 0)
THEN 2616 CALL l4f_log(l4f_error, &
2617 'coordinate file does not contain levels of type '// &
2618 t2c(input_levtype%level1)//
'/'//
t2c(input_levtype%level2)// &
2619 ' specified for input data')
2624 coord_3d_in = vol7d_coord_in%voldatir(:,1:1,ulstart:ulend,1,var_coord_in,1)
2626 IF (output_levtype%level1 == 103 &
2627 .OR. output_levtype%level1 == 108)
THEN 2628 spos = firsttrue(vol7d_coord_in%level(:) == vol7d_level_new(1))
2630 CALL l4f_log(l4f_error, &
2631 'output level '//
t2c(output_levtype%level1)// &
2632 ' requested, but height/press of surface not provided in coordinate file')
2636 DO k = 1,
SIZE(coord_3d_in,3)
2637 WHERE(
c_e(coord_3d_in(:,:,k)) .AND. &
2638 c_e(vol7d_coord_in%voldatir(:,1:1,spos,1,var_coord_in,1)))
2639 coord_3d_in(:,:,k) = coord_3d_in(:,:,k) - &
2640 vol7d_coord_in%voldatir(:,1:1,spos,1,var_coord_in,1)
2642 coord_3d_in(:,:,k) = rmiss
2650 IF (var_coord_in <= 0)
THEN 2652 CALL get_val(this, output_levtype=output_levtype)
2654 IF (
c_e(vcoord_var))
THEN 2655 DO i = 1,
SIZE(vol7d_in%dativar%r)
2656 IF (vol7d_in%dativar%r(i) == vcoord_var)
THEN 2662 IF (
c_e(var_coord_vol))
THEN 2663 CALL l4f_log(l4f_info, &
2664 'Coordinate for vertint found in input volume at position '// &
2671 IF (var_coord_in > 0)
THEN 2672 CALL init(grid_trans, this, lev_in=vol7d_in%level, lev_out=lev_out, &
2673 coord_3d_in=coord_3d_in, categoryappend=categoryappend)
2675 CALL init(grid_trans, this, lev_in=vol7d_in%level, lev_out=lev_out, &
2676 categoryappend=categoryappend)
2679 CALL get_val(grid_trans, output_level_auto=llev_out)
2680 IF (.NOT.
associated(llev_out)) llev_out => lev_out
2682 IF (
c_e(grid_trans)) then
2684 CALL vol7d_alloc(vol7d_out, nana=
SIZE(vol7d_in%ana), &
2685 ntime=
SIZE(vol7d_in%time), ntimerange=
SIZE(vol7d_in%timerange), &
2686 nlevel=
SIZE(llev_out), nnetwork=
SIZE(vol7d_in%network), ndativarr=nvar)
2687 vol7d_out%ana(:) = vol7d_in%ana(:)
2689 CALL vol7d_alloc_vol(vol7d_out)
2694 CALL compute(grid_trans, vol7d_in, vol7d_out, llev_out, &
2695 var_coord_vol=var_coord_vol)
2697 CALL l4f_log(l4f_error,
'v7d_v7d_transform: transformation not valid')
2701 CALL l4f_log(l4f_error, &
2702 'v7d_v7d_transform: vertint requested but lev_out not provided')
2708 CALL init(grid_trans, this, vol7d_in, v7d_locana, maskbounds=maskbounds, &
2709 categoryappend=categoryappend)
2712 IF (
c_e(grid_trans)) then
2714 CALL vol7d_alloc(vol7d_out, nana=
SIZE(v7d_locana%ana), &
2715 ntime=
SIZE(vol7d_in%time), ntimerange=
SIZE(vol7d_in%timerange), &
2716 nlevel=
SIZE(vol7d_in%level), nnetwork=
SIZE(vol7d_in%network), ndativarr=nvar)
2717 vol7d_out%ana = v7d_locana%ana
2719 CALL get_val(grid_trans, point_mask=point_mask, output_point_index=point_index)
2721 IF (
ALLOCATED(point_index))
THEN 2722 CALL vol7d_alloc(vol7d_out, nanavari=1)
2723 CALL init(vol7d_out%anavar%i(1),
'B01192')
2726 CALL vol7d_alloc_vol(vol7d_out)
2728 IF (
ALLOCATED(point_index))
THEN 2729 DO inetwork = 1,
SIZE(vol7d_in%network)
2730 vol7d_out%volanai(:,1,inetwork) = point_index(:)
2733 CALL compute(grid_trans, vol7d_in, vol7d_out)
2735 IF (
ALLOCATED(point_mask))
THEN 2736 IF (
SIZE(point_mask) /=
SIZE(vol7d_in%ana))
THEN 2737 CALL l4f_log(l4f_warn, &
2738 'v7d_v7d_transform: inconsistency in point size: '//
t2c(
SIZE(point_mask)) &
2739 //
':'//
t2c(
SIZE(vol7d_in%ana)))
2742 CALL l4f_log(l4f_debug,
'v7d_v7d_transform: merging ana from in to out')
2744 CALL vol7d_copy(vol7d_in, vol7d_tmpana, &
2745 lana=point_mask, lnetwork=(/.true./), &
2746 ltime=(/.false./), ltimerange=(/.false./), llevel=(/.false./))
2747 CALL vol7d_append(vol7d_out, vol7d_tmpana)
2752 CALL l4f_log(l4f_error,
'v7d_v7d_transform: transformation not valid')
2759 IF (.NOT.
PRESENT(v7d))
CALL delete(v7d_locana)
2761 END SUBROUTINE v7d_v7d_transform
2771 subroutine vg6d_wind_unrot(this)
2772 type(volgrid6d) :: this
2774 integer :: component_flag
2776 call get_val(this%griddim,component_flag=component_flag)
2778 if (component_flag == 1)
then 2780 "unrotating vector components")
2781 call vg6d_wind__un_rot(this,.false.)
2782 call set_val(this%griddim,component_flag=0)
2785 "no need to unrotate vector components")
2788 end subroutine vg6d_wind_unrot
2796 subroutine vg6d_wind_rot(this)
2797 type(volgrid6d) :: this
2799 integer :: component_flag
2801 call get_val(this%griddim,component_flag=component_flag)
2803 if (component_flag == 0)
then 2805 "rotating vector components")
2806 call vg6d_wind__un_rot(this,.true.)
2807 call set_val(this%griddim,component_flag=1)
2810 "no need to rotate vector components")
2813 end subroutine vg6d_wind_rot
2817 SUBROUTINE vg6d_wind__un_rot(this,rot)
2818 TYPE(volgrid6d) :: this
2821 INTEGER :: i, j, k, l, a11, a12, a21, a22, stallo
2822 double precision,
pointer :: rot_mat(:,:,:)
2823 real,
allocatable :: tmp_arr(:,:)
2824 REAL,
POINTER :: voldatiu(:,:), voldativ(:,:)
2825 INTEGER,
POINTER :: iu(:), iv(:)
2827 IF (.NOT.
ASSOCIATED(this%var))
THEN 2829 "trying to unrotate an incomplete volgrid6d object")
2830 CALL raise_fatal_error()
2834 CALL volgrid6d_var_hor_comp_index(this%var, iu, iv)
2835 IF (.NOT.
ASSOCIATED(iu))
THEN 2837 "unrotation impossible")
2838 CALL raise_fatal_error()
2843 ALLOCATE(tmp_arr(this%griddim%dim%nx, this%griddim%dim%ny),stat=stallo)
2844 IF (stallo /= 0)
THEN 2846 CALL raise_fatal_error()
2849 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 2850 ALLOCATE(voldatiu(this%griddim%dim%nx, this%griddim%dim%ny), &
2851 voldativ(this%griddim%dim%nx, this%griddim%dim%ny))
2854 CALL griddim_unproj(this%griddim)
2855 CALL wind_unrot(this%griddim, rot_mat)
2868 DO k = 1,
SIZE(this%timerange)
2869 DO j = 1,
SIZE(this%time)
2870 DO i = 1,
SIZE(this%level)
2872 CALL volgrid_get_vol_2d(this, i, j, k, iu(l), voldatiu)
2873 CALL volgrid_get_vol_2d(this, i, j, k, iv(l), voldativ)
2879 WHERE(voldatiu /= rmiss .AND. voldativ /= rmiss)
2880 tmp_arr(:,:) =
real(voldatiu(:,:)*rot_mat(:,:,a11) + &
2881 voldativ(:,:)*rot_mat(:,:,a12))
2882 voldativ(:,:) =
real(voldatiu(:,:)*rot_mat(:,:,a21) + &
2883 voldativ(:,:)*rot_mat(:,:,a22))
2884 voldatiu(:,:) = tmp_arr(:,:)
2890 CALL volgrid_set_vol_2d(this, i, j, k, iu(l), voldatiu)
2891 CALL volgrid_set_vol_2d(this, i, j, k, iv(l), voldativ)
2897 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 2898 DEALLOCATE(voldatiu, voldativ)
2900 DEALLOCATE(rot_mat, tmp_arr, iu, iv)
2902 END SUBROUTINE vg6d_wind__un_rot
2948 subroutine vg6d_c2a (this)
2950 TYPE(volgrid6d),
INTENT(inout) :: this(:)
2952 integer :: ngrid,igrid,jgrid,ugrid,vgrid,tgrid
2953 doubleprecision :: xmin, xmax, ymin, ymax
2954 doubleprecision :: xmin_t, xmax_t, ymin_t, ymax_t
2955 doubleprecision :: step_lon_t,step_lat_t
2956 character(len=80) :: type_t,type
2957 TYPE(griddim_def):: griddim_t
2963 call init(griddim_t)
2965 call get_val(this(igrid)%griddim,xmin=xmin_t, xmax=xmax_t, ymin=ymin_t, ymax=ymax_t,proj_type=type_t)
2966 step_lon_t=(xmax_t-xmin_t)/dble(this(igrid)%griddim%dim%nx-1)
2967 step_lat_t=(ymax_t-ymin_t)/dble(this(igrid)%griddim%dim%ny-1)
2980 if (this(igrid)%griddim == this(jgrid)%griddim ) cycle
2982 if (this(igrid)%griddim%dim%nx == this(jgrid)%griddim%dim%nx .and. &
2983 this(igrid)%griddim%dim%ny == this(jgrid)%griddim%dim%ny )
then 2985 call get_val(this(jgrid)%griddim,xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax,proj_type=type)
2987 if (type_t /=
type )cycle
2993 call l4f_category_log(this(igrid)%category,l4f_debug,
"diff coordinate lon"//&
2994 to_char(
abs(xmin - (xmin_t+step_lon_t/2.d0)))//&
2996 call l4f_category_log(this(igrid)%category,l4f_debug,
"diff coordinate lat"//&
2997 to_char(
abs(ymin - (ymin_t+step_lat_t/2.d0)))//&
2998 to_char(
abs(ymax - (ymax_t+step_lat_t/2.d0))))
3001 if (
abs(xmin - (xmin_t+step_lon_t/2.d0)) < 1.d-3 .and.
abs(xmax - (xmax_t+step_lon_t/2.d0)) < 1.d-3 )
then 3002 if (
abs(ymin - ymin_t) < 1.d-3 .and.
abs(ymax - ymax_t) < 1.d-3 )
then 3018 if (
abs(ymin - (ymin_t+step_lat_t/2.d0)) < 1.d-3 .and.
abs(ymax - (ymax_t+step_lat_t/2.d0)) < 1.d-3 )
then 3019 if (
abs(xmin - xmin_t) < 1.d-3 .and.
abs(xmax - xmax_t) < 1.d-3 )
then 3034 call l4f_category_log(this(igrid)%category,l4f_debug,
"C grid: test U and V"//&
3038 call l4f_category_log(this(igrid)%category,l4f_debug,
"UV diff coordinate lon"//&
3039 to_char(
abs(xmin_t - xmin)-step_lon_t/2.d0)//&
3041 call l4f_category_log(this(igrid)%category,l4f_debug,
"UV diff coordinate lat"//&
3042 to_char(
abs(ymin_t - ymin) -step_lat_t/2.d0)//&
3046 if (
abs(ymin - (ymin_t+step_lat_t/2.d0)) < 2.d-3 .and.
abs(ymax - (ymax_t+step_lat_t/2.d0)) < 2.d-3 )
then 3047 if (
abs(xmin_t - (xmin+step_lon_t/2.d0)) < 2.d-3 .and.
abs(xmax_t - (xmax+step_lon_t/2.d0)) < 2.d-3 )
then 3050 call l4f_category_log(this(igrid)%category,l4f_debug,
"C grid: found U and V case up and right")
3056 call init(griddim_t,xmin=xmin, xmax=xmax, ymin=ymin_t, ymax=ymax_t)
3063 if (
c_e(ugrid))
then 3068 call vg6d_c2a_grid(this(ugrid),this(tgrid)%griddim,cgrid=1)
3070 call vg6d_c2a_grid(this(ugrid),griddim_t,cgrid=1)
3072 call vg6d_c2a_mat(this(ugrid),cgrid=1)
3075 if (
c_e(vgrid))
then 3080 call vg6d_c2a_grid(this(vgrid),this(tgrid)%griddim,cgrid=2)
3082 call vg6d_c2a_grid(this(vgrid),griddim_t,cgrid=2)
3084 call vg6d_c2a_mat(this(vgrid),cgrid=2)
3094 end subroutine vg6d_c2a
3098 subroutine vg6d_c2a_grid(this,griddim_t,cgrid)
3100 type(volgrid6d),
intent(inout) :: this
3101 type(griddim_def),
intent(in),
optional :: griddim_t
3102 integer,
intent(in) :: cgrid
3104 doubleprecision :: xmin, xmax, ymin, ymax
3105 doubleprecision :: step_lon,step_lat
3108 if (
present(griddim_t))
then 3110 call get_val(griddim_t,xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax)
3111 call set_val(this%griddim,xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax)
3113 CALL griddim_setsteps(this%griddim)
3122 call l4f_category_log(this%category,l4f_debug,
"C grid: T points, nothing to do")
3129 call l4f_category_log(this%category,l4f_debug,
"C grid: U points, we need interpolation")
3132 call get_val(this%griddim, xmin=xmin, xmax=xmax)
3133 step_lon=(xmax-xmin)/dble(this%griddim%dim%nx-1)
3134 xmin=xmin-step_lon/2.d0
3135 xmax=xmax-step_lon/2.d0
3136 call set_val(this%griddim, xmin=xmin, xmax=xmax)
3138 CALL griddim_setsteps(this%griddim)
3143 call l4f_category_log(this%category,l4f_debug,
"C grid: V points, we need interpolation")
3146 call get_val(this%griddim, ymin=ymin, ymax=ymax)
3147 step_lat=(ymax-ymin)/dble(this%griddim%dim%ny-1)
3148 ymin=ymin-step_lat/2.d0
3149 ymax=ymax-step_lat/2.d0
3150 call set_val(this%griddim, ymin=ymin, ymax=ymax)
3152 CALL griddim_setsteps(this%griddim)
3157 call raise_fatal_error ()
3164 call griddim_unproj(this%griddim)
3167 end subroutine vg6d_c2a_grid
3170 subroutine vg6d_c2a_mat(this,cgrid)
3173 integer,
intent(in) :: cgrid
3175 INTEGER :: i, j, k, iv, stallo
3176 REAL,
ALLOCATABLE :: tmp_arr(:,:)
3177 REAL,
POINTER :: voldatiuv(:,:)
3180 IF (cgrid == 0)
RETURN 3181 IF (cgrid /= 1 .AND. cgrid /= 2)
THEN 3183 trim(
to_char(cgrid))//
" not known")
3189 ALLOCATE(tmp_arr(this%griddim%dim%nx, this%griddim%dim%ny),stat=stallo)
3191 call l4f_log(l4f_fatal,
"allocating memory")
3192 call raise_fatal_error()
3196 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 3197 ALLOCATE(voldatiuv(this%griddim%dim%nx, this%griddim%dim%ny), stat=stallo)
3198 IF (stallo /= 0)
THEN 3199 CALL l4f_log(l4f_fatal,
"allocating memory")
3200 CALL raise_fatal_error()
3204 IF (cgrid == 1)
THEN 3205 DO iv = 1,
SIZE(this%var)
3206 DO k = 1,
SIZE(this%timerange)
3207 DO j = 1,
SIZE(this%time)
3208 DO i = 1,
SIZE(this%level)
3209 tmp_arr(:,:) = rmiss
3210 CALL volgrid_get_vol_2d(this, i, j, k, iv, voldatiuv)
3213 WHERE(voldatiuv(1,:) /= rmiss .AND. voldatiuv(2,:) /= rmiss)
3214 tmp_arr(1,:) = voldatiuv(1,:) - (voldatiuv(2,:) - voldatiuv(1,:)) / 2.
3218 WHERE(voldatiuv(1:this%griddim%dim%nx-1,:) /= rmiss .AND. &
3219 voldatiuv(2:this%griddim%dim%nx,:) /= rmiss)
3220 tmp_arr(2:this%griddim%dim%nx,:) = &
3221 (voldatiuv(1:this%griddim%dim%nx-1,:) + &
3222 voldatiuv(2:this%griddim%dim%nx,:)) / 2.
3225 voldatiuv(:,:) = tmp_arr
3226 CALL volgrid_set_vol_2d(this, i, j, k, iv, voldatiuv)
3232 ELSE IF (cgrid == 2)
THEN 3233 DO iv = 1,
SIZE(this%var)
3234 DO k = 1,
SIZE(this%timerange)
3235 DO j = 1,
SIZE(this%time)
3236 DO i = 1,
SIZE(this%level)
3237 tmp_arr(:,:) = rmiss
3238 CALL volgrid_get_vol_2d(this, i, j, k, iv, voldatiuv)
3241 WHERE(voldatiuv(:,1) /= rmiss .AND. voldatiuv(:,2) /= rmiss)
3242 tmp_arr(:,1) = voldatiuv(:,1) - (voldatiuv(:,2) - voldatiuv(:,1)) / 2.
3246 WHERE(voldatiuv(:,1:this%griddim%dim%ny-1) /= rmiss .AND. &
3247 voldatiuv(:,2:this%griddim%dim%ny) /= rmiss)
3248 tmp_arr(:,2:this%griddim%dim%ny) = &
3249 (voldatiuv(:,1:this%griddim%dim%ny-1) + &
3250 voldatiuv(:,2:this%griddim%dim%ny)) / 2.
3253 voldatiuv(:,:) = tmp_arr
3254 CALL volgrid_set_vol_2d(this, i, j, k, iv, voldatiuv)
3261 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 3262 DEALLOCATE(voldatiuv)
3264 DEALLOCATE (tmp_arr)
3266 end subroutine vg6d_c2a_mat
3272 subroutine display_volgrid6d (this)
3281 print*,
"----------------------- volgrid6d display ---------------------" 3284 IF (
ASSOCIATED(this%time))
then 3285 print*,
"---- time vector ----" 3286 print*,
"elements=",
size(this%time)
3287 do i=1,
size(this%time)
3292 IF (
ASSOCIATED(this%timerange))
then 3293 print*,
"---- timerange vector ----" 3294 print*,
"elements=",
size(this%timerange)
3295 do i=1,
size(this%timerange)
3296 call display(this%timerange(i))
3300 IF (
ASSOCIATED(this%level))
then 3301 print*,
"---- level vector ----" 3302 print*,
"elements=",
size(this%level)
3303 do i=1,
size(this%level)
3308 IF (
ASSOCIATED(this%var))
then 3309 print*,
"---- var vector ----" 3310 print*,
"elements=",
size(this%var)
3311 do i=1,
size(this%var)
3316 IF (
ASSOCIATED(this%gaid))
then 3317 print*,
"---- gaid vector (present mask only) ----" 3318 print*,
"elements=",shape(this%gaid)
3319 print*,
c_e(reshape(this%gaid,(/
SIZE(this%gaid)/)))
3322 print*,
"--------------------------------------------------------------" 3325 end subroutine display_volgrid6d
3331 subroutine display_volgrid6dv (this)
3336 print*,
"----------------------- volgrid6d vector ---------------------" 3338 print*,
"elements=",
size(this)
3343 call l4f_category_log(this(i)%category,l4f_debug,
"ora mostro il vettore volgrid6d" )
3349 print*,
"--------------------------------------------------------------" 3351 end subroutine display_volgrid6dv
3356 subroutine vg6dv_rounding(vg6din,vg6dout,level,timerange,nostatproc,merge)
3358 type(
volgrid6d),
intent(out),
pointer :: vg6dout(:)
3361 logical,
intent(in),
optional :: merge
3362 logical,
intent(in),
optional :: nostatproc
3366 allocate(vg6dout(
size(vg6din)))
3368 do i = 1,
size(vg6din)
3369 call vg6d_rounding(vg6din(i),vg6dout(i),level,timerange,nostatproc,merge)
3372 end subroutine vg6dv_rounding
3385 subroutine vg6d_rounding(vg6din,vg6dout,level,timerange,nostatproc,merge)
3390 logical,
intent(in),
optional :: merge
3392 logical,
intent(in),
optional :: nostatproc
3394 integer :: ilevel,itimerange
3395 type(
vol7d_level) :: roundlevel(size(vg6din%level))
3398 roundlevel=vg6din%level
3400 if (
present(level))
then 3401 do ilevel = 1,
size(vg6din%level)
3402 if ((any(vg6din%level(ilevel) .almosteq. level)))
then 3403 roundlevel(ilevel)=level(1)
3408 roundtimerange=vg6din%timerange
3410 if (
present(timerange))
then 3411 do itimerange = 1,
size(vg6din%timerange)
3412 if ((any(vg6din%timerange(itimerange) .almosteq. timerange)))
then 3413 roundtimerange(itimerange)=timerange(1)
3420 if (optio_log(nostatproc))
then 3421 roundtimerange(:)%timerange=254
3422 roundtimerange(:)%p2=0
3426 call vg6d_reduce(vg6din,vg6dout,roundlevel,roundtimerange,merge)
3428 end subroutine vg6d_rounding
3438 subroutine vg6d_reduce(vg6din,vg6dout,roundlevel,roundtimerange,merge)
3443 logical,
intent(in),
optional :: merge
3445 integer :: nlevel,ntime,ntimerange,nvar,ilevel,itimerange,ivar,indl,indt,itime,nx,ny
3446 real,
allocatable :: vol2d(:,:)
3448 nx=vg6din%griddim%dim%nx
3449 ny=vg6din%griddim%dim%ny
3450 nlevel=count_distinct(roundlevel,back=.true.)
3451 ntime=
size(vg6din%time)
3452 ntimerange=count_distinct(roundtimerange,back=.true.)
3453 nvar=
size(vg6din%var)
3455 call init(vg6dout, vg6din%griddim, vg6din%time_definition, categoryappend=
"generated by vg6d_reduce")
3456 call volgrid6d_alloc(vg6dout, vg6din%griddim%dim, ntime, nlevel, ntimerange, nvar)
3458 if (
ASSOCIATED(vg6din%voldati) .or. optio_log(merge))
then 3459 call volgrid6d_alloc_vol(vg6dout,inivol=.true.,decode=.true.)
3460 allocate(vol2d(nx,ny))
3462 call volgrid6d_alloc_vol(vg6dout,inivol=.true.,decode=.false.)
3465 vg6dout%time=vg6din%time
3466 vg6dout%var=vg6din%var
3467 vg6dout%timerange=pack_distinct(roundtimerange,ntimerange,back=.true.)
3468 vg6dout%level=pack_distinct(roundlevel,nlevel,back=.true.)
3470 CALL sort(vg6dout%timerange)
3471 CALL sort(vg6dout%level)
3473 do ilevel=1,
size(vg6din%level)
3474 indl=
index(vg6dout%level,roundlevel(ilevel))
3475 do itimerange=1,
size(vg6din%timerange)
3476 indt=
index(vg6dout%timerange,roundtimerange(itimerange))
3480 if (
ASSOCIATED(vg6din%voldati))
then 3481 vol2d=vg6din%voldati(:,:,ilevel,itime,itimerange,ivar)
3484 if (optio_log(merge))
then 3486 if ( .not.
ASSOCIATED(vg6din%voldati))
then 3487 CALL grid_id_decode_data(vg6din%gaid(ilevel,itime,itimerange,ivar), vol2d)
3491 where (.not.
c_e(vg6dout%voldati(:,:,indl,itime,indt,ivar)))
3493 vg6dout%voldati(:,:,indl,itime,indt,ivar)=vol2d
3496 else if (
ASSOCIATED(vg6din%voldati))
then 3497 if (.not. any(
c_e(vg6dout%voldati(:,:,indl,itime,indt,ivar))))
then 3498 vg6dout%voldati(:,:,indl,itime,indt,ivar)=vol2d
3502 if (
c_e(vg6din%gaid(ilevel,itime,itimerange,ivar)).and. .not.
c_e(vg6dout%gaid(indl,itime,indt,ivar)))
then 3503 call copy (vg6din%gaid(ilevel,itime,itimerange,ivar), vg6dout%gaid(indl,itime,indt,ivar))
3510 if (
ASSOCIATED(vg6din%voldati) .or. optio_log(merge))
then 3514 end subroutine vg6d_reduce
Write the object on a formatted or unformatted file.
Read the object from a formatted or unformatted file.
Functions that return a trimmed CHARACTER representation of the input variable.
Compute forward coordinate transformation from geographical system to projected system.
Represent level object in a pretty string.
Constructor, it creates a new instance of the object.
Operatore di valore assoluto di un intervallo.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Destructor, it releases every information and memory buffer associated with the object.
Object describing a rectangular, homogeneous gridded dataset.
This module defines an abstract interface to different drivers for access to files containing gridded...
Apply the conversion function this to values.
Module for describing geographically referenced regular grids.
Decode and return the data array from a grid_id object associated to a gridinfo object.
Encode a data array into a grid_id object associated to a gridinfo object.
Classi per la gestione delle coordinate temporali.
This module defines objects and methods for managing data volumes on rectangular georeferenced grids...
classe per import ed export di volumi da e in DB-All.e
Convert a level type to a physical variable.
Definisce l'intervallo temporale di un'osservazione meteo.
Import an object dirctly from a native file, from a gridinfo object or from a supported file format t...
Export an object dirctly to a native file, to a gridinfo object or to a supported file format through...
Classe per la gestione dei livelli verticali in osservazioni meteo e affini.
Classe per la gestione di un volume completo di dati osservati.
This module defines usefull general purpose function and subroutine.
Class for managing information about a single gridded georeferenced field, typically imported from an...
Definisce il livello verticale di un'osservazione.
Classe per la gestione degli intervalli temporali di osservazioni meteo e affini. ...
Display on standard output a description of the volgrid6d object provided.
Module for defining the extension and coordinates of a rectangular georeferenced grid.
Clone the object, creating a new independent instance of the object exactly equal to the starting one...
classe per la gestione del logging
Class for managing physical variables in a grib 1/2 fashion.
Method for inserting elements of the array at a desired position.
Method for setting the contents of the object.
Emit log message for a category with specific priority.
Reduce some dimensions (level and timerage) for semplification (rounding).