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)))
482 DO ilevel = 1,
SIZE(this%level)
484 CALL grid_id_decode_data(this%gaid(ilevel,itime,itimerange,ivar), &
492 END SUBROUTINE volgrid_get_vol_3d
506 SUBROUTINE volgrid_set_vol_2d(this, ilevel, itime, itimerange, ivar, voldati)
507 TYPE(volgrid6d),
INTENT(inout) :: this
508 INTEGER,
INTENT(in) :: ilevel
509 INTEGER,
INTENT(in) :: itime
510 INTEGER,
INTENT(in) :: itimerange
511 INTEGER,
INTENT(in) :: ivar
512 REAL,
INTENT(in) :: voldati(:,:)
514 IF (
ASSOCIATED(this%voldati))
THEN 517 CALL grid_id_encode_data(this%gaid(ilevel,itime,itimerange,ivar), voldati)
520 END SUBROUTINE volgrid_set_vol_2d
534 SUBROUTINE volgrid_set_vol_3d(this, itime, itimerange, ivar, voldati)
535 TYPE(volgrid6d),
INTENT(inout) :: this
536 INTEGER,
INTENT(in) :: itime
537 INTEGER,
INTENT(in) :: itimerange
538 INTEGER,
INTENT(in) :: ivar
539 REAL,
INTENT(in) :: voldati(:,:,:)
543 IF (
ASSOCIATED(this%voldati))
THEN 548 DO ilevel = 1,
SIZE(this%level)
550 CALL grid_id_encode_data(this%gaid(ilevel,itime,itimerange,ivar), &
558 END SUBROUTINE volgrid_set_vol_3d
564 SUBROUTINE volgrid6d_delete(this)
565 TYPE(volgrid6d),
INTENT(inout) :: this
567 INTEGER :: i, ii, iii, iiii
573 if (
associated(this%gaid))
then 575 DO i=1 ,
SIZE(this%gaid,1)
576 DO ii=1 ,
SIZE(this%gaid,2)
577 DO iii=1 ,
SIZE(this%gaid,3)
578 DO iiii=1 ,
SIZE(this%gaid,4)
579 CALL delete(this%gaid(i,ii,iii,iiii))
584 DEALLOCATE(this%gaid)
595 if (
associated( this%time ))
deallocate(this%time)
596 if (
associated( this%timerange ))
deallocate(this%timerange)
597 if (
associated( this%level ))
deallocate(this%level)
598 if (
associated( this%var ))
deallocate(this%var)
600 if (
associated(this%voldati))
deallocate(this%voldati)
604 call l4f_category_delete(this%category)
606 END SUBROUTINE volgrid6d_delete
618 subroutine volgrid6d_write_on_file (this,unit,description,filename,filename_auto)
620 TYPE(volgrid6d),
INTENT(IN) :: this
621 integer,
optional,
intent(inout) :: unit
622 character(len=*),
intent(in),
optional :: filename
623 character(len=*),
intent(out),
optional :: filename_auto
624 character(len=*),
INTENT(IN),
optional :: description
627 character(len=254) :: ldescription,arg,lfilename
628 integer :: ntime, ntimerange, nlevel, nvar
630 logical :: opened,exist
642 call date_and_time(values=tarray)
645 if (
present(description))
then 646 ldescription=description
648 ldescription=
"Volgrid6d generated by: "//trim(arg)
651 if (.not.
present(unit))
then 662 lfilename=trim(arg)//
".vg6d" 663 if (
index(arg,
'/',back=.true.) > 0) lfilename=lfilename(
index(arg,
'/',back=.true.)+1 : )
665 if (
present(filename))
then 666 if (filename /=
"")
then 671 if (
present(filename_auto))filename_auto=lfilename
674 inquire(unit=lunit,opened=opened)
675 if (.not. opened)
then 676 inquire(file=lfilename,exist=exist)
677 if (exist)
CALL raise_error(
'file exist; cannot open new file')
678 if (.not.exist)
open (unit=lunit,file=lfilename,form=
"UNFORMATTED")
682 if (
associated(this%time)) ntime=
size(this%time)
683 if (
associated(this%timerange)) ntimerange=
size(this%timerange)
684 if (
associated(this%level)) nlevel=
size(this%level)
685 if (
associated(this%var)) nvar=
size(this%var)
688 write(unit=lunit)ldescription
689 write(unit=lunit)tarray
692 write(unit=lunit) ntime, ntimerange, nlevel, nvar
695 if (
associated(this%time))
call write_unit(this%time, lunit)
696 if (
associated(this%level))
write(unit=lunit)this%level
697 if (
associated(this%timerange))
write(unit=lunit)this%timerange
698 if (
associated(this%var))
write(unit=lunit)this%var
703 if (
associated(this%voldati))
write(unit=lunit)this%voldati
705 if (.not.
present(unit))
close(unit=lunit)
707 end subroutine volgrid6d_write_on_file
716 subroutine volgrid6d_read_from_file (this,unit,filename,description,tarray,filename_auto)
719 integer,
intent(inout),
optional :: unit
720 character(len=*),
INTENT(in),
optional :: filename
721 character(len=*),
intent(out),
optional :: filename_auto
722 character(len=*),
INTENT(out),
optional :: description
723 integer,
intent(out),
optional :: tarray(8)
725 integer :: ntime, ntimerange, nlevel, nvar
727 character(len=254) :: ldescription,lfilename,arg
728 integer :: ltarray(8),lunit
729 logical :: opened,exist
737 if (.not.
present(unit))
then 748 lfilename=trim(arg)//
".vg6d" 749 if (
index(arg,
'/',back=.true.) > 0) lfilename=lfilename(
index(arg,
'/',back=.true.)+1 : )
751 if (
present(filename))
then 752 if (filename /=
"")
then 757 if (
present(filename_auto))filename_auto=lfilename
760 inquire(unit=lunit,opened=opened)
761 if (.not. opened)
then 762 inquire(file=lfilename,exist=exist)
763 IF (.NOT. exist)
CALL raise_fatal_error(
'file '//trim(lfilename)//
' does not exist, cannot open')
764 open (unit=lunit,file=lfilename,form=
"UNFORMATTED")
767 read(unit=lunit)ldescription
768 read(unit=lunit)ltarray
770 call l4f_log(l4f_info,
"Info: reading volgrid6d from file: "//trim(lfilename))
771 call l4f_log(l4f_info,
"Info: description: "//trim(ldescription))
774 if (
present(description))description=ldescription
775 if (
present(tarray))tarray=ltarray
779 read(unit=lunit) ntime, ntimerange, nlevel, nvar
782 call volgrid6d_alloc (this, &
783 ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nvar=nvar)
785 call volgrid6d_alloc_vol (this)
787 if (
associated(this%time))
call read_unit(this%time, lunit)
788 if (
associated(this%level))
read(unit=lunit)this%level
789 if (
associated(this%timerange))
read(unit=lunit)this%timerange
790 if (
associated(this%var))
read(unit=lunit)this%var
795 if (
associated(this%voldati))
read(unit=lunit)this%voldati
797 if (.not.
present(unit))
close(unit=lunit)
799 end subroutine volgrid6d_read_from_file
821 SUBROUTINE import_from_gridinfo(this, gridinfo, force, dup_mode, clone, &
823 TYPE(volgrid6d),
INTENT(inout) :: this
824 TYPE(gridinfo_def),
INTENT(in) :: gridinfo
825 LOGICAL,
INTENT(in),
OPTIONAL :: force
826 INTEGER,
INTENT(in),
OPTIONAL :: dup_mode
827 LOGICAL ,
INTENT(in),
OPTIONAL :: clone
828 LOGICAL,
INTENT(IN),
OPTIONAL :: isanavar
830 CHARACTER(len=255) :: type
831 INTEGER :: itime0, itimerange0, itime1, itimerange1, itime, itimerange, &
832 ilevel, ivar, ldup_mode
834 TYPE(datetime) :: correctedtime
835 TYPE(vol7d_timerange) :: correctedtimerange
836 REAL,
ALLOCATABLE :: tmpgrid(:,:)
838 IF (
PRESENT(dup_mode))
THEN 844 call get_val(this%griddim,proj_type=type)
847 call l4f_category_log(this%category,l4f_debug,
"import_from_gridinfo: "//trim(type))
850 if (.not.
c_e(type))
then 851 call copy(gridinfo%griddim, this%griddim)
855 CALL volgrid6d_alloc_vol(this, ini=.true.)
857 else if (.not. (this%griddim == gridinfo%griddim ))
then 860 "volgrid and gridinfo grid type or size are different, gridinfo rejected")
867 ilevel =
index(this%level, gridinfo%level)
868 IF (ilevel == 0 .AND. optio_log(force))
THEN 869 ilevel =
index(this%level, vol7d_level_miss)
870 IF (ilevel /= 0) this%level(ilevel) = gridinfo%level
873 IF (ilevel == 0)
THEN 875 "volgrid6d: level not valid for volume, gridinfo rejected")
880 IF (optio_log(isanavar))
THEN 882 itime1 =
SIZE(this%time)
884 itimerange1 =
SIZE(this%timerange)
886 correctedtime = gridinfo%time
887 IF (this%time_definition == 1 .OR. this%time_definition == 2) correctedtime = correctedtime + &
888 timedelta_new(sec=gridinfo%timerange%p1)
889 itime0 =
index(this%time, correctedtime)
890 IF (itime0 == 0 .AND. optio_log(force))
THEN 891 itime0 =
index(this%time, datetime_miss)
892 IF (itime0 /= 0) this%time(itime0) = correctedtime
894 IF (itime0 == 0)
THEN 896 "volgrid6d: time not valid for volume, gridinfo rejected")
902 correctedtimerange = gridinfo%timerange
903 IF (this%time_definition == 2) correctedtimerange%p1 = 0
904 itimerange0 =
index(this%timerange, correctedtimerange)
905 IF (itimerange0 == 0 .AND. optio_log(force))
THEN 906 itimerange0 =
index(this%timerange, vol7d_timerange_miss)
907 IF (itimerange0 /= 0) this%timerange(itimerange0) = gridinfo%timerange
909 IF (itimerange0 == 0)
THEN 911 "volgrid6d: timerange not valid for volume, gridinfo rejected")
915 itimerange1 = itimerange0
918 ivar =
index(this%var, gridinfo%var)
919 IF (ivar == 0 .AND. optio_log(force))
THEN 920 ivar =
index(this%var, volgrid6d_var_miss)
921 IF (ivar /= 0) this%var(ivar) = gridinfo%var
925 "volgrid6d: var not valid for volume, gridinfo rejected")
930 DO itimerange = itimerange0, itimerange1
931 DO itime = itime0, itime1
932 IF (
ASSOCIATED(this%gaid))
THEN 934 IF (
c_e(this%gaid(ilevel,itime,itimerange,ivar)))
THEN 938 IF (optio_log(
clone))
CALL delete(this%gaid(ilevel,itime,itimerange,ivar))
941 IF (optio_log(
clone))
THEN 942 CALL copy(gridinfo%gaid, this%gaid(ilevel,itime,itimerange,ivar))
947 this%gaid(ilevel,itime,itimerange,ivar) = gridinfo%gaid
950 IF (
ASSOCIATED(this%voldati))
THEN 951 IF (.NOT.dup .OR. ldup_mode == 0)
THEN 952 this%voldati(:,:,ilevel,itime,itimerange,ivar) =
decode_gridinfo(gridinfo)
953 ELSE IF (ldup_mode == 1)
THEN 956 this%voldati(:,:,ilevel,itime,itimerange,ivar) = tmpgrid(:,:)
958 ELSE IF (ldup_mode == 2)
THEN 959 WHERE(.NOT.
c_e(this%voldati(:,:,ilevel,itime,itimerange,ivar)))
960 this%voldati(:,:,ilevel,itime,itimerange,ivar) =
decode_gridinfo(gridinfo)
967 "gaid not allocated, you probably need to call volgrid6d_alloc_vol first")
975 END SUBROUTINE import_from_gridinfo
982 SUBROUTINE export_to_gridinfo(this, gridinfo, itime, itimerange, ilevel, ivar, &
983 gaid_template, clone)
984 TYPE(volgrid6d),
INTENT(in) :: this
985 TYPE(gridinfo_def),
INTENT(inout) :: gridinfo
987 INTEGER :: itimerange
990 TYPE(grid_id),
INTENT(in),
OPTIONAL :: gaid_template
991 LOGICAL,
INTENT(in),
OPTIONAL :: clone
993 TYPE(grid_id) :: gaid
994 LOGICAL :: usetemplate
995 REAL,
POINTER :: voldati(:,:)
996 TYPE(datetime) :: correctedtime
1002 IF (.NOT.
c_e(this%gaid(ilevel,itime,itimerange,ivar)))
THEN 1004 CALL l4f_category_log(this%category,l4f_debug,
"empty gaid found, skipping export")
1009 usetemplate = .false.
1010 IF (
PRESENT(gaid_template))
THEN 1011 CALL copy(gaid_template, gaid)
1013 CALL l4f_category_log(this%category,l4f_debug,
"template cloned to a new gaid")
1015 usetemplate =
c_e(gaid)
1018 IF (.NOT.usetemplate)
THEN 1019 IF (optio_log(
clone))
THEN 1020 CALL copy(this%gaid(ilevel,itime,itimerange,ivar), gaid)
1022 CALL l4f_category_log(this%category,l4f_debug,
"original gaid cloned to a new one")
1025 gaid = this%gaid(ilevel,itime,itimerange,ivar)
1029 IF (this%time_definition == 1 .OR. this%time_definition == 2)
THEN 1030 correctedtime = this%time(itime) - &
1031 timedelta_new(sec=this%timerange(itimerange)%p1)
1033 correctedtime = this%time(itime)
1036 CALL init(gridinfo,gaid, this%griddim, correctedtime, this%timerange(itimerange), &
1037 this%level(ilevel), this%var(ivar))
1040 CALL export(gridinfo%griddim, gridinfo%gaid)
1042 IF (
ASSOCIATED(this%voldati))
THEN 1043 CALL encode_gridinfo(gridinfo, this%voldati(:,:,ilevel,itime,itimerange,ivar))
1044 ELSE IF (usetemplate)
THEN 1046 CALL volgrid_get_vol_2d(this, ilevel, itime, itimerange, ivar, voldati)
1051 END SUBROUTINE export_to_gridinfo
1071 SUBROUTINE import_from_gridinfovv(this, gridinfov, dup_mode, clone, decode, &
1072 time_definition, anavar, categoryappend)
1073 TYPE(volgrid6d),
POINTER :: this(:)
1074 TYPE(arrayof_gridinfo),
INTENT(in) :: gridinfov
1075 INTEGER,
INTENT(in),
OPTIONAL :: dup_mode
1076 LOGICAL ,
INTENT(in),
OPTIONAL :: clone
1077 LOGICAL,
INTENT(in),
OPTIONAL :: decode
1078 INTEGER,
INTENT(IN),
OPTIONAL :: time_definition
1079 CHARACTER(len=*),
INTENT(IN),
OPTIONAL :: anavar(:)
1080 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1082 INTEGER :: i, j, stallo
1083 INTEGER :: ngrid, ntime, ntimerange, nlevel, nvar, ltime_definition
1085 CHARACTER(len=512) :: a_name
1086 TYPE(datetime),
ALLOCATABLE :: correctedtime(:)
1087 LOGICAL,
ALLOCATABLE :: isanavar(:)
1088 TYPE(vol7d_var) :: lvar
1089 TYPE(vol7d_timerange),
ALLOCATABLE :: correctedtimerange(:)
1092 if (
present(categoryappend))
then 1093 call l4f_launcher(a_name,a_name_append=trim(subcategory)//
"."//trim(categoryappend))
1095 call l4f_launcher(a_name,a_name_append=trim(subcategory))
1097 category=l4f_category_get(a_name)
1103 IF (
PRESENT(time_definition))
THEN 1104 ltime_definition = max(min(time_definition, 2), 0)
1106 ltime_definition = 0
1109 ngrid=count_distinct(gridinfov%array(1:gridinfov%arraysize)%griddim,back=.true.)
1111 ' different grid definition(s) found in input data')
1113 ALLOCATE(this(ngrid),stat=stallo)
1114 IF (stallo /= 0)
THEN 1116 CALL raise_fatal_error()
1119 IF (
PRESENT(categoryappend))
THEN 1120 CALL init(this(i), time_definition=ltime_definition, categoryappend=trim(categoryappend)//
"-vol"//
t2c(i))
1122 CALL init(this(i), time_definition=ltime_definition, categoryappend=
"vol"//
t2c(i))
1126 this(:)%griddim=pack_distinct(gridinfov%array(1:gridinfov%arraysize)%griddim, &
1130 ALLOCATE(isanavar(gridinfov%arraysize))
1131 isanavar(:) = .false.
1132 IF (
PRESENT(anavar))
THEN 1133 DO i = 1, gridinfov%arraysize
1134 DO j = 1,
SIZE(anavar)
1135 lvar =
convert(gridinfov%array(i)%var)
1136 IF (lvar%btable == anavar(j))
THEN 1137 isanavar(i) = .true.
1143 t2c(gridinfov%arraysize)//
' constant-data messages found in input data')
1146 IF (ltime_definition == 1 .OR. ltime_definition == 2)
THEN 1147 ALLOCATE(correctedtime(gridinfov%arraysize))
1148 correctedtime(:) = gridinfov%array(1:gridinfov%arraysize)%time
1149 DO i = 1, gridinfov%arraysize
1150 correctedtime(i) = correctedtime(i) + &
1151 timedelta_new(sec=gridinfov%array(i)%timerange%p1)
1154 IF (ltime_definition == 2)
THEN 1155 ALLOCATE(correctedtimerange(gridinfov%arraysize))
1156 correctedtimerange(:) = gridinfov%array(1:gridinfov%arraysize)%timerange
1157 correctedtimerange(:)%p1 = 0
1161 IF (
PRESENT(anavar))
THEN 1162 j = count((this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1163 .AND. .NOT.isanavar(:))
1166 ' has only constant data, this is not allowed')
1168 CALL raise_fatal_error()
1171 IF (ltime_definition == 1 .OR. ltime_definition == 2)
THEN 1172 ntime = count_distinct(correctedtime, &
1173 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1174 .AND. .NOT.isanavar(:), back=.true.)
1176 ntime = count_distinct(gridinfov%array(1:gridinfov%arraysize)%time, &
1177 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1178 .AND. .NOT.isanavar(:), back=.true.)
1180 IF (ltime_definition == 2)
THEN 1181 ntimerange = count_distinct(correctedtimerange, &
1182 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1183 .AND. .NOT.isanavar(:), back=.true.)
1185 ntimerange = count_distinct(gridinfov%array(1:gridinfov%arraysize)%timerange, &
1186 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1187 .AND. .NOT.isanavar(:), back=.true.)
1189 nlevel = count_distinct(gridinfov%array(1:gridinfov%arraysize)%level, &
1190 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim), &
1192 nvar = count_distinct(gridinfov%array(1:gridinfov%arraysize)%var, &
1193 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim), &
1200 CALL volgrid6d_alloc(this(i),this(i)%griddim%dim,ntime=ntime, &
1201 ntimerange=ntimerange,nlevel=nlevel,nvar=nvar)
1203 IF (ltime_definition == 1 .OR. ltime_definition == 2)
THEN 1204 this(i)%time = pack_distinct(correctedtime, ntime, &
1205 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1206 .AND. .NOT.isanavar(:), back=.true.)
1208 this(i)%time = pack_distinct(gridinfov%array(1:gridinfov%arraysize)%time, ntime, &
1209 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1210 .AND. .NOT.isanavar(:), back=.true.)
1212 CALL sort(this(i)%time)
1214 IF (ltime_definition == 2)
THEN 1215 this(i)%timerange = pack_distinct(correctedtimerange, ntimerange, &
1216 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1217 .AND. .NOT.isanavar(:), back=.true.)
1219 this(i)%timerange = pack_distinct(gridinfov%array(1:gridinfov%arraysize)%timerange, &
1220 ntimerange, mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim) &
1221 .AND. .NOT.isanavar(:), back=.true.)
1223 CALL sort(this(i)%timerange)
1225 this(i)%level=pack_distinct(gridinfov%array(1:gridinfov%arraysize)%level, &
1226 nlevel,mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim), &
1228 CALL sort(this(i)%level)
1230 this(i)%var=pack_distinct(gridinfov%array(1:gridinfov%arraysize)%var, nvar, &
1231 mask=(this(i)%griddim == gridinfov%array(1:gridinfov%arraysize)%griddim), &
1237 CALL volgrid6d_alloc_vol(this(i), decode=decode)
1241 IF (ltime_definition == 1 .OR. ltime_definition == 2)
DEALLOCATE(correctedtime)
1242 IF (ltime_definition == 2)
DEALLOCATE(correctedtimerange)
1244 DO i = 1, gridinfov%arraysize
1249 "to volgrid6d index: "//
t2c(
index(this%griddim, gridinfov%array(i)%griddim)))
1252 CALL import(this(
index(this%griddim, gridinfov%array(i)%griddim)), &
1253 gridinfov%array(i), dup_mode=dup_mode,
clone=
clone, isanavar=isanavar(i))
1258 CALL l4f_category_delete(category)
1260 END SUBROUTINE import_from_gridinfovv
1268 SUBROUTINE export_to_gridinfov(this, gridinfov, gaid_template, clone)
1269 TYPE(volgrid6d),
INTENT(inout) :: this
1270 TYPE(arrayof_gridinfo),
INTENT(inout) :: gridinfov
1271 TYPE(grid_id),
INTENT(in),
OPTIONAL :: gaid_template
1272 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1274 INTEGER :: i ,itime, itimerange, ilevel, ivar
1275 INTEGER :: ntime, ntimerange, nlevel, nvar
1276 TYPE(gridinfo_def) :: gridinfol
1285 CALL dealloc(this%griddim%dim)
1288 ntime=
size(this%time)
1289 ntimerange=
size(this%timerange)
1290 nlevel=
size(this%level)
1294 DO itimerange=1,ntimerange
1298 CALL init(gridinfol)
1299 CALL export(this, gridinfol, itime, itimerange, ilevel, ivar, &
1301 IF (
c_e(gridinfol%gaid))
THEN 1302 CALL insert(gridinfov, gridinfol)
1312 END SUBROUTINE export_to_gridinfov
1320 SUBROUTINE export_to_gridinfovv(this, gridinfov, gaid_template, clone)
1323 TYPE(volgrid6d),
INTENT(inout) :: this(:)
1324 TYPE(arrayof_gridinfo),
INTENT(inout) :: gridinfov
1325 TYPE(grid_id),
INTENT(in),
OPTIONAL :: gaid_template
1326 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1330 DO i = 1,
SIZE(this)
1333 "export_to_gridinfovv grid index: "//
t2c(i))
1338 END SUBROUTINE export_to_gridinfovv
1350 SUBROUTINE volgrid6d_import_from_file(this, filename, dup_mode, decode, &
1351 time_definition, anavar, categoryappend)
1352 TYPE(volgrid6d),
POINTER :: this(:)
1353 CHARACTER(len=*),
INTENT(in) :: filename
1354 INTEGER,
INTENT(in),
OPTIONAL :: dup_mode
1355 LOGICAL,
INTENT(in),
OPTIONAL :: decode
1356 INTEGER,
INTENT(IN),
OPTIONAL :: time_definition
1357 CHARACTER(len=*),
INTENT(IN),
OPTIONAL :: anavar(:)
1358 character(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1360 TYPE(arrayof_gridinfo) :: gridinfo
1362 CHARACTER(len=512) :: a_name
1366 IF (
PRESENT(categoryappend))
THEN 1367 CALL l4f_launcher(a_name,a_name_append= &
1368 trim(subcategory)//
"."//trim(categoryappend))
1370 CALL l4f_launcher(a_name,a_name_append=trim(subcategory))
1372 category=l4f_category_get(a_name)
1374 CALL import(gridinfo, filename=filename, categoryappend=categoryappend)
1376 IF (gridinfo%arraysize > 0)
THEN 1378 CALL import(this, gridinfo, dup_mode=dup_mode,
clone=.true., decode=decode, &
1379 time_definition=time_definition, anavar=anavar, &
1380 categoryappend=categoryappend)
1386 CALL l4f_category_log(category,l4f_info,
"file does not contain gridded data")
1390 CALL l4f_category_delete(category)
1392 END SUBROUTINE volgrid6d_import_from_file
1402 SUBROUTINE volgrid6d_export_to_file(this, filename, gaid_template, categoryappend)
1403 TYPE(volgrid6d) :: this(:)
1404 CHARACTER(len=*),
INTENT(in) :: filename
1405 TYPE(grid_id),
INTENT(in),
OPTIONAL :: gaid_template
1406 character(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1408 TYPE(arrayof_gridinfo) :: gridinfo
1410 CHARACTER(len=512) :: a_name
1412 IF (
PRESENT(categoryappend))
THEN 1413 CALL l4f_launcher(a_name,a_name_append=trim(subcategory)//
"."//trim(categoryappend))
1415 CALL l4f_launcher(a_name,a_name_append=trim(subcategory))
1417 category=l4f_category_get(a_name)
1423 CALL l4f_category_log(category,l4f_info,
"writing volgrid6d to grib file: "//trim(filename))
1426 CALL export(this, gridinfo, gaid_template=gaid_template,
clone=.true.)
1427 IF (gridinfo%arraysize > 0)
THEN 1428 CALL export(gridinfo, filename)
1436 CALL l4f_category_delete(category)
1438 END SUBROUTINE volgrid6d_export_to_file
1444 SUBROUTINE volgrid6dv_delete(this)
1445 TYPE(volgrid6d),
POINTER :: this(:)
1449 IF (
ASSOCIATED(this))
THEN 1450 DO i = 1,
SIZE(this)
1453 "delete volgrid6d vector index: "//trim(
to_char(i)))
1460 END SUBROUTINE volgrid6dv_delete
1464 SUBROUTINE volgrid6d_transform_compute(this, volgrid6d_in, volgrid6d_out, &
1465 lev_out, var_coord_vol, clone)
1466 TYPE(grid_transform),
INTENT(in) :: this
1467 type(volgrid6d),
INTENT(in) :: volgrid6d_in
1468 type(volgrid6d),
INTENT(inout) :: volgrid6d_out
1469 TYPE(vol7d_level),
INTENT(in),
OPTIONAL :: lev_out(:)
1470 INTEGER,
INTENT(in),
OPTIONAL :: var_coord_vol
1471 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1473 INTEGER :: ntime, ntimerange, inlevel, onlevel, nvar, &
1474 itime, itimerange, ilevel, ivar, levshift, levused, lvar_coord_vol, spos
1475 REAL,
POINTER :: voldatiin(:,:,:), voldatiout(:,:,:), coord_3d_in(:,:,:)
1476 TYPE(vol7d_level) :: output_levtype
1480 call l4f_category_log(volgrid6d_in%category,l4f_debug,
"start volgrid6d_transform_compute")
1488 lvar_coord_vol = optio_i(var_coord_vol)
1490 if (
associated(volgrid6d_in%time))
then 1491 ntime=
size(volgrid6d_in%time)
1492 volgrid6d_out%time=volgrid6d_in%time
1495 if (
associated(volgrid6d_in%timerange))
then 1496 ntimerange=
size(volgrid6d_in%timerange)
1497 volgrid6d_out%timerange=volgrid6d_in%timerange
1500 IF (
ASSOCIATED(volgrid6d_in%level))
THEN 1501 inlevel=
SIZE(volgrid6d_in%level)
1503 IF (
PRESENT(lev_out))
THEN 1504 onlevel=
SIZE(lev_out)
1505 volgrid6d_out%level=lev_out
1506 ELSE IF (
ASSOCIATED(volgrid6d_in%level))
THEN 1507 onlevel=
SIZE(volgrid6d_in%level)
1508 volgrid6d_out%level=volgrid6d_in%level
1511 if (
associated(volgrid6d_in%var))
then 1512 nvar=
size(volgrid6d_in%var)
1513 volgrid6d_out%var=volgrid6d_in%var
1516 IF (.NOT.
ASSOCIATED(volgrid6d_in%voldati))
THEN 1517 ALLOCATE(voldatiin(volgrid6d_in%griddim%dim%nx, volgrid6d_in%griddim%dim%ny, &
1520 IF (.NOT.
ASSOCIATED(volgrid6d_out%voldati))
THEN 1521 ALLOCATE(voldatiout(volgrid6d_out%griddim%dim%nx, volgrid6d_out%griddim%dim%ny, &
1525 CALL get_val(this, levshift=levshift, levused=levused)
1527 IF (
c_e(lvar_coord_vol))
THEN 1528 CALL get_val(this%trans, output_levtype=output_levtype)
1529 IF (output_levtype%level1 == 103 .OR. output_levtype%level1 == 108)
THEN 1530 spos = firsttrue(volgrid6d_in%level(:) == vol7d_level_new(1))
1533 'output level '//
t2c(output_levtype%level1)// &
1534 ' requested, but height/press of surface not provided in volume')
1536 IF (.NOT.
c_e(levshift) .AND. .NOT.
c_e(levused))
THEN 1538 'internal inconsistence, levshift and levused undefined when they should be')
1547 DO itimerange=1,ntimerange
1552 volgrid6d_in%gaid(levshift+1:levshift+levused,itime,itimerange,ivar) &
1555 DO ilevel = 1, min(inlevel,onlevel)
1557 IF (
c_e(volgrid6d_in%gaid(ilevel,itime,itimerange,ivar)) .AND. .NOT. &
1558 c_e(volgrid6d_out%gaid(ilevel,itime,itimerange,ivar)))
THEN 1560 IF (optio_log(
clone))
THEN 1561 CALL copy(volgrid6d_in%gaid(ilevel,itime,itimerange,ivar),&
1562 volgrid6d_out%gaid(ilevel,itime,itimerange,ivar))
1565 "cloning gaid, level "//
t2c(ilevel))
1568 volgrid6d_out%gaid(ilevel,itime,itimerange,ivar) = &
1569 volgrid6d_in%gaid(ilevel,itime,itimerange,ivar)
1574 DO ilevel = min(inlevel,onlevel) + 1, onlevel
1575 IF (
c_e(volgrid6d_in%gaid(inlevel,itime,itimerange,ivar)) .AND. .NOT. &
1576 c_e(volgrid6d_out%gaid(ilevel,itime,itimerange,ivar)))
then 1578 CALL copy(volgrid6d_in%gaid(inlevel,itime,itimerange,ivar),&
1579 volgrid6d_out%gaid(ilevel,itime,itimerange,ivar))
1582 "forced cloning gaid, level "//
t2c(inlevel)//
"->"//
t2c(ilevel))
1587 IF (
c_e(lvar_coord_vol))
THEN 1588 NULLIFY(coord_3d_in)
1589 CALL volgrid_get_vol_3d(volgrid6d_in, itime, itimerange, lvar_coord_vol, &
1593 coord_3d_in(:,:,levshift+1:levshift+levused) = rmiss
1595 DO ilevel = levshift+1, levshift+levused
1596 WHERE(
c_e(coord_3d_in(:,:,ilevel)) .AND.
c_e(coord_3d_in(:,:,spos)))
1597 coord_3d_in(:,:,ilevel) = coord_3d_in(:,:,ilevel) - &
1598 coord_3d_in(:,:,spos)
1600 coord_3d_in(:,:,ilevel) = rmiss
1606 CALL volgrid_get_vol_3d(volgrid6d_in, itime, itimerange, ivar, &
1608 IF (
ASSOCIATED(volgrid6d_out%voldati)) &
1609 CALL volgrid_get_vol_3d(volgrid6d_out, itime, itimerange, ivar, &
1611 IF (
c_e(lvar_coord_vol))
THEN 1612 CALL compute(this, voldatiin, voldatiout,
convert(volgrid6d_in%var(ivar)), &
1613 coord_3d_in(:,:,levshift+1:levshift+levused))
1615 CALL compute(this, voldatiin, voldatiout,
convert(volgrid6d_in%var(ivar)))
1617 CALL volgrid_set_vol_3d(volgrid6d_out, itime, itimerange, ivar, &
1623 IF (
c_e(lvar_coord_vol))
THEN 1624 DEALLOCATE(coord_3d_in)
1626 IF (.NOT.
ASSOCIATED(volgrid6d_in%voldati))
THEN 1627 DEALLOCATE(voldatiin)
1629 IF (.NOT.
ASSOCIATED(volgrid6d_out%voldati))
THEN 1630 DEALLOCATE(voldatiout)
1634 END SUBROUTINE volgrid6d_transform_compute
1643 SUBROUTINE volgrid6d_transform(this, griddim, volgrid6d_in, volgrid6d_out, &
1644 lev_out, volgrid6d_coord_in, maskgrid, maskbounds, clone, decode, categoryappend)
1645 TYPE(transform_def),
INTENT(in) :: this
1646 TYPE(griddim_def),
INTENT(in),
OPTIONAL :: griddim
1647 TYPE(volgrid6d),
INTENT(inout) :: volgrid6d_in
1648 TYPE(volgrid6d),
INTENT(out) :: volgrid6d_out
1649 TYPE(vol7d_level),
INTENT(in),
OPTIONAL,
TARGET :: lev_out(:)
1650 TYPE(volgrid6d),
INTENT(in),
OPTIONAL :: volgrid6d_coord_in
1651 REAL,
INTENT(in),
OPTIONAL :: maskgrid(:,:)
1652 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
1653 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1654 LOGICAL,
INTENT(in),
OPTIONAL :: decode
1655 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1657 TYPE(grid_transform) :: grid_trans
1658 TYPE(vol7d_level),
POINTER :: llev_out(:)
1659 TYPE(vol7d_level) :: input_levtype, output_levtype
1660 TYPE(vol7d_var) :: vcoord_var
1661 INTEGER :: i, k, ntime, ntimerange, nlevel, nvar, var_coord_in, var_coord_vol, &
1662 cf_out, nxc, nyc, nxi, nyi, i3, i4, i5, i6, &
1663 ulstart, ulend, spos
1664 REAL,
ALLOCATABLE :: coord_3d_in(:,:,:)
1665 TYPE(geo_proj) :: proj_in, proj_out
1666 CHARACTER(len=80) :: trans_type
1668 LOGICAL,
ALLOCATABLE :: mask_in(:)
1671 call l4f_category_log(volgrid6d_in%category, l4f_debug,
"start volgrid6d_transform")
1679 if (
associated(volgrid6d_in%time)) ntime=
size(volgrid6d_in%time)
1680 if (
associated(volgrid6d_in%timerange)) ntimerange=
size(volgrid6d_in%timerange)
1681 if (
associated(volgrid6d_in%level)) nlevel=
size(volgrid6d_in%level)
1682 if (
associated(volgrid6d_in%var)) nvar=
size(volgrid6d_in%var)
1684 IF (ntime == 0 .OR. ntimerange == 0 .OR. nlevel == 0 .OR. nvar == 0)
THEN 1686 "trying to transform an incomplete volgrid6d object, ntime="//
t2c(ntime)// &
1687 ' ntimerange='//
t2c(ntimerange)//
' nlevel='//
t2c(nlevel)//
' nvar='//
t2c(nvar))
1688 CALL init(volgrid6d_out)
1693 CALL get_val(this, trans_type=trans_type)
1697 IF (
PRESENT(griddim) .AND. (trans_type ==
'inter' .OR. trans_type ==
'boxinter' &
1698 .OR. trans_type ==
'stencilinter'))
THEN 1700 CALL get_val(griddim, component_flag=cf_out,
proj=proj_out)
1702 IF (proj_in /= proj_out)
CALL vg6d_wind_unrot(volgrid6d_in)
1703 ELSE IF (
PRESENT(griddim))
THEN 1704 CALL get_val(griddim, component_flag=cf_out)
1708 var_coord_in = imiss
1709 var_coord_vol = imiss
1710 IF (trans_type ==
'vertint')
THEN 1711 IF (
PRESENT(lev_out))
THEN 1714 IF (
PRESENT(volgrid6d_coord_in))
THEN 1715 IF (
ASSOCIATED(volgrid6d_coord_in%voldati))
THEN 1718 IF (
SIZE(volgrid6d_coord_in%voldati,4) /= 1 .OR. &
1719 SIZE(volgrid6d_coord_in%voldati,5) /= 1)
THEN 1721 'volume providing constant input vertical coordinate must have & 1722 &only 1 time and 1 timerange')
1723 CALL init(volgrid6d_out)
1729 CALL get_val(this, output_levtype=output_levtype)
1731 IF (.NOT.
c_e(vcoord_var))
THEN 1733 'requested output level type '//
t2c(output_levtype%level1)// &
1734 ' does not correspond to any known physical variable for & 1735 &providing vertical coordinate')
1736 CALL init(volgrid6d_out)
1741 DO i = 1,
SIZE(volgrid6d_coord_in%var)
1742 IF (
convert(volgrid6d_coord_in%var(i)) == vcoord_var)
THEN 1748 IF (.NOT.
c_e(var_coord_in))
THEN 1750 'volume providing constant input vertical coordinate contains no & 1751 &variables matching output level type '//
t2c(output_levtype%level1))
1752 CALL init(volgrid6d_out)
1757 'Coordinate for vertint found in coord volume at position '// &
1763 CALL get_val(volgrid6d_coord_in%griddim, nx=nxc, ny=nyc)
1764 CALL get_val(volgrid6d_in%griddim, nx=nxi, ny=nyi)
1765 IF (nxc /= nxi .OR. nyc /= nyi)
THEN 1767 'volume providing constant input vertical coordinate must have & 1768 &the same grid as the input')
1770 'vertical coordinate: '//
t2c(nxc)//
'x'//
t2c(nyc)// &
1771 ', input volume: '//
t2c(nxi)//
'x'//
t2c(nyi))
1772 CALL init(volgrid6d_out)
1778 CALL get_val(this, input_levtype=input_levtype)
1780 (volgrid6d_coord_in%level(:)%level1 == input_levtype%level1) .AND. &
1781 (volgrid6d_coord_in%level(:)%level2 == input_levtype%level2)
1782 ulstart = firsttrue(mask_in)
1783 ulend = lasttrue(mask_in)
1784 IF (ulstart == 0 .OR. ulend == 0)
THEN 1786 'coordinate file does not contain levels of type '// &
1787 t2c(input_levtype%level1)//
'/'//
t2c(input_levtype%level2)// &
1788 ' specified for input data')
1789 CALL init(volgrid6d_out)
1794 coord_3d_in = volgrid6d_coord_in%voldati(:,:,ulstart:ulend,1,1,var_coord_in)
1796 IF (output_levtype%level1 == 103 .OR. &
1797 output_levtype%level1 == 108)
THEN 1798 spos = firsttrue(volgrid6d_coord_in%level(:) == vol7d_level_new(1))
1801 'output level '//
t2c(output_levtype%level1)// &
1802 ' requested, but height/press of surface not provided in coordinate file')
1803 CALL init(volgrid6d_out)
1807 DO k = 1,
SIZE(coord_3d_in,3)
1808 WHERE(
c_e(coord_3d_in(:,:,k)) .AND. &
1809 c_e(volgrid6d_coord_in%voldati(:,:,spos,1,1,var_coord_in)))
1810 coord_3d_in(:,:,k) = coord_3d_in(:,:,k) - &
1811 volgrid6d_coord_in%voldati(:,:,spos,1,1,var_coord_in)
1813 coord_3d_in(:,:,k) = rmiss
1821 IF (.NOT.
c_e(var_coord_in))
THEN 1823 CALL get_val(this, output_levtype=output_levtype)
1825 IF (
c_e(vcoord_var))
THEN 1826 DO i = 1,
SIZE(volgrid6d_in%var)
1827 IF (
convert(volgrid6d_in%var(i)) == vcoord_var)
THEN 1833 IF (
c_e(var_coord_vol))
THEN 1835 'Coordinate for vertint found in input volume at position '// &
1842 CALL init(volgrid6d_out, griddim=volgrid6d_in%griddim, &
1843 time_definition=volgrid6d_in%time_definition, categoryappend=categoryappend)
1844 IF (
c_e(var_coord_in))
THEN 1845 CALL init(grid_trans, this, lev_in=volgrid6d_in%level, lev_out=lev_out, &
1846 coord_3d_in=coord_3d_in, categoryappend=categoryappend)
1848 CALL init(grid_trans, this, lev_in=volgrid6d_in%level, lev_out=lev_out, &
1849 categoryappend=categoryappend)
1852 CALL get_val(grid_trans, output_level_auto=llev_out)
1853 IF (.NOT.
ASSOCIATED(llev_out)) llev_out => lev_out
1854 nlevel =
SIZE(llev_out)
1857 'volgrid6d_transform: vertint requested but lev_out not provided')
1858 CALL init(volgrid6d_out)
1864 CALL init(volgrid6d_out, griddim=griddim, &
1865 time_definition=volgrid6d_in%time_definition, categoryappend=categoryappend)
1866 CALL init(grid_trans, this, in=volgrid6d_in%griddim, out=volgrid6d_out%griddim, &
1867 maskgrid=maskgrid, maskbounds=maskbounds, categoryappend=categoryappend)
1871 IF (
c_e(grid_trans))
THEN 1873 CALL volgrid6d_alloc(volgrid6d_out, ntime=ntime, nlevel=nlevel, &
1874 ntimerange=ntimerange, nvar=nvar)
1876 IF (
PRESENT(decode))
THEN 1879 ldecode =
ASSOCIATED(volgrid6d_in%voldati)
1882 decode_loop:
DO i6 = 1,nvar
1883 DO i5 = 1, ntimerange
1886 IF (
c_e(volgrid6d_in%gaid(i3,i4,i5,i6)))
THEN 1887 ldecode = ldecode .OR. grid_id_readonly(volgrid6d_in%gaid(i3,i4,i5,i6))
1895 IF (
PRESENT(decode))
THEN 1896 IF (ldecode.NEQV.decode)
THEN 1898 'volgrid6d_transform: decode status forced to .TRUE. because driver does not allow copy')
1902 CALL volgrid6d_alloc_vol(volgrid6d_out, decode=ldecode)
1907 IF (trans_type ==
'vertint')
THEN 1910 "volgrid6d_transform: vertint to "//
t2c(nlevel)//
" levels")
1912 CALL compute(grid_trans, volgrid6d_in, volgrid6d_out, lev_out=llev_out, &
1915 CALL compute(grid_trans, volgrid6d_in, volgrid6d_out,
clone=
clone)
1918 IF (cf_out == 0)
THEN 1919 CALL wind_unrot(volgrid6d_out)
1920 ELSE IF (cf_out == 1)
THEN 1921 CALL wind_rot(volgrid6d_out)
1927 'volgrid6d_transform: transformation not valid')
1933 END SUBROUTINE volgrid6d_transform
1944 SUBROUTINE volgrid6dv_transform(this, griddim, volgrid6d_in, volgrid6d_out, &
1945 lev_out, volgrid6d_coord_in, maskgrid, maskbounds, clone, decode, categoryappend)
1946 TYPE(transform_def),
INTENT(in) :: this
1947 TYPE(griddim_def),
INTENT(in),
OPTIONAL :: griddim
1948 TYPE(volgrid6d),
INTENT(inout) :: volgrid6d_in(:)
1949 TYPE(volgrid6d),
POINTER :: volgrid6d_out(:)
1950 TYPE(vol7d_level),
INTENT(in),
OPTIONAL :: lev_out(:)
1951 TYPE(volgrid6d),
INTENT(in),
OPTIONAL :: volgrid6d_coord_in
1952 REAL,
INTENT(in),
OPTIONAL :: maskgrid(:,:)
1953 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
1954 LOGICAL,
INTENT(in),
OPTIONAL :: clone
1955 LOGICAL,
INTENT(in),
OPTIONAL :: decode
1956 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
1958 INTEGER :: i, stallo
1961 allocate(volgrid6d_out(
size(volgrid6d_in)),stat=stallo)
1962 if (stallo /= 0)
then 1963 call l4f_log(l4f_fatal,
"allocating memory")
1964 call raise_fatal_error()
1967 do i=1,
size(volgrid6d_in)
1968 call transform(this, griddim, volgrid6d_in(i), volgrid6d_out(i), &
1969 lev_out=lev_out, volgrid6d_coord_in=volgrid6d_coord_in, &
1970 maskgrid=maskgrid, maskbounds=maskbounds, &
1971 clone=
clone, decode=decode, categoryappend=categoryappend)
1974 END SUBROUTINE volgrid6dv_transform
1978 SUBROUTINE volgrid6d_v7d_transform_compute(this, volgrid6d_in, vol7d_out, &
1979 networkname, noconvert)
1980 TYPE(grid_transform),
INTENT(in) :: this
1981 type(volgrid6d),
INTENT(in) :: volgrid6d_in
1982 type(vol7d),
INTENT(inout) :: vol7d_out
1983 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
1984 LOGICAL,
OPTIONAL,
INTENT(in) :: noconvert
1986 INTEGER :: nntime, nana, ntime, ntimerange, nlevel, nvar, stallo
1987 INTEGER :: itime, itimerange, ivar, inetwork
1988 REAL,
ALLOCATABLE :: voldatir_out(:,:,:)
1989 TYPE(conv_func),
POINTER :: c_func(:)
1990 TYPE(datetime),
ALLOCATABLE :: validitytime(:,:)
1991 REAL,
POINTER :: voldatiin(:,:,:)
1994 call l4f_category_log(volgrid6d_in%category,l4f_debug,
"start volgrid6d_v7d_transform_compute")
2003 if (
present(networkname))
then 2004 call init(vol7d_out%network(1),name=networkname)
2006 call init(vol7d_out%network(1),name=
'generic')
2009 if (
associated(volgrid6d_in%timerange))
then 2010 ntimerange=
size(volgrid6d_in%timerange)
2011 vol7d_out%timerange=volgrid6d_in%timerange
2014 if (
associated(volgrid6d_in%time))
then 2015 ntime=
size(volgrid6d_in%time)
2017 if (vol7d_out%time_definition == volgrid6d_in%time_definition)
then 2020 vol7d_out%time=volgrid6d_in%time
2024 allocate (validitytime(ntime,ntimerange),stat=stallo)
2027 call raise_fatal_error()
2031 do itimerange=1,ntimerange
2032 if (vol7d_out%time_definition > volgrid6d_in%time_definition)
then 2033 validitytime(itime,itimerange) = &
2034 volgrid6d_in%time(itime) + timedelta_new(sec=volgrid6d_in%timerange(itimerange)%p1)
2036 validitytime(itime,itimerange) = &
2037 volgrid6d_in%time(itime) - timedelta_new(sec=volgrid6d_in%timerange(itimerange)%p1)
2042 nntime = count_distinct(reshape(validitytime,(/ntime*ntimerange/)), back=.true.)
2043 vol7d_out%time=pack_distinct(reshape(validitytime,(/ntime*ntimerange/)), nntime,back=.true.)
2048 IF (
ASSOCIATED(volgrid6d_in%level))
THEN 2049 nlevel =
SIZE(volgrid6d_in%level)
2050 vol7d_out%level=volgrid6d_in%level
2053 IF (
ASSOCIATED(volgrid6d_in%var))
THEN 2054 nvar =
SIZE(volgrid6d_in%var)
2055 IF (.NOT. optio_log(noconvert))
THEN 2056 CALL vargrib2varbufr(volgrid6d_in%var, vol7d_out%dativar%r, c_func)
2060 nana =
SIZE(vol7d_out%ana)
2063 IF (.NOT.
ASSOCIATED(volgrid6d_in%voldati))
THEN 2064 ALLOCATE(voldatiin(volgrid6d_in%griddim%dim%nx, volgrid6d_in%griddim%dim%ny, &
2068 ALLOCATE(voldatir_out(nana,1,nlevel),stat=stallo)
2069 IF (stallo /= 0)
THEN 2071 CALL raise_fatal_error()
2076 do itimerange=1,ntimerange
2088 CALL volgrid_get_vol_3d(volgrid6d_in, itime, itimerange, ivar, &
2091 CALL compute(this, voldatiin, voldatir_out, vol7d_out%dativar%r(ivar))
2093 if (vol7d_out%time_definition == volgrid6d_in%time_definition)
then 2094 vol7d_out%voldatir(:,itime,:,itimerange,ivar,inetwork) = &
2097 vol7d_out%voldatir(:,
index(vol7d_out%time,validitytime(itime,itimerange)),:,itimerange,ivar,inetwork)=&
2098 reshape(voldatir_out,(/nana,nlevel/))
2113 deallocate(voldatir_out)
2114 IF (.NOT.
ASSOCIATED(volgrid6d_in%voldati))
THEN 2115 DEALLOCATE(voldatiin)
2117 if (
allocated(validitytime))
deallocate(validitytime)
2120 IF (
ASSOCIATED(c_func))
THEN 2122 CALL compute(c_func(ivar), vol7d_out%voldatir(:,:,:,:,ivar,:))
2127 end SUBROUTINE volgrid6d_v7d_transform_compute
2136 SUBROUTINE volgrid6d_v7d_transform(this, volgrid6d_in, vol7d_out, v7d, &
2137 maskgrid, maskbounds, networkname, noconvert, find_index, categoryappend)
2138 TYPE(transform_def),
INTENT(in) :: this
2139 TYPE(volgrid6d),
INTENT(inout) :: volgrid6d_in
2140 TYPE(vol7d),
INTENT(out) :: vol7d_out
2141 TYPE(vol7d),
INTENT(in),
OPTIONAL :: v7d
2142 REAL,
INTENT(in),
OPTIONAL :: maskgrid(:,:)
2143 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
2144 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
2145 LOGICAL,
OPTIONAL,
INTENT(in) :: noconvert
2146 PROCEDURE(basic_find_index),
POINTER,
OPTIONAL :: find_index
2147 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
2149 type(grid_transform) :: grid_trans
2150 INTEGER :: ntime, ntimerange, nlevel, nvar, nana, time_definition, nnetwork, stallo
2151 INTEGER :: itime, itimerange, inetwork
2152 TYPE(datetime),
ALLOCATABLE :: validitytime(:,:)
2153 INTEGER,
ALLOCATABLE :: point_index(:)
2154 TYPE(vol7d) :: v7d_locana
2157 call l4f_category_log(volgrid6d_in%category,l4f_debug,
"start volgrid6d_v7d_transform")
2160 call vg6d_wind_unrot(volgrid6d_in)
2168 call get_val(this,time_definition=time_definition)
2169 if (.not.
c_e(time_definition))
then 2173 IF (
PRESENT(v7d))
THEN 2174 CALL vol7d_copy(v7d, v7d_locana)
2176 CALL init(v7d_locana)
2179 if (
associated(volgrid6d_in%timerange)) ntimerange=
size(volgrid6d_in%timerange)
2181 if (
associated(volgrid6d_in%time))
then 2183 ntime=
size(volgrid6d_in%time)
2185 if (time_definition /= volgrid6d_in%time_definition)
then 2188 allocate (validitytime(ntime,ntimerange),stat=stallo)
2191 call raise_fatal_error()
2195 do itimerange=1,ntimerange
2196 if (time_definition > volgrid6d_in%time_definition)
then 2197 validitytime(itime,itimerange) = &
2198 volgrid6d_in%time(itime) + timedelta_new(sec=volgrid6d_in%timerange(itimerange)%p1)
2200 validitytime(itime,itimerange) = &
2201 volgrid6d_in%time(itime) - timedelta_new(sec=volgrid6d_in%timerange(itimerange)%p1)
2206 ntime = count_distinct(reshape(validitytime,(/ntime*ntimerange/)), back=.true.)
2207 deallocate (validitytime)
2213 if (
associated(volgrid6d_in%level)) nlevel=
size(volgrid6d_in%level)
2214 if (
associated(volgrid6d_in%var)) nvar=
size(volgrid6d_in%var)
2216 CALL init(grid_trans, this, volgrid6d_in%griddim, v7d_locana, &
2217 maskgrid=maskgrid, maskbounds=maskbounds, find_index=find_index, &
2218 categoryappend=categoryappend)
2219 CALL init (vol7d_out,time_definition=time_definition)
2221 IF (
c_e(grid_trans))
THEN 2223 nana=
SIZE(v7d_locana%ana)
2224 CALL vol7d_alloc(vol7d_out, nana=nana, ntime=ntime, nlevel=nlevel, &
2225 ntimerange=ntimerange, ndativarr=nvar, nnetwork=nnetwork)
2226 vol7d_out%ana = v7d_locana%ana
2228 CALL get_val(grid_trans, output_point_index=point_index)
2229 IF (
ALLOCATED(point_index))
THEN 2231 CALL vol7d_alloc(vol7d_out, nanavari=1)
2232 CALL init(vol7d_out%anavar%i(1),
'B01192')
2235 CALL vol7d_alloc_vol(vol7d_out)
2237 IF (
ALLOCATED(point_index))
THEN 2238 DO inetwork = 1, nnetwork
2239 vol7d_out%volanai(:,1,inetwork) = point_index(:)
2242 CALL compute(grid_trans, volgrid6d_in, vol7d_out, networkname, noconvert)
2244 CALL l4f_log(l4f_error,
'vg6d_v7d_transform: transformation not valid')
2252 CALL vol7d_dballe_set_var_du(vol7d_out)
2257 END SUBROUTINE volgrid6d_v7d_transform
2268 SUBROUTINE volgrid6dv_v7d_transform(this, volgrid6d_in, vol7d_out, v7d, &
2269 maskgrid, maskbounds, networkname, noconvert, find_index, categoryappend)
2270 TYPE(transform_def),
INTENT(in) :: this
2271 TYPE(volgrid6d),
INTENT(inout) :: volgrid6d_in(:)
2272 TYPE(vol7d),
INTENT(out) :: vol7d_out
2273 TYPE(vol7d),
INTENT(in),
OPTIONAL :: v7d
2274 REAL,
INTENT(in),
OPTIONAL :: maskgrid(:,:)
2275 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
2276 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
2277 LOGICAL,
OPTIONAL,
INTENT(in) :: noconvert
2278 PROCEDURE(basic_find_index),
POINTER,
OPTIONAL :: find_index
2279 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
2282 TYPE(vol7d) :: v7dtmp
2286 CALL init(vol7d_out)
2288 DO i=1,
SIZE(volgrid6d_in)
2289 CALL transform(this, volgrid6d_in(i), v7dtmp, v7d=v7d, &
2290 maskgrid=maskgrid, maskbounds=maskbounds, &
2291 networkname=networkname, noconvert=noconvert, find_index=find_index, &
2292 categoryappend=categoryappend)
2293 CALL vol7d_append(vol7d_out, v7dtmp)
2296 END SUBROUTINE volgrid6dv_v7d_transform
2300 SUBROUTINE v7d_volgrid6d_transform_compute(this, vol7d_in, volgrid6d_out, networkname, gaid_template)
2301 TYPE(grid_transform),
INTENT(in) :: this
2302 type(vol7d),
INTENT(in) :: vol7d_in
2303 type(volgrid6d),
INTENT(inout) :: volgrid6d_out
2304 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
2305 TYPE(grid_id),
OPTIONAL,
INTENT(in) :: gaid_template
2307 integer :: nana, ntime, ntimerange, nlevel, nvar
2308 INTEGER :: ilevel, itime, itimerange, ivar, inetwork
2310 REAL,
POINTER :: voldatiout(:,:,:)
2311 type(vol7d_network) :: network
2312 TYPE(conv_func),
pointer :: c_func(:)
2316 'start v7d_volgrid6d_transform_compute')
2324 IF (
PRESENT(networkname))
THEN 2325 CALL init(network,name=networkname)
2326 inetwork =
index(vol7d_in%network,network)
2327 IF (inetwork <= 0)
THEN 2329 'network '//trim(networkname)//
' not found, first network will be transformed')
2337 if (
associated(vol7d_in%time))
then 2338 ntime=
size(vol7d_in%time)
2339 volgrid6d_out%time=vol7d_in%time
2342 if (
associated(vol7d_in%timerange))
then 2343 ntimerange=
size(vol7d_in%timerange)
2344 volgrid6d_out%timerange=vol7d_in%timerange
2347 if (
associated(vol7d_in%level))
then 2348 nlevel=
size(vol7d_in%level)
2349 volgrid6d_out%level=vol7d_in%level
2352 if (
associated(vol7d_in%dativar%r))
then 2353 nvar=
size(vol7d_in%dativar%r)
2354 CALL varbufr2vargrib(vol7d_in%dativar%r, volgrid6d_out%var, c_func, gaid_template)
2357 nana=
SIZE(vol7d_in%voldatir, 1)
2359 IF (.NOT.
ASSOCIATED(volgrid6d_out%voldati))
THEN 2360 ALLOCATE(voldatiout(volgrid6d_out%griddim%dim%nx, volgrid6d_out%griddim%dim%ny, &
2365 DO itimerange=1,ntimerange
2369 IF (
PRESENT(gaid_template))
THEN 2370 DO ilevel = 1, nlevel
2371 IF (any(
c_e(vol7d_in%voldatir(:,itime,ilevel,itimerange,ivar,inetwork))))
THEN 2372 CALL copy(gaid_template, volgrid6d_out%gaid(ilevel,itime,itimerange,ivar))
2374 volgrid6d_out%gaid(ilevel,itime,itimerange,ivar) = grid_id_new()
2380 IF (
ASSOCIATED(volgrid6d_out%voldati)) &
2381 CALL volgrid_get_vol_3d(volgrid6d_out, itime, itimerange, ivar, &
2384 CALL compute(this, &
2385 vol7d_in%voldatir(:,itime,:,itimerange,ivar,inetwork), voldatiout, &
2386 vol7d_in%dativar%r(ivar))
2388 IF (
ASSOCIATED(c_func))
THEN 2389 CALL compute(c_func(ivar), voldatiout(:,:,:))
2392 CALL volgrid_set_vol_3d(volgrid6d_out, itime, itimerange, ivar, &
2399 IF (.NOT.
ASSOCIATED(volgrid6d_out%voldati))
THEN 2400 DEALLOCATE(voldatiout)
2402 IF (
ASSOCIATED(c_func))
THEN 2406 END SUBROUTINE v7d_volgrid6d_transform_compute
2415 SUBROUTINE v7d_volgrid6d_transform(this, griddim, vol7d_in, volgrid6d_out, &
2416 networkname, gaid_template, categoryappend)
2417 TYPE(transform_def),
INTENT(in) :: this
2418 TYPE(griddim_def),
INTENT(in),
OPTIONAL :: griddim
2420 TYPE(vol7d),
INTENT(inout) :: vol7d_in
2421 TYPE(volgrid6d),
INTENT(out) :: volgrid6d_out
2422 CHARACTER(len=*),
OPTIONAL,
INTENT(in) :: networkname
2423 TYPE(grid_id),
OPTIONAL,
INTENT(in) :: gaid_template
2424 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
2426 type(grid_transform) :: grid_trans
2427 integer :: ntime, ntimerange, nlevel, nvar
2433 CALL vol7d_alloc_vol(vol7d_in)
2434 ntime=
SIZE(vol7d_in%time)
2435 ntimerange=
SIZE(vol7d_in%timerange)
2436 nlevel=
SIZE(vol7d_in%level)
2438 if (
associated(vol7d_in%dativar%r)) nvar=
size(vol7d_in%dativar%r)
2441 CALL l4f_log(l4f_error, &
2442 "trying to transform a vol7d object incomplete or without real variables")
2443 CALL init(volgrid6d_out)
2448 CALL init(grid_trans, this, vol7d_in, griddim, categoryappend=categoryappend)
2449 CALL init(volgrid6d_out, griddim, time_definition=vol7d_in%time_definition, &
2450 categoryappend=categoryappend)
2452 IF (
c_e(grid_trans))
THEN 2454 CALL volgrid6d_alloc(volgrid6d_out, griddim%dim, ntime=ntime, nlevel=nlevel, &
2455 ntimerange=ntimerange, nvar=nvar)
2457 CALL volgrid6d_alloc_vol(volgrid6d_out, decode=.true.)
2459 CALL compute(grid_trans, vol7d_in, volgrid6d_out, networkname, gaid_template)
2461 CALL vg6d_wind_rot(volgrid6d_out)
2464 CALL l4f_log(l4f_error,
'v7d_vg6d_transform: transformation not valid')
2470 END SUBROUTINE v7d_volgrid6d_transform
2474 SUBROUTINE v7d_v7d_transform_compute(this, vol7d_in, vol7d_out, lev_out, &
2476 TYPE(grid_transform),
INTENT(in) :: this
2477 type(vol7d),
INTENT(in) :: vol7d_in
2478 type(vol7d),
INTENT(inout) :: vol7d_out
2479 TYPE(vol7d_level),
INTENT(in),
OPTIONAL :: lev_out(:)
2480 INTEGER,
INTENT(in),
OPTIONAL :: var_coord_vol
2482 INTEGER :: itime, itimerange, ilevel, ivar, inetwork, &
2483 levshift, levused, lvar_coord_vol, spos
2484 REAL,
ALLOCATABLE :: coord_3d_in(:,:,:)
2485 TYPE(vol7d_level) :: output_levtype
2487 lvar_coord_vol = optio_i(var_coord_vol)
2488 vol7d_out%time(:) = vol7d_in%time(:)
2489 vol7d_out%timerange(:) = vol7d_in%timerange(:)
2490 IF (
PRESENT(lev_out))
THEN 2491 vol7d_out%level(:) = lev_out(:)
2493 vol7d_out%level(:) = vol7d_in%level(:)
2495 vol7d_out%network(:) = vol7d_in%network(:)
2496 IF (
ASSOCIATED(vol7d_in%dativar%r))
THEN 2497 vol7d_out%dativar%r(:) = vol7d_in%dativar%r(:)
2499 CALL get_val(this, levshift=levshift, levused=levused)
2501 IF (
c_e(lvar_coord_vol))
THEN 2502 CALL get_val(this%trans, output_levtype=output_levtype)
2503 IF (output_levtype%level1 == 103 .OR. output_levtype%level1 == 108)
THEN 2504 spos = firsttrue(vol7d_in%level(:) == vol7d_level_new(1))
2506 CALL l4f_log(l4f_error, &
2507 'output level '//
t2c(output_levtype%level1)// &
2508 ' requested, but height/press of surface not provided in volume')
2510 IF (.NOT.
c_e(levshift) .AND. .NOT.
c_e(levused))
THEN 2511 CALL l4f_log(l4f_error, &
2512 'internal inconsistence, levshift and levused undefined when they should be')
2514 ALLOCATE(coord_3d_in(
SIZE(vol7d_in%ana),1,
SIZE(vol7d_in%level)))
2519 DO inetwork = 1,
SIZE(vol7d_in%network)
2520 DO ivar = 1,
SIZE(vol7d_in%dativar%r)
2521 DO itimerange = 1,
SIZE(vol7d_in%timerange)
2522 DO itime = 1,
SIZE(vol7d_in%time)
2525 IF (
c_e(lvar_coord_vol))
THEN 2528 coord_3d_in(:,:,levshift+1:levshift+levused) = rmiss
2530 DO ilevel = levshift+1, levshift+levused
2531 WHERE(
c_e(vol7d_in%voldatir(:,itime:itime,ilevel,itimerange,lvar_coord_vol,inetwork)) .AND. &
2532 c_e(vol7d_in%voldatir(:,itime:itime,spos,itimerange,lvar_coord_vol,inetwork)))
2533 coord_3d_in(:,:,ilevel) = vol7d_in%voldatir(:,itime:itime,ilevel,itimerange,lvar_coord_vol,inetwork) - &
2534 vol7d_in%voldatir(:,itime:itime,spos,itimerange,lvar_coord_vol,inetwork)
2536 coord_3d_in(:,:,ilevel) = rmiss
2540 CALL compute(this, &
2541 vol7d_in%voldatir(:,itime,:,itimerange,ivar,inetwork), &
2542 vol7d_out%voldatir(:,itime:itime,:,itimerange,ivar,inetwork), &
2543 var=vol7d_in%dativar%r(ivar), &
2544 coord_3d_in=coord_3d_in)
2546 CALL compute(this, &
2547 vol7d_in%voldatir(:,itime,:,itimerange,ivar,inetwork), &
2548 vol7d_out%voldatir(:,itime:itime,:,itimerange,ivar,inetwork), &
2549 var=vol7d_in%dativar%r(ivar), &
2550 coord_3d_in=vol7d_in%voldatir(:,itime:itime,:,itimerange, &
2551 lvar_coord_vol,inetwork))
2554 CALL compute(this, &
2555 vol7d_in%voldatir(:,itime,:,itimerange,ivar,inetwork), &
2556 vol7d_out%voldatir(:,itime:itime,:,itimerange,ivar,inetwork), &
2557 var=vol7d_in%dativar%r(ivar))
2566 END SUBROUTINE v7d_v7d_transform_compute
2576 SUBROUTINE v7d_v7d_transform(this, vol7d_in, vol7d_out, v7d, maskbounds, &
2577 lev_out, vol7d_coord_in, categoryappend)
2578 TYPE(transform_def),
INTENT(in) :: this
2579 TYPE(vol7d),
INTENT(inout) :: vol7d_in
2580 TYPE(vol7d),
INTENT(out) :: vol7d_out
2581 TYPE(vol7d),
INTENT(in),
OPTIONAL :: v7d
2582 REAL,
INTENT(in),
OPTIONAL :: maskbounds(:)
2583 TYPE(vol7d_level),
INTENT(in),
OPTIONAL,
TARGET :: lev_out(:)
2584 TYPE(vol7d),
INTENT(in),
OPTIONAL :: vol7d_coord_in
2585 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: categoryappend
2587 INTEGER :: nvar, inetwork
2588 TYPE(grid_transform) :: grid_trans
2589 TYPE(vol7d_level),
POINTER :: llev_out(:)
2590 TYPE(vol7d_level) :: input_levtype, output_levtype
2591 TYPE(vol7d_var) :: vcoord_var
2592 REAL,
ALLOCATABLE :: coord_3d_in(:,:,:)
2593 INTEGER :: var_coord_in, var_coord_vol, i, k, ulstart, ulend, spos
2594 INTEGER,
ALLOCATABLE :: point_index(:)
2595 TYPE(vol7d) :: v7d_locana, vol7d_tmpana
2596 CHARACTER(len=80) :: trans_type
2597 LOGICAL,
ALLOCATABLE :: mask_in(:), point_mask(:)
2599 CALL vol7d_alloc_vol(vol7d_in)
2601 IF (
ASSOCIATED(vol7d_in%dativar%r)) nvar=
SIZE(vol7d_in%dativar%r)
2603 CALL init(v7d_locana)
2604 IF (
PRESENT(v7d)) v7d_locana = v7d
2605 CALL init(vol7d_out, time_definition=vol7d_in%time_definition)
2607 CALL get_val(this, trans_type=trans_type)
2609 var_coord_vol = imiss
2610 IF (trans_type ==
'vertint')
THEN 2612 IF (
PRESENT(lev_out))
THEN 2616 IF (
PRESENT(vol7d_coord_in))
THEN 2617 IF (
ASSOCIATED(vol7d_coord_in%voldatir) .AND. &
2618 ASSOCIATED(vol7d_coord_in%dativar%r))
THEN 2621 IF (
SIZE(vol7d_coord_in%voldatir,2) /= 1 .OR. &
2622 SIZE(vol7d_coord_in%voldatir,4) /= 1 .OR. &
2623 SIZE(vol7d_coord_in%voldatir,6) /= 1)
THEN 2624 CALL l4f_log(l4f_error, &
2625 'volume providing constant input vertical coordinate must have & 2626 &only 1 time, 1 timerange and 1 network')
2632 CALL get_val(this, output_levtype=output_levtype)
2634 IF (.NOT.
c_e(vcoord_var))
THEN 2635 CALL l4f_log(l4f_error, &
2636 'requested output level type '//
t2c(output_levtype%level1)// &
2637 ' does not correspond to any known physical variable for & 2638 &providing vertical coordinate')
2643 var_coord_in =
index(vol7d_coord_in%dativar%r, vcoord_var)
2645 IF (var_coord_in <= 0)
THEN 2646 CALL l4f_log(l4f_error, &
2647 'volume providing constant input vertical coordinate contains no & 2648 &real variables matching output level type '//
t2c(output_levtype%level1))
2652 CALL l4f_log(l4f_info, &
2653 'Coordinate for vertint found in coord volume at position '// &
2657 CALL get_val(this, input_levtype=input_levtype)
2659 (vol7d_coord_in%level(:)%level1 == input_levtype%level1) .AND. &
2660 (vol7d_coord_in%level(:)%level2 == input_levtype%level2)
2661 ulstart = firsttrue(mask_in)
2662 ulend = lasttrue(mask_in)
2663 IF (ulstart == 0 .OR. ulend == 0)
THEN 2664 CALL l4f_log(l4f_error, &
2665 'coordinate file does not contain levels of type '// &
2666 t2c(input_levtype%level1)//
'/'//
t2c(input_levtype%level2)// &
2667 ' specified for input data')
2672 coord_3d_in = vol7d_coord_in%voldatir(:,1:1,ulstart:ulend,1,var_coord_in,1)
2674 IF (output_levtype%level1 == 103 &
2675 .OR. output_levtype%level1 == 108)
THEN 2676 spos = firsttrue(vol7d_coord_in%level(:) == vol7d_level_new(1))
2678 CALL l4f_log(l4f_error, &
2679 'output level '//
t2c(output_levtype%level1)// &
2680 ' requested, but height/press of surface not provided in coordinate file')
2684 DO k = 1,
SIZE(coord_3d_in,3)
2685 WHERE(
c_e(coord_3d_in(:,:,k)) .AND. &
2686 c_e(vol7d_coord_in%voldatir(:,1:1,spos,1,var_coord_in,1)))
2687 coord_3d_in(:,:,k) = coord_3d_in(:,:,k) - &
2688 vol7d_coord_in%voldatir(:,1:1,spos,1,var_coord_in,1)
2690 coord_3d_in(:,:,k) = rmiss
2698 IF (var_coord_in <= 0)
THEN 2700 CALL get_val(this, output_levtype=output_levtype)
2702 IF (
c_e(vcoord_var))
THEN 2703 DO i = 1,
SIZE(vol7d_in%dativar%r)
2704 IF (vol7d_in%dativar%r(i) == vcoord_var)
THEN 2710 IF (
c_e(var_coord_vol))
THEN 2711 CALL l4f_log(l4f_info, &
2712 'Coordinate for vertint found in input volume at position '// &
2719 IF (var_coord_in > 0)
THEN 2720 CALL init(grid_trans, this, lev_in=vol7d_in%level, lev_out=lev_out, &
2721 coord_3d_in=coord_3d_in, categoryappend=categoryappend)
2723 CALL init(grid_trans, this, lev_in=vol7d_in%level, lev_out=lev_out, &
2724 categoryappend=categoryappend)
2727 CALL get_val(grid_trans, output_level_auto=llev_out)
2728 IF (.NOT.
associated(llev_out)) llev_out => lev_out
2730 IF (
c_e(grid_trans)) then
2732 CALL vol7d_alloc(vol7d_out, nana=
SIZE(vol7d_in%ana), &
2733 ntime=
SIZE(vol7d_in%time), ntimerange=
SIZE(vol7d_in%timerange), &
2734 nlevel=
SIZE(llev_out), nnetwork=
SIZE(vol7d_in%network), ndativarr=nvar)
2735 vol7d_out%ana(:) = vol7d_in%ana(:)
2737 CALL vol7d_alloc_vol(vol7d_out)
2742 CALL compute(grid_trans, vol7d_in, vol7d_out, llev_out, &
2743 var_coord_vol=var_coord_vol)
2745 CALL l4f_log(l4f_error,
'v7d_v7d_transform: transformation not valid')
2749 CALL l4f_log(l4f_error, &
2750 'v7d_v7d_transform: vertint requested but lev_out not provided')
2756 CALL init(grid_trans, this, vol7d_in, v7d_locana, maskbounds=maskbounds, &
2757 categoryappend=categoryappend)
2760 IF (
c_e(grid_trans)) then
2762 CALL vol7d_alloc(vol7d_out, nana=
SIZE(v7d_locana%ana), &
2763 ntime=
SIZE(vol7d_in%time), ntimerange=
SIZE(vol7d_in%timerange), &
2764 nlevel=
SIZE(vol7d_in%level), nnetwork=
SIZE(vol7d_in%network), ndativarr=nvar)
2765 vol7d_out%ana = v7d_locana%ana
2767 CALL get_val(grid_trans, point_mask=point_mask, output_point_index=point_index)
2769 IF (
ALLOCATED(point_index))
THEN 2770 CALL vol7d_alloc(vol7d_out, nanavari=1)
2771 CALL init(vol7d_out%anavar%i(1),
'B01192')
2774 CALL vol7d_alloc_vol(vol7d_out)
2776 IF (
ALLOCATED(point_index))
THEN 2777 DO inetwork = 1,
SIZE(vol7d_in%network)
2778 vol7d_out%volanai(:,1,inetwork) = point_index(:)
2781 CALL compute(grid_trans, vol7d_in, vol7d_out)
2783 IF (
ALLOCATED(point_mask))
THEN 2784 IF (
SIZE(point_mask) /=
SIZE(vol7d_in%ana))
THEN 2785 CALL l4f_log(l4f_warn, &
2786 'v7d_v7d_transform: inconsistency in point size: '//
t2c(
SIZE(point_mask)) &
2787 //
':'//
t2c(
SIZE(vol7d_in%ana)))
2790 CALL l4f_log(l4f_debug,
'v7d_v7d_transform: merging ana from in to out')
2792 CALL vol7d_copy(vol7d_in, vol7d_tmpana, &
2793 lana=point_mask, lnetwork=(/.true./), &
2794 ltime=(/.false./), ltimerange=(/.false./), llevel=(/.false./))
2795 CALL vol7d_append(vol7d_out, vol7d_tmpana)
2800 CALL l4f_log(l4f_error,
'v7d_v7d_transform: transformation not valid')
2807 IF (.NOT.
PRESENT(v7d))
CALL delete(v7d_locana)
2809 END SUBROUTINE v7d_v7d_transform
2819 subroutine vg6d_wind_unrot(this)
2820 type(volgrid6d) :: this
2822 integer :: component_flag
2824 call get_val(this%griddim,component_flag=component_flag)
2826 if (component_flag == 1)
then 2828 "unrotating vector components")
2829 call vg6d_wind__un_rot(this,.false.)
2830 call set_val(this%griddim,component_flag=0)
2833 "no need to unrotate vector components")
2836 end subroutine vg6d_wind_unrot
2844 subroutine vg6d_wind_rot(this)
2845 type(volgrid6d) :: this
2847 integer :: component_flag
2849 call get_val(this%griddim,component_flag=component_flag)
2851 if (component_flag == 0)
then 2853 "rotating vector components")
2854 call vg6d_wind__un_rot(this,.true.)
2855 call set_val(this%griddim,component_flag=1)
2858 "no need to rotate vector components")
2861 end subroutine vg6d_wind_rot
2865 SUBROUTINE vg6d_wind__un_rot(this,rot)
2866 TYPE(volgrid6d) :: this
2869 INTEGER :: i, j, k, l, a11, a12, a21, a22, stallo
2870 double precision,
pointer :: rot_mat(:,:,:)
2871 real,
allocatable :: tmp_arr(:,:)
2872 REAL,
POINTER :: voldatiu(:,:), voldativ(:,:)
2873 INTEGER,
POINTER :: iu(:), iv(:)
2875 IF (.NOT.
ASSOCIATED(this%var))
THEN 2877 "trying to unrotate an incomplete volgrid6d object")
2878 CALL raise_fatal_error()
2882 CALL volgrid6d_var_hor_comp_index(this%var, iu, iv)
2883 IF (.NOT.
ASSOCIATED(iu))
THEN 2885 "unrotation impossible")
2886 CALL raise_fatal_error()
2891 ALLOCATE(tmp_arr(this%griddim%dim%nx, this%griddim%dim%ny),stat=stallo)
2892 IF (stallo /= 0)
THEN 2894 CALL raise_fatal_error()
2897 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 2898 ALLOCATE(voldatiu(this%griddim%dim%nx, this%griddim%dim%ny), &
2899 voldativ(this%griddim%dim%nx, this%griddim%dim%ny))
2902 CALL griddim_unproj(this%griddim)
2903 CALL wind_unrot(this%griddim, rot_mat)
2916 DO k = 1,
SIZE(this%timerange)
2917 DO j = 1,
SIZE(this%time)
2918 DO i = 1,
SIZE(this%level)
2920 CALL volgrid_get_vol_2d(this, i, j, k, iu(l), voldatiu)
2921 CALL volgrid_get_vol_2d(this, i, j, k, iv(l), voldativ)
2927 WHERE(voldatiu /= rmiss .AND. voldativ /= rmiss)
2928 tmp_arr(:,:) =
real(voldatiu(:,:)*rot_mat(:,:,a11) + &
2929 voldativ(:,:)*rot_mat(:,:,a12))
2930 voldativ(:,:) =
real(voldatiu(:,:)*rot_mat(:,:,a21) + &
2931 voldativ(:,:)*rot_mat(:,:,a22))
2932 voldatiu(:,:) = tmp_arr(:,:)
2938 CALL volgrid_set_vol_2d(this, i, j, k, iu(l), voldatiu)
2939 CALL volgrid_set_vol_2d(this, i, j, k, iv(l), voldativ)
2945 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 2946 DEALLOCATE(voldatiu, voldativ)
2948 DEALLOCATE(rot_mat, tmp_arr, iu, iv)
2950 END SUBROUTINE vg6d_wind__un_rot
2996 subroutine vg6d_c2a (this)
2998 TYPE(volgrid6d),
INTENT(inout) :: this(:)
3000 integer :: ngrid,igrid,jgrid,ugrid,vgrid,tgrid
3001 doubleprecision :: xmin, xmax, ymin, ymax
3002 doubleprecision :: xmin_t, xmax_t, ymin_t, ymax_t
3003 doubleprecision :: step_lon_t,step_lat_t
3004 character(len=80) :: type_t,type
3005 TYPE(griddim_def):: griddim_t
3011 call init(griddim_t)
3013 call get_val(this(igrid)%griddim,xmin=xmin_t, xmax=xmax_t, ymin=ymin_t, ymax=ymax_t,proj_type=type_t)
3014 step_lon_t=(xmax_t-xmin_t)/dble(this(igrid)%griddim%dim%nx-1)
3015 step_lat_t=(ymax_t-ymin_t)/dble(this(igrid)%griddim%dim%ny-1)
3028 if (this(igrid)%griddim == this(jgrid)%griddim ) cycle
3030 if (this(igrid)%griddim%dim%nx == this(jgrid)%griddim%dim%nx .and. &
3031 this(igrid)%griddim%dim%ny == this(jgrid)%griddim%dim%ny )
then 3033 call get_val(this(jgrid)%griddim,xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax,proj_type=type)
3035 if (type_t /=
type )cycle
3041 call l4f_category_log(this(igrid)%category,l4f_debug,
"diff coordinate lon"//&
3042 to_char(
abs(xmin - (xmin_t+step_lon_t/2.d0)))//&
3044 call l4f_category_log(this(igrid)%category,l4f_debug,
"diff coordinate lat"//&
3045 to_char(
abs(ymin - (ymin_t+step_lat_t/2.d0)))//&
3046 to_char(
abs(ymax - (ymax_t+step_lat_t/2.d0))))
3049 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 3050 if (
abs(ymin - ymin_t) < 1.d-3 .and.
abs(ymax - ymax_t) < 1.d-3 )
then 3066 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 3067 if (
abs(xmin - xmin_t) < 1.d-3 .and.
abs(xmax - xmax_t) < 1.d-3 )
then 3082 call l4f_category_log(this(igrid)%category,l4f_debug,
"C grid: test U and V"//&
3086 call l4f_category_log(this(igrid)%category,l4f_debug,
"UV diff coordinate lon"//&
3087 to_char(
abs(xmin_t - xmin)-step_lon_t/2.d0)//&
3089 call l4f_category_log(this(igrid)%category,l4f_debug,
"UV diff coordinate lat"//&
3090 to_char(
abs(ymin_t - ymin) -step_lat_t/2.d0)//&
3094 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 3095 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 3098 call l4f_category_log(this(igrid)%category,l4f_debug,
"C grid: found U and V case up and right")
3104 call init(griddim_t,xmin=xmin, xmax=xmax, ymin=ymin_t, ymax=ymax_t)
3111 if (
c_e(ugrid))
then 3116 call vg6d_c2a_grid(this(ugrid),this(tgrid)%griddim,cgrid=1)
3118 call vg6d_c2a_grid(this(ugrid),griddim_t,cgrid=1)
3120 call vg6d_c2a_mat(this(ugrid),cgrid=1)
3123 if (
c_e(vgrid))
then 3128 call vg6d_c2a_grid(this(vgrid),this(tgrid)%griddim,cgrid=2)
3130 call vg6d_c2a_grid(this(vgrid),griddim_t,cgrid=2)
3132 call vg6d_c2a_mat(this(vgrid),cgrid=2)
3142 end subroutine vg6d_c2a
3146 subroutine vg6d_c2a_grid(this,griddim_t,cgrid)
3148 type(volgrid6d),
intent(inout) :: this
3149 type(griddim_def),
intent(in),
optional :: griddim_t
3150 integer,
intent(in) :: cgrid
3152 doubleprecision :: xmin, xmax, ymin, ymax
3153 doubleprecision :: step_lon,step_lat
3156 if (
present(griddim_t))
then 3158 call get_val(griddim_t,xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax)
3159 call set_val(this%griddim,xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax)
3161 CALL griddim_setsteps(this%griddim)
3170 call l4f_category_log(this%category,l4f_debug,
"C grid: T points, nothing to do")
3177 call l4f_category_log(this%category,l4f_debug,
"C grid: U points, we need interpolation")
3180 call get_val(this%griddim, xmin=xmin, xmax=xmax)
3181 step_lon=(xmax-xmin)/dble(this%griddim%dim%nx-1)
3182 xmin=xmin-step_lon/2.d0
3183 xmax=xmax-step_lon/2.d0
3184 call set_val(this%griddim, xmin=xmin, xmax=xmax)
3186 CALL griddim_setsteps(this%griddim)
3191 call l4f_category_log(this%category,l4f_debug,
"C grid: V points, we need interpolation")
3194 call get_val(this%griddim, ymin=ymin, ymax=ymax)
3195 step_lat=(ymax-ymin)/dble(this%griddim%dim%ny-1)
3196 ymin=ymin-step_lat/2.d0
3197 ymax=ymax-step_lat/2.d0
3198 call set_val(this%griddim, ymin=ymin, ymax=ymax)
3200 CALL griddim_setsteps(this%griddim)
3205 call raise_fatal_error ()
3212 call griddim_unproj(this%griddim)
3215 end subroutine vg6d_c2a_grid
3218 subroutine vg6d_c2a_mat(this,cgrid)
3221 integer,
intent(in) :: cgrid
3223 INTEGER :: i, j, k, iv, stallo
3224 REAL,
ALLOCATABLE :: tmp_arr(:,:)
3225 REAL,
POINTER :: voldatiuv(:,:)
3228 IF (cgrid == 0)
RETURN 3229 IF (cgrid /= 1 .AND. cgrid /= 2)
THEN 3231 trim(
to_char(cgrid))//
" not known")
3237 ALLOCATE(tmp_arr(this%griddim%dim%nx, this%griddim%dim%ny),stat=stallo)
3239 call l4f_log(l4f_fatal,
"allocating memory")
3240 call raise_fatal_error()
3244 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 3245 ALLOCATE(voldatiuv(this%griddim%dim%nx, this%griddim%dim%ny), stat=stallo)
3246 IF (stallo /= 0)
THEN 3247 CALL l4f_log(l4f_fatal,
"allocating memory")
3248 CALL raise_fatal_error()
3252 IF (cgrid == 1)
THEN 3253 DO iv = 1,
SIZE(this%var)
3254 DO k = 1,
SIZE(this%timerange)
3255 DO j = 1,
SIZE(this%time)
3256 DO i = 1,
SIZE(this%level)
3257 tmp_arr(:,:) = rmiss
3258 CALL volgrid_get_vol_2d(this, i, j, k, iv, voldatiuv)
3261 WHERE(voldatiuv(1,:) /= rmiss .AND. voldatiuv(2,:) /= rmiss)
3262 tmp_arr(1,:) = voldatiuv(1,:) - (voldatiuv(2,:) - voldatiuv(1,:)) / 2.
3266 WHERE(voldatiuv(1:this%griddim%dim%nx-1,:) /= rmiss .AND. &
3267 voldatiuv(2:this%griddim%dim%nx,:) /= rmiss)
3268 tmp_arr(2:this%griddim%dim%nx,:) = &
3269 (voldatiuv(1:this%griddim%dim%nx-1,:) + &
3270 voldatiuv(2:this%griddim%dim%nx,:)) / 2.
3273 voldatiuv(:,:) = tmp_arr
3274 CALL volgrid_set_vol_2d(this, i, j, k, iv, voldatiuv)
3280 ELSE IF (cgrid == 2)
THEN 3281 DO iv = 1,
SIZE(this%var)
3282 DO k = 1,
SIZE(this%timerange)
3283 DO j = 1,
SIZE(this%time)
3284 DO i = 1,
SIZE(this%level)
3285 tmp_arr(:,:) = rmiss
3286 CALL volgrid_get_vol_2d(this, i, j, k, iv, voldatiuv)
3289 WHERE(voldatiuv(:,1) /= rmiss .AND. voldatiuv(:,2) /= rmiss)
3290 tmp_arr(:,1) = voldatiuv(:,1) - (voldatiuv(:,2) - voldatiuv(:,1)) / 2.
3294 WHERE(voldatiuv(:,1:this%griddim%dim%ny-1) /= rmiss .AND. &
3295 voldatiuv(:,2:this%griddim%dim%ny) /= rmiss)
3296 tmp_arr(:,2:this%griddim%dim%ny) = &
3297 (voldatiuv(:,1:this%griddim%dim%ny-1) + &
3298 voldatiuv(:,2:this%griddim%dim%ny)) / 2.
3301 voldatiuv(:,:) = tmp_arr
3302 CALL volgrid_set_vol_2d(this, i, j, k, iv, voldatiuv)
3309 IF (.NOT.
ASSOCIATED(this%voldati))
THEN 3310 DEALLOCATE(voldatiuv)
3312 DEALLOCATE (tmp_arr)
3314 end subroutine vg6d_c2a_mat
3320 subroutine display_volgrid6d (this)
3329 print*,
"----------------------- volgrid6d display ---------------------" 3332 IF (
ASSOCIATED(this%time))
then 3333 print*,
"---- time vector ----" 3334 print*,
"elements=",
size(this%time)
3335 do i=1,
size(this%time)
3340 IF (
ASSOCIATED(this%timerange))
then 3341 print*,
"---- timerange vector ----" 3342 print*,
"elements=",
size(this%timerange)
3343 do i=1,
size(this%timerange)
3344 call display(this%timerange(i))
3348 IF (
ASSOCIATED(this%level))
then 3349 print*,
"---- level vector ----" 3350 print*,
"elements=",
size(this%level)
3351 do i=1,
size(this%level)
3356 IF (
ASSOCIATED(this%var))
then 3357 print*,
"---- var vector ----" 3358 print*,
"elements=",
size(this%var)
3359 do i=1,
size(this%var)
3364 IF (
ASSOCIATED(this%gaid))
then 3365 print*,
"---- gaid vector (present mask only) ----" 3366 print*,
"elements=",shape(this%gaid)
3367 print*,
c_e(reshape(this%gaid,(/
SIZE(this%gaid)/)))
3370 print*,
"--------------------------------------------------------------" 3373 end subroutine display_volgrid6d
3379 subroutine display_volgrid6dv (this)
3384 print*,
"----------------------- volgrid6d vector ---------------------" 3386 print*,
"elements=",
size(this)
3391 call l4f_category_log(this(i)%category,l4f_debug,
"ora mostro il vettore volgrid6d" )
3397 print*,
"--------------------------------------------------------------" 3399 end subroutine display_volgrid6dv
3404 subroutine vg6dv_rounding(vg6din,vg6dout,level,timerange,nostatproc,merge)
3406 type(
volgrid6d),
intent(out),
pointer :: vg6dout(:)
3409 logical,
intent(in),
optional :: merge
3410 logical,
intent(in),
optional :: nostatproc
3414 allocate(vg6dout(
size(vg6din)))
3416 do i = 1,
size(vg6din)
3417 call vg6d_rounding(vg6din(i),vg6dout(i),level,timerange,nostatproc,merge)
3420 end subroutine vg6dv_rounding
3433 subroutine vg6d_rounding(vg6din,vg6dout,level,timerange,nostatproc,merge)
3438 logical,
intent(in),
optional :: merge
3440 logical,
intent(in),
optional :: nostatproc
3442 integer :: ilevel,itimerange
3443 type(
vol7d_level) :: roundlevel(size(vg6din%level))
3446 roundlevel=vg6din%level
3448 if (
present(level))
then 3449 do ilevel = 1,
size(vg6din%level)
3450 if ((any(vg6din%level(ilevel) .almosteq. level)))
then 3451 roundlevel(ilevel)=level(1)
3456 roundtimerange=vg6din%timerange
3458 if (
present(timerange))
then 3459 do itimerange = 1,
size(vg6din%timerange)
3460 if ((any(vg6din%timerange(itimerange) .almosteq. timerange)))
then 3461 roundtimerange(itimerange)=timerange(1)
3468 if (optio_log(nostatproc))
then 3469 roundtimerange(:)%timerange=254
3470 roundtimerange(:)%p2=0
3474 call vg6d_reduce(vg6din,vg6dout,roundlevel,roundtimerange,merge)
3476 end subroutine vg6d_rounding
3486 subroutine vg6d_reduce(vg6din,vg6dout,roundlevel,roundtimerange,merge)
3491 logical,
intent(in),
optional :: merge
3493 integer :: nlevel,ntime,ntimerange,nvar,ilevel,itimerange,ivar,indl,indt,itime,nx,ny
3494 real,
allocatable :: vol2d(:,:)
3496 nx=vg6din%griddim%dim%nx
3497 ny=vg6din%griddim%dim%ny
3498 nlevel=count_distinct(roundlevel,back=.true.)
3499 ntime=
size(vg6din%time)
3500 ntimerange=count_distinct(roundtimerange,back=.true.)
3501 nvar=
size(vg6din%var)
3503 call init(vg6dout, vg6din%griddim, vg6din%time_definition, categoryappend=
"generated by vg6d_reduce")
3504 call volgrid6d_alloc(vg6dout, vg6din%griddim%dim, ntime, nlevel, ntimerange, nvar)
3506 if (
ASSOCIATED(vg6din%voldati) .or. optio_log(merge))
then 3507 call volgrid6d_alloc_vol(vg6dout,inivol=.true.,decode=.true.)
3508 allocate(vol2d(nx,ny))
3510 call volgrid6d_alloc_vol(vg6dout,inivol=.true.,decode=.false.)
3513 vg6dout%time=vg6din%time
3514 vg6dout%var=vg6din%var
3515 vg6dout%timerange=pack_distinct(roundtimerange,ntimerange,back=.true.)
3516 vg6dout%level=pack_distinct(roundlevel,nlevel,back=.true.)
3518 CALL sort(vg6dout%timerange)
3519 CALL sort(vg6dout%level)
3521 do ilevel=1,
size(vg6din%level)
3522 indl=
index(vg6dout%level,roundlevel(ilevel))
3523 do itimerange=1,
size(vg6din%timerange)
3524 indt=
index(vg6dout%timerange,roundtimerange(itimerange))
3528 if (
ASSOCIATED(vg6din%voldati))
then 3529 vol2d=vg6din%voldati(:,:,ilevel,itime,itimerange,ivar)
3532 if (optio_log(merge))
then 3534 if ( .not.
ASSOCIATED(vg6din%voldati))
then 3535 CALL grid_id_decode_data(vg6din%gaid(ilevel,itime,itimerange,ivar), vol2d)
3539 where (.not.
c_e(vg6dout%voldati(:,:,indl,itime,indt,ivar)))
3541 vg6dout%voldati(:,:,indl,itime,indt,ivar)=vol2d
3544 else if (
ASSOCIATED(vg6din%voldati))
then 3545 if (.not. any(
c_e(vg6dout%voldati(:,:,indl,itime,indt,ivar))))
then 3546 vg6dout%voldati(:,:,indl,itime,indt,ivar)=vol2d
3550 if (
c_e(vg6din%gaid(ilevel,itime,itimerange,ivar)).and. .not.
c_e(vg6dout%gaid(indl,itime,indt,ivar)))
then 3551 call copy (vg6din%gaid(ilevel,itime,itimerange,ivar), vg6dout%gaid(indl,itime,indt,ivar))
3558 if (
ASSOCIATED(vg6din%voldati) .or. optio_log(merge))
then 3562 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).