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)
203 if(
present(time_definition))
then 204 this%time_definition = time_definition
206 this%time_definition = 0
209 nullify (this%time,this%timerange,this%level,this%var)
210 nullify (this%gaid,this%voldati)
212 END SUBROUTINE volgrid6d_init
225 SUBROUTINE volgrid6d_alloc(this, dim, ntime, nlevel, ntimerange, nvar, ini)
226 TYPE(volgrid6d),
INTENT(inout) :: this
227 TYPE(grid_dim),
INTENT(in),
OPTIONAL :: dim
228 INTEGER,
INTENT(in),
OPTIONAL :: ntime
229 INTEGER,
INTENT(in),
OPTIONAL :: nlevel
230 INTEGER,
INTENT(in),
OPTIONAL :: ntimerange
231 INTEGER,
INTENT(in),
OPTIONAL :: nvar
232 LOGICAL,
INTENT(in),
OPTIONAL :: ini
241 IF (
PRESENT(ini))
THEN 248 if (
present(dim))
call copy (dim,this%griddim%dim)
251 IF (
PRESENT(ntime))
THEN 253 IF (
ASSOCIATED(this%time))
DEALLOCATE(this%time)
257 ALLOCATE(this%time(ntime),stat=stallo)
260 CALL raise_fatal_error()
264 this%time(i) = datetime_miss
271 IF (
PRESENT(nlevel))
THEN 272 IF (nlevel >= 0)
THEN 273 IF (
ASSOCIATED(this%level))
DEALLOCATE(this%level)
277 ALLOCATE(this%level(nlevel),stat=stallo)
280 CALL raise_fatal_error()
284 CALL init(this%level(i))
289 IF (
PRESENT(ntimerange))
THEN 290 IF (ntimerange >= 0)
THEN 291 IF (
ASSOCIATED(this%timerange))
DEALLOCATE(this%timerange)
295 ALLOCATE(this%timerange(ntimerange),stat=stallo)
298 CALL raise_fatal_error()
307 IF (
PRESENT(nvar))
THEN 309 IF (
ASSOCIATED(this%var))
DEALLOCATE(this%var)
313 ALLOCATE(this%var(nvar),stat=stallo)
316 CALL raise_fatal_error()
320 CALL init(this%var(i))
326 end SUBROUTINE volgrid6d_alloc
337 SUBROUTINE volgrid6d_alloc_vol(this, ini, inivol, decode)
338 TYPE(volgrid6d),
INTENT(inout) :: this
339 LOGICAL,
INTENT(in),
OPTIONAL :: ini
340 LOGICAL,
INTENT(in),
OPTIONAL :: inivol
341 LOGICAL,
INTENT(in),
OPTIONAL :: decode
350 IF (
PRESENT(inivol))
THEN 356 IF (this%griddim%dim%nx > 0 .AND. this%griddim%dim%ny > 0)
THEN 359 IF (.NOT.
ASSOCIATED(this%var))
CALL volgrid6d_alloc(this, nvar=1, ini=ini)
360 IF (.NOT.
ASSOCIATED(this%time))
CALL volgrid6d_alloc(this, ntime=1, ini=ini)
361 IF (.NOT.
ASSOCIATED(this%level))
CALL volgrid6d_alloc(this, nlevel=1, ini=ini)
362 IF (.NOT.
ASSOCIATED(this%timerange))
CALL volgrid6d_alloc(this, ntimerange=1, ini=ini)
364 IF (optio_log(decode))
THEN 365 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 370 ALLOCATE(this%voldati(this%griddim%dim%nx,this%griddim%dim%ny,&
371 SIZE(this%level),
SIZE(this%time), &
372 SIZE(this%timerange),
SIZE(this%var)),stat=stallo)
375 CALL raise_fatal_error()
380 IF (linivol) this%voldati = rmiss
385 IF (.NOT.
ASSOCIATED(this%gaid))
THEN 389 ALLOCATE(this%gaid(
SIZE(this%level),
SIZE(this%time), &
390 SIZE(this%timerange),
SIZE(this%var)),stat=stallo)
393 CALL raise_fatal_error()
407 this%gaid = grid_id_new()
413 &trying to allocate a volume with an invalid or unspecified horizontal grid')
414 CALL raise_fatal_error()
417 END SUBROUTINE volgrid6d_alloc_vol
433 SUBROUTINE volgrid_get_vol_2d(this, ilevel, itime, itimerange, ivar, voldati)
434 TYPE(volgrid6d),
INTENT(in) :: this
435 INTEGER,
INTENT(in) :: ilevel
436 INTEGER,
INTENT(in) :: itime
437 INTEGER,
INTENT(in) :: itimerange
438 INTEGER,
INTENT(in) :: ivar
439 REAL,
POINTER :: voldati(:,:)
441 IF (
ASSOCIATED(this%voldati))
THEN 442 voldati => this%voldati(:,:,ilevel,itime,itimerange,ivar)
445 IF (.NOT.
ASSOCIATED(voldati))
THEN 446 ALLOCATE(voldati(this%griddim%dim%nx,this%griddim%dim%ny))
448 CALL grid_id_decode_data(this%gaid(ilevel,itime,itimerange,ivar), voldati)
451 END SUBROUTINE volgrid_get_vol_2d
467 SUBROUTINE volgrid_get_vol_3d(this, itime, itimerange, ivar, voldati)
469 INTEGER,
INTENT(in) :: itime
470 INTEGER,
INTENT(in) :: itimerange
471 INTEGER,
INTENT(in) :: ivar
472 REAL,
POINTER :: voldati(:,:,:)
476 IF (
ASSOCIATED(this%voldati))
THEN 477 voldati => this%voldati(:,:,:,itime,itimerange,ivar)
480 IF (.NOT.
ASSOCIATED(voldati))
THEN 481 ALLOCATE(voldati(this%griddim%dim%nx,this%griddim%dim%ny,
SIZE(this%level)))
483 DO ilevel = 1,
SIZE(this%level)
484 CALL grid_id_decode_data(this%gaid(ilevel,itime,itimerange,ivar), &
489 END SUBROUTINE volgrid_get_vol_3d
503 SUBROUTINE volgrid_set_vol_2d(this, ilevel, itime, itimerange, ivar, voldati)
505 INTEGER,
INTENT(in) :: ilevel
506 INTEGER,
INTENT(in) :: itime
507 INTEGER,
INTENT(in) :: itimerange
508 INTEGER,
INTENT(in) :: ivar
509 REAL,
INTENT(in) :: voldati(:,:)
511 IF (
ASSOCIATED(this%voldati))
THEN 514 CALL grid_id_encode_data(this%gaid(ilevel,itime,itimerange,ivar), voldati)
517 END SUBROUTINE volgrid_set_vol_2d
531 SUBROUTINE volgrid_set_vol_3d(this, itime, itimerange, ivar, voldati)
533 INTEGER,
INTENT(in) :: itime
534 INTEGER,
INTENT(in) :: itimerange
535 INTEGER,
INTENT(in) :: ivar
536 REAL,
INTENT(in) :: voldati(:,:,:)
540 IF (
ASSOCIATED(this%voldati))
THEN 543 DO ilevel = 1,
SIZE(this%level)
544 CALL grid_id_encode_data(this%gaid(ilevel,itime,itimerange,ivar), &
549 END SUBROUTINE volgrid_set_vol_3d
555 SUBROUTINE volgrid6d_delete(this)
558 INTEGER :: i, ii, iii, iiii
564 if (
associated(this%gaid))
then 566 DO i=1 ,
SIZE(this%gaid,1)
567 DO ii=1 ,
SIZE(this%gaid,2)
568 DO iii=1 ,
SIZE(this%gaid,3)
569 DO iiii=1 ,
SIZE(this%gaid,4)
570 CALL delete(this%gaid(i,ii,iii,iiii))
575 DEALLOCATE(this%gaid)
586 if (
associated( this%time ))
deallocate(this%time)
587 if (
associated( this%timerange ))
deallocate(this%timerange)
588 if (
associated( this%level ))
deallocate(this%level)
589 if (
associated( this%var ))
deallocate(this%var)
591 if (
associated(this%voldati))
deallocate(this%voldati)
595 call l4f_category_delete(this%category)
597 END SUBROUTINE volgrid6d_delete
609 subroutine volgrid6d_write_on_file (this,unit,description,filename,filename_auto)
612 integer,
optional,
intent(inout) :: unit
613 character(len=*),
intent(in),
optional :: filename
614 character(len=*),
intent(out),
optional :: filename_auto
615 character(len=*),
INTENT(IN),
optional :: description
618 character(len=254) :: ldescription,arg,lfilename
619 integer :: ntime, ntimerange, nlevel, nvar
621 logical :: opened,exist
633 call date_and_time(values=tarray)
636 if (
present(description))
then 637 ldescription=description
639 ldescription=
"Volgrid6d generated by: "//trim(arg)
642 if (.not.
present(unit))
then 653 lfilename=trim(arg)//
".vg6d" 654 if (
index(arg,
'/',back=.true.) > 0) lfilename=lfilename(
index(arg,
'/',back=.true.)+1 : )
656 if (
present(filename))
then 657 if (filename /=
"")
then 662 if (
present(filename_auto))filename_auto=lfilename
665 inquire(unit=lunit,opened=opened)
666 if (.not. opened)
then 667 inquire(file=lfilename,exist=exist)
668 if (exist)
CALL raise_error(
'file exist; cannot open new file')
669 if (.not.exist)
open (unit=lunit,file=lfilename,form=
"UNFORMATTED")
673 if (
associated(this%time)) ntime=
size(this%time)
674 if (
associated(this%timerange)) ntimerange=
size(this%timerange)
675 if (
associated(this%level)) nlevel=
size(this%level)
676 if (
associated(this%var)) nvar=
size(this%var)
679 write(unit=lunit)ldescription
680 write(unit=lunit)tarray
683 write(unit=lunit) ntime, ntimerange, nlevel, nvar
686 if (
associated(this%time))
call write_unit(this%time, lunit)
687 if (
associated(this%level))
write(unit=lunit)this%level
688 if (
associated(this%timerange))
write(unit=lunit)this%timerange
689 if (
associated(this%var))
write(unit=lunit)this%var
694 if (
associated(this%voldati))
write(unit=lunit)this%voldati
696 if (.not.
present(unit))
close(unit=lunit)
698 end subroutine volgrid6d_write_on_file
707 subroutine volgrid6d_read_from_file (this,unit,filename,description,tarray,filename_auto)
710 integer,
intent(inout),
optional :: unit
711 character(len=*),
INTENT(in),
optional :: filename
712 character(len=*),
intent(out),
optional :: filename_auto
713 character(len=*),
INTENT(out),
optional :: description
714 integer,
intent(out),
optional :: tarray(8)
716 integer :: ntime, ntimerange, nlevel, nvar
718 character(len=254) :: ldescription,lfilename,arg
719 integer :: ltarray(8),lunit
720 logical :: opened,exist
728 if (.not.
present(unit))
then 739 lfilename=trim(arg)//
".vg6d" 740 if (
index(arg,
'/',back=.true.) > 0) lfilename=lfilename(
index(arg,
'/',back=.true.)+1 : )
742 if (
present(filename))
then 743 if (filename /=
"")
then 748 if (
present(filename_auto))filename_auto=lfilename
751 inquire(unit=lunit,opened=opened)
752 if (.not. opened)
then 753 inquire(file=lfilename,exist=exist)
754 IF (.NOT. exist)
CALL raise_fatal_error(
'file '//trim(lfilename)//
' does not exist, cannot open')
755 open (unit=lunit,file=lfilename,form=
"UNFORMATTED")
758 read(unit=lunit)ldescription
759 read(unit=lunit)ltarray
761 call l4f_log(l4f_info,
"Info: reading volgrid6d from file: "//trim(lfilename))
762 call l4f_log(l4f_info,
"Info: description: "//trim(ldescription))
765 if (
present(description))description=ldescription
766 if (
present(tarray))tarray=ltarray
770 read(unit=lunit) ntime, ntimerange, nlevel, nvar
773 call volgrid6d_alloc (this, &
774 ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nvar=nvar)
776 call volgrid6d_alloc_vol (this)
778 if (
associated(this%time))
call read_unit(this%time, lunit)
779 if (
associated(this%level))
read(unit=lunit)this%level
780 if (
associated(this%timerange))
read(unit=lunit)this%timerange
781 if (
associated(this%var))
read(unit=lunit)this%var
786 if (
associated(this%voldati))
read(unit=lunit)this%voldati
788 if (.not.
present(unit))
close(unit=lunit)
790 end subroutine volgrid6d_read_from_file
812 SUBROUTINE import_from_gridinfo(this, gridinfo, force, dup_mode, clone, &
814 TYPE(volgrid6d),
INTENT(inout) :: this
815 TYPE(gridinfo_def),
INTENT(in) :: gridinfo
816 LOGICAL,
INTENT(in),
OPTIONAL :: force
817 INTEGER,
INTENT(in),
OPTIONAL :: dup_mode
818 LOGICAL ,
INTENT(in),
OPTIONAL :: clone
819 LOGICAL,
INTENT(IN),
OPTIONAL :: isanavar
821 CHARACTER(len=255) :: type
822 INTEGER :: itime0, itimerange0, itime1, itimerange1, itime, itimerange, &
823 ilevel, ivar, ldup_mode
825 TYPE(datetime) :: correctedtime
826 REAL,
ALLOCATABLE :: tmpgrid(:,:)
828 IF (
PRESENT(dup_mode))
THEN 834 call get_val(this%griddim,proj_type=type)
837 call l4f_category_log(this%category,l4f_debug,
"import_from_gridinfo: "//trim(type))
840 if (.not.
c_e(type))
then 841 call copy(gridinfo%griddim, this%griddim)
845 CALL volgrid6d_alloc_vol(this, ini=.true.)
847 else if (.not. (this%griddim == gridinfo%griddim ))
then 850 "volgrid and gridinfo grid type or size are different, gridinfo rejected")
857 ilevel =
index(this%level, gridinfo%level)
858 IF (ilevel == 0 .AND. optio_log(force))
THEN 859 ilevel =
index(this%level, vol7d_level_miss)
860 IF (ilevel /= 0) this%level(ilevel) = gridinfo%level
863 IF (ilevel == 0)
THEN 865 "volgrid6d: level not valid for volume, gridinfo rejected")
870 IF (optio_log(isanavar))
THEN 872 itime1 =
SIZE(this%time)
874 itimerange1 =
SIZE(this%timerange)
876 correctedtime = gridinfo%time
877 IF (this%time_definition == 1) correctedtime = correctedtime + &
878 timedelta_new(sec=gridinfo%timerange%p1)
879 itime0 =
index(this%time, correctedtime)
880 IF (itime0 == 0 .AND. optio_log(force))
THEN 881 itime0 =
index(this%time, datetime_miss)
882 IF (itime0 /= 0) this%time(itime0) = correctedtime
884 IF (itime0 == 0)
THEN 886 "volgrid6d: time not valid for volume, gridinfo rejected")
892 itimerange0 =
index(this%timerange,gridinfo%timerange)
893 IF (itimerange0 == 0 .AND. optio_log(force))
THEN 894 itimerange0 =
index(this%timerange, vol7d_timerange_miss)
895 IF (itimerange0 /= 0) this%timerange(itimerange0) = gridinfo%timerange
897 IF (itimerange0 == 0)
THEN 899 "volgrid6d: timerange not valid for volume, gridinfo rejected")
903 itimerange1 = itimerange0
906 ivar =
index(this%var, gridinfo%var)
907 IF (ivar == 0 .AND. optio_log(force))
THEN 908 ivar =
index(this%var, volgrid6d_var_miss)
909 IF (ivar /= 0) this%var(ivar) = gridinfo%var
913 "volgrid6d: var not valid for volume, gridinfo rejected")
918 DO itimerange = itimerange0, itimerange1
919 DO itime = itime0, itime1
920 IF (
ASSOCIATED(this%gaid))
THEN 922 IF (
c_e(this%gaid(ilevel,itime,itimerange,ivar)))
THEN 926 IF (optio_log(
clone))
CALL delete(this%gaid(ilevel,itime,itimerange,ivar))
929 IF (optio_log(
clone))
THEN 930 CALL copy(gridinfo%gaid, this%gaid(ilevel,itime,itimerange,ivar))
935 this%gaid(ilevel,itime,itimerange,ivar) = gridinfo%gaid
938 IF (
ASSOCIATED(this%voldati))
THEN 939 IF (.NOT.dup .OR. ldup_mode == 0)
THEN 940 this%voldati(:,:,ilevel,itime,itimerange,ivar) =
decode_gridinfo(gridinfo)
941 ELSE IF (ldup_mode == 1)
THEN 944 this%voldati(:,:,ilevel,itime,itimerange,ivar) = tmpgrid(:,:)
946 ELSE IF (ldup_mode == 2)
THEN 947 WHERE(.NOT.
c_e(this%voldati(:,:,ilevel,itime,itimerange,ivar)))
948 this%voldati(:,:,ilevel,itime,itimerange,ivar) =
decode_gridinfo(gridinfo)
955 "gaid not allocated, you probably need to call volgrid6d_alloc_vol first")
963 END SUBROUTINE import_from_gridinfo
970 SUBROUTINE export_to_gridinfo(this, gridinfo, itime, itimerange, ilevel, ivar, &
971 gaid_template, clone)
972 TYPE(volgrid6d),
INTENT(in) :: this
973 TYPE(gridinfo_def),
INTENT(inout) :: gridinfo
975 INTEGER :: itimerange
978 TYPE(grid_id),
INTENT(in),
OPTIONAL :: gaid_template
979 LOGICAL,
INTENT(in),
OPTIONAL :: clone
981 TYPE(grid_id) :: gaid
982 LOGICAL :: usetemplate
983 REAL,
POINTER :: voldati(:,:)
984 TYPE(datetime) :: correctedtime
990 IF (.NOT.
c_e(this%gaid(ilevel,itime,itimerange,ivar)))
THEN 992 CALL l4f_category_log(this%category,l4f_debug,
"empty gaid found, skipping export")
997 usetemplate = .false.
998 IF (
PRESENT(gaid_template))
THEN 999 CALL copy(gaid_template, gaid)
1001 CALL l4f_category_log(this%category,l4f_debug,
"template cloned to a new gaid")
1003 usetemplate =
c_e(gaid)
1006 IF (.NOT.usetemplate)
THEN 1007 IF (optio_log(
clone))
THEN 1008 CALL copy(this%gaid(ilevel,itime,itimerange,ivar), gaid)
1010 CALL l4f_category_log(this%category,l4f_debug,
"original gaid cloned to a new one")
1013 gaid = this%gaid(ilevel,itime,itimerange,ivar)
1017 IF (this%time_definition == 1)
THEN 1018 correctedtime = this%time(itime) - &
1019 timedelta_new(sec=this%timerange(itimerange)%p1)
1021 correctedtime = this%time(itime)
1024 CALL init(gridinfo,gaid, this%griddim, correctedtime, this%timerange(itimerange), &
1025 this%level(ilevel), this%var(ivar))
1028 CALL export(gridinfo%griddim, gridinfo%gaid)
1030 IF (
ASSOCIATED(this%voldati))
THEN 1031 CALL encode_gridinfo(gridinfo, this%voldati(:,:,ilevel,itime,itimerange,ivar))
1032 ELSE IF (usetemplate)
THEN 1034 CALL volgrid_get_vol_2d(this, ilevel, itime, itimerange, ivar, voldati)
1039 END SUBROUTINE export_to_gridinfo
1059 SUBROUTINE import_from_gridinfovv(this, gridinfov, dup_mode, clone, decode, &
1060 time_definition, anavar, categoryappend)
1061 TYPE(volgrid6d),
POINTER :: this(:)
1062 TYPE(arrayof_gridinfo),
INTENT(in) :: gridinfov
1063 INTEGER,
INTENT(in),
OPTIONAL :: dup_mode
1064 LOGICAL ,
INTENT(in),
OPTIONAL :: clone
1065 LOGICAL,
INTENT(in),
OPTIONAL :: decode
1066 INTEGER,
INTENT(IN),
OPTIONAL :: time_definition
1067 CHARACTER(len=*),
INTENT(IN),
OPTIONAL :: anavar(:)
1068 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1070 INTEGER :: i, j, stallo
1071 INTEGER :: ngrid, ntime, ntimerange, nlevel, nvar
1073 CHARACTER(len=512) :: a_name
1074 TYPE(datetime),
ALLOCATABLE :: correctedtime(:)
1075 LOGICAL,
ALLOCATABLE :: isanavar(:)
1076 TYPE(vol7d_var) :: lvar
1079 if (
present(categoryappend))
then 1080 call l4f_launcher(a_name,a_name_append=trim(subcategory)//
"."//trim(categoryappend))
1082 call l4f_launcher(a_name,a_name_append=trim(subcategory))
1084 category=l4f_category_get(a_name)
1090 ngrid=count_distinct(gridinfov%array(1:gridinfov%arraysize)%griddim,back=.true.)
1092 ' different grid definition(s) found in input data')
1094 ALLOCATE(this(ngrid),stat=stallo)
1095 IF (stallo /= 0)
THEN 1097 CALL raise_fatal_error()
1100 IF (
PRESENT(categoryappend))
THEN 1101 CALL init(this(i), time_definition=time_definition, categoryappend=trim(categoryappend)//
"-vol"//
t2c(i))
1103 CALL init(this(i), time_definition=time_definition, categoryappend=
"vol"//
t2c(i))
1107 this(:)%griddim=pack_distinct(gridinfov%array(1:gridinfov%arraysize)%griddim, &
1111 ALLOCATE(isanavar(gridinfov%arraysize))
1112 isanavar(:) = .false.
1113 IF (
PRESENT(anavar))
THEN 1114 DO i = 1, gridinfov%arraysize
1115 DO j = 1,
SIZE(anavar)
1116 lvar =
convert(gridinfov%array(i)%var)
1117 IF (lvar%btable == anavar(j))
THEN 1118 isanavar(i) = .true.
1124 t2c(gridinfov%arraysize)//
' constant-data messages found in input data')
1128 ALLOCATE(correctedtime(gridinfov%arraysize))
1129 correctedtime(:) = gridinfov%array(1:gridinfov%arraysize)%time
1130 IF (
PRESENT(time_definition))
THEN 1131 IF (time_definition == 1)
THEN 1132 DO i = 1, gridinfov%arraysize
1133 correctedtime(i) = correctedtime(i) + &
1134 timedelta_new(sec=gridinfov%array(i)%timerange%p1)
1140 IF (
PRESENT(anavar))
THEN 1141 j = count((this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1142 .AND. .NOT.isanavar(:))
1145 ' has only constant data, this is not allowed')
1147 CALL raise_fatal_error()
1150 ntime = count_distinct(correctedtime, &
1151 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1152 .AND. .NOT.isanavar(:), back=.true.)
1153 ntimerange = count_distinct(gridinfov%array(1:gridinfov%arraysize)%timerange, &
1154 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1155 .AND. .NOT.isanavar(:), back=.true.)
1156 nlevel = count_distinct(gridinfov%array(1:gridinfov%arraysize)%level, &
1157 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim), &
1159 nvar = count_distinct(gridinfov%array(1:gridinfov%arraysize)%var, &
1160 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim), &
1167 CALL volgrid6d_alloc(this(i),this(i)%griddim%dim,ntime=ntime, &
1168 ntimerange=ntimerange,nlevel=nlevel,nvar=nvar)
1170 this(i)%time = pack_distinct(correctedtime, ntime, &
1171 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1172 .AND. .NOT.isanavar(:), back=.true.)
1173 CALL sort(this(i)%time)
1175 this(i)%timerange = pack_distinct(gridinfov%array( &
1176 1:gridinfov%arraysize)%timerange, ntimerange, &
1177 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1178 .AND. .NOT.isanavar(:), back=.true.)
1179 CALL sort(this(i)%timerange)
1181 this(i)%level=pack_distinct(gridinfov%array(1:gridinfov%arraysize)%level, &
1182 nlevel,mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim), &
1184 CALL sort(this(i)%level)
1186 this(i)%var=pack_distinct(gridinfov%array(1:gridinfov%arraysize)%var, nvar, &
1187 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim), &
1193 CALL volgrid6d_alloc_vol(this(i), decode=decode)
1197 DEALLOCATE(correctedtime)
1199 DO i = 1, gridinfov%arraysize
1204 "to volgrid6d index: "//
t2c(
index(this%griddim, gridinfov%array(i)%griddim)))
1207 CALL import(this(
index(this%griddim, gridinfov%array(i)%griddim)), &
1208 gridinfov%array(i), dup_mode=dup_mode,
clone=
clone, isanavar=isanavar(i))
1213 CALL l4f_category_delete(category)
1215 END SUBROUTINE import_from_gridinfovv
1223 SUBROUTINE export_to_gridinfov(this, gridinfov, gaid_template, clone)
1224 TYPE(volgrid6d),
INTENT(inout) :: this
1225 TYPE(arrayof_gridinfo),
INTENT(inout) :: gridinfov
1226 TYPE(grid_id),
INTENT(in),
OPTIONAL :: gaid_template
1227 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1229 INTEGER :: i ,itime, itimerange, ilevel, ivar
1230 INTEGER :: ntime, ntimerange, nlevel, nvar
1231 TYPE(gridinfo_def) :: gridinfol
1240 CALL dealloc(this%griddim%dim)
1243 ntime=
size(this%time)
1244 ntimerange=
size(this%timerange)
1245 nlevel=
size(this%level)
1249 DO itimerange=1,ntimerange
1253 CALL init(gridinfol)
1254 CALL export(this, gridinfol, itime, itimerange, ilevel, ivar, &
1256 IF (
c_e(gridinfol%gaid))
THEN 1257 CALL insert(gridinfov, gridinfol)
1267 END SUBROUTINE export_to_gridinfov
1275 SUBROUTINE export_to_gridinfovv(this, gridinfov, gaid_template, clone)
1278 TYPE(volgrid6d),
INTENT(inout) :: this(:)
1279 TYPE(arrayof_gridinfo),
INTENT(inout) :: gridinfov
1280 TYPE(grid_id),
INTENT(in),
OPTIONAL :: gaid_template
1281 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1285 DO i = 1,
SIZE(this)
1288 "export_to_gridinfovv grid index: "//
t2c(i))
1293 END SUBROUTINE export_to_gridinfovv
1305 SUBROUTINE volgrid6d_import_from_file(this, filename, dup_mode, decode, &
1306 time_definition, anavar, categoryappend)
1307 TYPE(volgrid6d),
POINTER :: this(:)
1308 CHARACTER(len=*),
INTENT(in) :: filename
1309 INTEGER,
INTENT(in),
OPTIONAL :: dup_mode
1310 LOGICAL,
INTENT(in),
OPTIONAL :: decode
1311 INTEGER,
INTENT(IN),
OPTIONAL :: time_definition
1312 CHARACTER(len=*),
INTENT(IN),
OPTIONAL :: anavar(:)
1313 character(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1315 TYPE(arrayof_gridinfo) :: gridinfo
1317 CHARACTER(len=512) :: a_name
1321 IF (
PRESENT(categoryappend))
THEN 1322 CALL l4f_launcher(a_name,a_name_append= &
1323 trim(subcategory)//
"."//trim(categoryappend))
1325 CALL l4f_launcher(a_name,a_name_append=trim(subcategory))
1327 category=l4f_category_get(a_name)
1329 CALL import(gridinfo, filename=filename, categoryappend=categoryappend)
1331 IF (gridinfo%arraysize > 0)
THEN 1333 CALL import(this, gridinfo, dup_mode=dup_mode,
clone=.true., decode=decode, &
1334 time_definition=time_definition, anavar=anavar, &
1335 categoryappend=categoryappend)
1341 CALL l4f_category_log(category,l4f_info,
"file does not contain gridded data")
1345 CALL l4f_category_delete(category)
1347 END SUBROUTINE volgrid6d_import_from_file
1357 SUBROUTINE volgrid6d_export_to_file(this, filename, gaid_template, categoryappend)
1358 TYPE(volgrid6d) :: this(:)
1359 CHARACTER(len=*),
INTENT(in) :: filename
1360 TYPE(grid_id),
INTENT(in),
OPTIONAL :: gaid_template
1361 character(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1363 TYPE(arrayof_gridinfo) :: gridinfo
1365 CHARACTER(len=512) :: a_name
1367 IF (
PRESENT(categoryappend))
THEN 1368 CALL l4f_launcher(a_name,a_name_append=trim(subcategory)//
"."//trim(categoryappend))
1370 CALL l4f_launcher(a_name,a_name_append=trim(subcategory))
1372 category=l4f_category_get(a_name)
1378 CALL l4f_category_log(category,l4f_info,
"writing volgrid6d to grib file: "//trim(filename))
1381 CALL export(this, gridinfo, gaid_template=gaid_template,
clone=.true.)
1382 IF (gridinfo%arraysize > 0)
THEN 1383 CALL export(gridinfo, filename)
1391 CALL l4f_category_delete(category)
1393 END SUBROUTINE volgrid6d_export_to_file
1399 SUBROUTINE volgrid6dv_delete(this)
1400 TYPE(volgrid6d),
POINTER :: this(:)
1404 IF (
ASSOCIATED(this))
THEN 1405 DO i = 1,
SIZE(this)
1408 "delete volgrid6d vector index: "//trim(
to_char(i)))
1415 END SUBROUTINE volgrid6dv_delete
1419 SUBROUTINE volgrid6d_transform_compute(this, volgrid6d_in, volgrid6d_out, &
1420 lev_out, var_coord_vol, clone)
1421 TYPE(grid_transform),
INTENT(in) :: this
1422 type(volgrid6d),
INTENT(in) :: volgrid6d_in
1423 type(volgrid6d),
INTENT(inout) :: volgrid6d_out
1424 TYPE(vol7d_level),
INTENT(in),
OPTIONAL :: lev_out(:)
1425 INTEGER,
INTENT(in),
OPTIONAL :: var_coord_vol
1426 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1428 INTEGER :: ntime, ntimerange, inlevel, onlevel, nvar, &
1429 itime, itimerange, ilevel, ivar, levshift, levused, lvar_coord_vol, spos
1430 REAL,
POINTER :: voldatiin(:,:,:), voldatiout(:,:,:), coord_3d_in(:,:,:)
1431 TYPE(vol7d_level) :: output_levtype
1435 call l4f_category_log(volgrid6d_in%category,l4f_debug,
"start volgrid6d_transform_compute")
1443 lvar_coord_vol = optio_i(var_coord_vol)
1445 if (
associated(volgrid6d_in%time))
then 1446 ntime=
size(volgrid6d_in%time)
1447 volgrid6d_out%time=volgrid6d_in%time
1450 if (
associated(volgrid6d_in%timerange))
then 1451 ntimerange=
size(volgrid6d_in%timerange)
1452 volgrid6d_out%timerange=volgrid6d_in%timerange
1455 IF (
ASSOCIATED(volgrid6d_in%level))
THEN 1456 inlevel=
SIZE(volgrid6d_in%level)
1458 IF (
PRESENT(lev_out))
THEN 1459 onlevel=
SIZE(lev_out)
1460 volgrid6d_out%level=lev_out
1461 ELSE IF (
ASSOCIATED(volgrid6d_in%level))
THEN 1462 onlevel=
SIZE(volgrid6d_in%level)
1463 volgrid6d_out%level=volgrid6d_in%level
1466 if (
associated(volgrid6d_in%var))
then 1467 nvar=
size(volgrid6d_in%var)
1468 volgrid6d_out%var=volgrid6d_in%var
1471 IF (.NOT.
ASSOCIATED(volgrid6d_in%voldati))
THEN 1472 ALLOCATE(voldatiin(volgrid6d_in%griddim%dim%nx, volgrid6d_in%griddim%dim%ny, &
1475 IF (.NOT.
ASSOCIATED(volgrid6d_out%voldati))
THEN 1476 ALLOCATE(voldatiout(volgrid6d_out%griddim%dim%nx, volgrid6d_out%griddim%dim%ny, &
1480 CALL get_val(this, levshift=levshift, levused=levused)
1482 IF (
c_e(lvar_coord_vol))
THEN 1483 CALL get_val(this%trans, output_levtype=output_levtype)
1484 IF (output_levtype%level1 == 103 .OR. output_levtype%level1 == 108)
THEN 1485 spos = firsttrue(volgrid6d_in%level(:) == vol7d_level_new(1))
1488 'output level '//
t2c(output_levtype%level1)// &
1489 ' requested, but height/press of surface not provided in volume')
1491 IF (.NOT.
c_e(levshift) .AND. .NOT.
c_e(levused))
THEN 1493 'internal inconsistence, levshift and levused undefined when they should be')
1502 DO itimerange=1,ntimerange
1505 IF (
c_e(levshift) .AND.
c_e(levused))
THEN 1507 volgrid6d_in%gaid(levshift+1:levshift+levused,itime,itimerange,ivar) &
1510 DO ilevel = 1, min(inlevel,onlevel)
1512 IF (
c_e(volgrid6d_in%gaid(ilevel,itime,itimerange,ivar)) .AND. .NOT. &
1513 c_e(volgrid6d_out%gaid(ilevel,itime,itimerange,ivar)))
THEN 1515 IF (optio_log(
clone))
THEN 1516 CALL copy(volgrid6d_in%gaid(ilevel,itime,itimerange,ivar),&
1517 volgrid6d_out%gaid(ilevel,itime,itimerange,ivar))
1520 "cloning gaid, level "//
t2c(ilevel))
1523 volgrid6d_out%gaid(ilevel,itime,itimerange,ivar) = &
1524 volgrid6d_in%gaid(ilevel,itime,itimerange,ivar)
1529 DO ilevel = min(inlevel,onlevel) + 1, onlevel
1530 IF (
c_e(volgrid6d_in%gaid(inlevel,itime,itimerange,ivar)) .AND. .NOT. &
1531 c_e(volgrid6d_out%gaid(ilevel,itime,itimerange,ivar)))
then 1533 CALL copy(volgrid6d_in%gaid(inlevel,itime,itimerange,ivar),&
1534 volgrid6d_out%gaid(ilevel,itime,itimerange,ivar))
1537 "forced cloning gaid, level "//
t2c(inlevel)//
"->"//
t2c(ilevel))
1542 IF (
c_e(lvar_coord_vol))
THEN 1543 NULLIFY(coord_3d_in)
1544 CALL volgrid_get_vol_3d(volgrid6d_in, itime, itimerange, lvar_coord_vol, &
1548 coord_3d_in(:,:,levshift+1:levshift+levused) = rmiss
1550 DO ilevel = levshift+1, levshift+levused
1551 WHERE(
c_e(coord_3d_in(:,:,ilevel)) .AND.
c_e(coord_3d_in(:,:,spos)))
1552 coord_3d_in(:,:,ilevel) = coord_3d_in(:,:,ilevel) - &
1553 coord_3d_in(:,:,spos)
1555 coord_3d_in(:,:,ilevel) = rmiss
1561 CALL volgrid_get_vol_3d(volgrid6d_in, itime, itimerange, ivar, &
1563 IF (
ASSOCIATED(volgrid6d_out%voldati)) &
1564 CALL volgrid_get_vol_3d(volgrid6d_out, itime, itimerange, ivar, &
1566 IF (
c_e(lvar_coord_vol))
THEN 1567 CALL compute(this, voldatiin, voldatiout,
convert(volgrid6d_in%var(ivar)), &
1568 coord_3d_in(:,:,levshift+1:levshift+levused))
1570 CALL compute(this, voldatiin, voldatiout,
convert(volgrid6d_in%var(ivar)))
1572 CALL volgrid_set_vol_3d(volgrid6d_out, itime, itimerange, ivar, &
1578 IF (
c_e(lvar_coord_vol))
THEN 1579 DEALLOCATE(coord_3d_in)
1581 IF (.NOT.
ASSOCIATED(volgrid6d_in%voldati))
THEN 1582 DEALLOCATE(voldatiin)
1584 IF (.NOT.
ASSOCIATED(volgrid6d_out%voldati))
THEN 1585 DEALLOCATE(voldatiout)
1589 END SUBROUTINE volgrid6d_transform_compute
1598 SUBROUTINE volgrid6d_transform(this, griddim, volgrid6d_in, volgrid6d_out, &
1599 lev_out, volgrid6d_coord_in, maskgrid, maskbounds, clone, decode, categoryappend)
1600 TYPE(transform_def),
INTENT(in) :: this
1601 TYPE(griddim_def),
INTENT(in),
OPTIONAL :: griddim
1603 TYPE(volgrid6d),
INTENT(inout) :: volgrid6d_in
1604 TYPE(volgrid6d),
INTENT(out) :: volgrid6d_out
1605 TYPE(vol7d_level),
INTENT(in),
OPTIONAL,
TARGET :: lev_out(:)
1606 TYPE(volgrid6d),
INTENT(in),
OPTIONAL :: volgrid6d_coord_in
1607 REAL,
INTENT(in),
OPTIONAL :: maskgrid(:,:)
1608 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
1609 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1610 LOGICAL,
INTENT(in),
OPTIONAL :: decode
1611 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1613 TYPE(grid_transform) :: grid_trans
1614 TYPE(vol7d_level),
POINTER :: llev_out(:)
1615 TYPE(vol7d_level) :: input_levtype, output_levtype
1616 TYPE(vol7d_var) :: vcoord_var
1617 INTEGER :: i, k, ntime, ntimerange, nlevel, nvar, var_coord_in, var_coord_vol, &
1618 cf_out, nxc, nyc, nxi, nyi, i3, i4, i5, i6, &
1619 ulstart, ulend, spos
1620 REAL,
ALLOCATABLE :: coord_3d_in(:,:,:)
1621 TYPE(geo_proj) :: proj_in, proj_out
1622 CHARACTER(len=80) :: trans_type
1624 LOGICAL,
ALLOCATABLE :: mask_in(:)
1627 call l4f_category_log(volgrid6d_in%category, l4f_debug,
"start volgrid6d_transform")
1635 if (
associated(volgrid6d_in%time)) ntime=
size(volgrid6d_in%time)
1636 if (
associated(volgrid6d_in%timerange)) ntimerange=
size(volgrid6d_in%timerange)
1637 if (
associated(volgrid6d_in%level)) nlevel=
size(volgrid6d_in%level)
1638 if (
associated(volgrid6d_in%var)) nvar=
size(volgrid6d_in%var)
1640 IF (ntime == 0 .OR. ntimerange == 0 .OR. nlevel == 0 .OR. nvar == 0)
THEN 1642 "trying to transform an incomplete volgrid6d object, ntime="//
t2c(ntime)// &
1643 ' ntimerange='//
t2c(ntimerange)//
' nlevel='//
t2c(nlevel)//
' nvar='//
t2c(nvar))
1644 CALL init(volgrid6d_out)
1649 CALL get_val(this, trans_type=trans_type)
1653 IF (
PRESENT(griddim) .AND. (trans_type ==
'inter' .OR. trans_type ==
'boxinter' &
1654 .OR. trans_type ==
'stencilinter'))
THEN 1656 CALL get_val(griddim, component_flag=cf_out,
proj=proj_out)
1658 IF (proj_in /= proj_out)
CALL vg6d_wind_unrot(volgrid6d_in)
1659 ELSE IF (
PRESENT(griddim))
THEN 1660 CALL get_val(griddim, component_flag=cf_out)
1664 var_coord_in = imiss
1665 var_coord_vol = imiss
1666 IF (trans_type ==
'vertint')
THEN 1667 IF (
PRESENT(lev_out))
THEN 1670 IF (
PRESENT(volgrid6d_coord_in))
THEN 1671 IF (
ASSOCIATED(volgrid6d_coord_in%voldati))
THEN 1674 IF (
SIZE(volgrid6d_coord_in%voldati,4) /= 1 .OR. &
1675 SIZE(volgrid6d_coord_in%voldati,5) /= 1)
THEN 1677 'volume providing constant input vertical coordinate must have & 1678 &only 1 time and 1 timerange')
1679 CALL init(volgrid6d_out)
1685 CALL get_val(this, output_levtype=output_levtype)
1686 vcoord_var = vol7d_var_new(vol7d_level_to_var(output_levtype))
1687 IF (.NOT.
c_e(vcoord_var))
THEN 1689 'requested output level type '//
t2c(output_levtype%level1)// &
1690 ' does not correspond to any known physical variable for & 1691 &providing vertical coordinate')
1692 CALL init(volgrid6d_out)
1697 DO i = 1,
SIZE(volgrid6d_coord_in%var)
1698 IF (
convert(volgrid6d_coord_in%var(i)) == vcoord_var)
THEN 1704 IF (.NOT.
c_e(var_coord_in))
THEN 1706 'volume providing constant input vertical coordinate contains no & 1707 &variables matching output level type '//
t2c(output_levtype%level1))
1708 CALL init(volgrid6d_out)
1713 'Coordinate for vertint found in coord volume at position '// &
1719 CALL get_val(volgrid6d_coord_in%griddim, nx=nxc, ny=nyc)
1720 CALL get_val(volgrid6d_in%griddim, nx=nxi, ny=nyi)
1721 IF (nxc /= nxi .OR. nyc /= nyi)
THEN 1723 'volume providing constant input vertical coordinate must have & 1724 &the same grid as the input')
1726 'vertical coordinate: '//
t2c(nxc)//
'x'//
t2c(nyc)// &
1727 ', input volume: '//
t2c(nxi)//
'x'//
t2c(nyi))
1728 CALL init(volgrid6d_out)
1734 CALL get_val(this, input_levtype=input_levtype)
1736 (volgrid6d_coord_in%level(:)%level1 == input_levtype%level1) .AND. &
1737 (volgrid6d_coord_in%level(:)%level2 == input_levtype%level2)
1738 ulstart = firsttrue(mask_in)
1739 ulend = lasttrue(mask_in)
1740 IF (ulstart == 0 .OR. ulend == 0)
THEN 1742 'coordinate file does not contain levels of type '// &
1743 t2c(input_levtype%level1)//
'/'//
t2c(input_levtype%level2)// &
1744 ' specified for input data')
1745 CALL init(volgrid6d_out)
1750 coord_3d_in = volgrid6d_coord_in%voldati(:,:,ulstart:ulend,1,1,var_coord_in)
1752 IF (output_levtype%level1 == 103 .OR. &
1753 output_levtype%level1 == 108)
THEN 1754 spos = firsttrue(volgrid6d_coord_in%level(:) == vol7d_level_new(1))
1757 'output level '//
t2c(output_levtype%level1)// &
1758 ' requested, but height/press of surface not provided in coordinate file')
1759 CALL init(volgrid6d_out)
1763 DO k = 1,
SIZE(coord_3d_in,3)
1764 WHERE(
c_e(coord_3d_in(:,:,k)) .AND. &
1765 c_e(volgrid6d_coord_in%voldati(:,:,spos,1,1,var_coord_in)))
1766 coord_3d_in(:,:,k) = coord_3d_in(:,:,k) - &
1767 volgrid6d_coord_in%voldati(:,:,spos,1,1,var_coord_in)
1769 coord_3d_in(:,:,k) = rmiss
1777 IF (.NOT.
c_e(var_coord_in))
THEN 1779 CALL get_val(this, output_levtype=output_levtype)
1780 vcoord_var = vol7d_var_new(vol7d_level_to_var(output_levtype))
1781 IF (
c_e(vcoord_var))
THEN 1782 DO i = 1,
SIZE(volgrid6d_in%var)
1783 IF (
convert(volgrid6d_in%var(i)) == vcoord_var)
THEN 1789 IF (
c_e(var_coord_vol))
THEN 1791 'Coordinate for vertint found in input volume at position '// &
1798 CALL init(volgrid6d_out, griddim=volgrid6d_in%griddim, &
1799 time_definition=volgrid6d_in%time_definition, categoryappend=categoryappend)
1800 IF (
c_e(var_coord_in))
THEN 1801 CALL init(grid_trans, this, lev_in=volgrid6d_in%level, lev_out=lev_out, &
1802 coord_3d_in=coord_3d_in, categoryappend=categoryappend)
1804 CALL init(grid_trans, this, lev_in=volgrid6d_in%level, lev_out=lev_out, &
1805 categoryappend=categoryappend)
1808 CALL get_val(grid_trans, output_level_auto=llev_out)
1809 IF (.NOT.
ASSOCIATED(llev_out)) llev_out => lev_out
1810 nlevel =
SIZE(llev_out)
1813 'volgrid6d_transform: vertint requested but lev_out not provided')
1814 CALL init(volgrid6d_out)
1820 CALL init(volgrid6d_out, griddim=griddim, &
1821 time_definition=volgrid6d_in%time_definition, categoryappend=categoryappend)
1822 CALL init(grid_trans, this, in=volgrid6d_in%griddim, out=volgrid6d_out%griddim, &
1823 maskgrid=maskgrid, maskbounds=maskbounds, categoryappend=categoryappend)
1827 IF (
c_e(grid_trans))
THEN 1829 CALL volgrid6d_alloc(volgrid6d_out, ntime=ntime, nlevel=nlevel, &
1830 ntimerange=ntimerange, nvar=nvar)
1832 IF (
PRESENT(decode))
THEN 1835 ldecode =
ASSOCIATED(volgrid6d_in%voldati)
1838 decode_loop:
DO i6 = 1,nvar
1839 DO i5 = 1, ntimerange
1842 IF (
c_e(volgrid6d_in%gaid(i3,i4,i5,i6)))
THEN 1843 ldecode = ldecode .OR. grid_id_readonly(volgrid6d_in%gaid(i3,i4,i5,i6))
1851 IF (
PRESENT(decode))
THEN 1852 IF (ldecode.NEQV.decode)
THEN 1854 'volgrid6d_transform: decode status forced to .TRUE. because driver does not allow copy')
1858 CALL volgrid6d_alloc_vol(volgrid6d_out, decode=ldecode)
1863 IF (trans_type ==
'vertint')
THEN 1866 "volgrid6d_transform: vertint to "//
t2c(nlevel)//
" levels")
1868 CALL compute(grid_trans, volgrid6d_in, volgrid6d_out, lev_out=llev_out, &
1871 CALL compute(grid_trans, volgrid6d_in, volgrid6d_out,
clone=
clone)
1874 IF (cf_out == 0)
THEN 1875 CALL wind_unrot(volgrid6d_out)
1876 ELSE IF (cf_out == 1)
THEN 1877 CALL wind_rot(volgrid6d_out)
1883 'volgrid6d_transform: transformation not valid')
1889 END SUBROUTINE volgrid6d_transform
1900 SUBROUTINE volgrid6dv_transform(this, griddim, volgrid6d_in, volgrid6d_out, &
1901 lev_out, volgrid6d_coord_in, maskgrid, maskbounds, clone, decode, categoryappend)
1902 TYPE(transform_def),
INTENT(in) :: this
1903 TYPE(griddim_def),
INTENT(in),
OPTIONAL :: griddim
1905 TYPE(volgrid6d),
INTENT(inout) :: volgrid6d_in(:)
1906 TYPE(volgrid6d),
POINTER :: volgrid6d_out(:)
1907 TYPE(vol7d_level),
INTENT(in),
OPTIONAL :: lev_out(:)
1908 TYPE(volgrid6d),
INTENT(in),
OPTIONAL :: volgrid6d_coord_in
1909 REAL,
INTENT(in),
OPTIONAL :: maskgrid(:,:)
1910 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
1911 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1912 LOGICAL,
INTENT(in),
OPTIONAL :: decode
1913 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1915 INTEGER :: i, stallo
1918 allocate(volgrid6d_out(
size(volgrid6d_in)),stat=stallo)
1919 if (stallo /= 0)
then 1920 call l4f_log(l4f_fatal,
"allocating memory")
1921 call raise_fatal_error()
1924 do i=1,
size(volgrid6d_in)
1925 call transform(this, griddim, volgrid6d_in(i), volgrid6d_out(i), &
1926 lev_out=lev_out, volgrid6d_coord_in=volgrid6d_coord_in, &
1927 maskgrid=maskgrid, maskbounds=maskbounds, &
1928 clone=
clone, decode=decode, categoryappend=categoryappend)
1931 END SUBROUTINE volgrid6dv_transform
1935 SUBROUTINE volgrid6d_v7d_transform_compute(this, volgrid6d_in, vol7d_out, &
1936 networkname, noconvert)
1937 TYPE(grid_transform),
INTENT(in) :: this
1938 type(volgrid6d),
INTENT(in) :: volgrid6d_in
1939 type(vol7d),
INTENT(inout) :: vol7d_out
1940 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
1941 LOGICAL,
OPTIONAL,
INTENT(in) :: noconvert
1943 INTEGER :: nntime, nana, ntime, ntimerange, nlevel, nvar, stallo
1944 INTEGER :: itime, itimerange, ivar, inetwork
1945 REAL,
ALLOCATABLE :: voldatir_out(:,:,:)
1946 TYPE(conv_func),
POINTER :: c_func(:)
1947 TYPE(datetime),
ALLOCATABLE :: validitytime(:,:)
1948 REAL,
POINTER :: voldatiin(:,:,:)
1951 call l4f_category_log(volgrid6d_in%category,l4f_debug,
"start volgrid6d_v7d_transform_compute")
1960 if (
present(networkname))
then 1961 call init(vol7d_out%network(1),name=networkname)
1963 call init(vol7d_out%network(1),name=
'generic')
1966 if (
associated(volgrid6d_in%timerange))
then 1967 ntimerange=
size(volgrid6d_in%timerange)
1968 vol7d_out%timerange=volgrid6d_in%timerange
1971 if (
associated(volgrid6d_in%time))
then 1972 ntime=
size(volgrid6d_in%time)
1974 if (vol7d_out%time_definition == volgrid6d_in%time_definition)
then 1977 vol7d_out%time=volgrid6d_in%time
1981 allocate (validitytime(ntime,ntimerange),stat=stallo)
1984 call raise_fatal_error()
1988 do itimerange=1,ntimerange
1989 if (vol7d_out%time_definition > volgrid6d_in%time_definition)
then 1990 validitytime(itime,itimerange) = &
1991 volgrid6d_in%time(itime) + timedelta_new(sec=volgrid6d_in%timerange(itimerange)%p1)
1993 validitytime(itime,itimerange) = &
1994 volgrid6d_in%time(itime) - timedelta_new(sec=volgrid6d_in%timerange(itimerange)%p1)
1999 nntime = count_distinct(reshape(validitytime,(/ntime*ntimerange/)), back=.true.)
2000 vol7d_out%time=pack_distinct(reshape(validitytime,(/ntime*ntimerange/)), nntime,back=.true.)
2005 IF (
ASSOCIATED(volgrid6d_in%level))
THEN 2006 nlevel =
SIZE(volgrid6d_in%level)
2007 vol7d_out%level=volgrid6d_in%level
2010 IF (
ASSOCIATED(volgrid6d_in%var))
THEN 2011 nvar =
SIZE(volgrid6d_in%var)
2012 IF (.NOT. optio_log(noconvert))
THEN 2013 CALL vargrib2varbufr(volgrid6d_in%var, vol7d_out%dativar%r, c_func)
2017 nana =
SIZE(vol7d_out%ana)
2020 IF (.NOT.
ASSOCIATED(volgrid6d_in%voldati))
THEN 2021 ALLOCATE(voldatiin(volgrid6d_in%griddim%dim%nx, volgrid6d_in%griddim%dim%ny, &
2025 ALLOCATE(voldatir_out(nana,1,nlevel),stat=stallo)
2026 IF (stallo /= 0)
THEN 2028 CALL raise_fatal_error()
2033 do itimerange=1,ntimerange
2045 CALL volgrid_get_vol_3d(volgrid6d_in, itime, itimerange, ivar, &
2048 CALL compute(this, voldatiin, voldatir_out, vol7d_out%dativar%r(ivar))
2050 if (vol7d_out%time_definition == volgrid6d_in%time_definition)
then 2051 vol7d_out%voldatir(:,itime,:,itimerange,ivar,inetwork) = &
2054 vol7d_out%voldatir(:,
index(vol7d_out%time,validitytime(itime,itimerange)),:,itimerange,ivar,inetwork)=&
2055 reshape(voldatir_out,(/nana,nlevel/))
2070 deallocate(voldatir_out)
2071 IF (.NOT.
ASSOCIATED(volgrid6d_in%voldati))
THEN 2072 DEALLOCATE(voldatiin)
2074 if (
allocated(validitytime))
deallocate(validitytime)
2077 IF (
ASSOCIATED(c_func))
THEN 2079 CALL compute(c_func(ivar), vol7d_out%voldatir(:,:,:,:,ivar,:))
2084 end SUBROUTINE volgrid6d_v7d_transform_compute
2093 SUBROUTINE volgrid6d_v7d_transform(this, volgrid6d_in, vol7d_out, v7d, &
2094 maskgrid, maskbounds, networkname, noconvert, categoryappend)
2095 TYPE(transform_def),
INTENT(in) :: this
2096 TYPE(volgrid6d),
INTENT(inout) :: volgrid6d_in
2097 TYPE(vol7d),
INTENT(out) :: vol7d_out
2098 TYPE(vol7d),
INTENT(in),
OPTIONAL :: v7d
2099 REAL,
INTENT(in),
OPTIONAL :: maskgrid(:,:)
2100 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
2101 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
2102 LOGICAL,
OPTIONAL,
INTENT(in) :: noconvert
2103 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
2105 type(grid_transform) :: grid_trans
2106 INTEGER :: ntime, ntimerange, nlevel, nvar, nana, time_definition, nnetwork, stallo
2107 INTEGER :: itime, itimerange, inetwork
2108 TYPE(datetime),
ALLOCATABLE :: validitytime(:,:)
2109 INTEGER,
ALLOCATABLE :: point_index(:)
2110 TYPE(vol7d) :: v7d_locana
2113 call l4f_category_log(volgrid6d_in%category,l4f_debug,
"start volgrid6d_v7d_transform")
2116 call vg6d_wind_unrot(volgrid6d_in)
2124 call get_val(this,time_definition=time_definition)
2125 if (.not.
c_e(time_definition))
then 2129 IF (
PRESENT(v7d))
THEN 2130 CALL vol7d_copy(v7d, v7d_locana)
2132 CALL init(v7d_locana)
2135 if (
associated(volgrid6d_in%timerange)) ntimerange=
size(volgrid6d_in%timerange)
2137 if (
associated(volgrid6d_in%time))
then 2139 ntime=
size(volgrid6d_in%time)
2141 if (time_definition /= volgrid6d_in%time_definition)
then 2144 allocate (validitytime(ntime,ntimerange),stat=stallo)
2147 call raise_fatal_error()
2151 do itimerange=1,ntimerange
2152 if (time_definition > volgrid6d_in%time_definition)
then 2153 validitytime(itime,itimerange) = &
2154 volgrid6d_in%time(itime) + timedelta_new(sec=volgrid6d_in%timerange(itimerange)%p1)
2156 validitytime(itime,itimerange) = &
2157 volgrid6d_in%time(itime) - timedelta_new(sec=volgrid6d_in%timerange(itimerange)%p1)
2162 ntime = count_distinct(reshape(validitytime,(/ntime*ntimerange/)), back=.true.)
2163 deallocate (validitytime)
2169 if (
associated(volgrid6d_in%level)) nlevel=
size(volgrid6d_in%level)
2170 if (
associated(volgrid6d_in%var)) nvar=
size(volgrid6d_in%var)
2172 CALL init(grid_trans, this, volgrid6d_in%griddim, v7d_locana, &
2173 maskgrid=maskgrid, maskbounds=maskbounds, categoryappend=categoryappend)
2174 CALL init (vol7d_out,time_definition=time_definition)
2176 IF (
c_e(grid_trans))
THEN 2178 nana=
SIZE(v7d_locana%ana)
2179 CALL vol7d_alloc(vol7d_out, nana=nana, ntime=ntime, nlevel=nlevel, &
2180 ntimerange=ntimerange, ndativarr=nvar, nnetwork=nnetwork)
2181 vol7d_out%ana = v7d_locana%ana
2183 CALL get_val(grid_trans, output_point_index=point_index)
2184 IF (
ALLOCATED(point_index))
THEN 2186 CALL vol7d_alloc(vol7d_out, nanavari=1)
2187 CALL init(vol7d_out%anavar%i(1),
'B01192')
2190 CALL vol7d_alloc_vol(vol7d_out)
2192 IF (
ALLOCATED(point_index))
THEN 2193 DO inetwork = 1, nnetwork
2194 vol7d_out%volanai(:,1,inetwork) = point_index(:)
2197 CALL compute(grid_trans, volgrid6d_in, vol7d_out, networkname, noconvert)
2199 CALL l4f_log(l4f_error,
'vg6d_v7d_transform: transformation not valid')
2207 CALL vol7d_dballe_set_var_du(vol7d_out)
2212 END SUBROUTINE volgrid6d_v7d_transform
2223 SUBROUTINE volgrid6dv_v7d_transform(this, volgrid6d_in, vol7d_out, v7d, &
2224 maskgrid, maskbounds, networkname, noconvert, categoryappend)
2225 TYPE(transform_def),
INTENT(in) :: this
2226 TYPE(volgrid6d),
INTENT(inout) :: volgrid6d_in(:)
2227 TYPE(vol7d),
INTENT(out) :: vol7d_out
2228 TYPE(vol7d),
INTENT(in),
OPTIONAL :: v7d
2229 REAL,
INTENT(in),
OPTIONAL :: maskgrid(:,:)
2230 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
2231 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
2232 LOGICAL,
OPTIONAL,
INTENT(in) :: noconvert
2233 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
2236 TYPE(vol7d) :: v7dtmp
2240 CALL init(vol7d_out)
2242 DO i=1,
SIZE(volgrid6d_in)
2243 CALL transform(this, volgrid6d_in(i), v7dtmp, v7d=v7d, &
2244 maskgrid=maskgrid, maskbounds=maskbounds, &
2245 networkname=networkname, noconvert=noconvert, categoryappend=categoryappend)
2246 CALL vol7d_append(vol7d_out, v7dtmp)
2249 END SUBROUTINE volgrid6dv_v7d_transform
2253 SUBROUTINE v7d_volgrid6d_transform_compute(this, vol7d_in, volgrid6d_out, networkname, gaid_template)
2254 TYPE(grid_transform),
INTENT(in) :: this
2255 type(vol7d),
INTENT(in) :: vol7d_in
2256 type(volgrid6d),
INTENT(inout) :: volgrid6d_out
2257 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
2258 TYPE(grid_id),
OPTIONAL,
INTENT(in) :: gaid_template
2260 integer :: nana, ntime, ntimerange, nlevel, nvar
2261 INTEGER :: ilevel, itime, itimerange, ivar, inetwork
2263 REAL,
POINTER :: voldatiout(:,:,:)
2264 type(vol7d_network) :: network
2265 TYPE(conv_func),
pointer :: c_func(:)
2268 call l4f_category_log(volgrid6d_out%category,l4f_debug,
"start v7d_volgrid6d_transform_compute")
2276 if (
present(networkname))
then 2277 call init(network,name=networkname)
2278 inetwork=
index(vol7d_in%network,network)
2284 if (
associated(vol7d_in%time))
then 2285 ntime=
size(vol7d_in%time)
2286 volgrid6d_out%time=vol7d_in%time
2289 if (
associated(vol7d_in%timerange))
then 2290 ntimerange=
size(vol7d_in%timerange)
2291 volgrid6d_out%timerange=vol7d_in%timerange
2294 if (
associated(vol7d_in%level))
then 2295 nlevel=
size(vol7d_in%level)
2296 volgrid6d_out%level=vol7d_in%level
2299 if (
associated(vol7d_in%dativar%r))
then 2300 nvar=
size(vol7d_in%dativar%r)
2301 CALL varbufr2vargrib(vol7d_in%dativar%r, volgrid6d_out%var, c_func, gaid_template)
2304 nana=
SIZE(vol7d_in%voldatir, 1)
2306 IF (.NOT.
ASSOCIATED(volgrid6d_out%voldati))
THEN 2307 ALLOCATE(voldatiout(volgrid6d_out%griddim%dim%nx, volgrid6d_out%griddim%dim%ny, &
2312 DO itimerange=1,ntimerange
2316 IF (
PRESENT(gaid_template))
THEN 2317 DO ilevel = 1, nlevel
2318 IF (any(
c_e(vol7d_in%voldatir(:,itime,ilevel,itimerange,ivar,inetwork))))
THEN 2319 CALL copy(gaid_template, volgrid6d_out%gaid(ilevel,itime,itimerange,ivar))
2321 volgrid6d_out%gaid(ilevel,itime,itimerange,ivar) = grid_id_new()
2327 IF (
ASSOCIATED(volgrid6d_out%voldati)) &
2328 CALL volgrid_get_vol_3d(volgrid6d_out, itime, itimerange, ivar, &
2331 CALL compute(this, &
2332 vol7d_in%voldatir(:,itime,:,itimerange,ivar,inetwork), voldatiout, &
2333 vol7d_in%dativar%r(ivar))
2335 IF (
ASSOCIATED(c_func))
THEN 2336 CALL compute(c_func(ivar), voldatiout(:,:,:))
2339 CALL volgrid_set_vol_3d(volgrid6d_out, itime, itimerange, ivar, &
2346 IF (.NOT.
ASSOCIATED(volgrid6d_out%voldati))
THEN 2347 DEALLOCATE(voldatiout)
2349 IF (
ASSOCIATED(c_func))
THEN 2353 END SUBROUTINE v7d_volgrid6d_transform_compute
2362 SUBROUTINE v7d_volgrid6d_transform(this, griddim, vol7d_in, volgrid6d_out, &
2363 networkname, gaid_template, categoryappend)
2364 TYPE(transform_def),
INTENT(in) :: this
2365 TYPE(griddim_def),
INTENT(in),
OPTIONAL :: griddim
2367 TYPE(vol7d),
INTENT(inout) :: vol7d_in
2368 TYPE(volgrid6d),
INTENT(out) :: volgrid6d_out
2369 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
2370 TYPE(grid_id),
OPTIONAL,
INTENT(in) :: gaid_template
2371 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
2373 type(grid_transform) :: grid_trans
2374 integer :: ntime, ntimerange, nlevel, nvar
2380 CALL vol7d_alloc_vol(vol7d_in)
2381 ntime=
SIZE(vol7d_in%time)
2382 ntimerange=
SIZE(vol7d_in%timerange)
2383 nlevel=
SIZE(vol7d_in%level)
2385 if (
associated(vol7d_in%dativar%r)) nvar=
size(vol7d_in%dativar%r)
2388 CALL l4f_log(l4f_error, &
2389 "trying to transform a vol7d object incomplete or without real variables")
2390 CALL init(volgrid6d_out)
2395 CALL init(grid_trans, this, vol7d_in, griddim, categoryappend=categoryappend)
2396 CALL init(volgrid6d_out, griddim, time_definition=vol7d_in%time_definition, &
2397 categoryappend=categoryappend)
2399 IF (
c_e(grid_trans))
THEN 2401 CALL volgrid6d_alloc(volgrid6d_out, griddim%dim, ntime=ntime, nlevel=nlevel, &
2402 ntimerange=ntimerange, nvar=nvar)
2404 CALL volgrid6d_alloc_vol(volgrid6d_out, decode=.true.)
2406 CALL compute(grid_trans, vol7d_in, volgrid6d_out, networkname, gaid_template)
2408 CALL vg6d_wind_rot(volgrid6d_out)
2411 CALL l4f_log(l4f_error,
'v7d_vg6d_transform: transformation not valid')
2417 END SUBROUTINE v7d_volgrid6d_transform
2421 SUBROUTINE v7d_v7d_transform_compute(this, vol7d_in, vol7d_out, lev_out, &
2423 TYPE(grid_transform),
INTENT(in) :: this
2424 type(vol7d),
INTENT(in) :: vol7d_in
2425 type(vol7d),
INTENT(inout) :: vol7d_out
2426 TYPE(vol7d_level),
INTENT(in),
OPTIONAL :: lev_out(:)
2427 INTEGER,
INTENT(in),
OPTIONAL :: var_coord_vol
2429 INTEGER :: itime, itimerange, ilevel, ivar, inetwork, &
2430 levshift, levused, lvar_coord_vol, spos
2431 REAL,
ALLOCATABLE :: coord_3d_in(:,:,:)
2432 TYPE(vol7d_level) :: output_levtype
2434 lvar_coord_vol = optio_i(var_coord_vol)
2435 vol7d_out%time(:) = vol7d_in%time(:)
2436 vol7d_out%timerange(:) = vol7d_in%timerange(:)
2437 IF (
PRESENT(lev_out))
THEN 2438 vol7d_out%level(:) = lev_out(:)
2440 vol7d_out%level(:) = vol7d_in%level(:)
2442 vol7d_out%network(:) = vol7d_in%network(:)
2443 IF (
ASSOCIATED(vol7d_in%dativar%r))
THEN 2444 vol7d_out%dativar%r(:) = vol7d_in%dativar%r(:)
2446 CALL get_val(this, levshift=levshift, levused=levused)
2448 IF (
c_e(lvar_coord_vol))
THEN 2449 CALL get_val(this%trans, output_levtype=output_levtype)
2450 IF (output_levtype%level1 == 103 .OR. output_levtype%level1 == 108)
THEN 2451 spos = firsttrue(vol7d_in%level(:) == vol7d_level_new(1))
2453 CALL l4f_log(l4f_error, &
2454 'output level '//
t2c(output_levtype%level1)// &
2455 ' requested, but height/press of surface not provided in volume')
2457 IF (.NOT.
c_e(levshift) .AND. .NOT.
c_e(levused))
THEN 2458 CALL l4f_log(l4f_error, &
2459 'internal inconsistence, levshift and levused undefined when they should be')
2461 ALLOCATE(coord_3d_in(
SIZE(vol7d_in%ana),1,
SIZE(vol7d_in%level)))
2466 DO inetwork = 1,
SIZE(vol7d_in%network)
2467 DO ivar = 1,
SIZE(vol7d_in%dativar%r)
2468 DO itimerange = 1,
SIZE(vol7d_in%timerange)
2469 DO itime = 1,
SIZE(vol7d_in%time)
2472 IF (
c_e(lvar_coord_vol))
THEN 2475 coord_3d_in(:,:,levshift+1:levshift+levused) = rmiss
2477 DO ilevel = levshift+1, levshift+levused
2478 WHERE(
c_e(vol7d_in%voldatir(:,itime:itime,ilevel,itimerange,lvar_coord_vol,inetwork)) .AND. &
2479 c_e(vol7d_in%voldatir(:,itime:itime,spos,itimerange,lvar_coord_vol,inetwork)))
2480 coord_3d_in(:,:,ilevel) = vol7d_in%voldatir(:,itime:itime,ilevel,itimerange,lvar_coord_vol,inetwork) - &
2481 vol7d_in%voldatir(:,itime:itime,spos,itimerange,lvar_coord_vol,inetwork)
2483 coord_3d_in(:,:,ilevel) = rmiss
2487 CALL compute(this, &
2488 vol7d_in%voldatir(:,itime,:,itimerange,ivar,inetwork), &
2489 vol7d_out%voldatir(:,itime:itime,:,itimerange,ivar,inetwork), &
2490 var=vol7d_in%dativar%r(ivar), &
2491 coord_3d_in=coord_3d_in)
2493 CALL compute(this, &
2494 vol7d_in%voldatir(:,itime,:,itimerange,ivar,inetwork), &
2495 vol7d_out%voldatir(:,itime:itime,:,itimerange,ivar,inetwork), &
2496 var=vol7d_in%dativar%r(ivar), &
2497 coord_3d_in=vol7d_in%voldatir(:,itime:itime,:,itimerange, &
2498 lvar_coord_vol,inetwork))
2501 CALL compute(this, &
2502 vol7d_in%voldatir(:,itime,:,itimerange,ivar,inetwork), &
2503 vol7d_out%voldatir(:,itime:itime,:,itimerange,ivar,inetwork), &
2504 var=vol7d_in%dativar%r(ivar))
2513 END SUBROUTINE v7d_v7d_transform_compute
2523 SUBROUTINE v7d_v7d_transform(this, vol7d_in, vol7d_out, v7d, lev_out, vol7d_coord_in, &
2525 TYPE(transform_def),
INTENT(in) :: this
2526 TYPE(vol7d),
INTENT(inout) :: vol7d_in
2527 TYPE(vol7d),
INTENT(out) :: vol7d_out
2528 TYPE(vol7d),
INTENT(in),
OPTIONAL :: v7d
2529 TYPE(vol7d_level),
INTENT(in),
OPTIONAL,
TARGET :: lev_out(:)
2530 TYPE(vol7d),
INTENT(in),
OPTIONAL :: vol7d_coord_in
2531 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
2533 INTEGER :: nvar, inetwork
2534 TYPE(grid_transform) :: grid_trans
2535 TYPE(vol7d_level),
POINTER :: llev_out(:)
2536 TYPE(vol7d_level) :: input_levtype, output_levtype
2537 TYPE(vol7d_var) :: vcoord_var
2538 REAL,
ALLOCATABLE :: coord_3d_in(:,:,:)
2539 INTEGER :: var_coord_in, var_coord_vol, i, k, ulstart, ulend, spos
2540 INTEGER,
ALLOCATABLE :: point_index(:)
2541 TYPE(vol7d) :: v7d_locana, vol7d_tmpana
2542 CHARACTER(len=80) :: trans_type
2543 LOGICAL,
ALLOCATABLE :: mask_in(:), point_mask(:)
2545 CALL vol7d_alloc_vol(vol7d_in)
2547 IF (
ASSOCIATED(vol7d_in%dativar%r)) nvar=
SIZE(vol7d_in%dativar%r)
2549 CALL init(v7d_locana)
2550 IF (
PRESENT(v7d)) v7d_locana = v7d
2551 CALL init(vol7d_out, time_definition=vol7d_in%time_definition)
2553 CALL get_val(this, trans_type=trans_type)
2555 var_coord_vol = imiss
2556 IF (trans_type ==
'vertint')
THEN 2558 IF (
PRESENT(lev_out))
THEN 2562 IF (
PRESENT(vol7d_coord_in))
THEN 2563 IF (
ASSOCIATED(vol7d_coord_in%voldatir) .AND. &
2564 ASSOCIATED(vol7d_coord_in%dativar%r))
THEN 2567 IF (
SIZE(vol7d_coord_in%voldatir,2) /= 1 .OR. &
2568 SIZE(vol7d_coord_in%voldatir,4) /= 1 .OR. &
2569 SIZE(vol7d_coord_in%voldatir,6) /= 1)
THEN 2570 CALL l4f_log(l4f_error, &
2571 'volume providing constant input vertical coordinate must have & 2572 &only 1 time, 1 timerange and 1 network')
2578 CALL get_val(this, output_levtype=output_levtype)
2579 vcoord_var = vol7d_var_new(vol7d_level_to_var(output_levtype))
2580 IF (.NOT.
c_e(vcoord_var))
THEN 2581 CALL l4f_log(l4f_error, &
2582 'requested output level type '//
t2c(output_levtype%level1)// &
2583 ' does not correspond to any known physical variable for & 2584 &providing vertical coordinate')
2589 var_coord_in =
index(vol7d_coord_in%dativar%r, vcoord_var)
2591 IF (var_coord_in <= 0)
THEN 2592 CALL l4f_log(l4f_error, &
2593 'volume providing constant input vertical coordinate contains no & 2594 &real variables matching output level type '//
t2c(output_levtype%level1))
2598 CALL l4f_log(l4f_info, &
2599 'Coordinate for vertint found in coord volume at position '// &
2603 CALL get_val(this, input_levtype=input_levtype)
2605 (vol7d_coord_in%level(:)%level1 == input_levtype%level1) .AND. &
2606 (vol7d_coord_in%level(:)%level2 == input_levtype%level2)
2607 ulstart = firsttrue(mask_in)
2608 ulend = lasttrue(mask_in)
2609 IF (ulstart == 0 .OR. ulend == 0)
THEN 2610 CALL l4f_log(l4f_error, &
2611 'coordinate file does not contain levels of type '// &
2612 t2c(input_levtype%level1)//
'/'//
t2c(input_levtype%level2)// &
2613 ' specified for input data')
2618 coord_3d_in = vol7d_coord_in%voldatir(:,1:1,ulstart:ulend,1,var_coord_in,1)
2620 IF (output_levtype%level1 == 103 &
2621 .OR. output_levtype%level1 == 108)
THEN 2622 spos = firsttrue(vol7d_coord_in%level(:) == vol7d_level_new(1))
2624 CALL l4f_log(l4f_error, &
2625 'output level '//
t2c(output_levtype%level1)// &
2626 ' requested, but height/press of surface not provided in coordinate file')
2630 DO k = 1,
SIZE(coord_3d_in,3)
2631 WHERE(
c_e(coord_3d_in(:,:,k)) .AND. &
2632 c_e(vol7d_coord_in%voldatir(:,1:1,spos,1,var_coord_in,1)))
2633 coord_3d_in(:,:,k) = coord_3d_in(:,:,k) - &
2634 vol7d_coord_in%voldatir(:,1:1,spos,1,var_coord_in,1)
2636 coord_3d_in(:,:,k) = rmiss
2644 IF (var_coord_in <= 0)
THEN 2646 CALL get_val(this, output_levtype=output_levtype)
2647 vcoord_var = vol7d_var_new(vol7d_level_to_var(output_levtype))
2648 IF (
c_e(vcoord_var))
THEN 2649 DO i = 1,
SIZE(vol7d_in%dativar%r)
2650 IF (vol7d_in%dativar%r(i) == vcoord_var)
THEN 2656 IF (
c_e(var_coord_vol))
THEN 2657 CALL l4f_log(l4f_info, &
2658 'Coordinate for vertint found in input volume at position '// &
2665 IF (var_coord_in > 0)
THEN 2666 CALL init(grid_trans, this, lev_in=vol7d_in%level, lev_out=lev_out, &
2667 coord_3d_in=coord_3d_in, categoryappend=categoryappend)
2669 CALL init(grid_trans, this, lev_in=vol7d_in%level, lev_out=lev_out, &
2670 categoryappend=categoryappend)
2673 CALL get_val(grid_trans, output_level_auto=llev_out)
2674 IF (.NOT.
associated(llev_out)) llev_out => lev_out
2676 IF (
c_e(grid_trans)) then
2678 CALL vol7d_alloc(vol7d_out, nana=
SIZE(vol7d_in%ana), &
2679 ntime=
SIZE(vol7d_in%time), ntimerange=
SIZE(vol7d_in%timerange), &
2680 nlevel=
SIZE(llev_out), nnetwork=
SIZE(vol7d_in%network), ndativarr=nvar)
2681 vol7d_out%ana(:) = vol7d_in%ana(:)
2683 CALL vol7d_alloc_vol(vol7d_out)
2688 CALL compute(grid_trans, vol7d_in, vol7d_out, llev_out, &
2689 var_coord_vol=var_coord_vol)
2691 CALL l4f_log(l4f_error,
'v7d_v7d_transform: transformation not valid')
2695 CALL l4f_log(l4f_error, &
2696 'v7d_v7d_transform: vertint requested but lev_out not provided')
2702 CALL init(grid_trans, this, vol7d_in, v7d_locana, &
2703 categoryappend=categoryappend)
2706 IF (
c_e(grid_trans)) then
2708 CALL vol7d_alloc(vol7d_out, nana=
SIZE(v7d_locana%ana), &
2709 ntime=
SIZE(vol7d_in%time), ntimerange=
SIZE(vol7d_in%timerange), &
2710 nlevel=
SIZE(vol7d_in%level), nnetwork=
SIZE(vol7d_in%network), ndativarr=nvar)
2711 vol7d_out%ana = v7d_locana%ana
2713 CALL get_val(grid_trans, point_mask=point_mask, output_point_index=point_index)
2715 IF (
ALLOCATED(point_index))
THEN 2716 CALL vol7d_alloc(vol7d_out, nanavari=1)
2717 CALL init(vol7d_out%anavar%i(1),
'B01192')
2720 CALL vol7d_alloc_vol(vol7d_out)
2722 IF (
ALLOCATED(point_index))
THEN 2723 DO inetwork = 1,
SIZE(vol7d_in%network)
2724 vol7d_out%volanai(:,1,inetwork) = point_index(:)
2727 CALL compute(grid_trans, vol7d_in, vol7d_out)
2729 IF (
ALLOCATED(point_mask))
THEN 2730 IF (
SIZE(point_mask) /=
SIZE(vol7d_in%ana))
THEN 2731 CALL l4f_log(l4f_warn, &
2732 'v7d_v7d_transform: inconsistency in point size: '//
t2c(
SIZE(point_mask)) &
2733 //
':'//
t2c(
SIZE(vol7d_in%ana)))
2736 CALL l4f_log(l4f_debug,
'v7d_v7d_transform: merging ana from in to out')
2738 CALL vol7d_copy(vol7d_in, vol7d_tmpana, &
2739 lana=point_mask, lnetwork=(/.true./), &
2740 ltime=(/.false./), ltimerange=(/.false./), llevel=(/.false./))
2741 CALL vol7d_append(vol7d_out, vol7d_tmpana)
2746 CALL l4f_log(l4f_error,
'v7d_v7d_transform: transformation not valid')
2753 IF (.NOT.
PRESENT(v7d))
CALL delete(v7d_locana)
2755 END SUBROUTINE v7d_v7d_transform
2765 subroutine vg6d_wind_unrot(this)
2766 type(volgrid6d) :: this
2768 integer :: component_flag
2770 call get_val(this%griddim,component_flag=component_flag)
2772 if (component_flag == 1)
then 2774 "unrotating vector components")
2775 call vg6d_wind__un_rot(this,.false.)
2776 call set_val(this%griddim,component_flag=0)
2779 "no need to unrotate vector components")
2782 end subroutine vg6d_wind_unrot
2790 subroutine vg6d_wind_rot(this)
2791 type(volgrid6d) :: this
2793 integer :: component_flag
2795 call get_val(this%griddim,component_flag=component_flag)
2797 if (component_flag == 0)
then 2799 "rotating vector components")
2800 call vg6d_wind__un_rot(this,.true.)
2801 call set_val(this%griddim,component_flag=1)
2804 "no need to rotate vector components")
2807 end subroutine vg6d_wind_rot
2811 SUBROUTINE vg6d_wind__un_rot(this,rot)
2812 TYPE(volgrid6d) :: this
2815 INTEGER :: i, j, k, l, a11, a12, a21, a22, stallo
2816 double precision,
pointer :: rot_mat(:,:,:)
2817 real,
allocatable :: tmp_arr(:,:)
2818 REAL,
POINTER :: voldatiu(:,:), voldativ(:,:)
2819 INTEGER,
POINTER :: iu(:), iv(:)
2821 IF (.NOT.
ASSOCIATED(this%var))
THEN 2823 "trying to unrotate an incomplete volgrid6d object")
2824 CALL raise_fatal_error()
2828 CALL volgrid6d_var_hor_comp_index(this%var, iu, iv)
2829 IF (.NOT.
ASSOCIATED(iu))
THEN 2831 "unrotation impossible")
2832 CALL raise_fatal_error()
2837 ALLOCATE(tmp_arr(this%griddim%dim%nx, this%griddim%dim%ny),stat=stallo)
2838 IF (stallo /= 0)
THEN 2840 CALL raise_fatal_error()
2843 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 2844 ALLOCATE(voldatiu(this%griddim%dim%nx, this%griddim%dim%ny), &
2845 voldativ(this%griddim%dim%nx, this%griddim%dim%ny))
2848 CALL griddim_unproj(this%griddim)
2849 CALL wind_unrot(this%griddim, rot_mat)
2862 DO k = 1,
SIZE(this%timerange)
2863 DO j = 1,
SIZE(this%time)
2864 DO i = 1,
SIZE(this%level)
2866 CALL volgrid_get_vol_2d(this, i, j, k, iu(l), voldatiu)
2867 CALL volgrid_get_vol_2d(this, i, j, k, iv(l), voldativ)
2873 WHERE(voldatiu /= rmiss .AND. voldativ /= rmiss)
2874 tmp_arr(:,:) =
real(voldatiu(:,:)*rot_mat(:,:,a11) + &
2875 voldativ(:,:)*rot_mat(:,:,a12))
2876 voldativ(:,:) =
real(voldatiu(:,:)*rot_mat(:,:,a21) + &
2877 voldativ(:,:)*rot_mat(:,:,a22))
2878 voldatiu(:,:) = tmp_arr(:,:)
2884 CALL volgrid_set_vol_2d(this, i, j, k, iu(l), voldatiu)
2885 CALL volgrid_set_vol_2d(this, i, j, k, iv(l), voldativ)
2891 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 2892 DEALLOCATE(voldatiu, voldativ)
2894 DEALLOCATE(rot_mat, tmp_arr, iu, iv)
2896 END SUBROUTINE vg6d_wind__un_rot
2942 subroutine vg6d_c2a (this)
2944 TYPE(volgrid6d),
INTENT(inout) :: this(:)
2946 integer :: ngrid,igrid,jgrid,ugrid,vgrid,tgrid
2947 doubleprecision :: xmin, xmax, ymin, ymax
2948 doubleprecision :: xmin_t, xmax_t, ymin_t, ymax_t
2949 doubleprecision :: step_lon_t,step_lat_t
2950 character(len=80) :: type_t,type
2951 TYPE(griddim_def):: griddim_t
2957 call init(griddim_t)
2959 call get_val(this(igrid)%griddim,xmin=xmin_t, xmax=xmax_t, ymin=ymin_t, ymax=ymax_t,proj_type=type_t)
2960 step_lon_t=(xmax_t-xmin_t)/dble(this(igrid)%griddim%dim%nx-1)
2961 step_lat_t=(ymax_t-ymin_t)/dble(this(igrid)%griddim%dim%ny-1)
2974 if (this(igrid)%griddim == this(jgrid)%griddim ) cycle
2976 if (this(igrid)%griddim%dim%nx == this(jgrid)%griddim%dim%nx .and. &
2977 this(igrid)%griddim%dim%ny == this(jgrid)%griddim%dim%ny )
then 2979 call get_val(this(jgrid)%griddim,xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax,proj_type=type)
2981 if (type_t /=
type )cycle
2987 call l4f_category_log(this(igrid)%category,l4f_debug,
"diff coordinate lon"//&
2988 to_char(
abs(xmin - (xmin_t+step_lon_t/2.d0)))//&
2989 to_char(
abs(xmax - (xmax_t+step_lon_t/2.d0))))
2990 call l4f_category_log(this(igrid)%category,l4f_debug,
"diff coordinate lat"//&
2991 to_char(
abs(ymin - (ymin_t+step_lat_t/2.d0)))//&
2992 to_char(
abs(ymax - (ymax_t+step_lat_t/2.d0))))
2995 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 2996 if (
abs(ymin - ymin_t) < 1.d-3 .and.
abs(ymax - ymax_t) < 1.d-3 )
then 3012 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 3013 if (
abs(xmin - xmin_t) < 1.d-3 .and.
abs(xmax - xmax_t) < 1.d-3 )
then 3028 call l4f_category_log(this(igrid)%category,l4f_debug,
"C grid: test U and V"//&
3032 call l4f_category_log(this(igrid)%category,l4f_debug,
"UV diff coordinate lon"//&
3033 to_char(
abs(xmin_t - xmin)-step_lon_t/2.d0)//&
3035 call l4f_category_log(this(igrid)%category,l4f_debug,
"UV diff coordinate lat"//&
3036 to_char(
abs(ymin_t - ymin) -step_lat_t/2.d0)//&
3040 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 3041 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 3044 call l4f_category_log(this(igrid)%category,l4f_debug,
"C grid: found U and V case up and right")
3050 call init(griddim_t,xmin=xmin, xmax=xmax, ymin=ymin_t, ymax=ymax_t)
3057 if (
c_e(ugrid))
then 3062 call vg6d_c2a_grid(this(ugrid),this(tgrid)%griddim,cgrid=1)
3064 call vg6d_c2a_grid(this(ugrid),griddim_t,cgrid=1)
3066 call vg6d_c2a_mat(this(ugrid),cgrid=1)
3069 if (
c_e(vgrid))
then 3074 call vg6d_c2a_grid(this(vgrid),this(tgrid)%griddim,cgrid=2)
3076 call vg6d_c2a_grid(this(vgrid),griddim_t,cgrid=2)
3078 call vg6d_c2a_mat(this(vgrid),cgrid=2)
3088 end subroutine vg6d_c2a
3092 subroutine vg6d_c2a_grid(this,griddim_t,cgrid)
3094 type(volgrid6d),
intent(inout) :: this
3095 type(griddim_def),
intent(in),
optional :: griddim_t
3096 integer,
intent(in) :: cgrid
3098 doubleprecision :: xmin, xmax, ymin, ymax
3099 doubleprecision :: step_lon,step_lat
3102 if (
present(griddim_t))
then 3104 call get_val(griddim_t,xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax)
3105 call set_val(this%griddim,xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax)
3107 CALL griddim_setsteps(this%griddim)
3116 call l4f_category_log(this%category,l4f_debug,
"C grid: T points, nothing to do")
3123 call l4f_category_log(this%category,l4f_debug,
"C grid: U points, we need interpolation")
3126 call get_val(this%griddim, xmin=xmin, xmax=xmax)
3127 step_lon=(xmax-xmin)/dble(this%griddim%dim%nx-1)
3128 xmin=xmin-step_lon/2.d0
3129 xmax=xmax-step_lon/2.d0
3130 call set_val(this%griddim, xmin=xmin, xmax=xmax)
3132 CALL griddim_setsteps(this%griddim)
3137 call l4f_category_log(this%category,l4f_debug,
"C grid: V points, we need interpolation")
3140 call get_val(this%griddim, ymin=ymin, ymax=ymax)
3141 step_lat=(ymax-ymin)/dble(this%griddim%dim%ny-1)
3142 ymin=ymin-step_lat/2.d0
3143 ymax=ymax-step_lat/2.d0
3144 call set_val(this%griddim, ymin=ymin, ymax=ymax)
3146 CALL griddim_setsteps(this%griddim)
3151 call raise_fatal_error ()
3158 call griddim_unproj(this%griddim)
3161 end subroutine vg6d_c2a_grid
3164 subroutine vg6d_c2a_mat(this,cgrid)
3167 integer,
intent(in) :: cgrid
3169 INTEGER :: i, j, k, iv, stallo
3170 REAL,
ALLOCATABLE :: tmp_arr(:,:)
3171 REAL,
POINTER :: voldatiuv(:,:)
3174 IF (cgrid == 0)
RETURN 3175 IF (cgrid /= 1 .AND. cgrid /= 2)
THEN 3177 trim(
to_char(cgrid))//
" not known")
3183 ALLOCATE(tmp_arr(this%griddim%dim%nx, this%griddim%dim%ny),stat=stallo)
3185 call l4f_log(l4f_fatal,
"allocating memory")
3186 call raise_fatal_error()
3190 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 3191 ALLOCATE(voldatiuv(this%griddim%dim%nx, this%griddim%dim%ny), stat=stallo)
3192 IF (stallo /= 0)
THEN 3193 CALL l4f_log(l4f_fatal,
"allocating memory")
3194 CALL raise_fatal_error()
3198 IF (cgrid == 1)
THEN 3199 DO iv = 1,
SIZE(this%var)
3200 DO k = 1,
SIZE(this%timerange)
3201 DO j = 1,
SIZE(this%time)
3202 DO i = 1,
SIZE(this%level)
3203 tmp_arr(:,:) = rmiss
3204 CALL volgrid_get_vol_2d(this, i, j, k, iv, voldatiuv)
3207 WHERE(voldatiuv(1,:) /= rmiss .AND. voldatiuv(2,:) /= rmiss)
3208 tmp_arr(1,:) = voldatiuv(1,:) - (voldatiuv(2,:) - voldatiuv(1,:)) / 2.
3212 WHERE(voldatiuv(1:this%griddim%dim%nx-1,:) /= rmiss .AND. &
3213 voldatiuv(2:this%griddim%dim%nx,:) /= rmiss)
3214 tmp_arr(2:this%griddim%dim%nx,:) = &
3215 (voldatiuv(1:this%griddim%dim%nx-1,:) + &
3216 voldatiuv(2:this%griddim%dim%nx,:)) / 2.
3219 voldatiuv(:,:) = tmp_arr
3220 CALL volgrid_set_vol_2d(this, i, j, k, iv, voldatiuv)
3226 ELSE IF (cgrid == 2)
THEN 3227 DO iv = 1,
SIZE(this%var)
3228 DO k = 1,
SIZE(this%timerange)
3229 DO j = 1,
SIZE(this%time)
3230 DO i = 1,
SIZE(this%level)
3231 tmp_arr(:,:) = rmiss
3232 CALL volgrid_get_vol_2d(this, i, j, k, iv, voldatiuv)
3235 WHERE(voldatiuv(:,1) /= rmiss .AND. voldatiuv(:,2) /= rmiss)
3236 tmp_arr(:,1) = voldatiuv(:,1) - (voldatiuv(:,2) - voldatiuv(:,1)) / 2.
3240 WHERE(voldatiuv(:,1:this%griddim%dim%ny-1) /= rmiss .AND. &
3241 voldatiuv(:,2:this%griddim%dim%ny) /= rmiss)
3242 tmp_arr(:,2:this%griddim%dim%ny) = &
3243 (voldatiuv(:,1:this%griddim%dim%ny-1) + &
3244 voldatiuv(:,2:this%griddim%dim%ny)) / 2.
3247 voldatiuv(:,:) = tmp_arr
3248 CALL volgrid_set_vol_2d(this, i, j, k, iv, voldatiuv)
3255 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 3256 DEALLOCATE(voldatiuv)
3258 DEALLOCATE (tmp_arr)
3260 end subroutine vg6d_c2a_mat
3266 subroutine display_volgrid6d (this)
3275 print*,
"----------------------- volgrid6d display ---------------------" 3278 IF (
ASSOCIATED(this%time))
then 3279 print*,
"---- time vector ----" 3280 print*,
"elements=",
size(this%time)
3281 do i=1,
size(this%time)
3286 IF (
ASSOCIATED(this%timerange))
then 3287 print*,
"---- timerange vector ----" 3288 print*,
"elements=",
size(this%timerange)
3289 do i=1,
size(this%timerange)
3290 call display(this%timerange(i))
3294 IF (
ASSOCIATED(this%level))
then 3295 print*,
"---- level vector ----" 3296 print*,
"elements=",
size(this%level)
3297 do i=1,
size(this%level)
3302 IF (
ASSOCIATED(this%var))
then 3303 print*,
"---- var vector ----" 3304 print*,
"elements=",
size(this%var)
3305 do i=1,
size(this%var)
3310 IF (
ASSOCIATED(this%gaid))
then 3311 print*,
"---- gaid vector (present mask only) ----" 3312 print*,
"elements=",shape(this%gaid)
3313 print*,
c_e(reshape(this%gaid,(/
SIZE(this%gaid)/)))
3316 print*,
"--------------------------------------------------------------" 3319 end subroutine display_volgrid6d
3325 subroutine display_volgrid6dv (this)
3330 print*,
"----------------------- volgrid6d vector ---------------------" 3332 print*,
"elements=",
size(this)
3337 call l4f_category_log(this(i)%category,l4f_debug,
"ora mostro il vettore volgrid6d" )
3343 print*,
"--------------------------------------------------------------" 3345 end subroutine display_volgrid6dv
3350 subroutine vg6dv_rounding(vg6din,vg6dout,level,timerange,nostatproc,merge)
3352 type(
volgrid6d),
intent(out),
pointer :: vg6dout(:)
3355 logical,
intent(in),
optional :: merge
3356 logical,
intent(in),
optional :: nostatproc
3360 allocate(vg6dout(
size(vg6din)))
3362 do i = 1,
size(vg6din)
3363 call vg6d_rounding(vg6din(i),vg6dout(i),level,timerange,nostatproc,merge)
3366 end subroutine vg6dv_rounding
3379 subroutine vg6d_rounding(vg6din,vg6dout,level,timerange,nostatproc,merge)
3384 logical,
intent(in),
optional :: merge
3386 logical,
intent(in),
optional :: nostatproc
3388 integer :: ilevel,itimerange
3389 type(
vol7d_level) :: roundlevel(size(vg6din%level))
3392 roundlevel=vg6din%level
3394 if (
present(level))
then 3395 do ilevel = 1,
size(vg6din%level)
3396 if ((any(vg6din%level(ilevel) .almosteq. level)))
then 3397 roundlevel(ilevel)=level(1)
3402 roundtimerange=vg6din%timerange
3404 if (
present(timerange))
then 3405 do itimerange = 1,
size(vg6din%timerange)
3406 if ((any(vg6din%timerange(itimerange) .almosteq. timerange)))
then 3407 roundtimerange(itimerange)=timerange(1)
3414 if (optio_log(nostatproc))
then 3415 roundtimerange(:)%timerange=254
3416 roundtimerange(:)%p2=imiss
3420 call vg6d_reduce(vg6din,vg6dout,roundlevel,roundtimerange,merge)
3422 end subroutine vg6d_rounding
3432 subroutine vg6d_reduce(vg6din,vg6dout,roundlevel,roundtimerange,merge)
3437 logical,
intent(in),
optional :: merge
3439 integer :: nlevel,ntime,ntimerange,nvar,ilevel,itimerange,ivar,indl,indt,itime,nx,ny
3440 real,
allocatable :: vol2d(:,:)
3442 nx=vg6din%griddim%dim%nx
3443 ny=vg6din%griddim%dim%ny
3444 nlevel=count_distinct(roundlevel,back=.true.)
3445 ntime=
size(vg6din%time)
3446 ntimerange=count_distinct(roundtimerange,back=.true.)
3447 nvar=
size(vg6din%var)
3449 call init(vg6dout, vg6din%griddim, vg6din%time_definition, categoryappend=
"generated by vg6d_reduce")
3450 call volgrid6d_alloc(vg6dout, vg6din%griddim%dim, ntime, nlevel, ntimerange, nvar)
3452 if (
ASSOCIATED(vg6din%voldati) .or. optio_log(merge))
then 3453 call volgrid6d_alloc_vol(vg6dout,inivol=.true.,decode=.true.)
3454 allocate(vol2d(nx,ny))
3456 call volgrid6d_alloc_vol(vg6dout,inivol=.true.,decode=.false.)
3459 vg6dout%time=vg6din%time
3460 vg6dout%var=vg6din%var
3461 vg6dout%timerange=pack_distinct(roundtimerange,ntimerange,back=.true.)
3462 vg6dout%level=pack_distinct(roundlevel,nlevel,back=.true.)
3464 CALL sort(vg6dout%timerange)
3465 CALL sort(vg6dout%level)
3467 do ilevel=1,
size(vg6din%level)
3468 indl=
index(vg6dout%level,roundlevel(ilevel))
3469 do itimerange=1,
size(vg6din%timerange)
3470 indt=
index(vg6dout%timerange,roundtimerange(itimerange))
3474 if (
ASSOCIATED(vg6din%voldati))
then 3475 vol2d=vg6din%voldati(:,:,ilevel,itime,itimerange,ivar)
3478 if (optio_log(merge))
then 3480 if ( .not.
ASSOCIATED(vg6din%voldati))
then 3481 CALL grid_id_decode_data(vg6din%gaid(ilevel,itime,itimerange,ivar), vol2d)
3485 where (.not.
c_e(vg6dout%voldati(:,:,indl,itime,indt,ivar)))
3487 vg6dout%voldati(:,:,indl,itime,indt,ivar)=vol2d
3490 else if (
ASSOCIATED(vg6din%voldati))
then 3491 if (.not. any(
c_e(vg6dout%voldati(:,:,indl,itime,indt,ivar))))
then 3492 vg6dout%voldati(:,:,indl,itime,indt,ivar)=vol2d
3496 if (
c_e(vg6din%gaid(ilevel,itime,itimerange,ivar)).and. .not.
c_e(vg6dout%gaid(indl,itime,indt,ivar)))
then 3497 call copy (vg6din%gaid(ilevel,itime,itimerange,ivar), vg6dout%gaid(indl,itime,indt,ivar))
3504 if (
ASSOCIATED(vg6din%voldati) .or. optio_log(merge))
then 3508 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
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).