38 & varname, array, arraysize, history, range, &
39 & time, quiet, difftime, timed, time_average_store, err )
66 character(*),
intent(in):: varname
67 integer,
intent(in):: arraysize
68 real,
intent(in):: array(arraysize)
69 type(
gt_history),
intent(inout),
target,
optional:: history
70 character(*),
intent(in),
optional:: range
86 real,
intent(in),
optional:: time
108 logical,
intent(in),
optional:: quiet
125 real(
dp),
intent(in),
optional:: timed
131 logical,
intent(in),
optional:: time_average_store
148 logical,
intent(out),
optional:: err
163 character(STRING):: url, file, time_str
164 real:: time_value(1:1)
167 character(STRING):: avr_msg
168 real,
target:: array_work(arraysize)
169 real,
pointer:: array_work2(:) =>null()
170 integer:: arraysize_work2
171 integer,
allocatable:: start(:), count(:), stride(:)
174 character(STRING):: time_name
175 character(*),
parameter:: bnds_suffix =
'_bnds'
177 integer:: bnds_ord, time_count, bnds_rank
178 logical:: output_step
182 integer,
allocatable:: array_overwrap(:)
184 integer:: numdims, dimord, dimsize, dimsize_max, allcount, ra
185 character(STRING):: dimname
186 integer:: st_mpi(mpi_status_size)
187 real,
allocatable:: array_mpi_tmp(:)
188 real,
allocatable:: array_mpi_all(:,:)
191 character(STRING):: cause_c
193 subroutine timegoahead( varname, var, head, history, err )
196 character(len = *),
intent(in):: varname
198 real,
intent(in):: head
199 type(
gt_history),
intent(inout),
optional,
target:: history
200 logical,
intent(out),
optional:: err
203 character(*),
parameter:: subname =
"HistoryPutRealEx"
205 call beginsub(subname,
'varname=%a range=%a', &
209 if (
present(history))
then
218 if ( .not. hst % initialized )
then
220 cause_c =
'GT_HISTORY'
227 if ( (
present(time) .or.
present(difftime) .or.
present(timed) ) &
230 &
'(varname=%c) "range" and "time" or "timed" or "difftime" are not suppored at the same time', &
231 & c1 = trim(varname) )
233 cause_c =
'"range" and "time" or "timed" or "difftime" are not suppored at the same time'
240 if ( .not. hst % mpi_gather )
then
243 if ( hst % mpi_myrank == 0 )
then
246 call mpi_bcast( v_ord, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
247 call dbgmessage(
'v_ord=<%d> is shared on all nodes.', i = (/v_ord/) )
254 if (
present(difftime) )
then
255 timedw =
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
256 elseif (
present(timed) )
then
258 elseif (
present(time) )
then
261 if ( v_ord > 0 )
then
268 if ( hst % var_avr_count( v_ord ) > -1 )
then
273 if ( .not.
present(time) &
274 & .and. .not.
present(timed) &
275 & .and. .not.
present(difftime) )
then
277 &
'(varname=%c) arguments "time" or "timed" or "difftime" are needed ' // &
278 &
'when "time_average=.true." is specified to "HistoryAddVariable"', &
279 & c1 = trim(varname) )
291 if ( arraysize /= hst % var_avr_data( v_ord ) % length )
then
293 &
'(varname=%c) size of array should be (%d). size of array is (%d)', &
294 & i = (/hst % var_avr_data( v_ord ) % length, arraysize/), &
295 & c1 = trim(varname) )
311 if ( hst % var_avr_firstput( v_ord ) )
then
312 if ( hst % var_avr_count( v_ord ) == 0 )
then
314 hst % var_avr_prevtime( v_ord ) = timedw
316 hst % var_avr_baseint( v_ord ) = &
317 & timedw - hst % var_avr_prevtime( v_ord )
319 hst % var_avr_prevtime( v_ord ) = timedw
320 hst % var_avr_firstput( v_ord ) = .false.
330 if ( hst % var_avr_count( v_ord ) == 0 )
then
331 hst % var_avr_baseint( v_ord ) = &
332 & timedw - hst % var_avr_prevtime( v_ord )
334 hst % var_avr_prevtime( v_ord ) = timedw
341 avr_coef = ( timedw - hst % var_avr_prevtime( v_ord ) ) &
342 & / hst % var_avr_baseint( v_ord )
343 hst % var_avr_prevtime( v_ord ) = timedw
349 hst % var_avr_data( v_ord ) % a_DataAvr = &
350 & hst % var_avr_data( v_ord ) % a_DataAvr + array * avr_coef
355 hst % var_avr_count( v_ord ) = &
356 & hst % var_avr_count( v_ord ) + 1
357 hst % var_avr_coefsum( v_ord ) = &
358 & hst % var_avr_coefsum( v_ord ) + avr_coef
362 if (
present(difftime) )
then
363 hst % time_bnds(2:2) =
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
364 elseif (
present (timed) )
then
365 hst % time_bnds(2:2) = timed
367 hst % time_bnds(2:2) = time
375 if ( .not. hst % origin_setting )
then
376 if (
present(difftime) )
then
377 hst % origin =
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
378 hst % time_bnds =
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
379 hst % origin_setting = .true.
380 elseif (
present(timed) )
then
382 hst % time_bnds = timed
383 hst % origin_setting = .true.
384 elseif (
present(time) )
then
386 hst % time_bnds = time
387 hst % origin_setting = .true.
413 output_step = .false.
414 elseif (
present(difftime) .or.
present(timed) .or.
present(time) )
then
415 output_step = .false.
416 if ( abs( hst % interval ) <
dp_eps )
then
419 if ( abs(
mod( timedw - hst % origin, hst % interval ) ) <
dp_eps )
then
427 if ( .not. output_step )
then
432 if ( v_ord > 0 )
then
433 if ( hst % var_avr_count( v_ord ) > -1 )
then
435 avr_msg =
'(time average of ' // trim(
tochar(hst % var_avr_count( v_ord )) ) //
' step data)'
444 & ( hst % var_avr_data( v_ord ) % a_DataAvr ) / ( hst % var_avr_coefsum( v_ord ) ), &
445 & kind = kind(array_work) )
448 hst % var_avr_data( v_ord ) % a_DataAvr = 0.0
449 hst % var_avr_count( v_ord ) = 0
450 hst % var_avr_coefsum( v_ord ) = 0.0_dp
451 hst % var_avr_firstput( v_ord ) = .false.
455 if ( .not. hst % mpi_gather )
then
456 array_work2 => array_work
457 arraysize_work2 = arraysize
463 numdims =
size( hst % mpi_fileinfo % axes )
464 if ( hst % mpi_myrank == 0 )
then
468 & hst % mpi_fileinfo % axes(i), &
470 if ( trim(varname) == trim(dimname) )
then
475 call mpi_bcast( dimord, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
477 call mpi_bcast( dimord, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
479 if ( dimord > 0 )
then
481 & hst % mpi_fileinfo % axes(dimord), &
482 &
size = dimsize_max )
483 dimsize =
size( array )
484 if ( dimsize > dimsize_max .and. hst % unlimited_index /= dimord )
then
486 &
'dim=<%c> data size (%d) exceeds size of the dim (%d) by HistoryCreate. ' // &
487 &
'the data will be trancated. ', &
488 & i = (/ dimsize, dimsize_max /), c1 = trim(varname) )
489 dimsize = dimsize_max
491 if (
associated( hst % mpi_dimdata_each( dimord ) % a_Axis ) )
then
492 deallocate( hst % mpi_dimdata_each( dimord ) % a_Axis )
494 allocate( hst % mpi_dimdata_each( dimord ) % a_Axis(dimsize) )
495 hst % mpi_dimdata_each( dimord ) % a_Axis = array(1:dimsize)
496 hst % mpi_dimdata_each( dimord ) % length = dimsize
503 if ( v_ord > 0 )
then
504 if ( .not.
associated( hst % mpi_gthr_info ) )
then
508 if ( .not.
associated( hst % mpi_vars_index( v_ord ) % allcount ) )
then
517 if ( v_ord > 0 )
then
518 arraysize_work2 = hst % mpi_vars_index(v_ord) % allcount_all
519 if ( arraysize_work2 < 1 ) arraysize_work2 = 1
520 if ( hst % mpi_myrank == 0 )
then
521 do ra = 1, hst % mpi_nprocs - 1
522 allcount = hst % mpi_vars_index(v_ord) % allcount(ra)
523 call mpi_send( allcount, 1, mpi_integer, ra, 0, mpi_comm_world, err_mpi )
526 call mpi_recv( allcount, 1, mpi_integer, 0, 0, mpi_comm_world, st_mpi, err_mpi )
528 if ( hst % mpi_myrank /= 0 )
then
529 call mpi_send( array_work, allcount, &
530 & mpi_real, 0, 0, mpi_comm_world, err_mpi )
532 allocate( array_mpi_all(0: hst % mpi_nprocs - 1, arraysize_work2 ) )
533 allocate( array_mpi_tmp( arraysize_work2 ) )
534 array_mpi_all(:,:) = 0.0
535 array_mpi_tmp(:) = 0.0
536 allcount = hst % mpi_vars_index(v_ord) % allcount(0)
537 array_mpi_all(0,1:allcount) = array_work
538 do ra = 1, hst % mpi_nprocs - 1
539 allcount = hst % mpi_vars_index(v_ord) % allcount(ra)
540 call mpi_recv( array_mpi_tmp(1:allcount), allcount, &
541 & mpi_real, ra, 0, mpi_comm_world, st_mpi, err_mpi )
542 array_mpi_all(ra,1:allcount) = array_mpi_tmp(1:allcount)
544 allocate( array_work2( arraysize_work2 ) )
545 allocate( array_overwrap( arraysize_work2 ) )
547 array_overwrap(:) = 0
548 do ra = 0, hst % mpi_nprocs - 1
549 do i = 1, hst % mpi_vars_index(v_ord) % allcount(ra)
550 new_index = hst % mpi_vars_index(v_ord) % each2all(ra, i)
551 array_work2( new_index ) = &
552 & array_work2( new_index ) + array_mpi_all( ra, i )
553 array_overwrap( new_index ) = array_overwrap( new_index ) + 1
556 where ( array_overwrap == 0 )
559 array_work2(:) = array_work2(:) / array_overwrap(:)
560 deallocate( array_mpi_all, array_mpi_tmp, array_overwrap )
564 array_work2 => array_work
565 arraysize_work2 = arraysize
572 if ( .not. hst % mpi_gather &
573 & .or. ( hst % mpi_gather .and. &
574 & hst % mpi_myrank == 0 .and. &
575 & hst % mpi_fileinfo % already_output) )
then
577 & varname = varname, &
578 & head = real(array_work2(1)), &
580 & history = history, &
585 call dbgmessage(
'varname=<%c> has no dimension. so range is ignoread.', &
590 call put(var, array_work2, arraysize_work2)
595 allocate(start(dims), count(dims), stride(dims))
597 call get_slice(var, i, start(i), count(i), stride(i))
600 call slice(var, range, slice_err)
601 call put(var, array_work2, arraysize_work2)
604 call slice(var, i, start(i), count(i), stride(i))
606 deallocate(start, count, stride)
609 if ( hst % mpi_gather .and. v_ord > 0 )
then
610 deallocate( array_work2 )
617 if ( .not. hst % mpi_gather &
618 & .or. ( hst % mpi_gather .and. &
619 & hst % mpi_myrank == 0 .and. &
620 & hst % mpi_fileinfo % already_output ) )
then
621 if ( v_ord > 0 )
then
622 if ( hst % var_avr_count( v_ord ) > -1 )
then
626 timevar = hst % dimvars( hst % unlimited_index )
636 call open( var = bndsvar, &
637 & url =
urlmerge(file=file, var=trim(time_name) // bnds_suffix) )
646 if ( bnds_rank > 1 )
then
649 & dimord = hst % growable_indices(bnds_ord), &
650 & allcount = time_count )
652 if ( (hst % time_bnds_output_count < 1) &
653 & .or. (hst % time_bnds_output_count < time_count) )
then
654 call slice(bndsvar, hst % growable_indices(bnds_ord), &
655 & start=hst % time_bnds_output_count+1, count=1)
656 call put(bndsvar, hst % time_bnds, 2)
657 hst % time_bnds_output_count = hst % time_bnds_output_count + 1
659 call close( var = bndsvar )
660 if (
present(difftime) )
then
661 hst % time_bnds(1:1) = &
662 &
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
663 elseif (
present(timed) )
then
664 hst % time_bnds(1:1) = timed
666 hst % time_bnds(1:1) = time
675 if ( .not. hst % mpi_gather &
676 & .or. ( hst % mpi_gather .and. &
677 & hst % mpi_myrank == 0 .and. &
678 & hst % mpi_fileinfo % already_output ) )
then
680 call inquire( hst % dimvars(1), &
684 if ( hst % unlimited_index < 1 )
then
687 timevar = hst % dimvars(hst % unlimited_index)
688 call slice( timevar, &
689 & 1, start = hst % count(v_ord), count = 1 )
694 time_str =
'(time=' // trim(
tochar( time_value(1) )) //
')'
697 &
'"%a" => "%a" %a %a', &
698 & ca =
stoa( varname, file, time_str, avr_msg ) )
706 call storeerror( stat, subname, err, cause_c )
710 & varname, array, arraysize, history, range, &
711 & time, quiet, difftime, timed, time_average_store, err )
738 character(*),
intent(in):: varname
739 integer,
intent(in):: arraysize
740 real(
dp),
intent(in):: array(arraysize)
741 type(
gt_history),
intent(inout),
target,
optional:: history
742 character(*),
intent(in),
optional:: range
758 real,
intent(in),
optional:: time
780 logical,
intent(in),
optional:: quiet
797 real(
dp),
intent(in),
optional:: timed
803 logical,
intent(in),
optional:: time_average_store
820 logical,
intent(out),
optional:: err
835 character(STRING):: url, file, time_str
836 real:: time_value(1:1)
839 character(STRING):: avr_msg
840 real(
dp),
target:: array_work(arraysize)
841 real(
dp),
pointer:: array_work2(:) =>null()
842 integer:: arraysize_work2
843 integer,
allocatable:: start(:), count(:), stride(:)
846 character(STRING):: time_name
847 character(*),
parameter:: bnds_suffix =
'_bnds'
849 integer:: bnds_ord, time_count, bnds_rank
850 logical:: output_step
854 integer,
allocatable:: array_overwrap(:)
856 integer:: numdims, dimord, dimsize, dimsize_max, allcount, ra
857 character(STRING):: dimname
858 integer:: st_mpi(mpi_status_size)
859 real(
dp),
allocatable:: array_mpi_tmp(:)
860 real(
dp),
allocatable:: array_mpi_all(:,:)
863 character(STRING):: cause_c
865 subroutine timegoahead( varname, var, head, history, err )
868 character(len = *),
intent(in):: varname
870 real,
intent(in):: head
871 type(
gt_history),
intent(inout),
optional,
target:: history
872 logical,
intent(out),
optional:: err
875 character(*),
parameter:: subname =
"HistoryPutDoubleEx"
877 call beginsub(subname,
'varname=%a range=%a', &
881 if (
present(history))
then
890 if ( .not. hst % initialized )
then
892 cause_c =
'GT_HISTORY'
899 if ( (
present(time) .or.
present(difftime) .or.
present(timed) ) &
902 &
'(varname=%c) "range" and "time" or "timed" or "difftime" are not suppored at the same time', &
903 & c1 = trim(varname) )
905 cause_c =
'"range" and "time" or "timed" or "difftime" are not suppored at the same time'
912 if ( .not. hst % mpi_gather )
then
915 if ( hst % mpi_myrank == 0 )
then
918 call mpi_bcast( v_ord, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
919 call dbgmessage(
'v_ord=<%d> is shared on all nodes.', i = (/v_ord/) )
926 if (
present(difftime) )
then
927 timedw =
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
928 elseif (
present(timed) )
then
930 elseif (
present(time) )
then
933 if ( v_ord > 0 )
then
940 if ( hst % var_avr_count( v_ord ) > -1 )
then
945 if ( .not.
present(time) &
946 & .and. .not.
present(timed) &
947 & .and. .not.
present(difftime) )
then
949 &
'(varname=%c) arguments "time" or "timed" or "difftime" are needed ' // &
950 &
'when "time_average=.true." is specified to "HistoryAddVariable"', &
951 & c1 = trim(varname) )
963 if ( arraysize /= hst % var_avr_data( v_ord ) % length )
then
965 &
'(varname=%c) size of array should be (%d). size of array is (%d)', &
966 & i = (/hst % var_avr_data( v_ord ) % length, arraysize/), &
967 & c1 = trim(varname) )
983 if ( hst % var_avr_firstput( v_ord ) )
then
984 if ( hst % var_avr_count( v_ord ) == 0 )
then
986 hst % var_avr_prevtime( v_ord ) = timedw
988 hst % var_avr_baseint( v_ord ) = &
989 & timedw - hst % var_avr_prevtime( v_ord )
991 hst % var_avr_prevtime( v_ord ) = timedw
992 hst % var_avr_firstput( v_ord ) = .false.
1002 if ( hst % var_avr_count( v_ord ) == 0 )
then
1003 hst % var_avr_baseint( v_ord ) = &
1004 & timedw - hst % var_avr_prevtime( v_ord )
1006 hst % var_avr_prevtime( v_ord ) = timedw
1013 avr_coef = ( timedw - hst % var_avr_prevtime( v_ord ) ) &
1014 & / hst % var_avr_baseint( v_ord )
1015 hst % var_avr_prevtime( v_ord ) = timedw
1021 hst % var_avr_data( v_ord ) % a_DataAvr = &
1022 & hst % var_avr_data( v_ord ) % a_DataAvr + array * avr_coef
1027 hst % var_avr_count( v_ord ) = &
1028 & hst % var_avr_count( v_ord ) + 1
1029 hst % var_avr_coefsum( v_ord ) = &
1030 & hst % var_avr_coefsum( v_ord ) + avr_coef
1034 if (
present(difftime) )
then
1035 hst % time_bnds(2:2) =
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
1036 elseif (
present (timed) )
then
1037 hst % time_bnds(2:2) = timed
1039 hst % time_bnds(2:2) = time
1047 if ( .not. hst % origin_setting )
then
1048 if (
present(difftime) )
then
1049 hst % origin =
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
1050 hst % time_bnds =
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
1051 hst % origin_setting = .true.
1052 elseif (
present(timed) )
then
1053 hst % origin = timed
1054 hst % time_bnds = timed
1055 hst % origin_setting = .true.
1056 elseif (
present(time) )
then
1058 hst % time_bnds = time
1059 hst % origin_setting = .true.
1081 output_step = .true.
1083 output_step = .true.
1085 output_step = .false.
1086 elseif (
present(difftime) .or.
present(timed) .or.
present(time) )
then
1087 output_step = .false.
1088 if ( abs( hst % interval ) <
dp_eps )
then
1089 output_step = .true.
1091 if ( abs(
mod( timedw - hst % origin, hst % interval ) ) <
dp_eps )
then
1092 output_step = .true.
1099 if ( .not. output_step )
then
1104 if ( v_ord > 0 )
then
1105 if ( hst % var_avr_count( v_ord ) > -1 )
then
1107 avr_msg =
'(time average of ' // trim(
tochar(hst % var_avr_count( v_ord )) ) //
' step data)'
1115 array_work = real( &
1116 & ( hst % var_avr_data( v_ord ) % a_DataAvr ) / ( hst % var_avr_coefsum( v_ord ) ), &
1117 & kind = kind(array_work) )
1120 hst % var_avr_data( v_ord ) % a_DataAvr = 0.0
1121 hst % var_avr_count( v_ord ) = 0
1122 hst % var_avr_coefsum( v_ord ) = 0.0_dp
1123 hst % var_avr_firstput( v_ord ) = .false.
1127 if ( .not. hst % mpi_gather )
then
1128 array_work2 => array_work
1129 arraysize_work2 = arraysize
1135 numdims =
size( hst % mpi_fileinfo % axes )
1136 if ( hst % mpi_myrank == 0 )
then
1140 & hst % mpi_fileinfo % axes(i), &
1142 if ( trim(varname) == trim(dimname) )
then
1147 call mpi_bcast( dimord, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
1149 call mpi_bcast( dimord, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
1151 if ( dimord > 0 )
then
1153 & hst % mpi_fileinfo % axes(dimord), &
1154 &
size = dimsize_max )
1155 dimsize =
size( array )
1156 if ( dimsize > dimsize_max .and. hst % unlimited_index /= dimord )
then
1158 &
'dim=<%c> data size (%d) exceeds size of the dim (%d) by HistoryCreate. ' // &
1159 &
'the data will be trancated. ', &
1160 & i = (/ dimsize, dimsize_max /), c1 = trim(varname) )
1161 dimsize = dimsize_max
1163 if (
associated( hst % mpi_dimdata_each( dimord ) % a_Axis ) )
then
1164 deallocate( hst % mpi_dimdata_each( dimord ) % a_Axis )
1166 allocate( hst % mpi_dimdata_each( dimord ) % a_Axis(dimsize) )
1167 hst % mpi_dimdata_each( dimord ) % a_Axis = array(1:dimsize)
1168 hst % mpi_dimdata_each( dimord ) % length = dimsize
1175 if ( v_ord > 0 )
then
1176 if ( .not.
associated( hst % mpi_gthr_info ) )
then
1180 if ( .not.
associated( hst % mpi_vars_index( v_ord ) % allcount ) )
then
1189 if ( v_ord > 0 )
then
1190 arraysize_work2 = hst % mpi_vars_index(v_ord) % allcount_all
1191 if ( arraysize_work2 < 1 ) arraysize_work2 = 1
1192 if ( hst % mpi_myrank == 0 )
then
1193 do ra = 1, hst % mpi_nprocs - 1
1194 allcount = hst % mpi_vars_index(v_ord) % allcount(ra)
1195 call mpi_send( allcount, 1, mpi_integer, ra, 0, mpi_comm_world, err_mpi )
1198 call mpi_recv( allcount, 1, mpi_integer, 0, 0, mpi_comm_world, st_mpi, err_mpi )
1200 if ( hst % mpi_myrank /= 0 )
then
1201 call mpi_send( array_work, allcount, &
1202 & mpi_double_precision, 0, 0, mpi_comm_world, err_mpi )
1204 allocate( array_mpi_all(0: hst % mpi_nprocs - 1, arraysize_work2 ) )
1205 allocate( array_mpi_tmp( arraysize_work2 ) )
1206 array_mpi_all(:,:) = 0.0_dp
1207 array_mpi_tmp(:) = 0.0_dp
1208 allcount = hst % mpi_vars_index(v_ord) % allcount(0)
1209 array_mpi_all(0,1:allcount) = array_work
1210 do ra = 1, hst % mpi_nprocs - 1
1211 allcount = hst % mpi_vars_index(v_ord) % allcount(ra)
1212 call mpi_recv( array_mpi_tmp(1:allcount), allcount, &
1213 & mpi_double_precision, ra, 0, mpi_comm_world, st_mpi, err_mpi )
1214 array_mpi_all(ra,1:allcount) = array_mpi_tmp(1:allcount)
1216 allocate( array_work2( arraysize_work2 ) )
1217 allocate( array_overwrap( arraysize_work2 ) )
1218 array_work2 = 0.0_dp
1219 array_overwrap(:) = 0
1220 do ra = 0, hst % mpi_nprocs - 1
1221 do i = 1, hst % mpi_vars_index(v_ord) % allcount(ra)
1222 new_index = hst % mpi_vars_index(v_ord) % each2all(ra, i)
1223 array_work2( new_index ) = &
1224 & array_work2( new_index ) + array_mpi_all( ra, i )
1225 array_overwrap( new_index ) = array_overwrap( new_index ) + 1
1228 where ( array_overwrap == 0 )
1231 array_work2(:) = array_work2(:) / array_overwrap(:)
1232 deallocate( array_mpi_all, array_mpi_tmp, array_overwrap )
1236 array_work2 => array_work
1237 arraysize_work2 = arraysize
1244 if ( .not. hst % mpi_gather &
1245 & .or. ( hst % mpi_gather .and. &
1246 & hst % mpi_myrank == 0 .and. &
1247 & hst % mpi_fileinfo % already_output) )
then
1249 & varname = varname, &
1250 & head = real(array_work2(1)), &
1252 & history = history, &
1257 call dbgmessage(
'varname=<%c> has no dimension. so range is ignoread.', &
1262 call put(var, array_work2, arraysize_work2)
1267 allocate(start(dims), count(dims), stride(dims))
1269 call get_slice(var, i, start(i), count(i), stride(i))
1272 call slice(var, range, slice_err)
1273 call put(var, array_work2, arraysize_work2)
1276 call slice(var, i, start(i), count(i), stride(i))
1278 deallocate(start, count, stride)
1281 if ( hst % mpi_gather .and. v_ord > 0 )
then
1282 deallocate( array_work2 )
1289 if ( .not. hst % mpi_gather &
1290 & .or. ( hst % mpi_gather .and. &
1291 & hst % mpi_myrank == 0 .and. &
1292 & hst % mpi_fileinfo % already_output ) )
then
1293 if ( v_ord > 0 )
then
1294 if ( hst % var_avr_count( v_ord ) > -1 )
then
1298 timevar = hst % dimvars( hst % unlimited_index )
1302 & name = time_name )
1308 call open( var = bndsvar, &
1309 & url =
urlmerge(file=file, var=trim(time_name) // bnds_suffix) )
1316 & rank = bnds_rank )
1318 if ( bnds_rank > 1 )
then
1321 & dimord = hst % growable_indices(bnds_ord), &
1322 & allcount = time_count )
1324 if ( (hst % time_bnds_output_count < 1) &
1325 & .or. (hst % time_bnds_output_count < time_count) )
then
1326 call slice(bndsvar, hst % growable_indices(bnds_ord), &
1327 & start=hst % time_bnds_output_count+1, count=1)
1328 call put(bndsvar, hst % time_bnds, 2)
1329 hst % time_bnds_output_count = hst % time_bnds_output_count + 1
1331 call close( var = bndsvar )
1332 if (
present(difftime) )
then
1333 hst % time_bnds(1:1) = &
1334 &
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
1335 elseif (
present(timed) )
then
1336 hst % time_bnds(1:1) = timed
1338 hst % time_bnds(1:1) = time
1347 if ( .not. hst % mpi_gather &
1348 & .or. ( hst % mpi_gather .and. &
1349 & hst % mpi_myrank == 0 .and. &
1350 & hst % mpi_fileinfo % already_output ) )
then
1352 call inquire( hst % dimvars(1), &
1356 if ( hst % unlimited_index < 1 )
then
1359 timevar = hst % dimvars(hst % unlimited_index)
1360 call slice( timevar, &
1361 & 1, start = hst % count(v_ord), count = 1 )
1362 call get( timevar, &
1366 time_str =
'(time=' // trim(
tochar( time_value(1) )) //
')'
1369 &
'"%a" => "%a" %a %a', &
1370 & ca =
stoa( varname, file, time_str, avr_msg ) )
1378 call storeerror( stat, subname, err, cause_c )
1382 & varname, array, arraysize, history, range, &
1383 & time, quiet, difftime, timed, time_average_store, err )
1410 character(*),
intent(in):: varname
1411 integer,
intent(in):: arraysize
1412 integer,
intent(in):: array(arraysize)
1413 type(
gt_history),
intent(inout),
target,
optional:: history
1414 character(*),
intent(in),
optional:: range
1430 real,
intent(in),
optional:: time
1452 logical,
intent(in),
optional:: quiet
1463 type(
dc_difftime),
intent(in),
optional:: difftime
1469 real(
dp),
intent(in),
optional:: timed
1475 logical,
intent(in),
optional:: time_average_store
1492 logical,
intent(out),
optional:: err
1507 character(STRING):: url, file, time_str
1508 real:: time_value(1:1)
1511 character(STRING):: avr_msg
1512 integer,
target:: array_work(arraysize)
1513 integer,
pointer:: array_work2(:) =>null()
1514 integer:: arraysize_work2
1515 integer,
allocatable:: start(:), count(:), stride(:)
1517 logical :: slice_err
1518 character(STRING):: time_name
1519 character(*),
parameter:: bnds_suffix =
'_bnds'
1521 integer:: bnds_ord, time_count, bnds_rank
1522 logical:: output_step
1526 integer,
allocatable:: array_overwrap(:)
1528 integer:: numdims, dimord, dimsize, dimsize_max, allcount, ra
1529 character(STRING):: dimname
1530 integer:: st_mpi(mpi_status_size)
1531 integer,
allocatable:: array_mpi_tmp(:)
1532 integer,
allocatable:: array_mpi_all(:,:)
1535 character(STRING):: cause_c
1537 subroutine timegoahead( varname, var, head, history, err )
1540 character(len = *),
intent(in):: varname
1542 real,
intent(in):: head
1543 type(
gt_history),
intent(inout),
optional,
target:: history
1544 logical,
intent(out),
optional:: err
1547 character(*),
parameter:: subname =
"HistoryPutIntEx"
1549 call beginsub(subname,
'varname=%a range=%a', &
1553 if (
present(history))
then
1562 if ( .not. hst % initialized )
then
1564 cause_c =
'GT_HISTORY'
1571 if ( (
present(time) .or.
present(difftime) .or.
present(timed) ) &
1574 &
'(varname=%c) "range" and "time" or "timed" or "difftime" are not suppored at the same time', &
1575 & c1 = trim(varname) )
1577 cause_c =
'"range" and "time" or "timed" or "difftime" are not suppored at the same time'
1584 if ( .not. hst % mpi_gather )
then
1587 if ( hst % mpi_myrank == 0 )
then
1590 call mpi_bcast( v_ord, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
1591 call dbgmessage(
'v_ord=<%d> is shared on all nodes.', i = (/v_ord/) )
1598 if (
present(difftime) )
then
1599 timedw =
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
1600 elseif (
present(timed) )
then
1602 elseif (
present(time) )
then
1605 if ( v_ord > 0 )
then
1612 if ( hst % var_avr_count( v_ord ) > -1 )
then
1617 if ( .not.
present(time) &
1618 & .and. .not.
present(timed) &
1619 & .and. .not.
present(difftime) )
then
1621 &
'(varname=%c) arguments "time" or "timed" or "difftime" are needed ' // &
1622 &
'when "time_average=.true." is specified to "HistoryAddVariable"', &
1623 & c1 = trim(varname) )
1635 if ( arraysize /= hst % var_avr_data( v_ord ) % length )
then
1637 &
'(varname=%c) size of array should be (%d). size of array is (%d)', &
1638 & i = (/hst % var_avr_data( v_ord ) % length, arraysize/), &
1639 & c1 = trim(varname) )
1655 if ( hst % var_avr_firstput( v_ord ) )
then
1656 if ( hst % var_avr_count( v_ord ) == 0 )
then
1658 hst % var_avr_prevtime( v_ord ) = timedw
1660 hst % var_avr_baseint( v_ord ) = &
1661 & timedw - hst % var_avr_prevtime( v_ord )
1663 hst % var_avr_prevtime( v_ord ) = timedw
1664 hst % var_avr_firstput( v_ord ) = .false.
1674 if ( hst % var_avr_count( v_ord ) == 0 )
then
1675 hst % var_avr_baseint( v_ord ) = &
1676 & timedw - hst % var_avr_prevtime( v_ord )
1678 hst % var_avr_prevtime( v_ord ) = timedw
1685 avr_coef = ( timedw - hst % var_avr_prevtime( v_ord ) ) &
1686 & / hst % var_avr_baseint( v_ord )
1687 hst % var_avr_prevtime( v_ord ) = timedw
1693 hst % var_avr_data( v_ord ) % a_DataAvr = &
1694 & hst % var_avr_data( v_ord ) % a_DataAvr + array * avr_coef
1699 hst % var_avr_count( v_ord ) = &
1700 & hst % var_avr_count( v_ord ) + 1
1701 hst % var_avr_coefsum( v_ord ) = &
1702 & hst % var_avr_coefsum( v_ord ) + avr_coef
1706 if (
present(difftime) )
then
1707 hst % time_bnds(2:2) =
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
1708 elseif (
present (timed) )
then
1709 hst % time_bnds(2:2) = timed
1711 hst % time_bnds(2:2) = time
1719 if ( .not. hst % origin_setting )
then
1720 if (
present(difftime) )
then
1721 hst % origin =
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
1722 hst % time_bnds =
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
1723 hst % origin_setting = .true.
1724 elseif (
present(timed) )
then
1725 hst % origin = timed
1726 hst % time_bnds = timed
1727 hst % origin_setting = .true.
1728 elseif (
present(time) )
then
1730 hst % time_bnds = time
1731 hst % origin_setting = .true.
1753 output_step = .true.
1755 output_step = .true.
1757 output_step = .false.
1758 elseif (
present(difftime) .or.
present(timed) .or.
present(time) )
then
1759 output_step = .false.
1760 if ( abs( hst % interval ) <
dp_eps )
then
1761 output_step = .true.
1763 if ( abs(
mod( timedw - hst % origin, hst % interval ) ) <
dp_eps )
then
1764 output_step = .true.
1771 if ( .not. output_step )
then
1776 if ( v_ord > 0 )
then
1777 if ( hst % var_avr_count( v_ord ) > -1 )
then
1779 avr_msg =
'(time average of ' // trim(
tochar(hst % var_avr_count( v_ord )) ) //
' step data)'
1788 & ( hst % var_avr_data( v_ord ) % a_DataAvr ) / ( hst % var_avr_coefsum( v_ord ) ), &
1789 & kind = kind(array_work) )
1792 hst % var_avr_data( v_ord ) % a_DataAvr = 0.0
1793 hst % var_avr_count( v_ord ) = 0
1794 hst % var_avr_coefsum( v_ord ) = 0.0_dp
1795 hst % var_avr_firstput( v_ord ) = .false.
1799 if ( .not. hst % mpi_gather )
then
1800 array_work2 => array_work
1801 arraysize_work2 = arraysize
1807 numdims =
size( hst % mpi_fileinfo % axes )
1808 if ( hst % mpi_myrank == 0 )
then
1812 & hst % mpi_fileinfo % axes(i), &
1814 if ( trim(varname) == trim(dimname) )
then
1819 call mpi_bcast( dimord, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
1821 call mpi_bcast( dimord, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
1823 if ( dimord > 0 )
then
1825 & hst % mpi_fileinfo % axes(dimord), &
1826 &
size = dimsize_max )
1827 dimsize =
size( array )
1828 if ( dimsize > dimsize_max .and. hst % unlimited_index /= dimord )
then
1830 &
'dim=<%c> data size (%d) exceeds size of the dim (%d) by HistoryCreate. ' // &
1831 &
'the data will be trancated. ', &
1832 & i = (/ dimsize, dimsize_max /), c1 = trim(varname) )
1833 dimsize = dimsize_max
1835 if (
associated( hst % mpi_dimdata_each( dimord ) % a_Axis ) )
then
1836 deallocate( hst % mpi_dimdata_each( dimord ) % a_Axis )
1838 allocate( hst % mpi_dimdata_each( dimord ) % a_Axis(dimsize) )
1839 hst % mpi_dimdata_each( dimord ) % a_Axis = array(1:dimsize)
1840 hst % mpi_dimdata_each( dimord ) % length = dimsize
1847 if ( v_ord > 0 )
then
1848 if ( .not.
associated( hst % mpi_gthr_info ) )
then
1852 if ( .not.
associated( hst % mpi_vars_index( v_ord ) % allcount ) )
then
1861 if ( v_ord > 0 )
then
1862 arraysize_work2 = hst % mpi_vars_index(v_ord) % allcount_all
1863 if ( arraysize_work2 < 1 ) arraysize_work2 = 1
1864 if ( hst % mpi_myrank == 0 )
then
1865 do ra = 1, hst % mpi_nprocs - 1
1866 allcount = hst % mpi_vars_index(v_ord) % allcount(ra)
1867 call mpi_send( allcount, 1, mpi_integer, ra, 0, mpi_comm_world, err_mpi )
1870 call mpi_recv( allcount, 1, mpi_integer, 0, 0, mpi_comm_world, st_mpi, err_mpi )
1872 if ( hst % mpi_myrank /= 0 )
then
1873 call mpi_send( array_work, allcount, &
1874 & mpi_integer, 0, 0, mpi_comm_world, err_mpi )
1876 allocate( array_mpi_all(0: hst % mpi_nprocs - 1, arraysize_work2 ) )
1877 allocate( array_mpi_tmp( arraysize_work2 ) )
1878 array_mpi_all(:,:) = 0
1879 array_mpi_tmp(:) = 0
1880 allcount = hst % mpi_vars_index(v_ord) % allcount(0)
1881 array_mpi_all(0,1:allcount) = array_work
1882 do ra = 1, hst % mpi_nprocs - 1
1883 allcount = hst % mpi_vars_index(v_ord) % allcount(ra)
1884 call mpi_recv( array_mpi_tmp(1:allcount), allcount, &
1885 & mpi_integer, ra, 0, mpi_comm_world, st_mpi, err_mpi )
1886 array_mpi_all(ra,1:allcount) = array_mpi_tmp(1:allcount)
1888 allocate( array_work2( arraysize_work2 ) )
1889 allocate( array_overwrap( arraysize_work2 ) )
1891 array_overwrap(:) = 0
1892 do ra = 0, hst % mpi_nprocs - 1
1893 do i = 1, hst % mpi_vars_index(v_ord) % allcount(ra)
1894 new_index = hst % mpi_vars_index(v_ord) % each2all(ra, i)
1895 array_work2( new_index ) = &
1896 & array_work2( new_index ) + array_mpi_all( ra, i )
1897 array_overwrap( new_index ) = array_overwrap( new_index ) + 1
1900 where ( array_overwrap == 0 )
1903 array_work2(:) = array_work2(:) / array_overwrap(:)
1904 deallocate( array_mpi_all, array_mpi_tmp, array_overwrap )
1908 array_work2 => array_work
1909 arraysize_work2 = arraysize
1916 if ( .not. hst % mpi_gather &
1917 & .or. ( hst % mpi_gather .and. &
1918 & hst % mpi_myrank == 0 .and. &
1919 & hst % mpi_fileinfo % already_output) )
then
1921 & varname = varname, &
1922 & head = real(array_work2(1)), &
1924 & history = history, &
1929 call dbgmessage(
'varname=<%c> has no dimension. so range is ignoread.', &
1934 call put(var, array_work2, arraysize_work2)
1939 allocate(start(dims), count(dims), stride(dims))
1941 call get_slice(var, i, start(i), count(i), stride(i))
1944 call slice(var, range, slice_err)
1945 call put(var, array_work2, arraysize_work2)
1948 call slice(var, i, start(i), count(i), stride(i))
1950 deallocate(start, count, stride)
1953 if ( hst % mpi_gather .and. v_ord > 0 )
then
1954 deallocate( array_work2 )
1961 if ( .not. hst % mpi_gather &
1962 & .or. ( hst % mpi_gather .and. &
1963 & hst % mpi_myrank == 0 .and. &
1964 & hst % mpi_fileinfo % already_output ) )
then
1965 if ( v_ord > 0 )
then
1966 if ( hst % var_avr_count( v_ord ) > -1 )
then
1970 timevar = hst % dimvars( hst % unlimited_index )
1974 & name = time_name )
1980 call open( var = bndsvar, &
1981 & url =
urlmerge(file=file, var=trim(time_name) // bnds_suffix) )
1988 & rank = bnds_rank )
1990 if ( bnds_rank > 1 )
then
1993 & dimord = hst % growable_indices(bnds_ord), &
1994 & allcount = time_count )
1996 if ( (hst % time_bnds_output_count < 1) &
1997 & .or. (hst % time_bnds_output_count < time_count) )
then
1998 call slice(bndsvar, hst % growable_indices(bnds_ord), &
1999 & start=hst % time_bnds_output_count+1, count=1)
2000 call put(bndsvar, hst % time_bnds, 2)
2001 hst % time_bnds_output_count = hst % time_bnds_output_count + 1
2003 call close( var = bndsvar )
2004 if (
present(difftime) )
then
2005 hst % time_bnds(1:1) = &
2006 &
evalbyunit( difftime,
'', hst % unlimited_units_symbol )
2007 elseif (
present(timed) )
then
2008 hst % time_bnds(1:1) = timed
2010 hst % time_bnds(1:1) = time
2019 if ( .not. hst % mpi_gather &
2020 & .or. ( hst % mpi_gather .and. &
2021 & hst % mpi_myrank == 0 .and. &
2022 & hst % mpi_fileinfo % already_output ) )
then
2024 call inquire( hst % dimvars(1), &
2028 if ( hst % unlimited_index < 1 )
then
2031 timevar = hst % dimvars(hst % unlimited_index)
2032 call slice( timevar, &
2033 & 1, start = hst % count(v_ord), count = 1 )
2034 call get( timevar, &
2038 time_str =
'(time=' // trim(
tochar( time_value(1) )) //
')'
2041 &
'"%a" => "%a" %a %a', &
2042 & ca =
stoa( varname, file, time_str, avr_msg ) )
2050 call storeerror( stat, subname, err, cause_c )
2377 character(*),
intent(in):: varname
2378 real,
intent(in):: array(:)
2379 type(
gt_history),
intent(inout),
optional,
target:: history
2380 logical,
intent(out),
optional:: err
2382 integer:: dimord, dimsize, numdims, i, j, attr_size
2384 character(STRING):: dimname
2385 character(STRING):: name, longname, units, xtype, origin_str, url
2386 real(DP):: origin_work
2388 character(STRING):: cause_c
2389 character(*),
parameter:: subname =
"HistoryPutAxisMPIReal"
2391 call beginsub(subname,
'varname=%c', c1 = trim(varname) )
2394 if (
present(history))
then
2399 if ( .not. hst % initialized )
then
2401 cause_c =
'GT_HISTORY'
2404 call dbgmessage(
'mpi_gather=<%b>', l = (/ hst % mpi_gather /) )
2405 if ( .not. hst % mpi_gather )
then
2408 numdims =
size( hst % dimvars )
2412 & hst % mpi_fileinfo % axes(i), &
2414 if ( trim(varname) == trim(dimname) )
then
2419 if ( dimord < 1 )
then
2424 dimsize =
size( array )
2425 if (
associated( hst % mpi_dimdata_all( dimord ) % a_Axis ) )
then
2426 deallocate( hst % mpi_dimdata_all( dimord ) % a_Axis )
2428 allocate( hst % mpi_dimdata_all( dimord ) % a_Axis(dimsize) )
2429 hst % mpi_dimdata_all( dimord ) % a_Axis = array
2430 hst % mpi_dimdata_all( dimord ) % length = dimsize
2435 numdims =
size( hst % dimvars )
2437 if ( hst % unlimited_index == i ) cycle
2438 if ( hst % time_nv_index == i ) cycle
2439 if ( hst % mpi_dimdata_all( i ) % length < 1 )
goto 999
2441 if ( hst % mpi_myrank /= 0 )
goto 2000
2442 if ( hst % mpi_fileinfo % already_output )
goto 999
2445 & name, dimsize, longname, units, xtype )
2446 url =
urlmerge(file = hst % mpi_fileinfo % file, var = name)
2450 if ( hst % unlimited_index /= i )
then
2451 dimsize = hst % mpi_dimdata_all( i ) % length
2457 & hst % dimvars(i), trim(url), &
2458 & dimsize, xtype = xtype, &
2459 & overwrite = hst % mpi_fileinfo % overwrite )
2463 call put_attr(hst % dimvars(i),
'+Conventions', trim(hst % mpi_fileinfo % conventions ))
2464 if ( hst % mpi_fileinfo % gtver_add )
then
2465 call put_attr(hst % dimvars(i),
'+gt_version', trim(hst % mpi_fileinfo % gt_version ))
2468 call put_attr(hst % dimvars(i),
'+title', hst % mpi_fileinfo % title)
2469 call put_attr(hst % dimvars(i),
'+source', hst % mpi_fileinfo % source)
2470 call put_attr(hst % dimvars(i),
'+institution', trim(hst % mpi_fileinfo % institution))
2471 call put_attr(hst % dimvars(i),
'+history', trim(hst % mpi_fileinfo % nc_history))
2472 call put_attr(hst % dimvars(i),
'long_name', longname)
2473 call put_attr(hst % dimvars(i),
'units', units)
2474 origin_work = hst % origin
2476 origin_str = trim(
tochar( origin_work ) ) // &
2477 &
' [' // trim( hst % unlimited_units ) //
']'
2481 if ( hst % unlimited_index /= i )
then
2482 call put(hst % dimvars(i), &
2483 & hst % mpi_dimdata_all( i ) % a_Axis, dimsize )
2484 hst % dim_value_written(i) = .true.
2489 attrs => hst % mpi_dimdata_all(i) % attrs
2490 if (
associated( attrs ) )
then
2491 attr_size =
size( attrs )
2493 if (
strhead(
'char', trim(
lchar(attrs(j)%attrtype))) )
then
2495 & attrs(j) % attrname, trim( attrs(j) % Charvalue ) )
2496 elseif (
strhead(
'int', trim(
lchar(attrs(j)%attrtype))) )
then
2497 if ( attrs(j)%array )
then
2500 & attrs(j) % attrname, attrs(j) % Intarray )
2504 & attrs(j) % attrname, (/attrs(j) % Intvalue/) )
2506 elseif (
strhead(
'real', trim(
lchar(attrs(j)%attrtype))) )
then
2507 if ( attrs(j)%array )
then
2510 & attrs(j) % attrname, attrs(j) % Realarray )
2514 & attrs(j) % attrname, (/attrs(j) % Realvalue/) )
2516 elseif (
strhead(
'double', trim(
lchar(attrs(j)%attrtype))) )
then
2517 if ( attrs(j)%array )
then
2518 call dbgmessage(
'Doublearray(:) is selected.')
2520 & attrs(j) % attrname, attrs(j) % Doublearray )
2524 & attrs(j) % attrname, (/attrs(j) % Doublevalue/) )
2526 elseif (
strhead(
'logical', trim(
lchar(attrs(j)%attrtype))) )
then
2528 & attrs(j) % attrname, attrs(j) % Logicalvalue )
2530 call dbgmessage(
'attrtype=<%c>=<%c>is Invalid.' , &
2531 & c1=trim(attrs(j)%attrtype) , &
2532 & c2=trim(
lchar(attrs(j)%attrtype)) )
2537 if ( .not. hst % mpi_fileinfo % quiet )
then
2539 &
'"%c" is created (origin=%c)', &
2540 & c1 = trim( hst % mpi_fileinfo % file ), &
2541 & c2 = trim( origin_str ) )
2544 hst % mpi_fileinfo % already_output = .true.
2549 call storeerror( stat, subname, err, cause_c )
2588 character(*),
intent(in):: varname
2600 real(DP),
intent(in):: array(:)
2604 type(
gt_history),
intent(inout),
optional,
target:: history
2619 logical,
intent(out),
optional:: err
2634 integer:: dimord, dimsize, numdims, i, j, attr_size
2636 character(STRING):: dimname
2637 character(STRING):: name, longname, units, xtype, origin_str, url
2638 real(DP):: origin_work
2640 character(STRING):: cause_c
2641 character(*),
parameter:: subname =
"HistoryPutAxisMPIDouble"
2643 call beginsub(subname,
'varname=%c', c1 = trim(varname) )
2646 if (
present(history))
then
2651 if ( .not. hst % initialized )
then
2653 cause_c =
'GT_HISTORY'
2656 call dbgmessage(
'mpi_gather=<%b>', l = (/ hst % mpi_gather /) )
2657 if ( .not. hst % mpi_gather )
then
2660 numdims =
size( hst % dimvars )
2664 & hst % mpi_fileinfo % axes(i), &
2666 if ( trim(varname) == trim(dimname) )
then
2671 if ( dimord < 1 )
then
2676 dimsize =
size( array )
2677 if (
associated( hst % mpi_dimdata_all( dimord ) % a_Axis ) )
then
2678 deallocate( hst % mpi_dimdata_all( dimord ) % a_Axis )
2680 allocate( hst % mpi_dimdata_all( dimord ) % a_Axis(dimsize) )
2681 hst % mpi_dimdata_all( dimord ) % a_Axis = array
2682 hst % mpi_dimdata_all( dimord ) % length = dimsize
2687 numdims =
size( hst % dimvars )
2689 if ( hst % unlimited_index == i ) cycle
2690 if ( hst % time_nv_index == i ) cycle
2691 if ( hst % mpi_dimdata_all( i ) % length < 1 )
goto 999
2693 if ( hst % mpi_myrank /= 0 )
goto 2000
2694 if ( hst % mpi_fileinfo % already_output )
goto 999
2697 & name, dimsize, longname, units, xtype )
2698 url =
urlmerge(file = hst % mpi_fileinfo % file, var = name)
2702 if ( hst % unlimited_index /= i )
then
2703 dimsize = hst % mpi_dimdata_all( i ) % length
2709 & hst % dimvars(i), trim(url), &
2710 & dimsize, xtype = xtype, &
2711 & overwrite = hst % mpi_fileinfo % overwrite )
2715 call put_attr(hst % dimvars(i),
'+Conventions', trim(hst % mpi_fileinfo % conventions ))
2716 if ( hst % mpi_fileinfo % gtver_add )
then
2717 call put_attr(hst % dimvars(i),
'+gt_version', trim(hst % mpi_fileinfo % gt_version ))
2720 call put_attr(hst % dimvars(i),
'+title', hst % mpi_fileinfo % title)
2721 call put_attr(hst % dimvars(i),
'+source', hst % mpi_fileinfo % source)
2722 call put_attr(hst % dimvars(i),
'+institution', trim(hst % mpi_fileinfo % institution))
2723 call put_attr(hst % dimvars(i),
'+history', trim(hst % mpi_fileinfo % nc_history))
2724 call put_attr(hst % dimvars(i),
'long_name', longname)
2725 call put_attr(hst % dimvars(i),
'units', units)
2726 origin_work = hst % origin
2728 origin_str = trim(
tochar( origin_work ) ) // &
2729 &
' [' // trim( hst % unlimited_units ) //
']'
2733 if ( hst % unlimited_index /= i )
then
2734 call put(hst % dimvars(i), &
2735 & hst % mpi_dimdata_all( i ) % a_Axis, dimsize )
2736 hst % dim_value_written(i) = .true.
2741 attrs => hst % mpi_dimdata_all(i) % attrs
2742 if (
associated( attrs ) )
then
2743 attr_size =
size( attrs )
2745 if (
strhead(
'char', trim(
lchar(attrs(j)%attrtype))) )
then
2747 & attrs(j) % attrname, trim( attrs(j) % Charvalue ) )
2748 elseif (
strhead(
'int', trim(
lchar(attrs(j)%attrtype))) )
then
2749 if ( attrs(j)%array )
then
2752 & attrs(j) % attrname, attrs(j) % Intarray )
2756 & attrs(j) % attrname, (/attrs(j) % Intvalue/) )
2758 elseif (
strhead(
'real', trim(
lchar(attrs(j)%attrtype))) )
then
2759 if ( attrs(j)%array )
then
2762 & attrs(j) % attrname, attrs(j) % Realarray )
2766 & attrs(j) % attrname, (/attrs(j) % Realvalue/) )
2768 elseif (
strhead(
'double', trim(
lchar(attrs(j)%attrtype))) )
then
2769 if ( attrs(j)%array )
then
2770 call dbgmessage(
'Doublearray(:) is selected.')
2772 & attrs(j) % attrname, attrs(j) % Doublearray )
2776 & attrs(j) % attrname, (/attrs(j) % Doublevalue/) )
2778 elseif (
strhead(
'logical', trim(
lchar(attrs(j)%attrtype))) )
then
2780 & attrs(j) % attrname, attrs(j) % Logicalvalue )
2782 call dbgmessage(
'attrtype=<%c>=<%c>is Invalid.' , &
2783 & c1=trim(attrs(j)%attrtype) , &
2784 & c2=trim(
lchar(attrs(j)%attrtype)) )
2789 if ( .not. hst % mpi_fileinfo % quiet )
then
2791 &
'"%c" is created (origin=%c)', &
2792 & c1 = trim( hst % mpi_fileinfo % file ), &
2793 & c2 = trim( origin_str ) )
2796 hst % mpi_fileinfo % already_output = .true.
2801 call storeerror( stat, subname, err, cause_c )
2840 character(*),
intent(in):: varname
2841 integer,
intent(in):: array(:)
2842 type(
gt_history),
intent(inout),
optional,
target:: history
2843 logical,
intent(out),
optional:: err
2845 integer:: dimord, dimsize, numdims, i, j, attr_size
2847 character(STRING):: dimname
2848 character(STRING):: name, longname, units, xtype, origin_str, url
2849 real(DP):: origin_work
2851 character(STRING):: cause_c
2852 character(*),
parameter:: subname =
"HistoryPutAxisMPIInt"
2854 call beginsub(subname,
'varname=%c', c1 = trim(varname) )
2857 if (
present(history))
then
2862 if ( .not. hst % initialized )
then
2864 cause_c =
'GT_HISTORY'
2867 call dbgmessage(
'mpi_gather=<%b>', l = (/ hst % mpi_gather /) )
2868 if ( .not. hst % mpi_gather )
then
2871 numdims =
size( hst % dimvars )
2875 & hst % mpi_fileinfo % axes(i), &
2877 if ( trim(varname) == trim(dimname) )
then
2882 if ( dimord < 1 )
then
2887 dimsize =
size( array )
2888 if (
associated( hst % mpi_dimdata_all( dimord ) % a_Axis ) )
then
2889 deallocate( hst % mpi_dimdata_all( dimord ) % a_Axis )
2891 allocate( hst % mpi_dimdata_all( dimord ) % a_Axis(dimsize) )
2892 hst % mpi_dimdata_all( dimord ) % a_Axis = array
2893 hst % mpi_dimdata_all( dimord ) % length = dimsize
2898 numdims =
size( hst % dimvars )
2900 if ( hst % unlimited_index == i ) cycle
2901 if ( hst % time_nv_index == i ) cycle
2902 if ( hst % mpi_dimdata_all( i ) % length < 1 )
goto 999
2904 if ( hst % mpi_myrank /= 0 )
goto 2000
2905 if ( hst % mpi_fileinfo % already_output )
goto 999
2908 & name, dimsize, longname, units, xtype )
2909 url =
urlmerge(file = hst % mpi_fileinfo % file, var = name)
2913 if ( hst % unlimited_index /= i )
then
2914 dimsize = hst % mpi_dimdata_all( i ) % length
2920 & hst % dimvars(i), trim(url), &
2921 & dimsize, xtype = xtype, &
2922 & overwrite = hst % mpi_fileinfo % overwrite )
2926 call put_attr(hst % dimvars(i),
'+Conventions', trim(hst % mpi_fileinfo % conventions ))
2927 if ( hst % mpi_fileinfo % gtver_add )
then
2928 call put_attr(hst % dimvars(i),
'+gt_version', trim(hst % mpi_fileinfo % gt_version ))
2931 call put_attr(hst % dimvars(i),
'+title', hst % mpi_fileinfo % title)
2932 call put_attr(hst % dimvars(i),
'+source', hst % mpi_fileinfo % source)
2933 call put_attr(hst % dimvars(i),
'+institution', trim(hst % mpi_fileinfo % institution))
2934 call put_attr(hst % dimvars(i),
'+history', trim(hst % mpi_fileinfo % nc_history))
2935 call put_attr(hst % dimvars(i),
'long_name', longname)
2936 call put_attr(hst % dimvars(i),
'units', units)
2937 origin_work = hst % origin
2939 origin_str = trim(
tochar( origin_work ) ) // &
2940 &
' [' // trim( hst % unlimited_units ) //
']'
2944 if ( hst % unlimited_index /= i )
then
2945 call put(hst % dimvars(i), &
2946 & hst % mpi_dimdata_all( i ) % a_Axis, dimsize )
2947 hst % dim_value_written(i) = .true.
2952 attrs => hst % mpi_dimdata_all(i) % attrs
2953 if (
associated( attrs ) )
then
2954 attr_size =
size( attrs )
2956 if (
strhead(
'char', trim(
lchar(attrs(j)%attrtype))) )
then
2958 & attrs(j) % attrname, trim( attrs(j) % Charvalue ) )
2959 elseif (
strhead(
'int', trim(
lchar(attrs(j)%attrtype))) )
then
2960 if ( attrs(j)%array )
then
2963 & attrs(j) % attrname, attrs(j) % Intarray )
2967 & attrs(j) % attrname, (/attrs(j) % Intvalue/) )
2969 elseif (
strhead(
'real', trim(
lchar(attrs(j)%attrtype))) )
then
2970 if ( attrs(j)%array )
then
2973 & attrs(j) % attrname, attrs(j) % Realarray )
2977 & attrs(j) % attrname, (/attrs(j) % Realvalue/) )
2979 elseif (
strhead(
'double', trim(
lchar(attrs(j)%attrtype))) )
then
2980 if ( attrs(j)%array )
then
2981 call dbgmessage(
'Doublearray(:) is selected.')
2983 & attrs(j) % attrname, attrs(j) % Doublearray )
2987 & attrs(j) % attrname, (/attrs(j) % Doublevalue/) )
2989 elseif (
strhead(
'logical', trim(
lchar(attrs(j)%attrtype))) )
then
2991 & attrs(j) % attrname, attrs(j) % Logicalvalue )
2993 call dbgmessage(
'attrtype=<%c>=<%c>is Invalid.' , &
2994 & c1=trim(attrs(j)%attrtype) , &
2995 & c2=trim(
lchar(attrs(j)%attrtype)) )
3000 if ( .not. hst % mpi_fileinfo % quiet )
then
3002 &
'"%c" is created (origin=%c)', &
3003 & c1 = trim( hst % mpi_fileinfo % file ), &
3004 & c2 = trim( origin_str ) )
3007 hst % mpi_fileinfo % already_output = .true.
3012 call storeerror( stat, subname, err, cause_c )
4609 use,non_intrinsic ::
dc_date_generic, only: evalbyunit,
operator(+),
operator(*), &
4614 character(len = *),
intent(in) :: varname
4616 real,
intent(in):: head
4617 type(
gt_history),
intent(inout),
optional,
target:: history
4618 logical,
intent(out),
optional :: err
4622 real,
pointer:: time(:) =>null()
4625 integer:: timestart, rest
4630 character(STRING):: cause_c, subname_r
4631 character(*),
parameter:: subname =
"TimeGoAhead"
4633 call beginsub(subname,
'varname=%c head=%r', &
4634 & c1=trim(varname), r=(/head/))
4638 if (
present(history))
then
4647 if (v_ord == 0)
goto 1000
4649 if (hst % growable_indices(v_ord) == 0)
then
4652 if (hst % dim_value_written(hst % unlimited_index))
then
4658 call slice(var, hst % growable_indices(v_ord), &
4659 & start=hst % count(1), count=1)
4667 hst % count(v_ord) = hst % count(v_ord) + 1
4668 call slice(var, hst % growable_indices(v_ord), &
4669 & start=hst % count(v_ord), count=1)
4677 timevar = hst % dimvars(hst % unlimited_index)
4678 call get_slice(timevar, 1, start=timestart)
4679 call dbgmessage(
'map(timevar)start is <%d>. map(%c)start is <%d>', &
4680 & i=(/timestart, hst % count(v_ord)/), &
4681 & c1=trim(varname) )
4682 call get(timevar, time, get_err)
4683 call dbgmessage(
'time(%d)=<%*r>, err=<%b>', &
4684 & i=(/
size(time)/), r=(/time(:)/), &
4685 & l=(/get_err/), n=(/
size(time)/) )
4686 if (get_err .or. hst % count(v_ord) == 1 .and. timestart == 1)
then
4692 call slice(timevar, 1, start=1, count=1)
4693 curtime = hst % origin
4695 call put(timevar, (/curtime/), 1)
4696 elseif (hst % count(v_ord) > timestart)
then
4702 rest = timestart + 1
4704 call slice(timevar, 1, start=rest, count=1)
4705 curtime = hst % origin + hst % interval * (rest - 1)
4709 call put(timevar, (/curtime/), 1 )
4711 if ( rest > hst % count(v_ord) )
exit
4728 if (d_ord == 0)
then
4729 subname_r =
'HistoryPut'
4731 cause_c =
'varname="' // trim(varname) //
'" is not found'
4734 hst % dim_value_written(d_ord) = .true.
4735 if (d_ord /= hst % unlimited_index)
then
4741 hst % count(:) = maxval(hst % count(:)) + 1
4746 call slice(var, 1, start=hst % count(1), count=1)
4748 call storeerror(stat, trim(subname_r), err, cause_c)