73
82 use netcdf, only: nf90_ebaddim
88 use dc_date,
only: dcdifftimecreate
93 use mpi
94 implicit none
95 character(len = *), intent(in):: varname
96
97
98
99
100 character(len = *), intent(in):: dims(:)
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115 character(len = *), intent(in):: longname
116
117
118
119
120 character(len = *), intent(in):: units
121
122
123
124
125 character(len = *), intent(in), optional:: xtype
126
127
128
129
130
131
132
133
134
135
136 logical, intent(in), optional:: time_average
137
138
139
140
141
142
143
144
145 logical, intent(in), optional:: average
146
147
148 type(GT_HISTORY), intent(inout), optional, target:: history
149
150
151
152
153
154
155
156 logical, intent(out), optional:: err
157
158
159
160
161
162
163
164
165
166
167
168
169
170 type(GT_HISTORY), pointer:: hst =>null()
171 type(GT_VARIABLE), pointer:: vwork(:) =>null(), dimvars(:) =>null()
172 character(STRING):: fullname, url, cause_c
173 integer, pointer:: count_work(:) =>null()
174 integer, pointer:: var_avr_count_work(:) =>null()
175 integer:: var_avr_length
176 type(GT_HISTORY_AVRDATA), pointer:: var_avr_data_work(:) =>null()
177 logical, pointer:: var_avr_firstput_work(:) =>null()
178 real(DP), pointer:: var_avr_coefsum_work(:) =>null()
179 real(DP), pointer:: var_avr_baseint_work(:) =>null()
180 real(DP), pointer:: var_avr_prevtime_work(:) =>null()
181
182
183 character(STRING):: time_name, time_xtype, time_url
184 type(GT_VARIABLE), pointer:: dimvars_work(:) =>null()
185 logical, pointer:: dim_value_written_work(:) =>null()
186 integer:: dimvars_size
187 logical:: nv_exist, bnds_exist
188 character(STRING):: nv_name_check, bnds_name_check
189 character(*), parameter:: nv_suffix = '_nv'
190 character(*), parameter:: bnds_suffix = '_bnds'
191 integer, pointer:: dimord(:) =>null()
192 integer:: nvars, numdims, i, stat
193 integer:: err_mpi
194 type(GT_HISTORY_VARINFO), pointer:: work_mpi_varinfo(:) =>null()
195 type(GT_HISTORY_MPIVARINDEX), pointer:: work_mpi_vars_index(:) =>null()
196 character(*), parameter:: subname = "HistoryAddVariable1"
197 continue
198 call beginsub(subname,
'name=<%a>, dims=<%a>, longname=<%a>, units=<%a>', &
201 cause_c = ''
202
203
204 if (present(history)) then
205 hst => history
206 else
208 endif
209
210
211
212 if ( .not. hst % initialized ) then
214 cause_c = 'GT_HISTORY'
215 goto 999
216 end if
217
218
219
220 if ( hst % mpi_gather .and. hst % mpi_myrank == 0 .and. &
221 & .not. hst % mpi_fileinfo % already_output ) then
223 & 'Specify data of axes in whole area by "HistoryPutAxisMPI" explicitly ' // &
224 & 'before "call HistoryAddVariable".' )
226 goto 999
227 end if
228
229
230 if ( hst % mpi_gather ) then
231 if ( associated(hst % mpi_varinfo) ) then
232 nvars = size(hst % mpi_varinfo(:))
233 work_mpi_varinfo => hst % mpi_varinfo
234 nullify( hst % mpi_varinfo )
235 allocate( hst % mpi_varinfo(nvars + 1) )
236 hst % mpi_varinfo(1:nvars) = work_mpi_varinfo
237 deallocate( work_mpi_varinfo )
238 nvars = size(hst % mpi_vars_index(:))
239 work_mpi_vars_index => hst % mpi_vars_index
240 nullify( hst % mpi_vars_index )
241 allocate( hst % mpi_vars_index(nvars + 1) )
242 hst % mpi_vars_index(1:nvars) = work_mpi_vars_index
243 deallocate( work_mpi_vars_index )
244 else
245 nvars = 0
246 allocate( hst % mpi_varinfo(nvars + 1) )
247 allocate( hst % mpi_vars_index(nvars + 1) )
248 end if
250 & hst % mpi_varinfo(nvars + 1), &
251 & varname, dims, longname, units, xtype, &
252 & time_average, average )
253 end if
254
255
256 if (associated(hst % vars)) then
257 nvars = size(hst % vars(:))
258 vwork => hst % vars
259 count_work => hst % count
260 nullify(hst % vars, hst % count)
261 allocate(hst % vars(nvars + 1), hst % count(nvars + 1))
262 hst % vars(1:nvars) = vwork(1:nvars)
263 hst % count(1:nvars) = count_work(1:nvars)
264 deallocate(vwork, count_work)
265 count_work => hst % growable_indices
266 nullify(hst % growable_indices)
267 allocate(hst % growable_indices(nvars + 1))
268 hst % growable_indices(1:nvars) = count_work(1:nvars)
269 deallocate(count_work)
270
271
272
273 var_avr_count_work => hst % var_avr_count
274 nullify( hst % var_avr_count )
275 allocate( hst % var_avr_count(nvars + 1) )
276 hst % var_avr_count(1:nvars) = var_avr_count_work(1:nvars)
277 deallocate( var_avr_count_work )
278 var_avr_data_work => hst % var_avr_data
279 nullify(hst % var_avr_data)
280 allocate(hst % var_avr_data(nvars + 1))
281 do i = 1, nvars
282 hst % var_avr_data(i) % length = var_avr_data_work(i) % length
283 allocate(hst % var_avr_data(i) % &
284 & a_dataavr(var_avr_data_work(i) % length))
285 hst % var_avr_data(i) % a_DataAvr = var_avr_data_work(i) % a_DataAvr
286 deallocate( var_avr_data_work(i) % a_DataAvr )
287 end do
288 deallocate( var_avr_data_work )
289 var_avr_firstput_work => hst % var_avr_firstput
290 nullify( hst % var_avr_firstput )
291 allocate( hst % var_avr_firstput(nvars + 1) )
292 hst % var_avr_firstput(1:nvars) = var_avr_firstput_work(1:nvars)
293 deallocate( var_avr_firstput_work )
294 var_avr_coefsum_work => hst % var_avr_coefsum
295 nullify( hst % var_avr_coefsum )
296 allocate( hst % var_avr_coefsum(nvars + 1) )
297 hst % var_avr_coefsum(1:nvars) = var_avr_coefsum_work(1:nvars)
298 deallocate( var_avr_coefsum_work )
299 var_avr_baseint_work => hst % var_avr_baseint
300 nullify( hst % var_avr_baseint )
301 allocate( hst % var_avr_baseint(nvars + 1) )
302 hst % var_avr_baseint(1:nvars) = var_avr_baseint_work(1:nvars)
303 deallocate( var_avr_baseint_work )
304 var_avr_prevtime_work => hst % var_avr_prevtime
305 nullify( hst % var_avr_prevtime )
306 allocate( hst % var_avr_prevtime(nvars + 1) )
307 hst % var_avr_prevtime(1:nvars) = var_avr_prevtime_work(1:nvars)
308 deallocate( var_avr_prevtime_work )
309 else
310
311
312
313 allocate(hst % vars(1), hst % count(2), hst % growable_indices(1))
314 hst % count(2) = 0
315 allocate(hst % var_avr_count(1), hst % var_avr_data(1))
316 allocate(hst % var_avr_firstput(1), hst % var_avr_coefsum(1))
317 allocate(hst % var_avr_baseint(1), hst % var_avr_prevtime(1))
318 endif
319 nvars = size(hst % vars(:))
320 hst % growable_indices(nvars) = 0
321 if ( nvars < 2 ) then
322 hst % count(nvars) = 0
323 else
324 hst % count(nvars) = hst % count(1)
325 end if
326
327
328 if (size(dims) == 1 .and. trim(dims(1)) == '') then
329 numdims = 0
330 else
331 numdims = size(dims)
332 end if
333 allocate( dimvars(numdims) )
334 allocate( dimord(numdims) )
335 if ( .not. hst % mpi_gather &
336 & .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 ) ) then
337
338
339 do, i = 1, numdims
340
341
342
344 & ord = dimord(i) )
345 if (dimord(i) == 0) then
346 stat = nf90_ebaddim
347 cause_c =
cprintf(
'"%c" dimension is not found.', c1=trim(dims(i)))
348 goto 999
349 end if
350 end do
351 if ( hst % mpi_gather ) then
352 call mpi_bcast( dimord, numdims, mpi_integer, 0, mpi_comm_world, err_mpi )
353 end if
354 elseif ( hst % mpi_gather .and. hst % mpi_myrank /= 0 ) then
355 call mpi_bcast( dimord, numdims, mpi_integer, 0, mpi_comm_world, err_mpi )
356 end if
357
358
359 do, i = 1, numdims
360
361
362
363 if (dimord(i) == hst % unlimited_index) then
364 hst % growable_indices(nvars) = i
365 endif
366 enddo
367 if ( .not. hst % mpi_gather &
368 & .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 ) ) then
369
370
371 call inquire(hst % dimvars(1), url=url)
373 call create(hst % vars(nvars), trim(fullname), dimvars, xtype=xtype)
374 if ( associated(dimvars) ) deallocate( dimvars )
375
376
377 if (hst % growable_indices(nvars) /= 0) then
378 call slice(hst % vars(nvars), hst % growable_indices(nvars), &
379 & start=1, count=1, stride=1)
380 endif
381 call put_attr(hst % vars(nvars),
'long_name', longname)
382 call put_attr(hst % vars(nvars),
'units', units)
383 end if
384
385
388 hst % var_avr_count(nvars) = 0
389 if ( .not. hst % mpi_gather &
390 & .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 ) ) then
391
392
393
395 & var = hst % dimvars( hst % unlimited_index ), &
396 & name = time_name, url = time_url, &
397 & xtype = time_xtype )
398 if ( hst % mpi_gather ) then
399 call mpi_bcast( time_name,
string, mpi_character, 0, mpi_comm_world, err_mpi )
400 call mpi_bcast( time_url,
string, mpi_character, 0, mpi_comm_world, err_mpi )
401 call mpi_bcast( time_xtype,
string, mpi_character, 0, mpi_comm_world, err_mpi )
402 end if
403 elseif ( hst % mpi_gather .and. hst % mpi_myrank /= 0 ) then
404 call mpi_bcast( time_name,
string, mpi_character, 0, mpi_comm_world, err_mpi )
405 call mpi_bcast( time_url,
string, mpi_character, 0, mpi_comm_world, err_mpi )
406 call mpi_bcast( time_xtype,
string, mpi_character, 0, mpi_comm_world, err_mpi )
407 end if
408
409
410 if ( .not. hst % mpi_gather ) then
411 call inquire(hst % vars(nvars),
size = var_avr_length )
412 else
413 var_avr_length = 1
414 do i = 1, numdims
415 if ( hst % unlimited_index == dimord(i) ) cycle
416 var_avr_length = &
417 & var_avr_length * hst % mpi_dimdata_each( dimord(i) ) % length
418 end do
419 end if
420
421
422 hst % var_avr_data(nvars) % length = var_avr_length
423 allocate(hst % var_avr_data(nvars) % a_DataAvr(var_avr_length))
424 hst % var_avr_data(nvars) % a_DataAvr = 0.0_dp
425
426
427 hst % var_avr_firstput = .true.
428 hst % var_avr_coefsum(nvars) = 0.0_dp
429 hst % var_avr_baseint(nvars) = 0.0_dp
430
431
432
433 hst % var_avr_prevtime(nvars) = hst % var_avr_baseint(nvars)
434
435
436 if ( hst % growable_indices(nvars) < 1 ) then
438 cause_c = trim(varname)
439 goto 999
440 end if
441 if ( .not. hst % mpi_gather &
442 & .or. ( hst % mpi_gather .and. hst % mpi_myrank == 0 ) ) then
443
444
445 call put_attr( var = hst % dimvars( hst % unlimited_index ), &
446 & name = 'bounds', &
447 & value = trim(time_name) // bnds_suffix )
448
449
450 call put_attr( var = hst % vars(nvars), &
451 & name = 'cell_methods', &
452 & value = trim(time_name) // ': mean' )
453
454
455 dimvars_size = size( hst % dimvars )
456 nv_exist = .false.
457 do i = 1, dimvars_size
459 & var = hst % dimvars(i), &
460 & name = nv_name_check )
461 if ( trim(time_name) // trim(nv_suffix) == trim(nv_name_check) ) then
462 nv_exist = .true.
463 exit
464 end if
465 end do
466 if ( .not. nv_exist ) then
467 dimvars_work => hst % dimvars
468 dim_value_written_work => hst % dim_value_written
469 nullify(hst % dimvars, hst % dim_value_written)
470 allocate(hst % dimvars(dimvars_size + 1))
471 allocate(hst % dim_value_written(dimvars_size + 1))
472 hst % dimvars(1:dimvars_size) = dimvars_work(1:dimvars_size)
473 hst % dim_value_written(1:dimvars_size) = dim_value_written_work(1:dimvars_size)
474 deallocate(dimvars_work)
475 deallocate(dim_value_written_work)
477 & var = hst % dimvars(dimvars_size + 1), &
478 & url = trim(time_url) // trim(nv_suffix), &
479 & length = 2, xtype = 'integer' )
480 hst % time_nv_index = dimvars_size + 1
481 call put_attr( var = hst % dimvars(dimvars_size + 1), &
482 & name = 'long_name', &
483 & value = 'number of vertices of time')
484 call put_attr( var = hst % dimvars(dimvars_size + 1), &
485 & name = 'units', value = '1' )
486 call put( var = hst % dimvars(dimvars_size + 1), &
487 & value = (/1, 2/) )
488 hst % dim_value_written(dimvars_size + 1) = .true.
489 end if
490
491
492 bnds_exist = .false.
493 do i = 1, nvars
495 & var = hst % vars(i), &
496 & name = bnds_name_check )
497 if ( trim(time_name) // trim(bnds_suffix) == trim(bnds_name_check) ) then
498 bnds_exist = .true.
499 exit
500 end if
501 end do
502 if ( hst % mpi_gather ) then
503 call mpi_bcast( hst % time_nv_index, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
504 call mpi_bcast( bnds_exist, 1, mpi_logical, 0, mpi_comm_world, err_mpi )
505 end if
506 elseif ( hst % mpi_gather .and. hst % mpi_myrank /= 0 ) then
507 call mpi_bcast( hst % time_nv_index, 1, mpi_integer, 0, mpi_comm_world, err_mpi )
508 call mpi_bcast( bnds_exist, 1, mpi_logical, 0, mpi_comm_world, err_mpi )
509 end if
510 if ( associated(dimord) ) deallocate( dimord )
511 if ( .not. bnds_exist ) then
513 & history = hst, &
514 & varname = trim(time_name) // trim(bnds_suffix), &
515 & dims =
stoa( trim(time_name) // trim(nv_suffix), &
516 & trim(time_name) ), &
517 & longname = 'bounds of time', &
518 & units = hst % unlimited_units, &
519 & xtype = time_xtype )
520 end if
521
522
523 else
524 hst % var_avr_count(nvars) = -1
525
526
527 var_avr_length = 1
528 hst % var_avr_data(nvars) % length = var_avr_length
529 allocate(hst % var_avr_data(nvars) % a_DataAvr(var_avr_length))
530 hst % var_avr_data(nvars) % a_DataAvr = 0.0_dp
531
532
533 hst % var_avr_firstput = .true.
534 hst % var_avr_coefsum(nvars) = 0.0_dp
535 hst % var_avr_baseint(nvars) = 0.0_dp
536
537
538
539 hst % var_avr_prevtime(nvars) = hst % var_avr_baseint(nvars)
540 end if
541
542
543
544999 continue
545 if ( associated(dimvars) ) deallocate( dimvars )
546 if ( associated(dimord) ) deallocate( dimord )
Derived types and parameters for date and time.
Date and time manipulation module.
subroutine, public storeerror(number, where, err, cause_c, cause_i)
integer, parameter, public dc_noerr
Error storage variables
integer, parameter, public dc_enotinit
-400 or less: DC utilities errors
integer, parameter, public hst_enodependtime
integer, parameter, public hst_empinoaxisdata
Judge optional control parameters.
logical function, public present_and_true(arg)
Handling character types.
character(string) function, public joinchar(carray, expr)
subroutine, public beginsub(name, fmt, i, r, d, l, n, c1, c2, c3, ca, version)
subroutine, public endsub(name, fmt, i, r, d, l, n, c1, c2, c3, ca)
Provides kind type parameter values.
integer, parameter, public dp
Double Precision Real number
integer, parameter, public string
Character length for string
Variable URL string parser.
character, parameter, public gt_atmark
type(gt_history), target, save, public default