SCALE-RM
scale_file.F90
Go to the documentation of this file.
1 !-------------------------------------------------------------------------------
10 !-------------------------------------------------------------------------------
11 ! Warning: This file was generated from file/scale_file.F90.erb.
12 ! Do not edit this file.
13 !-------------------------------------------------------------------------------
14 #include "scalelib.h"
15 module scale_file
16  !-----------------------------------------------------------------------------
17  !
18  !++ Used modules
19  !
20  use scale_precision
21  use scale_io
22  use scale_prof
23  use scale_file_h
24  use scale_prc, only: &
25  prc_abort
26  use iso_c_binding
27 #ifdef _OPENACC
28  use openacc
29 #endif
30  !-----------------------------------------------------------------------------
31  implicit none
32  private
33 
34  include 'scale_file_c.inc'
35  !-----------------------------------------------------------------------------
36  !
37  !++ Public procedures
38  !
39  public :: file_setup
40  public :: file_finalize
41  public :: file_open
42  public :: file_opened
43  public :: file_single
44  public :: file_allnodes
45  public :: file_create
46  public :: file_get_dimlength
47  public :: file_set_option
48  public :: file_def_axis
49  public :: file_put_axis
50  public :: file_write_axis
52  public :: file_put_associatedcoordinate
53  public :: file_write_associatedcoordinate
54  public :: file_add_variable
55  public :: file_def_variable
56  public :: file_get_shape
57  public :: file_get_stepsize
58  public :: file_get_commoninfo
59  public :: file_get_datainfo
60  public :: file_get_all_datainfo
61  public :: file_read
62  public :: file_write
63  public :: file_get_attribute
64  public :: file_set_attribute
66  public :: file_enddef
67  public :: file_redef
68  public :: file_flush
69  public :: file_close
70  public :: file_close_all
71  public :: file_attach_buffer
72  public :: file_detach_buffer
73  public :: file_get_cftunits
74  public :: file_get_aggregate
75 
76  interface file_get_commoninfo
77  module procedure file_get_commoninfo_fid
78  module procedure file_get_commoninfo_fname
79  end interface file_get_commoninfo
80 
81  interface file_get_shape
82  module procedure file_get_shape_fid
83  module procedure file_get_shape_fname
84  end interface file_get_shape
85 
86  interface file_get_datainfo
87  module procedure file_get_datainfo_fid
88  module procedure file_get_datainfo_fname
89  end interface file_get_datainfo
90 
91  interface file_get_all_datainfo
92  module procedure file_get_all_datainfo_fid
93  module procedure file_get_all_datainfo_fname
94  end interface file_get_all_datainfo
95 
96  interface file_put_axis
97  module procedure file_put_axis_realsp
98  module procedure file_put_axis_realdp
99  end interface file_put_axis
100  interface file_write_axis
101  module procedure file_write_axis_realsp
102  module procedure file_write_axis_realdp
103  end interface file_write_axis
104  interface file_put_associatedcoordinate
105  module procedure file_put_associatedcoordinate_realsp_1d
106  module procedure file_put_associatedcoordinate_realdp_1d
107  module procedure file_put_associatedcoordinate_realsp_2d
108  module procedure file_put_associatedcoordinate_realdp_2d
109  module procedure file_put_associatedcoordinate_realsp_3d
110  module procedure file_put_associatedcoordinate_realdp_3d
111  module procedure file_put_associatedcoordinate_realsp_4d
112  module procedure file_put_associatedcoordinate_realdp_4d
113  end interface file_put_associatedcoordinate
114  interface file_write_associatedcoordinate
115  module procedure file_write_associatedcoordinate_realsp_1d
116  module procedure file_write_associatedcoordinate_realdp_1d
117  module procedure file_write_associatedcoordinate_realsp_2d
118  module procedure file_write_associatedcoordinate_realdp_2d
119  module procedure file_write_associatedcoordinate_realsp_3d
120  module procedure file_write_associatedcoordinate_realdp_3d
121  module procedure file_write_associatedcoordinate_realsp_4d
122  module procedure file_write_associatedcoordinate_realdp_4d
123  end interface file_write_associatedcoordinate
124  interface file_add_variable
125  module procedure file_add_variable_no_time
126  module procedure file_add_variable_with_time
127  end interface file_add_variable
128  interface file_read
129  module procedure file_read_realsp_1d
130  module procedure file_read_realdp_1d
131  module procedure file_read_realsp_2d
132  module procedure file_read_realdp_2d
133  module procedure file_read_realsp_3d
134  module procedure file_read_realdp_3d
135  module procedure file_read_realsp_4d
136  module procedure file_read_realdp_4d
137  module procedure file_read_var_realsp_1d
138  module procedure file_read_var_realdp_1d
139  module procedure file_read_var_realsp_2d
140  module procedure file_read_var_realdp_2d
141  module procedure file_read_var_realsp_3d
142  module procedure file_read_var_realdp_3d
143  module procedure file_read_var_realsp_4d
144  module procedure file_read_var_realdp_4d
145  end interface file_read
146  interface file_write
147  module procedure file_write_realsp_1d
148  module procedure file_write_realdp_1d
149  module procedure file_write_realsp_2d
150  module procedure file_write_realdp_2d
151  module procedure file_write_realsp_3d
152  module procedure file_write_realdp_3d
153  module procedure file_write_realsp_4d
154  module procedure file_write_realdp_4d
155  end interface file_write
156  interface file_get_attribute
157  module procedure file_get_attribute_text_fname
158  module procedure file_get_attribute_logical_fname
159  module procedure file_get_attribute_int_fname_ary
160  module procedure file_get_attribute_int_fname
161  module procedure file_get_attribute_float_fname_ary
162  module procedure file_get_attribute_float_fname
163  module procedure file_get_attribute_double_fname_ary
164  module procedure file_get_attribute_double_fname
165  module procedure file_get_attribute_text_fid
166  module procedure file_get_attribute_logical_fid
167  module procedure file_get_attribute_int_fid_ary
168  module procedure file_get_attribute_int_fid
169  module procedure file_get_attribute_float_fid_ary
170  module procedure file_get_attribute_float_fid
171  module procedure file_get_attribute_double_fid_ary
172  module procedure file_get_attribute_double_fid
173  end interface file_get_attribute
174  interface file_set_attribute
175  module procedure file_set_attribute_text
176  module procedure file_set_attribute_logical
177  module procedure file_set_attribute_int_ary
178  module procedure file_set_attribute_int
179  module procedure file_set_attribute_float_ary
180  module procedure file_set_attribute_float
181  module procedure file_set_attribute_double_ary
182  module procedure file_set_attribute_double
183  end interface file_set_attribute
184 
185 #if defined(__GFORTRAN__) && __GNUC__ < 7
186  interface cloc
187  module procedure cloc_sp
188  module procedure cloc_dp
189  end interface cloc
190 #endif
191 
192  !-----------------------------------------------------------------------------
193  !
194  !++ Public parameters & variables
195  !
196  logical, public :: file_aggregate
197 
198  !-----------------------------------------------------------------------------
199  !
200  !++ Private procedures
201  !
202  private :: file_get_fid
203 
204  !-----------------------------------------------------------------------------
205  !
206  !++ Private parameters & variables
207  !
208  type file
209  character(len=FILE_HLONG) :: name
210  integer :: fid
211  logical :: aggregate
212  logical :: single
213  logical :: allnodes
214  integer(8) :: buffer_size
215  end type file
216  type(file) :: file_files(file_file_max)
217  integer :: file_nfiles = 0
218 
219  type var
220  character(len=FILE_HLONG) :: name
221  integer :: fid
222  integer :: vid
223  end type var
224  type(var) :: file_vars(file_var_max)
225  integer :: file_nvars = 0
226 
227  integer :: mpi_myrank
228 
229  !-----------------------------------------------------------------------------
230 contains
231  !-----------------------------------------------------------------------------
233  !-----------------------------------------------------------------------------
234  subroutine file_setup( &
235  myrank )
236  use scale_prc, only: &
238  implicit none
239 
240  integer, intent(in) :: myrank
241 
242  namelist / param_file / &
244 
245  integer :: fid
246  integer :: ierr
247 
248  file_aggregate = .false.
249 
250  !--- read namelist
251  rewind(io_fid_conf)
252  read(io_fid_conf,nml=param_file,iostat=ierr)
253  if( ierr < 0 ) then !--- missing
254  log_info("FILE_setup",*) 'Not found namelist. Default used.'
255  elseif( ierr > 0 ) then !--- fatal error
256  log_error("FILE_setup",*) 'Not appropriate names in namelist PARAM_FILE. Check!'
257  call prc_abort
258  endif
259  log_nml(param_file)
260 
261  mpi_myrank = myrank
262 
264 
265  do fid = 1, file_file_max
266  file_files(fid)%fid = -1
267  file_files(fid)%name = ""
268  end do
269 
270  return
271  end subroutine file_setup
272 
273  !-----------------------------------------------------------------------------
275  !-----------------------------------------------------------------------------
276  subroutine file_finalize
277 
278  file_nfiles = 0
279  file_nvars = 0
280 
281  return
282  end subroutine file_finalize
283 
284  !-----------------------------------------------------------------------------
288  subroutine file_create( &
289  basename, &
290  title, source, institution, &
291  fid, existed, &
292  rankid, single, aggregate, &
293  time_units, calendar, &
294  allnodes, append )
295  implicit none
296 
297  character(len=*), intent(in) :: basename
298  character(len=*), intent(in) :: title
299  character(len=*), intent(in) :: source
300  character(len=*), intent(in) :: institution
301 
302  integer, intent(out) :: fid
303  logical, intent(out) :: existed
304 
305  integer, intent(in), optional :: rankid
306  logical, intent(in), optional :: single
307  logical, intent(in), optional :: aggregate
308  character(len=*), intent(in), optional :: time_units
309  character(len=*), intent(in), optional :: calendar
310  logical, intent(in), optional :: allnodes
311  logical, intent(in), optional :: append
312 
313  character(len=FILE_HMID) :: time_units_
314  character(len=FILE_HSHORT) :: calendar_
315  integer :: rankid_
316  logical :: single_
317  integer :: mode
318 
319  integer :: error
320  !---------------------------------------------------------------------------
321 
322 
323  if ( present(rankid) ) then
324  rankid_ = rankid
325  else
326  rankid_ = mpi_myrank
327  end if
328 
329  single_ = .false.
330  if ( present(single) ) then
331  single_ = single
332  endif
333 
334  if ( present(time_units) ) then
335  time_units_ = time_units
336  else
337  time_units_ = 'seconds'
338  endif
339 
340  if ( present(calendar) ) then
341  calendar_ = calendar
342  else
343  calendar_ = ""
344  end if
345 
346  mode = file_fwrite
347  if ( present(append) ) then
348  if( append ) mode = file_fappend
349  endif
350 
351  if ( single_ .and. rankid_ /= 0 ) then
352  fid = -1
353  existed = .false.
354  return
355  end if
356 
357  call file_get_fid( basename, mode, & ! [IN]
358  rankid_, single_, & ! [IN]
359  fid, existed, & ! [OUT]
360  allnodes=allnodes, & ! [IN]
361  aggregate=aggregate ) ! [IN]
362 
363  if( existed ) return
364 
365  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
366 
367  !--- append package header to the file
368  call file_set_attribute( fid, "global", "title" , title ) ! [IN]
369  call file_set_attribute( fid, "global", "source" , source ) ! [IN]
370  call file_set_attribute( fid, "global", "institution", institution ) ! [IN]
371 
372  if ( ( .not. present(aggregate) ) .or. .not. aggregate ) then
373  ! for shared-file parallel I/O, skip attributes related to MPI processes
374  call file_set_attribute( fid, "global", "rankid" , (/rankid_/) ) ! [IN]
375  endif
376 
377  error = file_set_tunits_c( file_files(fid)%fid, & ! [IN]
378  cstr(time_units_), &
379  cstr(calendar_ ) ) ! [IN]
380 
381  if ( error /= file_success_code ) then
382  log_error("FILE_create",*) 'failed to set time units'
383  call prc_abort
384  endif
385 
386  call prof_rapend('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
387 
388  return
389  end subroutine file_create
390 
391  !-----------------------------------------------------------------------------
392  subroutine file_get_var_num( &
393  fid, nvars_limit, &
394  nvars )
395  implicit none
396 
397  integer, intent(in) :: fid
398  integer, intent(in) :: nvars_limit
399  integer, intent(out) :: nvars
400 
401  integer :: error
402  !---------------------------------------------------------------------------
403 
404  if ( .not. file_opened(fid) ) then
405  log_error("FILE_get_var_num",*) 'File is not opened. fid = ', fid
406  call prc_abort
407  end if
408 
409  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
410 
411  error = file_get_nvars_c( nvars, & ! (out)
412  file_files(fid)%fid ) ! (in)
413  if ( error /= file_success_code ) then
414  log_error("FILE_get_var_num",*) 'failed to get varnum. fid = ', fid
415  call prc_abort
416  end if
417 
418  if ( nvars > nvars_limit ) then
419  log_error("FILE_get_var_num",*) 'number of variables exceeds the requested size.', nvars, nvars_limit
420  call prc_abort
421  endif
422 
423  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
424 
425  return
426  end subroutine file_get_var_num
427 
428  !-----------------------------------------------------------------------------
429  subroutine file_get_var_name( &
430  fid, cvid, &
431  varname )
432  implicit none
433 
434  integer, intent(in) :: fid
435  integer, intent(in) :: cvid
436  character(len=*), intent(out) :: varname
437 
438  integer :: error
439  !---------------------------------------------------------------------------
440 
441  if ( .not. file_opened(fid) ) then
442  log_error("FILE_get_var_name",*) 'File is not opened. fid = ', fid
443  call prc_abort
444  end if
445 
446  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
447 
448  error = file_get_varname_c( varname, &
449  file_files(fid)%fid, cvid, len(varname) ) ! (in)
450  call fstr(varname)
451  if ( error /= file_success_code ) then
452  log_error("FILE_get_var_name",*) 'failed to get varname. cvid = ', cvid
453  call prc_abort
454  end if
455 
456  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
457 
458  return
459  end subroutine file_get_var_name
460 
461  !-----------------------------------------------------------------------------
462  subroutine file_add_associatedvariable( fid, vname, existed )
463  integer, intent(in) :: fid
464  character(len=*), intent(in) :: vname
465  logical, optional, intent(out) :: existed
466 
467  integer :: error
468 
469  if ( .not. file_opened(fid) ) then
470  log_error("FILE_add_associatedVariable",*) 'File is not opened. fid = ', fid
471  call prc_abort
472  end if
473 
474  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
475 
476  error = file_add_associatedvariable_c( file_files(fid)%fid, cstr(vname) ) ! (in)
477 
478  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
479 
480  if ( present(existed) ) then
481  if ( error == file_already_existed_code ) then
482  existed = .true.
483  return
484  end if
485  existed = .false.
486  end if
487 
488  if ( error /= file_success_code ) then
489  log_error("FILE_add_associatedvariable",*) 'failed to add associated variable: '//trim(vname)
490  call prc_abort
491  end if
492 
493  return
494  end subroutine file_add_associatedvariable
495 
496  !-----------------------------------------------------------------------------
497  subroutine file_set_option( &
498  fid, &
499  filetype, key, val )
500  integer, intent(in) :: fid
501  character(len=*), intent(in) :: filetype
502  character(len=*), intent(in) :: key
503  character(len=*), intent(in) :: val
504 
505  integer :: error
506 
507  if ( .not. file_opened(fid) ) then
508  log_error("FILE_set_option",*) 'File is not opened. fid = ', fid
509  call prc_abort
510  end if
511 
512  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
513 
514  error = file_set_option_c( file_files(fid)%fid, cstr(filetype), cstr(key), cstr(val) ) ! (in)
515  if ( error /= file_success_code ) then
516  log_error("FILE_set_option",*) 'failed to set option'
517  call prc_abort
518  end if
519 
520  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
521 
522  return
523  end subroutine file_set_option
524 
525  !-----------------------------------------------------------------------------
526  subroutine file_open( &
527  basename, &
528  fid, &
529  mode, &
530  single, &
531  allnodes, &
532  aggregate, &
533  rankid, &
534  postfix )
535  implicit none
536 
537  character(len=*), intent( in) :: basename
538  integer, intent(out) :: fid
539  integer, intent( in), optional :: mode
540  logical, intent( in), optional :: single
541  logical, intent( in), optional :: allnodes
542  logical, intent( in), optional :: aggregate
543  integer, intent( in), optional :: rankid
544  character(len=*), intent( in), optional :: postfix
545 
546  integer :: mode_
547  integer :: rankid_
548  logical :: existed
549  logical :: single_
550 
551  single_ = .false.
552 
553  if ( present(mode) ) then
554  mode_ = mode
555  else
556  mode_ = file_fread
557  end if
558 
559  if ( present(single) ) single_ = single
560  if ( present(rankid) ) then
561  rankid_ = rankid
562  else
563  rankid_ = mpi_myrank
564  end if
565 
566  call file_get_fid( basename, mode_, rankid_, single_, & ! (in)
567  fid, existed, & ! (out)
568  allnodes=allnodes, & ! (in)
569  aggregate=aggregate, postfix=postfix ) ! (in)
570 
571  return
572  end subroutine file_open
573 
574  !-----------------------------------------------------------------------------
576  function file_opened( fid )
577  implicit none
578 
579  integer, intent( in) :: fid
580  logical :: file_opened
581 
582  if ( fid < 1 ) then
583  file_opened = .false.
584  else
585  file_opened = file_files(fid)%fid >= 0
586  end if
587 
588  return
589  end function file_opened
590 
591  !-----------------------------------------------------------------------------
593  function file_single( fid )
594  implicit none
595 
596  integer, intent( in) :: fid
597  logical :: file_single
598 
599  if ( fid < 1 ) then
600  file_single = .false.
601  else
602  file_single = file_files(fid)%single
603  end if
604 
605  return
606  end function file_single
607 
608  !-----------------------------------------------------------------------------
610  function file_allnodes( fid )
611  implicit none
612 
613  integer, intent( in) :: fid
614  logical :: file_allnodes
615 
616  if ( fid < 1 ) then
617  file_allnodes = .false.
618  else
619  file_allnodes = file_files(fid)%allnodes
620  end if
621 
622  return
623  end function file_allnodes
624 
625  !-----------------------------------------------------------------------------
627  !-----------------------------------------------------------------------------
628  subroutine file_get_dimlength( &
629  fid, dimname, &
630  len, &
631  error )
632  integer, intent(in) :: fid
633  character(len=*), intent(in) :: dimname
634 
635  integer, intent(out) :: len
636 
637  logical, intent(out), optional :: error
638 
639  logical(c_bool) :: suppress
640  integer :: ierror
641 
642 
643  if ( .not. file_opened(fid) ) then
644  log_error("FILE_get_dimLength",*) 'File is not opened. fid = ', fid
645  call prc_abort
646  end if
647 
648  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
649 
650  if ( present(error) ) then
651  suppress = .true.
652  else
653  suppress = .false.
654  end if
655 
656  ierror = file_get_dim_length_c( len, & ! (out)
657  file_files(fid)%fid, & ! (in)
658  cstr(dimname), & ! (in)
659  suppress ) ! (in)
660  if ( ierror /= file_success_code .and. ierror /= file_already_existed_code ) then
661  if ( present(error) ) then
662  error = .true.
663  else
664  log_error("FILE_get_dimLength",*) 'failed to get dimension length'
665  call prc_abort
666  end if
667  else
668  if ( present(error) ) error = .false.
669  end if
670 
671  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
672 
673  return
674  end subroutine file_get_dimlength
675 
676  !-----------------------------------------------------------------------------
677  ! interface FILE_PutAxis
678  !-----------------------------------------------------------------------------
679  subroutine file_put_axis_realsp( &
680  fid, &
681  name, desc, units, &
682  dim_name, dtype, &
683  val )
684  integer, intent(in) :: fid
685  character(len=*), intent(in) :: name
686  character(len=*), intent(in) :: desc
687  character(len=*), intent(in) :: units
688  character(len=*), intent(in) :: dim_name
689  integer, intent(in) :: dtype
690  real(sp), intent(in), target, contiguous :: val(:)
691 
692  integer :: error
693  intrinsic size
694 
695  if ( .not. file_opened(fid) ) then
696  log_error("FILE_put_axis_real",*) 'File is not opened. fid = ', fid
697  call prc_abort
698  end if
699 
700  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
701 
702  !$acc update host(val) if(acc_is_present(val))
703 
704  error = file_put_axis_c( file_files(fid)%fid, & ! (in)
705  cstr(name), cstr(desc), cstr(units), & ! (in)
706  cstr(dim_name), dtype, & ! (in)
707 #if defined(__GFORTRAN__) && __GNUC__ < 7
708  cloc(val(1)), size(val), sp ) ! (in)
709 #else
710  c_loc(val), size(val), sp ) ! (in)
711 #endif
712  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
713  log_error("FILE_put_axis_realSP",*) 'failed to put axis'
714  call prc_abort
715  end if
716 
717  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
718 
719  return
720  end subroutine file_put_axis_realsp
721  subroutine file_put_axis_realdp( &
722  fid, &
723  name, desc, units, &
724  dim_name, dtype, &
725  val )
726  integer, intent(in) :: fid
727  character(len=*), intent(in) :: name
728  character(len=*), intent(in) :: desc
729  character(len=*), intent(in) :: units
730  character(len=*), intent(in) :: dim_name
731  integer, intent(in) :: dtype
732  real(dp), intent(in), target, contiguous :: val(:)
733 
734  integer :: error
735  intrinsic size
736 
737  if ( .not. file_opened(fid) ) then
738  log_error("FILE_put_axis_real",*) 'File is not opened. fid = ', fid
739  call prc_abort
740  end if
741 
742  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
743 
744  !$acc update host(val) if(acc_is_present(val))
745 
746  error = file_put_axis_c( file_files(fid)%fid, & ! (in)
747  cstr(name), cstr(desc), cstr(units), & ! (in)
748  cstr(dim_name), dtype, & ! (in)
749 #if defined(__GFORTRAN__) && __GNUC__ < 7
750  cloc(val(1)), size(val), dp ) ! (in)
751 #else
752  c_loc(val), size(val), dp ) ! (in)
753 #endif
754  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
755  log_error("FILE_put_axis_realDP",*) 'failed to put axis'
756  call prc_abort
757  end if
758 
759  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
760 
761  return
762  end subroutine file_put_axis_realdp
763 
764  subroutine file_def_axis( &
765  fid, &
766  name, desc, units, &
767  dim_name, dtype, dim_size, &
768  bounds )
769  integer, intent(in) :: fid
770  character(len=*), intent(in) :: name
771  character(len=*), intent(in) :: desc
772  character(len=*), intent(in) :: units
773  character(len=*), intent(in) :: dim_name
774  integer, intent(in) :: dtype
775  integer, intent(in) :: dim_size
776 
777  logical, intent(in), optional :: bounds
778 
779  integer :: error
780  integer :: bounds_
781 
782  bounds_ = 0 ! .false.
783  if ( present(bounds) ) then
784  if ( bounds ) bounds_ = 1 ! .true.
785  end if
786 
787  if ( .not. file_opened(fid) ) then
788  log_error("FILE_def_axis",*) 'File is not opened. fid = ', fid
789  call prc_abort
790  end if
791 
792  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
793 
794  error = file_def_axis_c( file_files(fid)%fid, & ! (in)
795  cstr(name), cstr(desc), cstr(units), & ! (in)
796  cstr(dim_name), dtype, dim_size, bounds_ ) ! (in)
797  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
798  log_error("FILE_def_axis",*) 'failed to define axis'
799  call prc_abort
800  end if
801 
802  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
803 
804  return
805  end subroutine file_def_axis
806 
807  !-----------------------------------------------------------------------------
808  ! interface FILE_WriteAxis
809  !-----------------------------------------------------------------------------
810  subroutine file_write_axis_realsp( &
811  fid, &
812  name, &
813  val, &
814  start )
815  integer, intent(in) :: fid
816  character(len=*), intent(in) :: name
817  real(sp), intent(in), target, contiguous :: val(:)
818  integer, intent(in), optional :: start(:)
819 
820  integer :: error
821  intrinsic shape
822 
823  if ( .not. file_opened(fid) ) then
824  log_error("FILE_write_axis_realSP",*) 'File is not opened. fid = ', fid
825  call prc_abort
826  end if
827 
828  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
829 
830  !$acc update host(val) if(acc_is_present(val))
831 
832  if ( present(start) ) then
833  error = file_write_axis_c( file_files(fid)%fid, cstr(name), & ! (in)
834 #if defined(__GFORTRAN__) && __GNUC__ < 7
835  cloc(val(1)), sp, start-1, shape(val) ) ! (in)
836 #else
837  c_loc(val), sp, start-1, shape(val) ) ! (in)
838 #endif
839  else
840  error = file_write_axis_c( file_files(fid)%fid, cstr(name), & ! (in)
841 #if defined(__GFORTRAN__) && __GNUC__ < 7
842  cloc(val(1)), sp, (/0/), shape(val) ) ! (in)
843 #else
844  c_loc(val), sp, (/0/), shape(val) ) ! (in)
845 #endif
846  end if
847  if ( error /= file_success_code ) then
848  log_error("FILE_write_axis_realSP",*) 'failed to write axis: '//trim(name)
849  call prc_abort
850  end if
851 
852  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
853 
854  return
855  end subroutine file_write_axis_realsp
856  subroutine file_write_axis_realdp( &
857  fid, &
858  name, &
859  val, &
860  start )
861  integer, intent(in) :: fid
862  character(len=*), intent(in) :: name
863  real(dp), intent(in), target, contiguous :: val(:)
864  integer, intent(in), optional :: start(:)
865 
866  integer :: error
867  intrinsic shape
868 
869  if ( .not. file_opened(fid) ) then
870  log_error("FILE_write_axis_realDP",*) 'File is not opened. fid = ', fid
871  call prc_abort
872  end if
873 
874  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
875 
876  !$acc update host(val) if(acc_is_present(val))
877 
878  if ( present(start) ) then
879  error = file_write_axis_c( file_files(fid)%fid, cstr(name), & ! (in)
880 #if defined(__GFORTRAN__) && __GNUC__ < 7
881  cloc(val(1)), dp, start-1, shape(val) ) ! (in)
882 #else
883  c_loc(val), dp, start-1, shape(val) ) ! (in)
884 #endif
885  else
886  error = file_write_axis_c( file_files(fid)%fid, cstr(name), & ! (in)
887 #if defined(__GFORTRAN__) && __GNUC__ < 7
888  cloc(val(1)), dp, (/0/), shape(val) ) ! (in)
889 #else
890  c_loc(val), dp, (/0/), shape(val) ) ! (in)
891 #endif
892  end if
893  if ( error /= file_success_code ) then
894  log_error("FILE_write_axis_realDP",*) 'failed to write axis: '//trim(name)
895  call prc_abort
896  end if
897 
898  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
899 
900  return
901  end subroutine file_write_axis_realdp
902 
903  !-----------------------------------------------------------------------------
904  ! interface FILE_put_associatedCoordinate
905  !-----------------------------------------------------------------------------
906  subroutine file_put_associatedcoordinate_realsp_1d( &
907  fid, &
908  name, desc, units, &
909  dim_names, dtype, &
910  val )
911  integer, intent(in) :: fid
912  character(len=*), intent(in) :: name
913  character(len=*), intent(in) :: desc
914  character(len=*), intent(in) :: units
915  character(len=*), intent(in) :: dim_names(:)
916  integer, intent(in) :: dtype
917 #ifdef NVIDIA
918  real(sp), intent(in) :: val(:)
919 #else
920  real(sp), intent(in), target, contiguous :: val(:)
921 #endif
922 
923  type(c_ptr) :: dim_names_(size(dim_names))
924  !character(:,c_char), allocatable, target :: cptr(:)
925  character(len=H_SHORT), allocatable, target :: cptr(:)
926 
927  integer :: i
928  integer :: error
929  intrinsic size, len
930 
931  if ( .not. file_opened(fid) ) then
932  log_error("FILE_put_associatedCoordinate_realSP_1D",*) 'File is not opened. fid = ', fid
933  call prc_abort
934  end if
935 
936  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
937 
938  !allocate( character(len=len(dim_names)+1) :: cptr(size(dim_names)) )
939  allocate( cptr(size(dim_names)) )
940  do i = 1, size(dim_names)
941  cptr(i) = cstr(dim_names(i))
942  dim_names_(i) = c_loc(cptr(i))
943  end do
944 
945  !$acc update host(val) if(acc_is_present(val))
946 
947 #ifdef NVIDIA
948  block
949  real(sp), allocatable, target :: work(:)
950  allocate(work, source=val)
951 #endif
953  file_files(fid)%fid, & ! (in)
954  cstr(name), cstr(desc), cstr(units), & ! (in)
955  dim_names_, size(dim_names), dtype, & ! (in)
956 #if defined(__GFORTRAN__) && __GNUC__ < 7
957  cloc(val(1)), sp ) ! (in)
958 #elif defined(NVIDIA)
959  c_loc(work), sp ) ! (in)
960 #else
961  c_loc(val), sp ) ! (in)
962 #endif
963  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
964  log_error("FILE_put_associatedCoordinate_realSP_1D",*) 'failed to put associated coordinate: '//trim(name)
965  call prc_abort
966  end if
967 
968 #ifdef NVIDIA
969  end block
970 #endif
971 
972  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
973 
974  return
975  end subroutine file_put_associatedcoordinate_realsp_1d
976  subroutine file_put_associatedcoordinate_realdp_1d( &
977  fid, &
978  name, desc, units, &
979  dim_names, dtype, &
980  val )
981  integer, intent(in) :: fid
982  character(len=*), intent(in) :: name
983  character(len=*), intent(in) :: desc
984  character(len=*), intent(in) :: units
985  character(len=*), intent(in) :: dim_names(:)
986  integer, intent(in) :: dtype
987 #ifdef NVIDIA
988  real(dp), intent(in) :: val(:)
989 #else
990  real(dp), intent(in), target, contiguous :: val(:)
991 #endif
992 
993  type(c_ptr) :: dim_names_(size(dim_names))
994  !character(:,c_char), allocatable, target :: cptr(:)
995  character(len=H_SHORT), allocatable, target :: cptr(:)
996 
997  integer :: i
998  integer :: error
999  intrinsic size, len
1000 
1001  if ( .not. file_opened(fid) ) then
1002  log_error("FILE_put_associatedCoordinate_realDP_1D",*) 'File is not opened. fid = ', fid
1003  call prc_abort
1004  end if
1005 
1006  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1007 
1008  !allocate( character(len=len(dim_names)+1) :: cptr(size(dim_names)) )
1009  allocate( cptr(size(dim_names)) )
1010  do i = 1, size(dim_names)
1011  cptr(i) = cstr(dim_names(i))
1012  dim_names_(i) = c_loc(cptr(i))
1013  end do
1014 
1015  !$acc update host(val) if(acc_is_present(val))
1016 
1017 #ifdef NVIDIA
1018  block
1019  real(dp), allocatable, target :: work(:)
1020  allocate(work, source=val)
1021 #endif
1023  file_files(fid)%fid, & ! (in)
1024  cstr(name), cstr(desc), cstr(units), & ! (in)
1025  dim_names_, size(dim_names), dtype, & ! (in)
1026 #if defined(__GFORTRAN__) && __GNUC__ < 7
1027  cloc(val(1)), dp ) ! (in)
1028 #elif defined(NVIDIA)
1029  c_loc(work), dp ) ! (in)
1030 #else
1031  c_loc(val), dp ) ! (in)
1032 #endif
1033  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1034  log_error("FILE_put_associatedCoordinate_realDP_1D",*) 'failed to put associated coordinate: '//trim(name)
1035  call prc_abort
1036  end if
1037 
1038 #ifdef NVIDIA
1039  end block
1040 #endif
1041 
1042  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1043 
1044  return
1045  end subroutine file_put_associatedcoordinate_realdp_1d
1046  subroutine file_put_associatedcoordinate_realsp_2d( &
1047  fid, &
1048  name, desc, units, &
1049  dim_names, dtype, &
1050  val )
1051  integer, intent(in) :: fid
1052  character(len=*), intent(in) :: name
1053  character(len=*), intent(in) :: desc
1054  character(len=*), intent(in) :: units
1055  character(len=*), intent(in) :: dim_names(:)
1056  integer, intent(in) :: dtype
1057 #ifdef NVIDIA
1058  real(sp), intent(in) :: val(:,:)
1059 #else
1060  real(sp), intent(in), target, contiguous :: val(:,:)
1061 #endif
1062 
1063  type(c_ptr) :: dim_names_(size(dim_names))
1064  !character(:,c_char), allocatable, target :: cptr(:)
1065  character(len=H_SHORT), allocatable, target :: cptr(:)
1066 
1067  integer :: i
1068  integer :: error
1069  intrinsic size, len
1070 
1071  if ( .not. file_opened(fid) ) then
1072  log_error("FILE_put_associatedCoordinate_realSP_2D",*) 'File is not opened. fid = ', fid
1073  call prc_abort
1074  end if
1075 
1076  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1077 
1078  !allocate( character(len=len(dim_names)+1) :: cptr(size(dim_names)) )
1079  allocate( cptr(size(dim_names)) )
1080  do i = 1, size(dim_names)
1081  cptr(i) = cstr(dim_names(i))
1082  dim_names_(i) = c_loc(cptr(i))
1083  end do
1084 
1085  !$acc update host(val) if(acc_is_present(val))
1086 
1087 #ifdef NVIDIA
1088  block
1089  real(sp), allocatable, target :: work(:,:)
1090  allocate(work, source=val)
1091 #endif
1093  file_files(fid)%fid, & ! (in)
1094  cstr(name), cstr(desc), cstr(units), & ! (in)
1095  dim_names_, size(dim_names), dtype, & ! (in)
1096 #if defined(__GFORTRAN__) && __GNUC__ < 7
1097  cloc(val(1,1)), sp ) ! (in)
1098 #elif defined(NVIDIA)
1099  c_loc(work), sp ) ! (in)
1100 #else
1101  c_loc(val), sp ) ! (in)
1102 #endif
1103  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1104  log_error("FILE_put_associatedCoordinate_realSP_2D",*) 'failed to put associated coordinate: '//trim(name)
1105  call prc_abort
1106  end if
1107 
1108 #ifdef NVIDIA
1109  end block
1110 #endif
1111 
1112  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1113 
1114  return
1115  end subroutine file_put_associatedcoordinate_realsp_2d
1116  subroutine file_put_associatedcoordinate_realdp_2d( &
1117  fid, &
1118  name, desc, units, &
1119  dim_names, dtype, &
1120  val )
1121  integer, intent(in) :: fid
1122  character(len=*), intent(in) :: name
1123  character(len=*), intent(in) :: desc
1124  character(len=*), intent(in) :: units
1125  character(len=*), intent(in) :: dim_names(:)
1126  integer, intent(in) :: dtype
1127 #ifdef NVIDIA
1128  real(dp), intent(in) :: val(:,:)
1129 #else
1130  real(dp), intent(in), target, contiguous :: val(:,:)
1131 #endif
1132 
1133  type(c_ptr) :: dim_names_(size(dim_names))
1134  !character(:,c_char), allocatable, target :: cptr(:)
1135  character(len=H_SHORT), allocatable, target :: cptr(:)
1136 
1137  integer :: i
1138  integer :: error
1139  intrinsic size, len
1140 
1141  if ( .not. file_opened(fid) ) then
1142  log_error("FILE_put_associatedCoordinate_realDP_2D",*) 'File is not opened. fid = ', fid
1143  call prc_abort
1144  end if
1145 
1146  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1147 
1148  !allocate( character(len=len(dim_names)+1) :: cptr(size(dim_names)) )
1149  allocate( cptr(size(dim_names)) )
1150  do i = 1, size(dim_names)
1151  cptr(i) = cstr(dim_names(i))
1152  dim_names_(i) = c_loc(cptr(i))
1153  end do
1154 
1155  !$acc update host(val) if(acc_is_present(val))
1156 
1157 #ifdef NVIDIA
1158  block
1159  real(dp), allocatable, target :: work(:,:)
1160  allocate(work, source=val)
1161 #endif
1163  file_files(fid)%fid, & ! (in)
1164  cstr(name), cstr(desc), cstr(units), & ! (in)
1165  dim_names_, size(dim_names), dtype, & ! (in)
1166 #if defined(__GFORTRAN__) && __GNUC__ < 7
1167  cloc(val(1,1)), dp ) ! (in)
1168 #elif defined(NVIDIA)
1169  c_loc(work), dp ) ! (in)
1170 #else
1171  c_loc(val), dp ) ! (in)
1172 #endif
1173  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1174  log_error("FILE_put_associatedCoordinate_realDP_2D",*) 'failed to put associated coordinate: '//trim(name)
1175  call prc_abort
1176  end if
1177 
1178 #ifdef NVIDIA
1179  end block
1180 #endif
1181 
1182  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1183 
1184  return
1185  end subroutine file_put_associatedcoordinate_realdp_2d
1186  subroutine file_put_associatedcoordinate_realsp_3d( &
1187  fid, &
1188  name, desc, units, &
1189  dim_names, dtype, &
1190  val )
1191  integer, intent(in) :: fid
1192  character(len=*), intent(in) :: name
1193  character(len=*), intent(in) :: desc
1194  character(len=*), intent(in) :: units
1195  character(len=*), intent(in) :: dim_names(:)
1196  integer, intent(in) :: dtype
1197 #ifdef NVIDIA
1198  real(sp), intent(in) :: val(:,:,:)
1199 #else
1200  real(sp), intent(in), target, contiguous :: val(:,:,:)
1201 #endif
1202 
1203  type(c_ptr) :: dim_names_(size(dim_names))
1204  !character(:,c_char), allocatable, target :: cptr(:)
1205  character(len=H_SHORT), allocatable, target :: cptr(:)
1206 
1207  integer :: i
1208  integer :: error
1209  intrinsic size, len
1210 
1211  if ( .not. file_opened(fid) ) then
1212  log_error("FILE_put_associatedCoordinate_realSP_3D",*) 'File is not opened. fid = ', fid
1213  call prc_abort
1214  end if
1215 
1216  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1217 
1218  !allocate( character(len=len(dim_names)+1) :: cptr(size(dim_names)) )
1219  allocate( cptr(size(dim_names)) )
1220  do i = 1, size(dim_names)
1221  cptr(i) = cstr(dim_names(i))
1222  dim_names_(i) = c_loc(cptr(i))
1223  end do
1224 
1225  !$acc update host(val) if(acc_is_present(val))
1226 
1227 #ifdef NVIDIA
1228  block
1229  real(sp), allocatable, target :: work(:,:,:)
1230  allocate(work, source=val)
1231 #endif
1233  file_files(fid)%fid, & ! (in)
1234  cstr(name), cstr(desc), cstr(units), & ! (in)
1235  dim_names_, size(dim_names), dtype, & ! (in)
1236 #if defined(__GFORTRAN__) && __GNUC__ < 7
1237  cloc(val(1,1,1)), sp ) ! (in)
1238 #elif defined(NVIDIA)
1239  c_loc(work), sp ) ! (in)
1240 #else
1241  c_loc(val), sp ) ! (in)
1242 #endif
1243  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1244  log_error("FILE_put_associatedCoordinate_realSP_3D",*) 'failed to put associated coordinate: '//trim(name)
1245  call prc_abort
1246  end if
1247 
1248 #ifdef NVIDIA
1249  end block
1250 #endif
1251 
1252  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1253 
1254  return
1255  end subroutine file_put_associatedcoordinate_realsp_3d
1256  subroutine file_put_associatedcoordinate_realdp_3d( &
1257  fid, &
1258  name, desc, units, &
1259  dim_names, dtype, &
1260  val )
1261  integer, intent(in) :: fid
1262  character(len=*), intent(in) :: name
1263  character(len=*), intent(in) :: desc
1264  character(len=*), intent(in) :: units
1265  character(len=*), intent(in) :: dim_names(:)
1266  integer, intent(in) :: dtype
1267 #ifdef NVIDIA
1268  real(dp), intent(in) :: val(:,:,:)
1269 #else
1270  real(dp), intent(in), target, contiguous :: val(:,:,:)
1271 #endif
1272 
1273  type(c_ptr) :: dim_names_(size(dim_names))
1274  !character(:,c_char), allocatable, target :: cptr(:)
1275  character(len=H_SHORT), allocatable, target :: cptr(:)
1276 
1277  integer :: i
1278  integer :: error
1279  intrinsic size, len
1280 
1281  if ( .not. file_opened(fid) ) then
1282  log_error("FILE_put_associatedCoordinate_realDP_3D",*) 'File is not opened. fid = ', fid
1283  call prc_abort
1284  end if
1285 
1286  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1287 
1288  !allocate( character(len=len(dim_names)+1) :: cptr(size(dim_names)) )
1289  allocate( cptr(size(dim_names)) )
1290  do i = 1, size(dim_names)
1291  cptr(i) = cstr(dim_names(i))
1292  dim_names_(i) = c_loc(cptr(i))
1293  end do
1294 
1295  !$acc update host(val) if(acc_is_present(val))
1296 
1297 #ifdef NVIDIA
1298  block
1299  real(dp), allocatable, target :: work(:,:,:)
1300  allocate(work, source=val)
1301 #endif
1303  file_files(fid)%fid, & ! (in)
1304  cstr(name), cstr(desc), cstr(units), & ! (in)
1305  dim_names_, size(dim_names), dtype, & ! (in)
1306 #if defined(__GFORTRAN__) && __GNUC__ < 7
1307  cloc(val(1,1,1)), dp ) ! (in)
1308 #elif defined(NVIDIA)
1309  c_loc(work), dp ) ! (in)
1310 #else
1311  c_loc(val), dp ) ! (in)
1312 #endif
1313  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1314  log_error("FILE_put_associatedCoordinate_realDP_3D",*) 'failed to put associated coordinate: '//trim(name)
1315  call prc_abort
1316  end if
1317 
1318 #ifdef NVIDIA
1319  end block
1320 #endif
1321 
1322  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1323 
1324  return
1325  end subroutine file_put_associatedcoordinate_realdp_3d
1326  subroutine file_put_associatedcoordinate_realsp_4d( &
1327  fid, &
1328  name, desc, units, &
1329  dim_names, dtype, &
1330  val )
1331  integer, intent(in) :: fid
1332  character(len=*), intent(in) :: name
1333  character(len=*), intent(in) :: desc
1334  character(len=*), intent(in) :: units
1335  character(len=*), intent(in) :: dim_names(:)
1336  integer, intent(in) :: dtype
1337 #ifdef NVIDIA
1338  real(sp), intent(in) :: val(:,:,:,:)
1339 #else
1340  real(sp), intent(in), target, contiguous :: val(:,:,:,:)
1341 #endif
1342 
1343  type(c_ptr) :: dim_names_(size(dim_names))
1344  !character(:,c_char), allocatable, target :: cptr(:)
1345  character(len=H_SHORT), allocatable, target :: cptr(:)
1346 
1347  integer :: i
1348  integer :: error
1349  intrinsic size, len
1350 
1351  if ( .not. file_opened(fid) ) then
1352  log_error("FILE_put_associatedCoordinate_realSP_4D",*) 'File is not opened. fid = ', fid
1353  call prc_abort
1354  end if
1355 
1356  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1357 
1358  !allocate( character(len=len(dim_names)+1) :: cptr(size(dim_names)) )
1359  allocate( cptr(size(dim_names)) )
1360  do i = 1, size(dim_names)
1361  cptr(i) = cstr(dim_names(i))
1362  dim_names_(i) = c_loc(cptr(i))
1363  end do
1364 
1365  !$acc update host(val) if(acc_is_present(val))
1366 
1367 #ifdef NVIDIA
1368  block
1369  real(sp), allocatable, target :: work(:,:,:,:)
1370  allocate(work, source=val)
1371 #endif
1373  file_files(fid)%fid, & ! (in)
1374  cstr(name), cstr(desc), cstr(units), & ! (in)
1375  dim_names_, size(dim_names), dtype, & ! (in)
1376 #if defined(__GFORTRAN__) && __GNUC__ < 7
1377  cloc(val(1,1,1,1)), sp ) ! (in)
1378 #elif defined(NVIDIA)
1379  c_loc(work), sp ) ! (in)
1380 #else
1381  c_loc(val), sp ) ! (in)
1382 #endif
1383  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1384  log_error("FILE_put_associatedCoordinate_realSP_4D",*) 'failed to put associated coordinate: '//trim(name)
1385  call prc_abort
1386  end if
1387 
1388 #ifdef NVIDIA
1389  end block
1390 #endif
1391 
1392  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1393 
1394  return
1395  end subroutine file_put_associatedcoordinate_realsp_4d
1396  subroutine file_put_associatedcoordinate_realdp_4d( &
1397  fid, &
1398  name, desc, units, &
1399  dim_names, dtype, &
1400  val )
1401  integer, intent(in) :: fid
1402  character(len=*), intent(in) :: name
1403  character(len=*), intent(in) :: desc
1404  character(len=*), intent(in) :: units
1405  character(len=*), intent(in) :: dim_names(:)
1406  integer, intent(in) :: dtype
1407 #ifdef NVIDIA
1408  real(dp), intent(in) :: val(:,:,:,:)
1409 #else
1410  real(dp), intent(in), target, contiguous :: val(:,:,:,:)
1411 #endif
1412 
1413  type(c_ptr) :: dim_names_(size(dim_names))
1414  !character(:,c_char), allocatable, target :: cptr(:)
1415  character(len=H_SHORT), allocatable, target :: cptr(:)
1416 
1417  integer :: i
1418  integer :: error
1419  intrinsic size, len
1420 
1421  if ( .not. file_opened(fid) ) then
1422  log_error("FILE_put_associatedCoordinate_realDP_4D",*) 'File is not opened. fid = ', fid
1423  call prc_abort
1424  end if
1425 
1426  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1427 
1428  !allocate( character(len=len(dim_names)+1) :: cptr(size(dim_names)) )
1429  allocate( cptr(size(dim_names)) )
1430  do i = 1, size(dim_names)
1431  cptr(i) = cstr(dim_names(i))
1432  dim_names_(i) = c_loc(cptr(i))
1433  end do
1434 
1435  !$acc update host(val) if(acc_is_present(val))
1436 
1437 #ifdef NVIDIA
1438  block
1439  real(dp), allocatable, target :: work(:,:,:,:)
1440  allocate(work, source=val)
1441 #endif
1443  file_files(fid)%fid, & ! (in)
1444  cstr(name), cstr(desc), cstr(units), & ! (in)
1445  dim_names_, size(dim_names), dtype, & ! (in)
1446 #if defined(__GFORTRAN__) && __GNUC__ < 7
1447  cloc(val(1,1,1,1)), dp ) ! (in)
1448 #elif defined(NVIDIA)
1449  c_loc(work), dp ) ! (in)
1450 #else
1451  c_loc(val), dp ) ! (in)
1452 #endif
1453  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1454  log_error("FILE_put_associatedCoordinate_realDP_4D",*) 'failed to put associated coordinate: '//trim(name)
1455  call prc_abort
1456  end if
1457 
1458 #ifdef NVIDIA
1459  end block
1460 #endif
1461 
1462  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1463 
1464  return
1465  end subroutine file_put_associatedcoordinate_realdp_4d
1466 
1467  subroutine file_def_associatedcoordinate( &
1468  fid, &
1469  name, desc, units, &
1470  dim_names, dtype )
1471  integer, intent(in) :: fid
1472  character(len=*), intent(in) :: name
1473  character(len=*), intent(in) :: desc
1474  character(len=*), intent(in) :: units
1475  character(len=*), intent(in) :: dim_names(:)
1476  integer, intent(in) :: dtype
1477 
1478  type(c_ptr) :: dim_names_(size(dim_names))
1479 ! character(:,c_char), allocatable, target :: cptr(:)
1480  character(len=H_SHORT+1), allocatable, target :: cptr(:)
1481 
1482  integer :: error
1483  integer :: i
1484  intrinsic size, len
1485 
1486  if ( .not. file_opened(fid) ) then
1487  log_error("FILE_def_associatedCoordinate",*) 'File is not opened. fid = ', fid
1488  call prc_abort
1489  end if
1490 
1491  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1492 
1493  !allocate( character(len=len(dim_names)+1) :: cptr(size(dim_names)) )
1494  allocate( cptr(size(dim_names)) )
1495  do i = 1, size(dim_names)
1496  cptr(i) = cstr(dim_names(i))
1497  dim_names_(i) = c_loc(cptr(i))
1498  end do
1499 
1501  file_files(fid)%fid, & ! (in)
1502  cstr(name), cstr(desc), cstr(units), & ! (in)
1503  dim_names_, size(dim_names), dtype ) ! (in)
1504  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1505  log_error("FILE_def_associatedCoordinate",*) 'failed to define associated coordinate: '//trim(name)
1506  call prc_abort
1507  end if
1508 
1509  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1510 
1511  return
1512  end subroutine file_def_associatedcoordinate
1513 
1514  !-----------------------------------------------------------------------------
1515  ! interface FILE_write_associatedCoordinate
1516  !-----------------------------------------------------------------------------
1517  subroutine file_write_associatedcoordinate_realsp_1d( &
1518  fid, &
1519  name, &
1520  val, &
1521  start, count, &
1522  ndims )
1523  integer, intent(in) :: fid
1524  character(len=*), intent(in) :: name
1525 #ifdef NVIDIA
1526  real(sp), intent(in) :: val(:)
1527 #else
1528  real(sp), intent(in), target, contiguous :: val(:)
1529 #endif
1530  integer, intent(in), optional :: start(:)
1531  integer, intent(in), optional :: count(:) ! in case val has been reshaped
1532  integer, intent(in), optional :: ndims ! in case val has been reshaped
1533 
1534  integer :: ndims_
1535  integer, allocatable :: start_(:), count_(:)
1536  integer :: error
1537  integer :: i
1538  intrinsic shape, size
1539 
1540  if ( .not. file_opened(fid) ) then
1541  log_error("FILE_write_associatedCoordinate_realSP_1D",*) 'File is not opened. fid = ', fid
1542  call prc_abort
1543  end if
1544 
1545  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1546 
1547  if ( present(ndims) ) then
1548  ndims_ = ndims
1549  else
1550  ndims_ = 1
1551  end if
1552  allocate( start_(ndims_), count_(ndims_) )
1553 
1554  if ( present(ndims) ) then
1555  ! Note this is called for history coordinates which have been reshaped
1556  ! from 2D/3D into 1D array. In this case, start and count must be also present
1557  do i = 1, ndims_
1558  start_(i) = start(ndims_-i+1) - 1
1559  count_(i) = count(ndims_-i+1)
1560  end do
1561  else if ( present(start) ) then
1562  ! Note this is called for restart coordinates
1563  do i = 1, ndims_
1564  start_(i) = start(1-i+1) - 1
1565  count_(i) = size(val, 1-i+1)
1566  end do
1567  else
1568  ! Note this is for the one-file-per-process I/O method
1569  do i = 1, 1
1570  start_(i) = 0
1571  count_(i) = size(val, 1-i+1)
1572  end do
1573  end if
1574 
1575  !$acc update host(val) if(acc_is_present(val))
1576 
1577 #ifdef NVIDIA
1578  block
1579  real(sp), allocatable, target :: work(:)
1580  allocate(work, source=val)
1581 #endif
1583  file_files(fid)%fid, cstr(name), & ! (in)
1584 #if defined(__GFORTRAN__) && __GNUC__ < 7
1585  cloc(val(1)), & ! (in)
1586 #elif defined(NVIDIA)
1587  c_loc(work), & ! (in)
1588 #else
1589  c_loc(val), & ! (in)
1590 #endif
1591  ndims_, sp, & ! (in)
1592  start_, count_ ) ! (in)
1593 
1594  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1595  log_error("FILE_write_associatedCoordinate_realSP_1D",*) 'failed to write associated coordinate: '//trim(name)
1596  call prc_abort
1597  end if
1598 
1599 #ifdef NVIDIA
1600  end block
1601 #endif
1602 
1603  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1604 
1605  return
1606  end subroutine file_write_associatedcoordinate_realsp_1d
1607  subroutine file_write_associatedcoordinate_realdp_1d( &
1608  fid, &
1609  name, &
1610  val, &
1611  start, count, &
1612  ndims )
1613  integer, intent(in) :: fid
1614  character(len=*), intent(in) :: name
1615 #ifdef NVIDIA
1616  real(dp), intent(in) :: val(:)
1617 #else
1618  real(dp), intent(in), target, contiguous :: val(:)
1619 #endif
1620  integer, intent(in), optional :: start(:)
1621  integer, intent(in), optional :: count(:) ! in case val has been reshaped
1622  integer, intent(in), optional :: ndims ! in case val has been reshaped
1623 
1624  integer :: ndims_
1625  integer, allocatable :: start_(:), count_(:)
1626  integer :: error
1627  integer :: i
1628  intrinsic shape, size
1629 
1630  if ( .not. file_opened(fid) ) then
1631  log_error("FILE_write_associatedCoordinate_realDP_1D",*) 'File is not opened. fid = ', fid
1632  call prc_abort
1633  end if
1634 
1635  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1636 
1637  if ( present(ndims) ) then
1638  ndims_ = ndims
1639  else
1640  ndims_ = 1
1641  end if
1642  allocate( start_(ndims_), count_(ndims_) )
1643 
1644  if ( present(ndims) ) then
1645  ! Note this is called for history coordinates which have been reshaped
1646  ! from 2D/3D into 1D array. In this case, start and count must be also present
1647  do i = 1, ndims_
1648  start_(i) = start(ndims_-i+1) - 1
1649  count_(i) = count(ndims_-i+1)
1650  end do
1651  else if ( present(start) ) then
1652  ! Note this is called for restart coordinates
1653  do i = 1, ndims_
1654  start_(i) = start(1-i+1) - 1
1655  count_(i) = size(val, 1-i+1)
1656  end do
1657  else
1658  ! Note this is for the one-file-per-process I/O method
1659  do i = 1, 1
1660  start_(i) = 0
1661  count_(i) = size(val, 1-i+1)
1662  end do
1663  end if
1664 
1665  !$acc update host(val) if(acc_is_present(val))
1666 
1667 #ifdef NVIDIA
1668  block
1669  real(dp), allocatable, target :: work(:)
1670  allocate(work, source=val)
1671 #endif
1673  file_files(fid)%fid, cstr(name), & ! (in)
1674 #if defined(__GFORTRAN__) && __GNUC__ < 7
1675  cloc(val(1)), & ! (in)
1676 #elif defined(NVIDIA)
1677  c_loc(work), & ! (in)
1678 #else
1679  c_loc(val), & ! (in)
1680 #endif
1681  ndims_, dp, & ! (in)
1682  start_, count_ ) ! (in)
1683 
1684  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1685  log_error("FILE_write_associatedCoordinate_realDP_1D",*) 'failed to write associated coordinate: '//trim(name)
1686  call prc_abort
1687  end if
1688 
1689 #ifdef NVIDIA
1690  end block
1691 #endif
1692 
1693  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1694 
1695  return
1696  end subroutine file_write_associatedcoordinate_realdp_1d
1697  subroutine file_write_associatedcoordinate_realsp_2d( &
1698  fid, &
1699  name, &
1700  val, &
1701  start, count, &
1702  ndims )
1703  integer, intent(in) :: fid
1704  character(len=*), intent(in) :: name
1705 #ifdef NVIDIA
1706  real(sp), intent(in) :: val(:,:)
1707 #else
1708  real(sp), intent(in), target, contiguous :: val(:,:)
1709 #endif
1710  integer, intent(in), optional :: start(:)
1711  integer, intent(in), optional :: count(:) ! in case val has been reshaped
1712  integer, intent(in), optional :: ndims ! in case val has been reshaped
1713 
1714  integer :: ndims_
1715  integer, allocatable :: start_(:), count_(:)
1716  integer :: error
1717  integer :: i
1718  intrinsic shape, size
1719 
1720  if ( .not. file_opened(fid) ) then
1721  log_error("FILE_write_associatedCoordinate_realSP_2D",*) 'File is not opened. fid = ', fid
1722  call prc_abort
1723  end if
1724 
1725  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1726 
1727  if ( present(ndims) ) then
1728  ndims_ = ndims
1729  else
1730  ndims_ = 2
1731  end if
1732  allocate( start_(ndims_), count_(ndims_) )
1733 
1734  if ( present(ndims) ) then
1735  ! Note this is called for history coordinates which have been reshaped
1736  ! from 2D/3D into 1D array. In this case, start and count must be also present
1737  do i = 1, ndims_
1738  start_(i) = start(ndims_-i+1) - 1
1739  count_(i) = count(ndims_-i+1)
1740  end do
1741  else if ( present(start) ) then
1742  ! Note this is called for restart coordinates
1743  do i = 1, ndims_
1744  start_(i) = start(2-i+1) - 1
1745  count_(i) = size(val, 2-i+1)
1746  end do
1747  else
1748  ! Note this is for the one-file-per-process I/O method
1749  do i = 1, 2
1750  start_(i) = 0
1751  count_(i) = size(val, 2-i+1)
1752  end do
1753  end if
1754 
1755  !$acc update host(val) if(acc_is_present(val))
1756 
1757 #ifdef NVIDIA
1758  block
1759  real(sp), allocatable, target :: work(:,:)
1760  allocate(work, source=val)
1761 #endif
1763  file_files(fid)%fid, cstr(name), & ! (in)
1764 #if defined(__GFORTRAN__) && __GNUC__ < 7
1765  cloc(val(1,1)), & ! (in)
1766 #elif defined(NVIDIA)
1767  c_loc(work), & ! (in)
1768 #else
1769  c_loc(val), & ! (in)
1770 #endif
1771  ndims_, sp, & ! (in)
1772  start_, count_ ) ! (in)
1773 
1774  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1775  log_error("FILE_write_associatedCoordinate_realSP_2D",*) 'failed to write associated coordinate: '//trim(name)
1776  call prc_abort
1777  end if
1778 
1779 #ifdef NVIDIA
1780  end block
1781 #endif
1782 
1783  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1784 
1785  return
1786  end subroutine file_write_associatedcoordinate_realsp_2d
1787  subroutine file_write_associatedcoordinate_realdp_2d( &
1788  fid, &
1789  name, &
1790  val, &
1791  start, count, &
1792  ndims )
1793  integer, intent(in) :: fid
1794  character(len=*), intent(in) :: name
1795 #ifdef NVIDIA
1796  real(dp), intent(in) :: val(:,:)
1797 #else
1798  real(dp), intent(in), target, contiguous :: val(:,:)
1799 #endif
1800  integer, intent(in), optional :: start(:)
1801  integer, intent(in), optional :: count(:) ! in case val has been reshaped
1802  integer, intent(in), optional :: ndims ! in case val has been reshaped
1803 
1804  integer :: ndims_
1805  integer, allocatable :: start_(:), count_(:)
1806  integer :: error
1807  integer :: i
1808  intrinsic shape, size
1809 
1810  if ( .not. file_opened(fid) ) then
1811  log_error("FILE_write_associatedCoordinate_realDP_2D",*) 'File is not opened. fid = ', fid
1812  call prc_abort
1813  end if
1814 
1815  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1816 
1817  if ( present(ndims) ) then
1818  ndims_ = ndims
1819  else
1820  ndims_ = 2
1821  end if
1822  allocate( start_(ndims_), count_(ndims_) )
1823 
1824  if ( present(ndims) ) then
1825  ! Note this is called for history coordinates which have been reshaped
1826  ! from 2D/3D into 1D array. In this case, start and count must be also present
1827  do i = 1, ndims_
1828  start_(i) = start(ndims_-i+1) - 1
1829  count_(i) = count(ndims_-i+1)
1830  end do
1831  else if ( present(start) ) then
1832  ! Note this is called for restart coordinates
1833  do i = 1, ndims_
1834  start_(i) = start(2-i+1) - 1
1835  count_(i) = size(val, 2-i+1)
1836  end do
1837  else
1838  ! Note this is for the one-file-per-process I/O method
1839  do i = 1, 2
1840  start_(i) = 0
1841  count_(i) = size(val, 2-i+1)
1842  end do
1843  end if
1844 
1845  !$acc update host(val) if(acc_is_present(val))
1846 
1847 #ifdef NVIDIA
1848  block
1849  real(dp), allocatable, target :: work(:,:)
1850  allocate(work, source=val)
1851 #endif
1853  file_files(fid)%fid, cstr(name), & ! (in)
1854 #if defined(__GFORTRAN__) && __GNUC__ < 7
1855  cloc(val(1,1)), & ! (in)
1856 #elif defined(NVIDIA)
1857  c_loc(work), & ! (in)
1858 #else
1859  c_loc(val), & ! (in)
1860 #endif
1861  ndims_, dp, & ! (in)
1862  start_, count_ ) ! (in)
1863 
1864  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1865  log_error("FILE_write_associatedCoordinate_realDP_2D",*) 'failed to write associated coordinate: '//trim(name)
1866  call prc_abort
1867  end if
1868 
1869 #ifdef NVIDIA
1870  end block
1871 #endif
1872 
1873  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1874 
1875  return
1876  end subroutine file_write_associatedcoordinate_realdp_2d
1877  subroutine file_write_associatedcoordinate_realsp_3d( &
1878  fid, &
1879  name, &
1880  val, &
1881  start, count, &
1882  ndims )
1883  integer, intent(in) :: fid
1884  character(len=*), intent(in) :: name
1885 #ifdef NVIDIA
1886  real(sp), intent(in) :: val(:,:,:)
1887 #else
1888  real(sp), intent(in), target, contiguous :: val(:,:,:)
1889 #endif
1890  integer, intent(in), optional :: start(:)
1891  integer, intent(in), optional :: count(:) ! in case val has been reshaped
1892  integer, intent(in), optional :: ndims ! in case val has been reshaped
1893 
1894  integer :: ndims_
1895  integer, allocatable :: start_(:), count_(:)
1896  integer :: error
1897  integer :: i
1898  intrinsic shape, size
1899 
1900  if ( .not. file_opened(fid) ) then
1901  log_error("FILE_write_associatedCoordinate_realSP_3D",*) 'File is not opened. fid = ', fid
1902  call prc_abort
1903  end if
1904 
1905  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1906 
1907  if ( present(ndims) ) then
1908  ndims_ = ndims
1909  else
1910  ndims_ = 3
1911  end if
1912  allocate( start_(ndims_), count_(ndims_) )
1913 
1914  if ( present(ndims) ) then
1915  ! Note this is called for history coordinates which have been reshaped
1916  ! from 2D/3D into 1D array. In this case, start and count must be also present
1917  do i = 1, ndims_
1918  start_(i) = start(ndims_-i+1) - 1
1919  count_(i) = count(ndims_-i+1)
1920  end do
1921  else if ( present(start) ) then
1922  ! Note this is called for restart coordinates
1923  do i = 1, ndims_
1924  start_(i) = start(3-i+1) - 1
1925  count_(i) = size(val, 3-i+1)
1926  end do
1927  else
1928  ! Note this is for the one-file-per-process I/O method
1929  do i = 1, 3
1930  start_(i) = 0
1931  count_(i) = size(val, 3-i+1)
1932  end do
1933  end if
1934 
1935  !$acc update host(val) if(acc_is_present(val))
1936 
1937 #ifdef NVIDIA
1938  block
1939  real(sp), allocatable, target :: work(:,:,:)
1940  allocate(work, source=val)
1941 #endif
1943  file_files(fid)%fid, cstr(name), & ! (in)
1944 #if defined(__GFORTRAN__) && __GNUC__ < 7
1945  cloc(val(1,1,1)), & ! (in)
1946 #elif defined(NVIDIA)
1947  c_loc(work), & ! (in)
1948 #else
1949  c_loc(val), & ! (in)
1950 #endif
1951  ndims_, sp, & ! (in)
1952  start_, count_ ) ! (in)
1953 
1954  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
1955  log_error("FILE_write_associatedCoordinate_realSP_3D",*) 'failed to write associated coordinate: '//trim(name)
1956  call prc_abort
1957  end if
1958 
1959 #ifdef NVIDIA
1960  end block
1961 #endif
1962 
1963  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1964 
1965  return
1966  end subroutine file_write_associatedcoordinate_realsp_3d
1967  subroutine file_write_associatedcoordinate_realdp_3d( &
1968  fid, &
1969  name, &
1970  val, &
1971  start, count, &
1972  ndims )
1973  integer, intent(in) :: fid
1974  character(len=*), intent(in) :: name
1975 #ifdef NVIDIA
1976  real(dp), intent(in) :: val(:,:,:)
1977 #else
1978  real(dp), intent(in), target, contiguous :: val(:,:,:)
1979 #endif
1980  integer, intent(in), optional :: start(:)
1981  integer, intent(in), optional :: count(:) ! in case val has been reshaped
1982  integer, intent(in), optional :: ndims ! in case val has been reshaped
1983 
1984  integer :: ndims_
1985  integer, allocatable :: start_(:), count_(:)
1986  integer :: error
1987  integer :: i
1988  intrinsic shape, size
1989 
1990  if ( .not. file_opened(fid) ) then
1991  log_error("FILE_write_associatedCoordinate_realDP_3D",*) 'File is not opened. fid = ', fid
1992  call prc_abort
1993  end if
1994 
1995  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
1996 
1997  if ( present(ndims) ) then
1998  ndims_ = ndims
1999  else
2000  ndims_ = 3
2001  end if
2002  allocate( start_(ndims_), count_(ndims_) )
2003 
2004  if ( present(ndims) ) then
2005  ! Note this is called for history coordinates which have been reshaped
2006  ! from 2D/3D into 1D array. In this case, start and count must be also present
2007  do i = 1, ndims_
2008  start_(i) = start(ndims_-i+1) - 1
2009  count_(i) = count(ndims_-i+1)
2010  end do
2011  else if ( present(start) ) then
2012  ! Note this is called for restart coordinates
2013  do i = 1, ndims_
2014  start_(i) = start(3-i+1) - 1
2015  count_(i) = size(val, 3-i+1)
2016  end do
2017  else
2018  ! Note this is for the one-file-per-process I/O method
2019  do i = 1, 3
2020  start_(i) = 0
2021  count_(i) = size(val, 3-i+1)
2022  end do
2023  end if
2024 
2025  !$acc update host(val) if(acc_is_present(val))
2026 
2027 #ifdef NVIDIA
2028  block
2029  real(dp), allocatable, target :: work(:,:,:)
2030  allocate(work, source=val)
2031 #endif
2033  file_files(fid)%fid, cstr(name), & ! (in)
2034 #if defined(__GFORTRAN__) && __GNUC__ < 7
2035  cloc(val(1,1,1)), & ! (in)
2036 #elif defined(NVIDIA)
2037  c_loc(work), & ! (in)
2038 #else
2039  c_loc(val), & ! (in)
2040 #endif
2041  ndims_, dp, & ! (in)
2042  start_, count_ ) ! (in)
2043 
2044  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
2045  log_error("FILE_write_associatedCoordinate_realDP_3D",*) 'failed to write associated coordinate: '//trim(name)
2046  call prc_abort
2047  end if
2048 
2049 #ifdef NVIDIA
2050  end block
2051 #endif
2052 
2053  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
2054 
2055  return
2056  end subroutine file_write_associatedcoordinate_realdp_3d
2057  subroutine file_write_associatedcoordinate_realsp_4d( &
2058  fid, &
2059  name, &
2060  val, &
2061  start, count, &
2062  ndims )
2063  integer, intent(in) :: fid
2064  character(len=*), intent(in) :: name
2065 #ifdef NVIDIA
2066  real(sp), intent(in) :: val(:,:,:,:)
2067 #else
2068  real(sp), intent(in), target, contiguous :: val(:,:,:,:)
2069 #endif
2070  integer, intent(in), optional :: start(:)
2071  integer, intent(in), optional :: count(:) ! in case val has been reshaped
2072  integer, intent(in), optional :: ndims ! in case val has been reshaped
2073 
2074  integer :: ndims_
2075  integer, allocatable :: start_(:), count_(:)
2076  integer :: error
2077  integer :: i
2078  intrinsic shape, size
2079 
2080  if ( .not. file_opened(fid) ) then
2081  log_error("FILE_write_associatedCoordinate_realSP_4D",*) 'File is not opened. fid = ', fid
2082  call prc_abort
2083  end if
2084 
2085  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
2086 
2087  if ( present(ndims) ) then
2088  ndims_ = ndims
2089  else
2090  ndims_ = 4
2091  end if
2092  allocate( start_(ndims_), count_(ndims_) )
2093 
2094  if ( present(ndims) ) then
2095  ! Note this is called for history coordinates which have been reshaped
2096  ! from 2D/3D into 1D array. In this case, start and count must be also present
2097  do i = 1, ndims_
2098  start_(i) = start(ndims_-i+1) - 1
2099  count_(i) = count(ndims_-i+1)
2100  end do
2101  else if ( present(start) ) then
2102  ! Note this is called for restart coordinates
2103  do i = 1, ndims_
2104  start_(i) = start(4-i+1) - 1
2105  count_(i) = size(val, 4-i+1)
2106  end do
2107  else
2108  ! Note this is for the one-file-per-process I/O method
2109  do i = 1, 4
2110  start_(i) = 0
2111  count_(i) = size(val, 4-i+1)
2112  end do
2113  end if
2114 
2115  !$acc update host(val) if(acc_is_present(val))
2116 
2117 #ifdef NVIDIA
2118  block
2119  real(sp), allocatable, target :: work(:,:,:,:)
2120  allocate(work, source=val)
2121 #endif
2123  file_files(fid)%fid, cstr(name), & ! (in)
2124 #if defined(__GFORTRAN__) && __GNUC__ < 7
2125  cloc(val(1,1,1,1)), & ! (in)
2126 #elif defined(NVIDIA)
2127  c_loc(work), & ! (in)
2128 #else
2129  c_loc(val), & ! (in)
2130 #endif
2131  ndims_, sp, & ! (in)
2132  start_, count_ ) ! (in)
2133 
2134  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
2135  log_error("FILE_write_associatedCoordinate_realSP_4D",*) 'failed to write associated coordinate: '//trim(name)
2136  call prc_abort
2137  end if
2138 
2139 #ifdef NVIDIA
2140  end block
2141 #endif
2142 
2143  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
2144 
2145  return
2146  end subroutine file_write_associatedcoordinate_realsp_4d
2147  subroutine file_write_associatedcoordinate_realdp_4d( &
2148  fid, &
2149  name, &
2150  val, &
2151  start, count, &
2152  ndims )
2153  integer, intent(in) :: fid
2154  character(len=*), intent(in) :: name
2155 #ifdef NVIDIA
2156  real(dp), intent(in) :: val(:,:,:,:)
2157 #else
2158  real(dp), intent(in), target, contiguous :: val(:,:,:,:)
2159 #endif
2160  integer, intent(in), optional :: start(:)
2161  integer, intent(in), optional :: count(:) ! in case val has been reshaped
2162  integer, intent(in), optional :: ndims ! in case val has been reshaped
2163 
2164  integer :: ndims_
2165  integer, allocatable :: start_(:), count_(:)
2166  integer :: error
2167  integer :: i
2168  intrinsic shape, size
2169 
2170  if ( .not. file_opened(fid) ) then
2171  log_error("FILE_write_associatedCoordinate_realDP_4D",*) 'File is not opened. fid = ', fid
2172  call prc_abort
2173  end if
2174 
2175  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
2176 
2177  if ( present(ndims) ) then
2178  ndims_ = ndims
2179  else
2180  ndims_ = 4
2181  end if
2182  allocate( start_(ndims_), count_(ndims_) )
2183 
2184  if ( present(ndims) ) then
2185  ! Note this is called for history coordinates which have been reshaped
2186  ! from 2D/3D into 1D array. In this case, start and count must be also present
2187  do i = 1, ndims_
2188  start_(i) = start(ndims_-i+1) - 1
2189  count_(i) = count(ndims_-i+1)
2190  end do
2191  else if ( present(start) ) then
2192  ! Note this is called for restart coordinates
2193  do i = 1, ndims_
2194  start_(i) = start(4-i+1) - 1
2195  count_(i) = size(val, 4-i+1)
2196  end do
2197  else
2198  ! Note this is for the one-file-per-process I/O method
2199  do i = 1, 4
2200  start_(i) = 0
2201  count_(i) = size(val, 4-i+1)
2202  end do
2203  end if
2204 
2205  !$acc update host(val) if(acc_is_present(val))
2206 
2207 #ifdef NVIDIA
2208  block
2209  real(dp), allocatable, target :: work(:,:,:,:)
2210  allocate(work, source=val)
2211 #endif
2213  file_files(fid)%fid, cstr(name), & ! (in)
2214 #if defined(__GFORTRAN__) && __GNUC__ < 7
2215  cloc(val(1,1,1,1)), & ! (in)
2216 #elif defined(NVIDIA)
2217  c_loc(work), & ! (in)
2218 #else
2219  c_loc(val), & ! (in)
2220 #endif
2221  ndims_, dp, & ! (in)
2222  start_, count_ ) ! (in)
2223 
2224  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
2225  log_error("FILE_write_associatedCoordinate_realDP_4D",*) 'failed to write associated coordinate: '//trim(name)
2226  call prc_abort
2227  end if
2228 
2229 #ifdef NVIDIA
2230  end block
2231 #endif
2232 
2233  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
2234 
2235  return
2236  end subroutine file_write_associatedcoordinate_realdp_4d
2237 
2238  !-----------------------------------------------------------------------------
2239  ! interface FILE_add_variable
2240  !-----------------------------------------------------------------------------
2241  subroutine file_add_variable_no_time( &
2242  fid, &
2243  varname, desc, units, &
2244  standard_name, &
2245  dims, dtype, &
2246  vid, &
2247  time_stats )
2248  integer, intent( in) :: fid
2249  character(len=*), intent( in) :: varname
2250  character(len=*), intent( in) :: desc
2251  character(len=*), intent( in) :: units
2252  character(len=*), intent( in) :: standard_name
2253  character(len=*), intent( in) :: dims(:)
2254  integer, intent( in) :: dtype
2255  integer, intent(out) :: vid
2256  character(len=*), intent( in), optional :: time_stats
2257 
2258  if ( .not. file_opened(fid) ) then
2259  log_error("FILE_add_variable_no_time",*) 'File is not opened. fid = ', fid
2260  call prc_abort
2261  end if
2262 
2263  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
2264 
2265  call file_add_variable_with_time( fid, & ! (in)
2266  varname, desc, units, standard_name, & ! (in)
2267  dims, dtype, -1.0_dp, & ! (in)
2268  vid, & ! (out)
2269  time_stats = time_stats ) ! (in)
2270 
2271  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
2272 
2273  return
2274  end subroutine file_add_variable_no_time
2275 
2276  !-----------------------------------------------------------------------------
2277  subroutine file_add_variable_with_time( &
2278  fid, &
2279  varname, desc, units, &
2280  standard_name, &
2281  dims, dtype, &
2282  time_int, &
2283  vid, &
2284  time_stats )
2285  implicit none
2286  integer, intent(in) :: fid
2287  character(len=*), intent(in) :: varname
2288  character(len=*), intent(in) :: desc
2289  character(len=*), intent(in) :: units
2290  character(len=*), intent(in) :: standard_name
2291  character(len=*), intent(in) :: dims(:)
2292  integer, intent(in) :: dtype
2293  real(dp), intent(in) :: time_int
2294 
2295  integer, intent(out) :: vid
2296 
2297  character(len=*), intent(in), optional :: time_stats
2298 
2299  type(c_ptr) :: dims_(size(dims))
2300  !character(:,c_char), allocatable, target :: cptr(:)
2301  character(len=H_SHORT), allocatable, target :: cptr(:)
2302 
2303  character(len=4) :: ctstats
2304 
2305  integer :: cvid
2306  integer :: ndims
2307  integer :: error
2308  integer :: n
2309 
2310  intrinsic size
2311  !---------------------------------------------------------------------------
2312 
2313  if ( .not. file_opened(fid) ) then
2314  log_error("FILE_add_variable_with_time",*) 'File is not opened. fid = ', fid
2315  call prc_abort
2316  end if
2317 
2318  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
2319 
2320  vid = -1
2321  do n = 1, file_nvars
2322  if ( file_vars(n)%fid == fid .and. file_vars(n)%name == varname ) then
2323  vid = file_vars(n)%vid
2324  exit
2325  endif
2326  enddo
2327 
2328  if ( vid < 0 ) then ! variable registration
2329 
2330  ndims = size(dims)
2331 
2332  ctstats = "none"
2333  if ( present(time_stats) ) then
2334  ctstats = time_stats
2335  endif
2336 
2337  !allocate( character(len=len(dims)+1) :: cptr(ndims) )
2338  allocate( cptr(ndims) )
2339  do n = 1, ndims
2340  cptr(n) = cstr(dims(n))
2341  dims_(n) = c_loc(cptr(n))
2342  end do
2343 
2344  error = file_add_variable_c( cvid, & ! [OUT]
2345  file_files(fid)%fid, & ! [IN]
2346  cstr(varname), cstr(desc), & ! [IN]
2347  cstr(units), cstr(standard_name), & ! [IN]
2348  dims_, ndims, dtype, & ! [IN]
2349  time_int, cstr(ctstats) ) ! [IN]
2350 
2351  if ( error /= file_success_code ) then
2352  log_error("FILE_add_variable_with_time",*) 'failed to add variable: '//trim(varname)
2353  call prc_abort
2354  endif
2355 
2356  file_nvars = file_nvars + 1
2357  vid = file_nvars
2358  file_vars(vid)%name = varname
2359  file_vars(vid)%vid = cvid
2360  file_vars(vid)%fid = fid
2361 
2362  log_info("FILE_add_variable_with_time",'(1x,A,I3.3,A,I4.4,2A)') &
2363  'Variable registration : NO.', fid, ', vid = ', vid, ', name = ', trim(varname)
2364  endif
2365 
2366  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
2367 
2368  return
2369  end subroutine file_add_variable_with_time
2370 
2371  subroutine file_def_variable( &
2372  fid, &
2373  varname, desc, units, &
2374  standard_name, &
2375  ndims, dims, &
2376  dtype, &
2377  vid, &
2378  time_int, time_stats, &
2379  existed )
2380  integer, intent( in) :: fid
2381  character(len=*), intent( in) :: varname
2382  character(len=*), intent( in) :: desc
2383  character(len=*), intent( in) :: units
2384  character(len=*), intent( in) :: standard_name
2385  integer, intent( in) :: ndims
2386  character(len=*), intent( in) :: dims(:)
2387  integer, intent( in) :: dtype
2388  integer, intent(out) :: vid
2389  real(dp), intent( in), optional :: time_int
2390  character(len=*), intent( in), optional :: time_stats
2391  logical, intent(out), optional :: existed
2392 
2393  type(c_ptr) :: dims_(size(dims))
2394  !character(:,c_char), allocatable, target :: cptr(:)
2395  character(len=H_SHORT), allocatable, target :: cptr(:)
2396 
2397  character(len=4) :: ctstats
2398 
2399  real(dp) :: tint_
2400  integer :: cvid
2401  integer :: error
2402  integer :: n
2403 
2404  !---------------------------------------------------------------------------
2405 
2406  if ( .not. file_opened(fid) ) then
2407  log_error("FILE_def_variable",*) 'File is not opened. fid = ', fid
2408  call prc_abort
2409  end if
2410 
2411  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
2412 
2413  vid = -1
2414  do n = 1, file_nvars
2415  if ( file_vars(n)%fid == fid .and. file_vars(n)%name == varname ) then
2416  vid = n
2417  end if
2418  enddo
2419 
2420  if ( vid < 0 ) then ! variable registration
2421 
2422  if ( present(time_int) ) then
2423  tint_ = time_int
2424  else
2425  tint_ = -1.0_dp
2426  endif
2427 
2428  ctstats = "none"
2429  if ( present(time_stats) ) then
2430  ctstats = time_stats
2431  end if
2432 
2433  !allocate( character(len=len(dims)+1) :: cptr(ndims) )
2434  allocate( cptr(ndims) )
2435  do n = 1, ndims
2436  cptr(n) = cstr(dims(n))
2437  dims_(n) = c_loc(cptr(n))
2438  end do
2439 
2440  error = file_add_variable_c( cvid, & ! [OUT]
2441  file_files(fid)%fid, & ! [IN]
2442  cstr(varname), cstr(desc), & ! [IN]
2443  cstr(units), cstr(standard_name), & ! [IN]
2444  dims_, ndims, dtype, tint_, cstr(ctstats) ) ! [IN]
2445 
2446  if ( error /= file_success_code ) then
2447  log_error("FILE_def_variable",*) 'failed to add variable: '//trim(varname)
2448  call prc_abort
2449  end if
2450 
2451  file_nvars = file_nvars + 1
2452  vid = file_nvars
2453  file_vars(vid)%name = varname
2454  file_vars(vid)%vid = cvid
2455  file_vars(vid)%fid = fid
2456 
2457  log_info("FILE_def_variable",'(1x,A,I3.3,A,I4.4,2A)') &
2458  'Variable registration : NO.', fid, ', vid = ', vid, ', name = ', trim(varname)
2459 
2460  if ( present(existed) ) existed = .false.
2461  else
2462  if ( present(existed) ) existed = .true.
2463  endif
2464 
2465  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
2466 
2467  return
2468  end subroutine file_def_variable
2469 
2470  !-----------------------------------------------------------------------------
2471  ! FILE_Get_Attribute
2472  !-----------------------------------------------------------------------------
2473  subroutine file_get_attribute_text_fid( &
2474  fid, &
2475  vname, key, &
2476  val, &
2477  existed )
2478  integer, intent(in ) :: fid
2479  character(len=*), intent(in ) :: vname
2480  character(len=*), intent(in ) :: key
2481  character(len=*), intent(out) :: val
2482 
2483  logical, intent(out), optional :: existed
2484 
2485  logical(c_bool) :: suppress
2486  integer :: error
2487 
2488  if ( .not. file_opened(fid) ) then
2489  log_error("FILE_get_attribute_text_fid",*) 'File is not opened. fid = ', fid
2490  call prc_abort
2491  end if
2492 
2493  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
2494 
2495  if ( present(existed) ) then
2496  suppress = .true.
2497  else
2498  suppress = .false.
2499  end if
2500  error = file_get_attribute_text_c( val, & ! (out)
2501  file_files(fid)%fid, & ! (in)
2502  cstr(vname), cstr(key), & ! (in)
2503  suppress, len(val) ) ! (in)
2504  call fstr(val)
2505  if ( error /= file_success_code ) then
2506  if ( present(existed) ) then
2507  existed = .false.
2508  else
2509  log_error("FILE_get_attribute_text_fid",*) 'failed to get text attribute for '//trim(vname)//': '//trim(key)
2510  call prc_abort
2511  end if
2512  else
2513  if ( present(existed) ) existed = .true.
2514  end if
2515 
2516  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
2517 
2518  return
2519  end subroutine file_get_attribute_text_fid
2520  subroutine file_get_attribute_text_fname( &
2521  basename, vname, key, &
2522  val, &
2523  single, aggregate, rankid, &
2524  existed )
2525  implicit none
2526 
2527  character(len=*), intent(in) :: basename
2528  character(len=*), intent(in) :: vname
2529  character(len=*), intent(in) :: key
2530 
2531  character(len=*), intent(out) :: val
2532 
2533  logical, intent(in), optional :: single
2534  logical, intent(in), optional :: aggregate
2535  integer, intent(in), optional :: rankid
2536 
2537  logical, intent(out), optional :: existed
2538  integer :: fid
2539 
2540  call file_open( basename, & ! (in)
2541  fid, & ! (out)
2542  single=single, & ! (in)
2543  aggregate=aggregate, & ! (in)
2544  rankid=rankid ) ! (in)
2545 
2546  call file_get_attribute_text_fid( &
2547  fid, vname, key, & ! (in)
2548  val, & ! (out)
2549  existed ) ! (out)
2550 
2551  return
2552  end subroutine file_get_attribute_text_fname
2553 
2554  !-----------------------------------------------------------------------------
2555  subroutine file_get_attribute_logical_fid( &
2556  fid, &
2557  vname, key, &
2558  val, &
2559  existed )
2560  integer, intent(in ) :: fid
2561  character(len=*), intent(in ) :: vname
2562  character(len=*), intent(in ) :: key
2563  logical, intent(out) :: val
2564 
2565  logical, intent(out), optional :: existed
2566 
2567  character(len=6) :: buf ! max length is for "false\0"
2568 
2569  if ( .not. file_opened(fid) ) then
2570  log_error("FILE_get_attribute_logical_fid",*) 'File is not opened. fid = ', fid
2571  call prc_abort
2572  end if
2573 
2574  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
2575 
2576  call file_get_attribute_text_fid( fid, vname, key, & ! (in)
2577  buf, existed ) ! (out)
2578 
2579  if ( present(existed) ) then
2580  if ( .not. existed ) return
2581  end if
2582 
2583  if ( buf == "true" ) then
2584  val = .true.
2585  else if ( buf == "false" ) then
2586  val = .false.
2587  else
2588  log_error("FILE_get_attribute_logical_fid",*) 'value is not eigher true or false'
2589  call prc_abort
2590  end if
2591 
2592  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
2593 
2594  return
2595  end subroutine file_get_attribute_logical_fid
2596  subroutine file_get_attribute_logical_fname( &
2597  basename, vname, key, &
2598  val, &
2599  single, aggregate, rankid, &
2600  existed )
2601  implicit none
2602 
2603  character(len=*), intent(in) :: basename
2604  character(len=*), intent(in) :: vname
2605  character(len=*), intent(in) :: key
2606 
2607  logical, intent(out) :: val
2608 
2609  logical, intent(in), optional :: single
2610  logical, intent(in), optional :: aggregate
2611  integer, intent(in), optional :: rankid
2612 
2613  logical, intent(out), optional :: existed
2614  integer :: fid
2615 
2616  call file_open( basename, & ! (in)
2617  fid, & ! (out)
2618  single=single, & ! (in)
2619  aggregate=aggregate, & ! (in)
2620  rankid=rankid ) ! (in)
2621 
2622  call file_get_attribute_logical_fid( &
2623  fid, vname, key, & ! (in)
2624  val, & ! (out)
2625  existed ) ! (out)
2626 
2627  return
2628  end subroutine file_get_attribute_logical_fname
2629 
2630  !-----------------------------------------------------------------------------
2631  subroutine file_get_attribute_int_fid_ary( &
2632  fid, vname, key, &
2633  val, &
2634  existed )
2635  integer, intent(in ) :: fid
2636  character(len=*), intent(in ) :: vname
2637  character(len=*), intent(in ) :: key
2638  integer, intent(out) :: val(:)
2639 
2640  logical, intent(out), optional :: existed
2641 
2642  logical(c_bool) :: suppress
2643  integer :: error
2644 
2645  intrinsic size
2646 
2647  if ( .not. file_opened(fid) ) then
2648  log_error("FILE_get_attribute_int_fid",*) 'File is not opened. fid = ', fid
2649  call prc_abort
2650  end if
2651 
2652  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
2653 
2654  if ( present(existed) ) then
2655  suppress = .true.
2656  else
2657  suppress = .false.
2658  end if
2659  error = file_get_attribute_int_c( val(:), & ! (out)
2660  file_files(fid)%fid, & ! (in)
2661  cstr(vname), cstr(key), & ! (in)
2662  suppress, size(val) ) ! (in)
2663  if ( error /= file_success_code ) then
2664  if ( present(existed) ) then
2665  existed = .false.
2666  else
2667  log_error("FILE_get_attribute_int_fid",*) 'failed to get integer attribute for '//trim(vname)//': '//trim(key)
2668  call prc_abort
2669  end if
2670  else
2671  if ( present(existed) ) existed = .true.
2672  end if
2673 
2674  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
2675 
2676  return
2677  end subroutine file_get_attribute_int_fid_ary
2678  subroutine file_get_attribute_int_fid( &
2679  fid, vname, key, &
2680  val, &
2681  existed )
2682  integer, intent(in ) :: fid
2683  character(len=*), intent(in ) :: vname
2684  character(len=*), intent(in ) :: key
2685  integer, intent(out) :: val
2686  logical, intent(out), optional :: existed
2687  integer :: ary(1)
2688 
2689  call file_get_attribute_int_fid_ary( &
2690  fid, vname, key, &
2691  ary(:), &
2692  existed )
2693  if ( present(existed) ) then
2694  if ( .not. existed ) return
2695  end if
2696  val = ary(1)
2697 
2698  return
2699  end subroutine file_get_attribute_int_fid
2700  subroutine file_get_attribute_int_fname_ary( &
2701  basename, vname, key, &
2702  val, &
2703  single, aggregate, rankid, &
2704  existed )
2705  implicit none
2706 
2707  character(len=*), intent(in) :: basename
2708  character(len=*), intent(in) :: vname
2709  character(len=*), intent(in) :: key
2710 
2711  integer, intent(out) :: val(:)
2712 
2713  logical, intent(in), optional :: single
2714  logical, intent(in), optional :: aggregate
2715  integer, intent(in), optional :: rankid
2716 
2717  logical, intent(out), optional :: existed
2718 
2719  integer :: fid
2720 
2721  call file_open( basename, & ! (in)
2722  fid, & ! (out)
2723  single=single, & ! (in)
2724  aggregate=aggregate, &
2725  rankid=rankid ) ! (in)
2726 
2727  call file_get_attribute_int_fid_ary( &
2728  fid, vname, key, & ! (in)
2729  val, & ! (out)
2730  existed ) ! (out)
2731 
2732  return
2733  end subroutine file_get_attribute_int_fname_ary
2734  subroutine file_get_attribute_int_fname( &
2735  basename, vname, key, &
2736  val, &
2737  single, aggregate, rankid, &
2738  existed )
2739  implicit none
2740  character(len=*), intent(in) :: basename
2741  character(len=*), intent(in) :: vname
2742  character(len=*), intent(in) :: key
2743  integer, intent(out) :: val
2744  logical, intent(in), optional :: single
2745  logical, intent(in), optional :: aggregate
2746  integer, intent(in), optional :: rankid
2747  logical, intent(out), optional :: existed
2748  integer :: ary(1)
2749 
2750  call file_get_attribute_int_fname_ary( &
2751  basename, vname, key, &
2752  ary(:), &
2753  single, aggregate, rankid, &
2754  existed )
2755  val = ary(1)
2756 
2757  return
2758  end subroutine file_get_attribute_int_fname
2759  !-----------------------------------------------------------------------------
2760 
2761  subroutine file_get_attribute_float_fid_ary( &
2762  fid, vname, key, &
2763  val, &
2764  existed )
2765  integer, intent(in ) :: fid
2766  character(len=*), intent(in ) :: vname
2767  character(len=*), intent(in ) :: key
2768  real(sp), intent(out) :: val(:)
2769 
2770  logical, intent(out), optional :: existed
2771 
2772  logical(c_bool) :: suppress
2773  integer :: error
2774 
2775  intrinsic size
2776 
2777  if ( .not. file_opened(fid) ) then
2778  log_error("FILE_get_attribute_float_fid",*) 'File is not opened. fid = ', fid
2779  call prc_abort
2780  end if
2781 
2782  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
2783 
2784  if ( present(existed) ) then
2785  suppress = .true.
2786  else
2787  suppress = .false.
2788  end if
2789  error = file_get_attribute_float_c( val, & ! (out)
2790  file_files(fid)%fid, & ! (in)
2791  cstr(vname), cstr(key), & ! (in)
2792  suppress, size(val) ) ! (in)
2793  if ( error /= file_success_code ) then
2794  if ( present(existed) ) then
2795  existed = .false.
2796  else
2797  log_error("FILE_get_attribute_float_fid",*) 'failed to get float attribute for '//trim(vname)//': '//trim(key)
2798  call prc_abort
2799  end if
2800  else
2801  if ( present(existed) ) existed = .true.
2802  end if
2803 
2804  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
2805 
2806  return
2807  end subroutine file_get_attribute_float_fid_ary
2808  subroutine file_get_attribute_float_fid( &
2809  fid, vname, key, &
2810  val, &
2811  existed )
2812  integer, intent(in ) :: fid
2813  character(len=*), intent(in ) :: vname
2814  character(len=*), intent(in ) :: key
2815  real(sp), intent(out) :: val
2816  logical, intent(out), optional :: existed
2817  real(sp) :: ary(1)
2818 
2819  call file_get_attribute_float_fid_ary( &
2820  fid, vname, key, &
2821  ary(:), &
2822  existed )
2823  if ( present(existed) ) then
2824  if ( .not. existed ) return
2825  end if
2826  val = ary(1)
2827 
2828  return
2829  end subroutine file_get_attribute_float_fid
2830  subroutine file_get_attribute_float_fname_ary( &
2831  basename, vname, key, &
2832  val, &
2833  single, aggregate, rankid, &
2834  existed )
2835  implicit none
2836 
2837  character(len=*), intent(in) :: basename
2838  character(len=*), intent(in) :: vname
2839  character(len=*), intent(in) :: key
2840 
2841  real(sp), intent(out) :: val(:)
2842 
2843  logical, intent(in), optional :: single
2844  logical, intent(in), optional :: aggregate
2845  integer, intent(in), optional :: rankid
2846 
2847  logical, intent(out), optional :: existed
2848 
2849  integer :: fid
2850 
2851  call file_open( basename, & ! (in)
2852  fid, & ! (out)
2853  single=single, & ! (in)
2854  aggregate=aggregate, & ! (in)
2855  rankid=rankid ) ! (in)
2856 
2857  call file_get_attribute_float_fid_ary( &
2858  fid, vname, key, & ! (in)
2859  val, & ! (out)
2860  existed ) ! (out)
2861 
2862  return
2863  end subroutine file_get_attribute_float_fname_ary
2864  subroutine file_get_attribute_float_fname( &
2865  basename, vname, key, &
2866  val, &
2867  single, aggregate, rankid, &
2868  existed )
2869  implicit none
2870  character(len=*), intent(in) :: basename
2871  character(len=*), intent(in) :: vname
2872  character(len=*), intent(in) :: key
2873  real(sp), intent(out) :: val
2874  logical, intent(in), optional :: single
2875  logical, intent(in), optional :: aggregate
2876  integer, intent(in), optional :: rankid
2877  logical, intent(out), optional :: existed
2878  real(sp) :: ary(1)
2879 
2880  call file_get_attribute_float_fname_ary( &
2881  basename, vname, key, &
2882  ary(:), &
2883  single, aggregate, rankid, &
2884  existed )
2885  val = ary(1)
2886 
2887  return
2888  end subroutine file_get_attribute_float_fname
2889  subroutine file_get_attribute_double_fid_ary( &
2890  fid, vname, key, &
2891  val, &
2892  existed )
2893  integer, intent(in ) :: fid
2894  character(len=*), intent(in ) :: vname
2895  character(len=*), intent(in ) :: key
2896  real(dp), intent(out) :: val(:)
2897 
2898  logical, intent(out), optional :: existed
2899 
2900  logical(c_bool) :: suppress
2901  integer :: error
2902 
2903  intrinsic size
2904 
2905  if ( .not. file_opened(fid) ) then
2906  log_error("FILE_get_attribute_double_fid",*) 'File is not opened. fid = ', fid
2907  call prc_abort
2908  end if
2909 
2910  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
2911 
2912  if ( present(existed) ) then
2913  suppress = .true.
2914  else
2915  suppress = .false.
2916  end if
2917  error = file_get_attribute_double_c( val, & ! (out)
2918  file_files(fid)%fid, & ! (in)
2919  cstr(vname), cstr(key), & ! (in)
2920  suppress, size(val) ) ! (in)
2921  if ( error /= file_success_code ) then
2922  if ( present(existed) ) then
2923  existed = .false.
2924  else
2925  log_error("FILE_get_attribute_double_fid",*) 'failed to get double attribute for '//trim(vname)//': '//trim(key)
2926  call prc_abort
2927  end if
2928  else
2929  if ( present(existed) ) existed = .true.
2930  end if
2931 
2932  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
2933 
2934  return
2935  end subroutine file_get_attribute_double_fid_ary
2936  subroutine file_get_attribute_double_fid( &
2937  fid, vname, key, &
2938  val, &
2939  existed )
2940  integer, intent(in ) :: fid
2941  character(len=*), intent(in ) :: vname
2942  character(len=*), intent(in ) :: key
2943  real(dp), intent(out) :: val
2944  logical, intent(out), optional :: existed
2945  real(dp) :: ary(1)
2946 
2947  call file_get_attribute_double_fid_ary( &
2948  fid, vname, key, &
2949  ary(:), &
2950  existed )
2951  if ( present(existed) ) then
2952  if ( .not. existed ) return
2953  end if
2954  val = ary(1)
2955 
2956  return
2957  end subroutine file_get_attribute_double_fid
2958  subroutine file_get_attribute_double_fname_ary( &
2959  basename, vname, key, &
2960  val, &
2961  single, aggregate, rankid, &
2962  existed )
2963  implicit none
2964 
2965  character(len=*), intent(in) :: basename
2966  character(len=*), intent(in) :: vname
2967  character(len=*), intent(in) :: key
2968 
2969  real(dp), intent(out) :: val(:)
2970 
2971  logical, intent(in), optional :: single
2972  logical, intent(in), optional :: aggregate
2973  integer, intent(in), optional :: rankid
2974 
2975  logical, intent(out), optional :: existed
2976 
2977  integer :: fid
2978 
2979  call file_open( basename, & ! (in)
2980  fid, & ! (out)
2981  single=single, & ! (in)
2982  aggregate=aggregate, & ! (in)
2983  rankid=rankid ) ! (in)
2984 
2985  call file_get_attribute_double_fid_ary( &
2986  fid, vname, key, & ! (in)
2987  val, & ! (out)
2988  existed ) ! (out)
2989 
2990  return
2991  end subroutine file_get_attribute_double_fname_ary
2992  subroutine file_get_attribute_double_fname( &
2993  basename, vname, key, &
2994  val, &
2995  single, aggregate, rankid, &
2996  existed )
2997  implicit none
2998  character(len=*), intent(in) :: basename
2999  character(len=*), intent(in) :: vname
3000  character(len=*), intent(in) :: key
3001  real(dp), intent(out) :: val
3002  logical, intent(in), optional :: single
3003  logical, intent(in), optional :: aggregate
3004  integer, intent(in), optional :: rankid
3005  logical, intent(out), optional :: existed
3006  real(dp) :: ary(1)
3007 
3008  call file_get_attribute_double_fname_ary( &
3009  basename, vname, key, &
3010  ary(:), &
3011  single, aggregate, rankid, &
3012  existed )
3013  val = ary(1)
3014 
3015  return
3016  end subroutine file_get_attribute_double_fname
3017 
3018  !-----------------------------------------------------------------------------
3019  ! FILE_set_attribute
3020  !-----------------------------------------------------------------------------
3021  subroutine file_set_attribute_text( &
3022  fid, vname, &
3023  key, val )
3024  integer, intent(in) :: fid
3025  character(len=*), intent(in) :: vname
3026  character(len=*), intent(in) :: key
3027  character(len=*), intent(in) :: val
3028 
3029  integer :: error
3030 
3031  if ( .not. file_opened(fid) ) then
3032  log_error("FILE_set_attribute_text",*) 'File is not opened. fid = ', fid
3033  call prc_abort
3034  end if
3035 
3036  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
3037 
3038  error = file_set_attribute_text_c( file_files(fid)%fid, & ! (in)
3039  cstr(vname), cstr(key), & ! (in)
3040  cstr(val) ) ! (in)
3041  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
3042  log_error("FILE_set_attribute_text",*) 'failed to set text attribute for '//trim(vname)//': '//trim(key)
3043  call prc_abort
3044  end if
3045 
3046  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
3047 
3048  return
3049  end subroutine file_set_attribute_text
3050 
3051  subroutine file_set_attribute_logical( &
3052  fid, vname, &
3053  key, val )
3054  integer, intent(in) :: fid
3055  character(len=*), intent(in) :: vname
3056  character(len=*), intent(in) :: key
3057  logical, intent(in) :: val
3058 
3059  character(len=5) :: buf
3060 
3061  if ( .not. file_opened(fid) ) then
3062  log_error("FILE_set_attribute_logical",*) 'File is not opened. fid = ', fid
3063  call prc_abort
3064  end if
3065 
3066  if ( val ) then
3067  buf = "true"
3068  else
3069  buf = "false"
3070  end if
3071 
3072  call file_set_attribute_text( fid, vname, key, buf )
3073 
3074  return
3075  end subroutine file_set_attribute_logical
3076 
3077  !-----------------------------------------------------------------------------
3078  subroutine file_set_attribute_int_ary( &
3079  fid, vname, &
3080  key, val )
3081  integer, intent(in) :: fid
3082  character(len=*), intent(in) :: vname
3083  character(len=*), intent(in) :: key
3084  integer, intent(in) :: val(:)
3085 
3086  integer :: error
3087 
3088  intrinsic size
3089 
3090  if ( .not. file_opened(fid) ) then
3091  log_error("FILE_set_attribute_int",*) 'File is not opened. fid = ', fid
3092  call prc_abort
3093  end if
3094 
3095  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
3096 
3097  error = file_set_attribute_int_c( file_files(fid)%fid, & ! (in)
3098  cstr(vname), cstr(key), & ! (in)
3099  val(:), size(val(:)) ) ! (in)
3100  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
3101  log_error("FILE_set_attribute_int",*) 'failed to set integer attribute for '//trim(vname)//': '//trim(key)
3102  call prc_abort
3103  end if
3104 
3105  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
3106 
3107  return
3108  end subroutine file_set_attribute_int_ary
3109 
3110  subroutine file_set_attribute_int( &
3111  fid, vname, &
3112  key, val )
3113  integer, intent(in) :: fid
3114  character(len=*), intent(in) :: vname
3115  character(len=*), intent(in) :: key
3116  integer, intent(in) :: val
3117 
3118  integer :: ary(1)
3119 
3120  ary(1) = val
3121  call file_set_attribute_int_ary( fid, vname, &
3122  key, ary(:) )
3123 
3124  return
3125  end subroutine file_set_attribute_int
3126 
3127  !-----------------------------------------------------------------------------
3128  subroutine file_set_attribute_float_ary( &
3129  fid, vname, &
3130  key, val )
3131  integer, intent(in) :: fid
3132  character(len=*), intent(in) :: vname
3133  character(len=*), intent(in) :: key
3134  real(sp), intent(in) :: val(:)
3135 
3136  integer :: error
3137 
3138  intrinsic size
3139 
3140  if ( .not. file_opened(fid) ) then
3141  log_error("FILE_set_attributefloat",*) 'File is not opened. fid = ', fid
3142  call prc_abort
3143  end if
3144 
3145  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
3146 
3147  error = file_set_attribute_float_c( file_files(fid)%fid, & ! (in)
3148  cstr(vname), cstr(key), & ! (in)
3149  val(:), size(val(:)) ) ! (in)
3150  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
3151  log_error("FILE_set_attribute_float",*) 'failed to set float attribute for '//trim(vname)//': '//trim(key)
3152  call prc_abort
3153  end if
3154 
3155  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
3156 
3157  return
3158  end subroutine file_set_attribute_float_ary
3159 
3160  subroutine file_set_attribute_float( &
3161  fid, vname, &
3162  key, val )
3163  integer, intent(in) :: fid
3164  character(len=*), intent(in) :: vname
3165  character(len=*), intent(in) :: key
3166  real(sp), intent(in) :: val
3167 
3168  real(sp) :: ary(1)
3169 
3170  ary(1) = val
3171  call file_set_attribute_float_ary( fid, vname, &
3172  key, ary(:) )
3173 
3174  return
3175  end subroutine file_set_attribute_float
3176  !-----------------------------------------------------------------------------
3177  subroutine file_set_attribute_double_ary( &
3178  fid, vname, &
3179  key, val )
3180  integer, intent(in) :: fid
3181  character(len=*), intent(in) :: vname
3182  character(len=*), intent(in) :: key
3183  real(dp), intent(in) :: val(:)
3184 
3185  integer :: error
3186 
3187  intrinsic size
3188 
3189  if ( .not. file_opened(fid) ) then
3190  log_error("FILE_set_attributedouble",*) 'File is not opened. fid = ', fid
3191  call prc_abort
3192  end if
3193 
3194  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
3195 
3196  error = file_set_attribute_double_c( file_files(fid)%fid, & ! (in)
3197  cstr(vname), cstr(key), & ! (in)
3198  val(:), size(val(:)) ) ! (in)
3199  if ( error /= file_success_code .and. error /= file_already_existed_code ) then
3200  log_error("FILE_set_attribute_double",*) 'failed to set double attribute for '//trim(vname)//': '//trim(key)
3201  call prc_abort
3202  end if
3203 
3204  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
3205 
3206  return
3207  end subroutine file_set_attribute_double_ary
3208 
3209  subroutine file_set_attribute_double( &
3210  fid, vname, &
3211  key, val )
3212  integer, intent(in) :: fid
3213  character(len=*), intent(in) :: vname
3214  character(len=*), intent(in) :: key
3215  real(dp), intent(in) :: val
3216 
3217  real(dp) :: ary(1)
3218 
3219  ary(1) = val
3220  call file_set_attribute_double_ary( fid, vname, &
3221  key, ary(:) )
3222 
3223  return
3224  end subroutine file_set_attribute_double
3225  !-----------------------------------------------------------------------------
3226  ! FILE_get_shape
3227  !-----------------------------------------------------------------------------
3228  subroutine file_get_shape_fname( &
3229  basename, varname, &
3230  dims, &
3231  rankid, single, &
3232  has_tdim, &
3233  error )
3234  implicit none
3235 
3236  character(len=*), intent( in) :: basename
3237  character(len=*), intent( in) :: varname
3238  integer, intent(out) :: dims(:)
3239  integer, intent( in), optional :: rankid
3240  logical, intent( in), optional :: single
3241  logical, intent(out), optional :: has_tdim
3242  logical, intent(out), optional :: error
3243 
3244  integer :: fid
3245  !---------------------------------------------------------------------------
3246 
3247  !--- search/register file
3248  call file_open( basename, & ! (in)
3249  fid, & ! (out)
3250  rankid=rankid, single=single ) ! (in)
3251 
3252  call file_get_shape_fid( fid, varname, & ! (in)
3253  dims(:), & ! (out)
3254  has_tdim = has_tdim, & ! (out)
3255  error = error ) ! (out)
3256 
3257  return
3258  end subroutine file_get_shape_fname
3259 
3260  subroutine file_get_shape_fid( &
3261  fid, varname, &
3262  dims, &
3263  has_tdim, &
3264  error )
3265  implicit none
3266  integer, intent( in) :: fid
3267  character(len=*), intent( in) :: varname
3268  integer, intent(out) :: dims(:)
3269  logical, intent(out), optional :: has_tdim
3270  logical, intent(out), optional :: error
3271 
3272  type(datainfo) :: dinfo
3273  integer :: ierror
3274  integer :: n
3275 
3276  logical(c_bool) :: suppress
3277 
3278  intrinsic size
3279  !---------------------------------------------------------------------------
3280 
3281  if ( .not. file_opened(fid) ) then
3282  log_error("FILE_get_shape_id",*) 'File is not opened. fid = ', fid
3283  call prc_abort
3284  end if
3285 
3286  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
3287 
3288  if ( present(error) ) then
3289  suppress = .true.
3290  else
3291  suppress = .false.
3292  end if
3293 
3294  !--- get data information
3295  ierror = file_get_datainfo_c( dinfo, & ! (out)
3296  file_files(fid)%fid, & ! (in)
3297  cstr(varname), & ! (in)
3298  1, suppress ) ! (in)
3299 
3300  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
3301 
3302  !--- verify
3303  if ( ierror /= file_success_code ) then
3304  if ( present(error) ) then
3305  error = .true.
3306  return
3307  else
3308  log_error("FILE_get_shape_fid",*) 'failed to get data information : ', trim(varname)
3309  call prc_abort
3310  end if
3311  end if
3312 
3313  if ( dinfo%rank /= size(dims) ) then
3314  log_error("FILE_get_shape_fid",*) 'rank is different, ', trim(varname), size(dims), dinfo%rank
3315  call prc_abort
3316  end if
3317  do n = 1, size(dims)
3318  dims(n) = dinfo%dim_size(n)
3319  end do
3320 
3321  if ( present(has_tdim) ) has_tdim = dinfo%has_tdim
3322  if ( present(error) ) error = .false.
3323 
3324  return
3325  end subroutine file_get_shape_fid
3326 
3327  !-----------------------------------------------------------------------------
3329  !-----------------------------------------------------------------------------
3330  subroutine file_get_stepsize( &
3331  fid, varname, &
3332  len, &
3333  error )
3334  integer, intent(in) :: fid
3335  character(len=*), intent(in) :: varname
3336 
3337  integer, intent(out) :: len
3338 
3339  logical, intent(out), optional :: error
3340 
3341  integer :: ierror
3342 
3343  if ( .not. file_opened(fid) ) then
3344  log_error("FILE_get_stepSize",*) 'File is not opened. fid = ', fid
3345  call prc_abort
3346  end if
3347 
3348  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
3349 
3350  ierror = file_get_step_size_c( len, & ! (out)
3351  file_files(fid)%fid, cstr(varname) ) ! (in)
3352  if ( ierror /= file_success_code .and. ierror /= file_already_existed_code ) then
3353  if ( present(error) ) then
3354  error = .true.
3355  else
3356  log_error("FILE_get_stepSize",*) 'failed to get number of steps'
3357  call prc_abort
3358  end if
3359  else
3360  if ( present(error) ) error = .false.
3361  end if
3362 
3363  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
3364 
3365  return
3366  end subroutine file_get_stepsize
3367 
3368  !-----------------------------------------------------------------------------
3369  ! FILE_get_commonInfo
3370  !-----------------------------------------------------------------------------
3371  subroutine file_get_commoninfo_fname( &
3372  basename, &
3373  rankid, &
3374  nvars_limit, &
3375  title, &
3376  source, &
3377  institution, &
3378  nvars, &
3379  varname )
3380  implicit none
3381 
3382  character(len=*), intent(in) :: basename
3383  integer, intent(in) :: rankid
3384  integer, intent(in) :: nvars_limit
3385  character(len=FILE_HMID), intent(out) :: title ! title of the file
3386  character(len=FILE_HMID), intent(out) :: source ! for file header
3387  character(len=FILE_HMID), intent(out) :: institution ! for file header
3388  integer, intent(out) :: nvars ! number of variables
3389  character(len=FILE_HSHORT), intent(out) :: varname(nvars_limit) ! name of variables
3390 
3391  integer :: fid
3392  !---------------------------------------------------------------------------
3393 
3394  call file_open( basename, & ! [IN]
3395  fid, & ! [OUT]
3396  rankid=rankid ) ! [IN]
3397 
3398  call file_get_commoninfo_fid( fid, & ! [IN]
3399  nvars_limit, & ! [IN]
3400  title, & ! [OUT]
3401  source, & ! [OUT]
3402  institution, & ! [OUT]
3403  nvars, & ! [OUT]
3404  varname(:) ) ! [OUT]
3405 
3406  return
3407  end subroutine file_get_commoninfo_fname
3408 
3409  subroutine file_get_commoninfo_fid( &
3410  fid, &
3411  nvars_limit, &
3412  title, &
3413  source, &
3414  institution, &
3415  nvars, &
3416  varname )
3417  implicit none
3418 
3419  integer, intent(in) :: fid
3420  integer, intent(in) :: nvars_limit
3421  character(len=FILE_HMID), intent(out) :: title ! title of the file
3422  character(len=FILE_HMID), intent(out) :: source ! for file header
3423  character(len=FILE_HMID), intent(out) :: institution ! for file header
3424  integer, intent(out) :: nvars ! number of variables
3425  character(len=FILE_HSHORT), intent(out) :: varname(nvars_limit) ! name of variables
3426 
3427  integer :: v
3428  !---------------------------------------------------------------------------
3429 
3430  if ( .not. file_opened(fid) ) then
3431  log_error("FILE_get_commonInfo_fid",*) 'File is not opened. fid = ', fid
3432  call prc_abort
3433  end if
3434 
3435  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
3436 
3437  call file_get_attribute( fid, 'global', 'title', title )
3438  call file_get_attribute( fid, 'global', 'source', source )
3439  call file_get_attribute( fid, 'global', 'institution', institution )
3440 
3441  call file_get_var_num( fid, nvars_limit, nvars )
3442 
3443  do v = 1, nvars
3444  call file_get_var_name( fid, v, varname(v) )
3445  enddo
3446 
3447  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
3448 
3449  return
3450  end subroutine file_get_commoninfo_fid
3451 
3452  !-----------------------------------------------------------------------------
3453  ! FILE_get_dataInfo
3454  !-----------------------------------------------------------------------------
3455  subroutine file_get_datainfo_fname( &
3456  basename, varname, &
3457  rankid, istep, single, &
3458  existed, &
3459  description, units, standard_name, &
3460  datatype, &
3461  dim_rank, dim_name, dim_size, &
3462  natts, att_name, att_type, att_len, &
3463  has_tdim, &
3464  time_start, time_end, time_units, &
3465  calendar )
3466  implicit none
3467 
3468  character(len=*), intent(in) :: basename
3469  character(len=*), intent(in) :: varname
3470 
3471  integer, intent(in), optional :: rankid
3472  integer, intent(in), optional :: istep
3473  logical, intent(in), optional :: single
3474  logical, intent(out), optional :: existed
3475  character(len=FILE_HMID), intent(out), optional :: description
3476  character(len=FILE_HSHORT), intent(out), optional :: units
3477  character(len=FILE_HMID), intent(out), optional :: standard_name
3478  integer, intent(out), optional :: datatype
3479  integer, intent(out), optional :: dim_rank
3480  character(len=FILE_HSHORT), intent(out), optional :: dim_name(:)
3481  integer, intent(out), optional :: dim_size(:)
3482  integer, intent(out), optional :: natts
3483  character(len=FILE_HSHORT), intent(out), optional :: att_name(:)
3484  integer, intent(out), optional :: att_type(:)
3485  integer, intent(out), optional :: att_len (:)
3486  logical, intent(out), optional :: has_tdim
3487  real(dp), intent(out), optional :: time_start
3488  real(dp), intent(out), optional :: time_end
3489  character(len=FILE_HMID), intent(out), optional :: time_units
3490  character(len=FILE_HSHORT), intent(out), optional :: calendar
3491 
3492  logical :: single_
3493  integer :: fid
3494  !---------------------------------------------------------------------------
3495 
3496  if ( present(single) ) then
3497  single_ = single
3498  else
3499  single_ = .false.
3500  endif
3501 
3502  !--- search/register file
3503  call file_open( basename, & ! [IN]
3504  fid, & ! [OUT]
3505  rankid=rankid, single=single_ ) ! [IN]
3506 
3507  call file_get_datainfo_fid( fid, varname, & ! [IN]
3508  istep, & ! [IN] , optional
3509  existed, & ! [OUT], optional
3510  description, units, standard_name, & ! [OUT], optional
3511  datatype, & ! [OUT], optional
3512  dim_rank, dim_name, dim_size, & ! [OUT], optional
3513  natts, att_name, att_type, att_len, & ! [OUT], optional
3514  has_tdim, & ! [OUT], optional
3515  time_start, time_end, time_units, & ! [OUT], optional
3516  calendar ) ! [OUT], optional
3517 
3518  return
3519  end subroutine file_get_datainfo_fname
3520 
3521  subroutine file_get_datainfo_fid( &
3522  fid, varname, &
3523  istep, &
3524  existed, &
3525  description, units, standard_name, &
3526  datatype, &
3527  dim_rank, dim_name, dim_size, &
3528  natts, att_name, att_type, att_len, &
3529  has_tdim, &
3530  time_start, time_end, time_units, &
3531  calendar )
3532  implicit none
3533 
3534  integer, intent(in) :: fid
3535  character(len=*), intent(in) :: varname
3536 
3537  integer, intent(in), optional :: istep
3538  logical, intent(out), optional :: existed
3539  character(len=*), intent(out), optional :: description
3540  character(len=*), intent(out), optional :: units
3541  character(len=*), intent(out), optional :: standard_name
3542  integer, intent(out), optional :: datatype
3543  integer, intent(out), optional :: dim_rank
3544  character(len=*), intent(out), optional :: dim_name(:)
3545  integer, intent(out), optional :: dim_size(:)
3546  integer, intent(out), optional :: natts
3547  character(len=*), intent(out), optional :: att_name(:)
3548  integer, intent(out), optional :: att_type(:)
3549  integer, intent(out), optional :: att_len (:)
3550  logical, intent(out), optional :: has_tdim
3551  real(dp), intent(out), optional :: time_start
3552  real(dp), intent(out), optional :: time_end
3553  character(len=*), intent(out), optional :: time_units
3554  character(len=*), intent(out), optional :: calendar
3555 
3556  type(datainfo) :: dinfo
3557 
3558  integer :: istep_
3559  real(dp) :: time(1)
3560  integer :: i
3561  integer :: error
3562 
3563  logical(c_bool) :: suppress
3564  logical :: existed2
3565 
3566  character(len=FILE_HMID) :: tu
3567 
3568  intrinsic size
3569  !---------------------------------------------------------------------------
3570 
3571  if ( present(istep) ) then
3572  istep_ = istep
3573  else
3574  istep_ = 1
3575  end if
3576 
3577  if ( present(existed) ) then
3578  suppress = .true.
3579  else
3580  suppress = .false.
3581  end if
3582 
3583  if ( .not. file_opened(fid) ) then
3584  log_error("FILE_get_dataInfo_fid",*) 'File is not opened. fid = ', fid
3585  call prc_abort
3586  end if
3587 
3588  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
3589 
3590  !--- get data information
3591  error = file_get_datainfo_c( dinfo, & ! [OUT]
3592  file_files(fid)%fid, & ! [IN]
3593  cstr(varname), & ! [IN]
3594  istep_, & ! [IN]
3595  suppress ) ! [IN]
3596 
3597  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
3598 
3599  !--- verify and exit
3600  if ( error /= file_success_code ) then
3601  if ( present( existed ) ) then
3602  existed = .false.
3603  return
3604  else
3605  log_error("FILE_get_dataInfo_fid",*) 'data info not found'
3606  call prc_abort
3607  end if
3608  endif
3609 
3610  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
3611 
3612  if ( present(existed) ) existed = .true.
3613 
3614  if ( present(description) ) call fstr(description, dinfo%description)
3615  if ( present(units) ) call fstr(units, dinfo%units)
3616  if ( present(standard_name) ) call fstr(standard_name, dinfo%standard_name)
3617  if ( present(datatype) ) datatype = dinfo%datatype
3618  if ( present(dim_rank) ) dim_rank = dinfo%rank
3619 
3620  if ( present(dim_name) ) then
3621  do i = 1, min( dinfo%rank, size(dim_name) ) ! limit dimension rank
3622  call fstr(dim_name(i), dinfo%dim_name(:,i))
3623  enddo
3624  endif
3625 
3626  if ( present(dim_size) ) then
3627  do i = 1, min( dinfo%rank, size(dim_size) ) ! limit dimension rank
3628  dim_size(i) = dinfo%dim_size(i)
3629  enddo
3630  endif
3631 
3632  if ( present(natts) ) natts = dinfo%natts
3633  if ( present(att_name) ) then
3634  do i = 1, min( dinfo%natts, size(att_name) )
3635  call fstr(att_name(i), dinfo%att_name(:,i))
3636  end do
3637  end if
3638  if ( present(att_type) ) then
3639  do i = 1, min( dinfo%natts, size(att_type) )
3640  att_type(i) = dinfo%att_type(i)
3641  end do
3642  end if
3643  if ( present(att_len) ) then
3644  do i = 1, min( dinfo%natts, size(att_len) )
3645  att_len(i) = dinfo%att_len(i)
3646  end do
3647  end if
3648 
3649  call fstr(tu, dinfo%time_units)
3650 
3651  if ( present(time_units) ) then
3652  if ( tu == "" ) then
3653  call file_get_attribute( fid, "global", "time_units", time_units )
3654  else
3655  time_units = tu
3656  endif
3657  endif
3658 
3659  if ( present(calendar) ) then
3660  if ( tu == "" ) then
3661  call file_get_attribute( fid, "global", "calendar", calendar, existed2 )
3662  if ( .not. existed2 ) calendar = ""
3663  else
3664  call fstr(calendar, dinfo%calendar)
3665  end if
3666  end if
3667 
3668  if ( present(has_tdim) ) then
3669  has_tdim = dinfo%has_tdim
3670  end if
3671 
3672  if ( present(time_start) ) then
3673  if ( tu == "" ) then
3674  call file_get_attribute( fid, "global", "time_start", time )
3675  time_start = time(1)
3676  else
3677  time_start = dinfo%time_start
3678  endif
3679  endif
3680 
3681  if ( present(time_end) ) then
3682  if ( tu == "" ) then
3683  call file_get_attribute( fid, "global", "time_start", time )
3684  time_end = time(1)
3685  else
3686  time_end = dinfo%time_end
3687  end if
3688  endif
3689 
3690  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
3691 
3692  return
3693  end subroutine file_get_datainfo_fid
3694 
3695  !-----------------------------------------------------------------------------
3696  ! FILE_get_data_all_dataInfo
3697  !-----------------------------------------------------------------------------
3698  subroutine file_get_all_datainfo_fname( &
3699  basename, varname, &
3700  step_nmax, &
3701  description, units, standard_name, &
3702  datatype, &
3703  dim_rank, dim_name, dim_size, &
3704  natts, att_name, att_type, att_len, &
3705  time_start, time_end, &
3706  time_units, calendar, &
3707  rankid, single )
3708  implicit none
3709  character(len=*), intent(in) :: basename
3710  character(len=*), intent(in) :: varname
3711  integer, intent(out) :: step_nmax
3712  character(len=FILE_HMID), intent(out) :: description
3713  character(len=FILE_HSHORT), intent(out) :: units
3714  character(len=FILE_HMID), intent(out) :: standard_name
3715  integer, intent(out) :: datatype
3716  integer, intent(out) :: dim_rank
3717  character(len=FILE_HSHORT), intent(out) :: dim_name (:)
3718  integer, intent(out) :: dim_size (:)
3719  integer, intent(out) :: natts
3720  character(len=FILE_HSHORT), intent(out) :: att_name (:)
3721  integer, intent(out) :: att_type (:)
3722  integer, intent(out) :: att_len (:)
3723  real(dp), intent(out) :: time_start(:)
3724  real(dp), intent(out) :: time_end (:)
3725  character(len=FILE_HMID), intent(out) :: time_units
3726  character(len=FILE_HSHORT), intent(out) :: calendar
3727 
3728  integer, intent(in), optional :: rankid
3729  logical, intent(in), optional :: single
3730 
3731  integer :: fid
3732  logical :: single_
3733  !---------------------------------------------------------------------------
3734 
3735  if ( present(single) ) then
3736  single_ = single
3737  else
3738  single_ = .false.
3739  endif
3740 
3741  !--- search/register file
3742  call file_open( basename, & ! [IN]
3743  fid, & ! [OUT]
3744  rankid=rankid, single=single_ ) ! [IN]
3745 
3746  call file_get_all_datainfo_fid( fid, varname, & ! [IN]
3747  step_nmax, & ! [OUT]
3748  description, units, standard_name, & ! [OUT]
3749  datatype, & ! [OUT]
3750  dim_rank, dim_name(:), dim_size(:), & ! [OUT]
3751  natts, att_name(:), att_type(:), att_len(:), & ! [OUT]
3752  time_start(:), time_end(:), & ! [OUT]
3753  time_units, calendar ) ! [OUT]
3754 
3755  return
3756  end subroutine file_get_all_datainfo_fname
3757 
3758  subroutine file_get_all_datainfo_fid( &
3759  fid, varname, &
3760  step_nmax, &
3761  description, units, standard_name, &
3762  datatype, &
3763  dim_rank, dim_name, dim_size, &
3764  natts, att_name, att_type, att_len, &
3765  time_start, time_end, &
3766  time_units, calendar )
3767  implicit none
3768 
3769  integer, intent(in) :: fid
3770  character(len=*), intent(in) :: varname
3771  integer, intent(out) :: step_nmax
3772  character(len=*), intent(out) :: description
3773  character(len=*), intent(out) :: units
3774  character(len=*), intent(out) :: standard_name
3775  integer, intent(out) :: datatype
3776  integer, intent(out) :: dim_rank
3777  character(len=*), intent(out) :: dim_name (:)
3778  integer, intent(out) :: dim_size (:)
3779  integer, intent(out) :: natts
3780  character(len=*), intent(out) :: att_name (:)
3781  integer, intent(out) :: att_type (:)
3782  integer, intent(out) :: att_len (:)
3783  real(dp), intent(out) :: time_start(:)
3784  real(dp), intent(out) :: time_end (:)
3785  character(len=*), intent(out) :: time_units
3786  character(len=*), intent(out) :: calendar
3787 
3788  type(datainfo) :: dinfo
3789 
3790  real(dp) :: time(1)
3791  integer :: i
3792  integer :: error
3793  logical :: existed
3794 
3795  integer :: istep
3796  integer :: istep_max
3797 
3798  logical(c_bool) :: suppress
3799  character(len=FILE_HMID) :: tu
3800 
3801  intrinsic size
3802  !---------------------------------------------------------------------------
3803 
3804  if ( .not. file_opened(fid) ) then
3805  log_error("FILE_get_all_dataInfo_fid",*) 'File is not opened. fid = ', fid
3806  call prc_abort
3807  end if
3808 
3809  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
3810 
3811  ! initialize
3812  description = ""
3813  units = ""
3814  standard_name = ""
3815  datatype = -1
3816  dim_rank = -1
3817  dim_name(:) = ""
3818  dim_size(:) = -1
3819  time_start(:) = file_rmiss
3820  time_end(:) = file_rmiss
3821 
3822  suppress = .true.
3823  istep_max = min( size(time_start), size(time_end) )
3824  do istep = 1, istep_max
3825  !--- get data information
3826  error = file_get_datainfo_c( dinfo, & ! [OUT]
3827  file_files(fid)%fid, & ! [IN]
3828  cstr(varname), & ! [IN]
3829  istep, suppress ) ! [IN]
3830 
3831  !--- verify and exit
3832  if ( error /= file_success_code ) then
3833  step_nmax = istep - 1
3834  exit
3835  endif
3836 
3837  if ( istep == 1 ) then
3838  call fstr(description, dinfo%description)
3839  call fstr(units, dinfo%units)
3840  call fstr(standard_name, dinfo%standard_name)
3841  datatype = dinfo%datatype
3842  dim_rank = dinfo%rank
3843  natts = dinfo%natts
3844 
3845  do i = 1, min( dinfo%rank, size(dim_name) ) ! limit dimension rank
3846  call fstr(dim_name(i), dinfo%dim_name(:,i))
3847  dim_size(i) = dinfo%dim_size(i)
3848  enddo
3849 
3850  do i = 1, min( dinfo%natts, size(att_name) )
3851  call fstr(att_name(i), dinfo%att_name(:,i))
3852  att_type(i) = dinfo%att_type(i)
3853  att_len(i) = dinfo%att_len (i)
3854  end do
3855 
3856  call fstr(tu, dinfo%time_units)
3857  if ( tu == "" ) then
3858  call file_get_attribute( fid, "global", "time_units", time_units )
3859  call file_get_attribute( fid, "global", "calendar", calendar, existed )
3860  if ( .not. existed ) calendar = ""
3861  call file_get_attribute( fid, "global", "time_start", time )
3862  time_start(1) = time(1)
3863  time_end(1) = time(1)
3864  step_nmax = 1
3865  exit
3866  else
3867  time_units = tu
3868  time_start(1) = dinfo%time_start
3869  time_end(1) = dinfo%time_end
3870  call fstr(calendar, dinfo%calendar)
3871  endif
3872  else
3873  time_start(istep) = dinfo%time_start
3874  time_end(istep) = dinfo%time_end
3875  endif
3876  enddo
3877 
3878  if ( istep == istep_max + 1 ) then
3879  if ( error /= file_success_code ) then
3880  log_error("FILE_get_all_dataInfo_fid",*) 'size of time is not enough: ', istep_max
3881  call prc_abort
3882  else
3883  step_nmax = istep - 1
3884  end if
3885  end if
3886 
3887  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
3888 
3889  return
3890  end subroutine file_get_all_datainfo_fid
3891 
3892  !-----------------------------------------------------------------------------
3893  ! interface FILE_read
3894  !-----------------------------------------------------------------------------
3895  subroutine file_read_realsp_1d( &
3896  basename, varname, &
3897  var, &
3898  step, rankid, single, postfix, &
3899  allow_missing, missing_value )
3900  implicit none
3901 
3902  character(len=*), intent( in) :: basename
3903  character(len=*), intent( in) :: varname
3904  real(sp), intent(out) :: var(:)
3905  integer, intent( in), optional :: step
3906  integer, intent( in), optional :: rankid
3907  logical, intent( in), optional :: single
3908  character(len=*), intent( in), optional :: postfix
3909  logical, intent( in), optional :: allow_missing
3910  real(sp), intent( in), optional :: missing_value
3911 
3912  integer :: fid
3913 
3914  intrinsic shape
3915  !---------------------------------------------------------------------------
3916 
3917  !--- search/register file
3918  call file_open( basename, & ! (in)
3919  fid, & ! (out)
3920  rankid=rankid, single=single, & ! (in)
3921  postfix=postfix ) ! (in)
3922 
3923  call file_read_var_realsp_1d( &
3924  fid, varname, & ! (in)
3925  var(:), & ! (out)
3926  step=step, & ! (in)
3927  allow_missing=allow_missing, missing_value=missing_value ) ! (in)
3928 
3929  return
3930  end subroutine file_read_realsp_1d
3931  subroutine file_read_realdp_1d( &
3932  basename, varname, &
3933  var, &
3934  step, rankid, single, postfix, &
3935  allow_missing, missing_value )
3936  implicit none
3937 
3938  character(len=*), intent( in) :: basename
3939  character(len=*), intent( in) :: varname
3940  real(dp), intent(out) :: var(:)
3941  integer, intent( in), optional :: step
3942  integer, intent( in), optional :: rankid
3943  logical, intent( in), optional :: single
3944  character(len=*), intent( in), optional :: postfix
3945  logical, intent( in), optional :: allow_missing
3946  real(dp), intent( in), optional :: missing_value
3947 
3948  integer :: fid
3949 
3950  intrinsic shape
3951  !---------------------------------------------------------------------------
3952 
3953  !--- search/register file
3954  call file_open( basename, & ! (in)
3955  fid, & ! (out)
3956  rankid=rankid, single=single, & ! (in)
3957  postfix=postfix ) ! (in)
3958 
3959  call file_read_var_realdp_1d( &
3960  fid, varname, & ! (in)
3961  var(:), & ! (out)
3962  step=step, & ! (in)
3963  allow_missing=allow_missing, missing_value=missing_value ) ! (in)
3964 
3965  return
3966  end subroutine file_read_realdp_1d
3967  subroutine file_read_realsp_2d( &
3968  basename, varname, &
3969  var, &
3970  step, rankid, single, postfix, &
3971  allow_missing, missing_value )
3972  implicit none
3973 
3974  character(len=*), intent( in) :: basename
3975  character(len=*), intent( in) :: varname
3976  real(sp), intent(out) :: var(:,:)
3977  integer, intent( in), optional :: step
3978  integer, intent( in), optional :: rankid
3979  logical, intent( in), optional :: single
3980  character(len=*), intent( in), optional :: postfix
3981  logical, intent( in), optional :: allow_missing
3982  real(sp), intent( in), optional :: missing_value
3983 
3984  integer :: fid
3985 
3986  intrinsic shape
3987  !---------------------------------------------------------------------------
3988 
3989  !--- search/register file
3990  call file_open( basename, & ! (in)
3991  fid, & ! (out)
3992  rankid=rankid, single=single, & ! (in)
3993  postfix=postfix ) ! (in)
3994 
3995  call file_read_var_realsp_2d( &
3996  fid, varname, & ! (in)
3997  var(:,:), & ! (out)
3998  step=step, & ! (in)
3999  allow_missing=allow_missing, missing_value=missing_value ) ! (in)
4000 
4001  return
4002  end subroutine file_read_realsp_2d
4003  subroutine file_read_realdp_2d( &
4004  basename, varname, &
4005  var, &
4006  step, rankid, single, postfix, &
4007  allow_missing, missing_value )
4008  implicit none
4009 
4010  character(len=*), intent( in) :: basename
4011  character(len=*), intent( in) :: varname
4012  real(dp), intent(out) :: var(:,:)
4013  integer, intent( in), optional :: step
4014  integer, intent( in), optional :: rankid
4015  logical, intent( in), optional :: single
4016  character(len=*), intent( in), optional :: postfix
4017  logical, intent( in), optional :: allow_missing
4018  real(dp), intent( in), optional :: missing_value
4019 
4020  integer :: fid
4021 
4022  intrinsic shape
4023  !---------------------------------------------------------------------------
4024 
4025  !--- search/register file
4026  call file_open( basename, & ! (in)
4027  fid, & ! (out)
4028  rankid=rankid, single=single, & ! (in)
4029  postfix=postfix ) ! (in)
4030 
4031  call file_read_var_realdp_2d( &
4032  fid, varname, & ! (in)
4033  var(:,:), & ! (out)
4034  step=step, & ! (in)
4035  allow_missing=allow_missing, missing_value=missing_value ) ! (in)
4036 
4037  return
4038  end subroutine file_read_realdp_2d
4039  subroutine file_read_realsp_3d( &
4040  basename, varname, &
4041  var, &
4042  step, rankid, single, postfix, &
4043  allow_missing, missing_value )
4044  implicit none
4045 
4046  character(len=*), intent( in) :: basename
4047  character(len=*), intent( in) :: varname
4048  real(sp), intent(out) :: var(:,:,:)
4049  integer, intent( in), optional :: step
4050  integer, intent( in), optional :: rankid
4051  logical, intent( in), optional :: single
4052  character(len=*), intent( in), optional :: postfix
4053  logical, intent( in), optional :: allow_missing
4054  real(sp), intent( in), optional :: missing_value
4055 
4056  integer :: fid
4057 
4058  intrinsic shape
4059  !---------------------------------------------------------------------------
4060 
4061  !--- search/register file
4062  call file_open( basename, & ! (in)
4063  fid, & ! (out)
4064  rankid=rankid, single=single, & ! (in)
4065  postfix=postfix ) ! (in)
4066 
4067  call file_read_var_realsp_3d( &
4068  fid, varname, & ! (in)
4069  var(:,:,:), & ! (out)
4070  step=step, & ! (in)
4071  allow_missing=allow_missing, missing_value=missing_value ) ! (in)
4072 
4073  return
4074  end subroutine file_read_realsp_3d
4075  subroutine file_read_realdp_3d( &
4076  basename, varname, &
4077  var, &
4078  step, rankid, single, postfix, &
4079  allow_missing, missing_value )
4080  implicit none
4081 
4082  character(len=*), intent( in) :: basename
4083  character(len=*), intent( in) :: varname
4084  real(dp), intent(out) :: var(:,:,:)
4085  integer, intent( in), optional :: step
4086  integer, intent( in), optional :: rankid
4087  logical, intent( in), optional :: single
4088  character(len=*), intent( in), optional :: postfix
4089  logical, intent( in), optional :: allow_missing
4090  real(dp), intent( in), optional :: missing_value
4091 
4092  integer :: fid
4093 
4094  intrinsic shape
4095  !---------------------------------------------------------------------------
4096 
4097  !--- search/register file
4098  call file_open( basename, & ! (in)
4099  fid, & ! (out)
4100  rankid=rankid, single=single, & ! (in)
4101  postfix=postfix ) ! (in)
4102 
4103  call file_read_var_realdp_3d( &
4104  fid, varname, & ! (in)
4105  var(:,:,:), & ! (out)
4106  step=step, & ! (in)
4107  allow_missing=allow_missing, missing_value=missing_value ) ! (in)
4108 
4109  return
4110  end subroutine file_read_realdp_3d
4111  subroutine file_read_realsp_4d( &
4112  basename, varname, &
4113  var, &
4114  step, rankid, single, postfix, &
4115  allow_missing, missing_value )
4116  implicit none
4117 
4118  character(len=*), intent( in) :: basename
4119  character(len=*), intent( in) :: varname
4120  real(sp), intent(out) :: var(:,:,:,:)
4121  integer, intent( in), optional :: step
4122  integer, intent( in), optional :: rankid
4123  logical, intent( in), optional :: single
4124  character(len=*), intent( in), optional :: postfix
4125  logical, intent( in), optional :: allow_missing
4126  real(sp), intent( in), optional :: missing_value
4127 
4128  integer :: fid
4129 
4130  intrinsic shape
4131  !---------------------------------------------------------------------------
4132 
4133  !--- search/register file
4134  call file_open( basename, & ! (in)
4135  fid, & ! (out)
4136  rankid=rankid, single=single, & ! (in)
4137  postfix=postfix ) ! (in)
4138 
4139  call file_read_var_realsp_4d( &
4140  fid, varname, & ! (in)
4141  var(:,:,:,:), & ! (out)
4142  step=step, & ! (in)
4143  allow_missing=allow_missing, missing_value=missing_value ) ! (in)
4144 
4145  return
4146  end subroutine file_read_realsp_4d
4147  subroutine file_read_realdp_4d( &
4148  basename, varname, &
4149  var, &
4150  step, rankid, single, postfix, &
4151  allow_missing, missing_value )
4152  implicit none
4153 
4154  character(len=*), intent( in) :: basename
4155  character(len=*), intent( in) :: varname
4156  real(dp), intent(out) :: var(:,:,:,:)
4157  integer, intent( in), optional :: step
4158  integer, intent( in), optional :: rankid
4159  logical, intent( in), optional :: single
4160  character(len=*), intent( in), optional :: postfix
4161  logical, intent( in), optional :: allow_missing
4162  real(dp), intent( in), optional :: missing_value
4163 
4164  integer :: fid
4165 
4166  intrinsic shape
4167  !---------------------------------------------------------------------------
4168 
4169  !--- search/register file
4170  call file_open( basename, & ! (in)
4171  fid, & ! (out)
4172  rankid=rankid, single=single, & ! (in)
4173  postfix=postfix ) ! (in)
4174 
4175  call file_read_var_realdp_4d( &
4176  fid, varname, & ! (in)
4177  var(:,:,:,:), & ! (out)
4178  step=step, & ! (in)
4179  allow_missing=allow_missing, missing_value=missing_value ) ! (in)
4180 
4181  return
4182  end subroutine file_read_realdp_4d
4183 
4184  subroutine file_read_var_realsp_1d( &
4185  fid, varname, &
4186  var, &
4187  step, &
4188  allow_missing, &
4189  missing_value, &
4190  ntypes, dtype, &
4191  start, count )
4192  implicit none
4193 
4194  integer, intent( in) :: fid
4195  character(len=*), intent( in) :: varname
4196 #ifdef NVIDIA
4197  real(sp), intent(out), target :: var(:)
4198 #else
4199  real(sp), intent(out), target, contiguous :: var(:)
4200 #endif
4201  integer, intent( in), optional :: step
4202  logical, intent( in), optional :: allow_missing
4203  real(sp), intent( in), optional :: missing_value
4204  integer, intent( in), optional :: ntypes
4205  integer, intent( in), optional :: dtype
4206  integer, intent( in), optional :: start(:)
4207  integer, intent( in), optional :: count(:)
4208 
4209  integer :: step_
4210  logical(c_bool) :: allow_missing_
4211  real(sp) :: missing_value_
4212 
4213  type(datainfo) :: dinfo
4214  integer :: dim_size(1)
4215 
4216  integer :: error
4217  integer :: n
4218 
4219  intrinsic size, shape
4220  !---------------------------------------------------------------------------
4221 
4222  if ( .not. file_opened(fid) ) then
4223  log_error("FILE_read_var_realSP_1D",*) 'File is not opened. fid = ', fid
4224  call prc_abort
4225  end if
4226 
4227  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
4228 
4229  if ( present(step) ) then
4230  step_ = step
4231  else
4232  step_ = 1
4233  end if
4234 
4235  if ( present(allow_missing) ) then
4236  allow_missing_ = allow_missing
4237  else
4238  allow_missing_ = .false.
4239  end if
4240 
4241  if ( present(missing_value) ) then
4242  missing_value_ = missing_value
4243  else
4244  missing_value_ = 0.0_sp
4245  end if
4246 
4247  !--- get data information
4248  error = file_get_datainfo_c( dinfo, & ! (out)
4249  file_files(fid)%fid, & ! (in)
4250  cstr(varname), & ! (in)
4251  step_, allow_missing_ ) ! (in)
4252 
4253  !--- verify
4254  if ( error /= file_success_code ) then
4255  if ( allow_missing_ ) then
4256  log_info("FILE_read_var_realSP_1D",*) '[INPUT]/[FILE] data not found! : ', &
4257  'varname= ',trim(varname),', step=',step_
4258  log_info("FILE_read_var_realSP_1D",*) '[INPUT]/[FILE] Value is set to ', missing_value_
4259  var(:) = missing_value_
4260  return
4261  else
4262  log_error("FILE_read_var_realSP_1D",*) 'failed to get data information :'//trim(varname)
4263  call prc_abort
4264  end if
4265  end if
4266 
4267  if ( dinfo%rank /= 1 ) then
4268  if ( (.not. present(start)) .and. (.not. present(count)) ) then
4269  log_error("FILE_read_var_realSP_1D",*) 'rank of '//trim(varname)//' is not 1', dinfo%rank
4270  call prc_abort
4271  end if
4272  end if
4273 
4274  if ( present(ntypes) ) then
4275 #if defined(__GFORTRAN__) && __GNUC__ < 7
4276  error = file_read_data_c( cloc(var(1)), & ! (out)
4277 #else
4278  error = file_read_data_c( c_loc(var), & ! (out)
4279 #endif
4280  dinfo, sp, ntypes, dtype, start(:), count(:) ) ! (in)
4281  else if ( present(start) .and. present(count) ) then
4282 #ifdef NVIDIA
4283  block
4284  real(sp), allocatable, target :: work(:)
4285  allocate(work, mold=var)
4286 #endif
4287  error = file_read_data_c( &
4288 #if defined(__GFORTRAN__) && __GNUC__ < 7
4289  cloc(var(1)), & ! (out)
4290 #elif defined(NVIDIA)
4291  c_loc(work), & ! (out)
4292 #else
4293  c_loc(var), & ! (out)
4294 #endif
4295  dinfo, sp, 0, 0, start(:), count(:) ) ! (in)
4296 #ifdef NVIDIA
4297  var = work
4298  end block
4299 #endif
4300  else
4301  dim_size(:) = shape(var)
4302  do n = 1, 1
4303  if ( dinfo%dim_size(n) /= dim_size(n) ) then
4304  log_error("FILE_read_var_realSP_1D",*) 'shape is different: ', trim(varname), n, dinfo%dim_size(n), dim_size(n)
4305  call prc_abort
4306  end if
4307  end do
4308 #ifdef NVIDIA
4309  block
4310  real(sp), allocatable, target :: work(:)
4311  allocate(work, mold=var)
4312 #endif
4313  error = file_read_data_c( &
4314 #if defined(__GFORTRAN__) && __GNUC__ < 7
4315  cloc(var(1)), & ! (out)
4316 #elif defined(NVIDIA)
4317  c_loc(work), & ! (out)
4318 #else
4319  c_loc(var), & ! (out)
4320 #endif
4321  dinfo, sp, 0, 0, (/0/), (/0/) ) ! (in)
4322 #ifdef NVIDIA
4323  var = work
4324  end block
4325 #endif
4326  end if
4327  if ( error /= file_success_code ) then
4328  log_error("FILE_read_var_realSP_1D",*) 'failed to get data value: ', trim(varname)
4329  call prc_abort
4330  end if
4331 
4332  !$acc update device(var) if(acc_is_present(var))
4333 
4334  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
4335 
4336  return
4337  end subroutine file_read_var_realsp_1d
4338  subroutine file_read_var_realdp_1d( &
4339  fid, varname, &
4340  var, &
4341  step, &
4342  allow_missing, &
4343  missing_value, &
4344  ntypes, dtype, &
4345  start, count )
4346  implicit none
4347 
4348  integer, intent( in) :: fid
4349  character(len=*), intent( in) :: varname
4350 #ifdef NVIDIA
4351  real(dp), intent(out), target :: var(:)
4352 #else
4353  real(dp), intent(out), target, contiguous :: var(:)
4354 #endif
4355  integer, intent( in), optional :: step
4356  logical, intent( in), optional :: allow_missing
4357  real(dp), intent( in), optional :: missing_value
4358  integer, intent( in), optional :: ntypes
4359  integer, intent( in), optional :: dtype
4360  integer, intent( in), optional :: start(:)
4361  integer, intent( in), optional :: count(:)
4362 
4363  integer :: step_
4364  logical(c_bool) :: allow_missing_
4365  real(dp) :: missing_value_
4366 
4367  type(datainfo) :: dinfo
4368  integer :: dim_size(1)
4369 
4370  integer :: error
4371  integer :: n
4372 
4373  intrinsic size, shape
4374  !---------------------------------------------------------------------------
4375 
4376  if ( .not. file_opened(fid) ) then
4377  log_error("FILE_read_var_realDP_1D",*) 'File is not opened. fid = ', fid
4378  call prc_abort
4379  end if
4380 
4381  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
4382 
4383  if ( present(step) ) then
4384  step_ = step
4385  else
4386  step_ = 1
4387  end if
4388 
4389  if ( present(allow_missing) ) then
4390  allow_missing_ = allow_missing
4391  else
4392  allow_missing_ = .false.
4393  end if
4394 
4395  if ( present(missing_value) ) then
4396  missing_value_ = missing_value
4397  else
4398  missing_value_ = 0.0_dp
4399  end if
4400 
4401  !--- get data information
4402  error = file_get_datainfo_c( dinfo, & ! (out)
4403  file_files(fid)%fid, & ! (in)
4404  cstr(varname), & ! (in)
4405  step_, allow_missing_ ) ! (in)
4406 
4407  !--- verify
4408  if ( error /= file_success_code ) then
4409  if ( allow_missing_ ) then
4410  log_info("FILE_read_var_realDP_1D",*) '[INPUT]/[FILE] data not found! : ', &
4411  'varname= ',trim(varname),', step=',step_
4412  log_info("FILE_read_var_realDP_1D",*) '[INPUT]/[FILE] Value is set to ', missing_value_
4413  var(:) = missing_value_
4414  return
4415  else
4416  log_error("FILE_read_var_realDP_1D",*) 'failed to get data information :'//trim(varname)
4417  call prc_abort
4418  end if
4419  end if
4420 
4421  if ( dinfo%rank /= 1 ) then
4422  if ( (.not. present(start)) .and. (.not. present(count)) ) then
4423  log_error("FILE_read_var_realDP_1D",*) 'rank of '//trim(varname)//' is not 1', dinfo%rank
4424  call prc_abort
4425  end if
4426  end if
4427 
4428  if ( present(ntypes) ) then
4429 #if defined(__GFORTRAN__) && __GNUC__ < 7
4430  error = file_read_data_c( cloc(var(1)), & ! (out)
4431 #else
4432  error = file_read_data_c( c_loc(var), & ! (out)
4433 #endif
4434  dinfo, dp, ntypes, dtype, start(:), count(:) ) ! (in)
4435  else if ( present(start) .and. present(count) ) then
4436 #ifdef NVIDIA
4437  block
4438  real(dp), allocatable, target :: work(:)
4439  allocate(work, mold=var)
4440 #endif
4441  error = file_read_data_c( &
4442 #if defined(__GFORTRAN__) && __GNUC__ < 7
4443  cloc(var(1)), & ! (out)
4444 #elif defined(NVIDIA)
4445  c_loc(work), & ! (out)
4446 #else
4447  c_loc(var), & ! (out)
4448 #endif
4449  dinfo, dp, 0, 0, start(:), count(:) ) ! (in)
4450 #ifdef NVIDIA
4451  var = work
4452  end block
4453 #endif
4454  else
4455  dim_size(:) = shape(var)
4456  do n = 1, 1
4457  if ( dinfo%dim_size(n) /= dim_size(n) ) then
4458  log_error("FILE_read_var_realDP_1D",*) 'shape is different: ', trim(varname), n, dinfo%dim_size(n), dim_size(n)
4459  call prc_abort
4460  end if
4461  end do
4462 #ifdef NVIDIA
4463  block
4464  real(dp), allocatable, target :: work(:)
4465  allocate(work, mold=var)
4466 #endif
4467  error = file_read_data_c( &
4468 #if defined(__GFORTRAN__) && __GNUC__ < 7
4469  cloc(var(1)), & ! (out)
4470 #elif defined(NVIDIA)
4471  c_loc(work), & ! (out)
4472 #else
4473  c_loc(var), & ! (out)
4474 #endif
4475  dinfo, dp, 0, 0, (/0/), (/0/) ) ! (in)
4476 #ifdef NVIDIA
4477  var = work
4478  end block
4479 #endif
4480  end if
4481  if ( error /= file_success_code ) then
4482  log_error("FILE_read_var_realDP_1D",*) 'failed to get data value: ', trim(varname)
4483  call prc_abort
4484  end if
4485 
4486  !$acc update device(var) if(acc_is_present(var))
4487 
4488  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
4489 
4490  return
4491  end subroutine file_read_var_realdp_1d
4492  subroutine file_read_var_realsp_2d( &
4493  fid, varname, &
4494  var, &
4495  step, &
4496  allow_missing, &
4497  missing_value, &
4498  ntypes, dtype, &
4499  start, count )
4500  implicit none
4501 
4502  integer, intent( in) :: fid
4503  character(len=*), intent( in) :: varname
4504 #ifdef NVIDIA
4505  real(sp), intent(out), target :: var(:,:)
4506 #else
4507  real(sp), intent(out), target, contiguous :: var(:,:)
4508 #endif
4509  integer, intent( in), optional :: step
4510  logical, intent( in), optional :: allow_missing
4511  real(sp), intent( in), optional :: missing_value
4512  integer, intent( in), optional :: ntypes
4513  integer, intent( in), optional :: dtype
4514  integer, intent( in), optional :: start(:)
4515  integer, intent( in), optional :: count(:)
4516 
4517  integer :: step_
4518  logical(c_bool) :: allow_missing_
4519  real(sp) :: missing_value_
4520 
4521  type(datainfo) :: dinfo
4522  integer :: dim_size(2)
4523 
4524  integer :: error
4525  integer :: n
4526 
4527  intrinsic size, shape
4528  !---------------------------------------------------------------------------
4529 
4530  if ( .not. file_opened(fid) ) then
4531  log_error("FILE_read_var_realSP_2D",*) 'File is not opened. fid = ', fid
4532  call prc_abort
4533  end if
4534 
4535  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
4536 
4537  if ( present(step) ) then
4538  step_ = step
4539  else
4540  step_ = 1
4541  end if
4542 
4543  if ( present(allow_missing) ) then
4544  allow_missing_ = allow_missing
4545  else
4546  allow_missing_ = .false.
4547  end if
4548 
4549  if ( present(missing_value) ) then
4550  missing_value_ = missing_value
4551  else
4552  missing_value_ = 0.0_sp
4553  end if
4554 
4555  !--- get data information
4556  error = file_get_datainfo_c( dinfo, & ! (out)
4557  file_files(fid)%fid, & ! (in)
4558  cstr(varname), & ! (in)
4559  step_, allow_missing_ ) ! (in)
4560 
4561  !--- verify
4562  if ( error /= file_success_code ) then
4563  if ( allow_missing_ ) then
4564  log_info("FILE_read_var_realSP_2D",*) '[INPUT]/[FILE] data not found! : ', &
4565  'varname= ',trim(varname),', step=',step_
4566  log_info("FILE_read_var_realSP_2D",*) '[INPUT]/[FILE] Value is set to ', missing_value_
4567  var(:,:) = missing_value_
4568  return
4569  else
4570  log_error("FILE_read_var_realSP_2D",*) 'failed to get data information :'//trim(varname)
4571  call prc_abort
4572  end if
4573  end if
4574 
4575  if ( dinfo%rank /= 2 ) then
4576  if ( (.not. present(start)) .and. (.not. present(count)) ) then
4577  log_error("FILE_read_var_realSP_2D",*) 'rank of '//trim(varname)//' is not 2', dinfo%rank
4578  call prc_abort
4579  end if
4580  end if
4581 
4582  if ( present(ntypes) ) then
4583 #if defined(__GFORTRAN__) && __GNUC__ < 7
4584  error = file_read_data_c( cloc(var(1,1)), & ! (out)
4585 #else
4586  error = file_read_data_c( c_loc(var), & ! (out)
4587 #endif
4588  dinfo, sp, ntypes, dtype, start(:), count(:) ) ! (in)
4589  else if ( present(start) .and. present(count) ) then
4590 #ifdef NVIDIA
4591  block
4592  real(sp), allocatable, target :: work(:,:)
4593  allocate(work, mold=var)
4594 #endif
4595  error = file_read_data_c( &
4596 #if defined(__GFORTRAN__) && __GNUC__ < 7
4597  cloc(var(1,1)), & ! (out)
4598 #elif defined(NVIDIA)
4599  c_loc(work), & ! (out)
4600 #else
4601  c_loc(var), & ! (out)
4602 #endif
4603  dinfo, sp, 0, 0, start(:), count(:) ) ! (in)
4604 #ifdef NVIDIA
4605  var = work
4606  end block
4607 #endif
4608  else
4609  dim_size(:) = shape(var)
4610  do n = 1, 2
4611  if ( dinfo%dim_size(n) /= dim_size(n) ) then
4612  log_error("FILE_read_var_realSP_2D",*) 'shape is different: ', trim(varname), n, dinfo%dim_size(n), dim_size(n)
4613  call prc_abort
4614  end if
4615  end do
4616 #ifdef NVIDIA
4617  block
4618  real(sp), allocatable, target :: work(:,:)
4619  allocate(work, mold=var)
4620 #endif
4621  error = file_read_data_c( &
4622 #if defined(__GFORTRAN__) && __GNUC__ < 7
4623  cloc(var(1,1)), & ! (out)
4624 #elif defined(NVIDIA)
4625  c_loc(work), & ! (out)
4626 #else
4627  c_loc(var), & ! (out)
4628 #endif
4629  dinfo, sp, 0, 0, (/0/), (/0/) ) ! (in)
4630 #ifdef NVIDIA
4631  var = work
4632  end block
4633 #endif
4634  end if
4635  if ( error /= file_success_code ) then
4636  log_error("FILE_read_var_realSP_2D",*) 'failed to get data value: ', trim(varname)
4637  call prc_abort
4638  end if
4639 
4640  !$acc update device(var) if(acc_is_present(var))
4641 
4642  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
4643 
4644  return
4645  end subroutine file_read_var_realsp_2d
4646  subroutine file_read_var_realdp_2d( &
4647  fid, varname, &
4648  var, &
4649  step, &
4650  allow_missing, &
4651  missing_value, &
4652  ntypes, dtype, &
4653  start, count )
4654  implicit none
4655 
4656  integer, intent( in) :: fid
4657  character(len=*), intent( in) :: varname
4658 #ifdef NVIDIA
4659  real(dp), intent(out), target :: var(:,:)
4660 #else
4661  real(dp), intent(out), target, contiguous :: var(:,:)
4662 #endif
4663  integer, intent( in), optional :: step
4664  logical, intent( in), optional :: allow_missing
4665  real(dp), intent( in), optional :: missing_value
4666  integer, intent( in), optional :: ntypes
4667  integer, intent( in), optional :: dtype
4668  integer, intent( in), optional :: start(:)
4669  integer, intent( in), optional :: count(:)
4670 
4671  integer :: step_
4672  logical(c_bool) :: allow_missing_
4673  real(dp) :: missing_value_
4674 
4675  type(datainfo) :: dinfo
4676  integer :: dim_size(2)
4677 
4678  integer :: error
4679  integer :: n
4680 
4681  intrinsic size, shape
4682  !---------------------------------------------------------------------------
4683 
4684  if ( .not. file_opened(fid) ) then
4685  log_error("FILE_read_var_realDP_2D",*) 'File is not opened. fid = ', fid
4686  call prc_abort
4687  end if
4688 
4689  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
4690 
4691  if ( present(step) ) then
4692  step_ = step
4693  else
4694  step_ = 1
4695  end if
4696 
4697  if ( present(allow_missing) ) then
4698  allow_missing_ = allow_missing
4699  else
4700  allow_missing_ = .false.
4701  end if
4702 
4703  if ( present(missing_value) ) then
4704  missing_value_ = missing_value
4705  else
4706  missing_value_ = 0.0_dp
4707  end if
4708 
4709  !--- get data information
4710  error = file_get_datainfo_c( dinfo, & ! (out)
4711  file_files(fid)%fid, & ! (in)
4712  cstr(varname), & ! (in)
4713  step_, allow_missing_ ) ! (in)
4714 
4715  !--- verify
4716  if ( error /= file_success_code ) then
4717  if ( allow_missing_ ) then
4718  log_info("FILE_read_var_realDP_2D",*) '[INPUT]/[FILE] data not found! : ', &
4719  'varname= ',trim(varname),', step=',step_
4720  log_info("FILE_read_var_realDP_2D",*) '[INPUT]/[FILE] Value is set to ', missing_value_
4721  var(:,:) = missing_value_
4722  return
4723  else
4724  log_error("FILE_read_var_realDP_2D",*) 'failed to get data information :'//trim(varname)
4725  call prc_abort
4726  end if
4727  end if
4728 
4729  if ( dinfo%rank /= 2 ) then
4730  if ( (.not. present(start)) .and. (.not. present(count)) ) then
4731  log_error("FILE_read_var_realDP_2D",*) 'rank of '//trim(varname)//' is not 2', dinfo%rank
4732  call prc_abort
4733  end if
4734  end if
4735 
4736  if ( present(ntypes) ) then
4737 #if defined(__GFORTRAN__) && __GNUC__ < 7
4738  error = file_read_data_c( cloc(var(1,1)), & ! (out)
4739 #else
4740  error = file_read_data_c( c_loc(var), & ! (out)
4741 #endif
4742  dinfo, dp, ntypes, dtype, start(:), count(:) ) ! (in)
4743  else if ( present(start) .and. present(count) ) then
4744 #ifdef NVIDIA
4745  block
4746  real(dp), allocatable, target :: work(:,:)
4747  allocate(work, mold=var)
4748 #endif
4749  error = file_read_data_c( &
4750 #if defined(__GFORTRAN__) && __GNUC__ < 7
4751  cloc(var(1,1)), & ! (out)
4752 #elif defined(NVIDIA)
4753  c_loc(work), & ! (out)
4754 #else
4755  c_loc(var), & ! (out)
4756 #endif
4757  dinfo, dp, 0, 0, start(:), count(:) ) ! (in)
4758 #ifdef NVIDIA
4759  var = work
4760  end block
4761 #endif
4762  else
4763  dim_size(:) = shape(var)
4764  do n = 1, 2
4765  if ( dinfo%dim_size(n) /= dim_size(n) ) then
4766  log_error("FILE_read_var_realDP_2D",*) 'shape is different: ', trim(varname), n, dinfo%dim_size(n), dim_size(n)
4767  call prc_abort
4768  end if
4769  end do
4770 #ifdef NVIDIA
4771  block
4772  real(dp), allocatable, target :: work(:,:)
4773  allocate(work, mold=var)
4774 #endif
4775  error = file_read_data_c( &
4776 #if defined(__GFORTRAN__) && __GNUC__ < 7
4777  cloc(var(1,1)), & ! (out)
4778 #elif defined(NVIDIA)
4779  c_loc(work), & ! (out)
4780 #else
4781  c_loc(var), & ! (out)
4782 #endif
4783  dinfo, dp, 0, 0, (/0/), (/0/) ) ! (in)
4784 #ifdef NVIDIA
4785  var = work
4786  end block
4787 #endif
4788  end if
4789  if ( error /= file_success_code ) then
4790  log_error("FILE_read_var_realDP_2D",*) 'failed to get data value: ', trim(varname)
4791  call prc_abort
4792  end if
4793 
4794  !$acc update device(var) if(acc_is_present(var))
4795 
4796  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
4797 
4798  return
4799  end subroutine file_read_var_realdp_2d
4800  subroutine file_read_var_realsp_3d( &
4801  fid, varname, &
4802  var, &
4803  step, &
4804  allow_missing, &
4805  missing_value, &
4806  ntypes, dtype, &
4807  start, count )
4808  implicit none
4809 
4810  integer, intent( in) :: fid
4811  character(len=*), intent( in) :: varname
4812 #ifdef NVIDIA
4813  real(sp), intent(out), target :: var(:,:,:)
4814 #else
4815  real(sp), intent(out), target, contiguous :: var(:,:,:)
4816 #endif
4817  integer, intent( in), optional :: step
4818  logical, intent( in), optional :: allow_missing
4819  real(sp), intent( in), optional :: missing_value
4820  integer, intent( in), optional :: ntypes
4821  integer, intent( in), optional :: dtype
4822  integer, intent( in), optional :: start(:)
4823  integer, intent( in), optional :: count(:)
4824 
4825  integer :: step_
4826  logical(c_bool) :: allow_missing_
4827  real(sp) :: missing_value_
4828 
4829  type(datainfo) :: dinfo
4830  integer :: dim_size(3)
4831 
4832  integer :: error
4833  integer :: n
4834 
4835  intrinsic size, shape
4836  !---------------------------------------------------------------------------
4837 
4838  if ( .not. file_opened(fid) ) then
4839  log_error("FILE_read_var_realSP_3D",*) 'File is not opened. fid = ', fid
4840  call prc_abort
4841  end if
4842 
4843  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
4844 
4845  if ( present(step) ) then
4846  step_ = step
4847  else
4848  step_ = 1
4849  end if
4850 
4851  if ( present(allow_missing) ) then
4852  allow_missing_ = allow_missing
4853  else
4854  allow_missing_ = .false.
4855  end if
4856 
4857  if ( present(missing_value) ) then
4858  missing_value_ = missing_value
4859  else
4860  missing_value_ = 0.0_sp
4861  end if
4862 
4863  !--- get data information
4864  error = file_get_datainfo_c( dinfo, & ! (out)
4865  file_files(fid)%fid, & ! (in)
4866  cstr(varname), & ! (in)
4867  step_, allow_missing_ ) ! (in)
4868 
4869  !--- verify
4870  if ( error /= file_success_code ) then
4871  if ( allow_missing_ ) then
4872  log_info("FILE_read_var_realSP_3D",*) '[INPUT]/[FILE] data not found! : ', &
4873  'varname= ',trim(varname),', step=',step_
4874  log_info("FILE_read_var_realSP_3D",*) '[INPUT]/[FILE] Value is set to ', missing_value_
4875  var(:,:,:) = missing_value_
4876  return
4877  else
4878  log_error("FILE_read_var_realSP_3D",*) 'failed to get data information :'//trim(varname)
4879  call prc_abort
4880  end if
4881  end if
4882 
4883  if ( dinfo%rank /= 3 ) then
4884  if ( (.not. present(start)) .and. (.not. present(count)) ) then
4885  log_error("FILE_read_var_realSP_3D",*) 'rank of '//trim(varname)//' is not 3', dinfo%rank
4886  call prc_abort
4887  end if
4888  end if
4889 
4890  if ( present(ntypes) ) then
4891 #if defined(__GFORTRAN__) && __GNUC__ < 7
4892  error = file_read_data_c( cloc(var(1,1,1)), & ! (out)
4893 #else
4894  error = file_read_data_c( c_loc(var), & ! (out)
4895 #endif
4896  dinfo, sp, ntypes, dtype, start(:), count(:) ) ! (in)
4897  else if ( present(start) .and. present(count) ) then
4898 #ifdef NVIDIA
4899  block
4900  real(sp), allocatable, target :: work(:,:,:)
4901  allocate(work, mold=var)
4902 #endif
4903  error = file_read_data_c( &
4904 #if defined(__GFORTRAN__) && __GNUC__ < 7
4905  cloc(var(1,1,1)), & ! (out)
4906 #elif defined(NVIDIA)
4907  c_loc(work), & ! (out)
4908 #else
4909  c_loc(var), & ! (out)
4910 #endif
4911  dinfo, sp, 0, 0, start(:), count(:) ) ! (in)
4912 #ifdef NVIDIA
4913  var = work
4914  end block
4915 #endif
4916  else
4917  dim_size(:) = shape(var)
4918  do n = 1, 3
4919  if ( dinfo%dim_size(n) /= dim_size(n) ) then
4920  log_error("FILE_read_var_realSP_3D",*) 'shape is different: ', trim(varname), n, dinfo%dim_size(n), dim_size(n)
4921  call prc_abort
4922  end if
4923  end do
4924 #ifdef NVIDIA
4925  block
4926  real(sp), allocatable, target :: work(:,:,:)
4927  allocate(work, mold=var)
4928 #endif
4929  error = file_read_data_c( &
4930 #if defined(__GFORTRAN__) && __GNUC__ < 7
4931  cloc(var(1,1,1)), & ! (out)
4932 #elif defined(NVIDIA)
4933  c_loc(work), & ! (out)
4934 #else
4935  c_loc(var), & ! (out)
4936 #endif
4937  dinfo, sp, 0, 0, (/0/), (/0/) ) ! (in)
4938 #ifdef NVIDIA
4939  var = work
4940  end block
4941 #endif
4942  end if
4943  if ( error /= file_success_code ) then
4944  log_error("FILE_read_var_realSP_3D",*) 'failed to get data value: ', trim(varname)
4945  call prc_abort
4946  end if
4947 
4948  !$acc update device(var) if(acc_is_present(var))
4949 
4950  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
4951 
4952  return
4953  end subroutine file_read_var_realsp_3d
4954  subroutine file_read_var_realdp_3d( &
4955  fid, varname, &
4956  var, &
4957  step, &
4958  allow_missing, &
4959  missing_value, &
4960  ntypes, dtype, &
4961  start, count )
4962  implicit none
4963 
4964  integer, intent( in) :: fid
4965  character(len=*), intent( in) :: varname
4966 #ifdef NVIDIA
4967  real(dp), intent(out), target :: var(:,:,:)
4968 #else
4969  real(dp), intent(out), target, contiguous :: var(:,:,:)
4970 #endif
4971  integer, intent( in), optional :: step
4972  logical, intent( in), optional :: allow_missing
4973  real(dp), intent( in), optional :: missing_value
4974  integer, intent( in), optional :: ntypes
4975  integer, intent( in), optional :: dtype
4976  integer, intent( in), optional :: start(:)
4977  integer, intent( in), optional :: count(:)
4978 
4979  integer :: step_
4980  logical(c_bool) :: allow_missing_
4981  real(dp) :: missing_value_
4982 
4983  type(datainfo) :: dinfo
4984  integer :: dim_size(3)
4985 
4986  integer :: error
4987  integer :: n
4988 
4989  intrinsic size, shape
4990  !---------------------------------------------------------------------------
4991 
4992  if ( .not. file_opened(fid) ) then
4993  log_error("FILE_read_var_realDP_3D",*) 'File is not opened. fid = ', fid
4994  call prc_abort
4995  end if
4996 
4997  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
4998 
4999  if ( present(step) ) then
5000  step_ = step
5001  else
5002  step_ = 1
5003  end if
5004 
5005  if ( present(allow_missing) ) then
5006  allow_missing_ = allow_missing
5007  else
5008  allow_missing_ = .false.
5009  end if
5010 
5011  if ( present(missing_value) ) then
5012  missing_value_ = missing_value
5013  else
5014  missing_value_ = 0.0_dp
5015  end if
5016 
5017  !--- get data information
5018  error = file_get_datainfo_c( dinfo, & ! (out)
5019  file_files(fid)%fid, & ! (in)
5020  cstr(varname), & ! (in)
5021  step_, allow_missing_ ) ! (in)
5022 
5023  !--- verify
5024  if ( error /= file_success_code ) then
5025  if ( allow_missing_ ) then
5026  log_info("FILE_read_var_realDP_3D",*) '[INPUT]/[FILE] data not found! : ', &
5027  'varname= ',trim(varname),', step=',step_
5028  log_info("FILE_read_var_realDP_3D",*) '[INPUT]/[FILE] Value is set to ', missing_value_
5029  var(:,:,:) = missing_value_
5030  return
5031  else
5032  log_error("FILE_read_var_realDP_3D",*) 'failed to get data information :'//trim(varname)
5033  call prc_abort
5034  end if
5035  end if
5036 
5037  if ( dinfo%rank /= 3 ) then
5038  if ( (.not. present(start)) .and. (.not. present(count)) ) then
5039  log_error("FILE_read_var_realDP_3D",*) 'rank of '//trim(varname)//' is not 3', dinfo%rank
5040  call prc_abort
5041  end if
5042  end if
5043 
5044  if ( present(ntypes) ) then
5045 #if defined(__GFORTRAN__) && __GNUC__ < 7
5046  error = file_read_data_c( cloc(var(1,1,1)), & ! (out)
5047 #else
5048  error = file_read_data_c( c_loc(var), & ! (out)
5049 #endif
5050  dinfo, dp, ntypes, dtype, start(:), count(:) ) ! (in)
5051  else if ( present(start) .and. present(count) ) then
5052 #ifdef NVIDIA
5053  block
5054  real(dp), allocatable, target :: work(:,:,:)
5055  allocate(work, mold=var)
5056 #endif
5057  error = file_read_data_c( &
5058 #if defined(__GFORTRAN__) && __GNUC__ < 7
5059  cloc(var(1,1,1)), & ! (out)
5060 #elif defined(NVIDIA)
5061  c_loc(work), & ! (out)
5062 #else
5063  c_loc(var), & ! (out)
5064 #endif
5065  dinfo, dp, 0, 0, start(:), count(:) ) ! (in)
5066 #ifdef NVIDIA
5067  var = work
5068  end block
5069 #endif
5070  else
5071  dim_size(:) = shape(var)
5072  do n = 1, 3
5073  if ( dinfo%dim_size(n) /= dim_size(n) ) then
5074  log_error("FILE_read_var_realDP_3D",*) 'shape is different: ', trim(varname), n, dinfo%dim_size(n), dim_size(n)
5075  call prc_abort
5076  end if
5077  end do
5078 #ifdef NVIDIA
5079  block
5080  real(dp), allocatable, target :: work(:,:,:)
5081  allocate(work, mold=var)
5082 #endif
5083  error = file_read_data_c( &
5084 #if defined(__GFORTRAN__) && __GNUC__ < 7
5085  cloc(var(1,1,1)), & ! (out)
5086 #elif defined(NVIDIA)
5087  c_loc(work), & ! (out)
5088 #else
5089  c_loc(var), & ! (out)
5090 #endif
5091  dinfo, dp, 0, 0, (/0/), (/0/) ) ! (in)
5092 #ifdef NVIDIA
5093  var = work
5094  end block
5095 #endif
5096  end if
5097  if ( error /= file_success_code ) then
5098  log_error("FILE_read_var_realDP_3D",*) 'failed to get data value: ', trim(varname)
5099  call prc_abort
5100  end if
5101 
5102  !$acc update device(var) if(acc_is_present(var))
5103 
5104  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
5105 
5106  return
5107  end subroutine file_read_var_realdp_3d
5108  subroutine file_read_var_realsp_4d( &
5109  fid, varname, &
5110  var, &
5111  step, &
5112  allow_missing, &
5113  missing_value, &
5114  ntypes, dtype, &
5115  start, count )
5116  implicit none
5117 
5118  integer, intent( in) :: fid
5119  character(len=*), intent( in) :: varname
5120 #ifdef NVIDIA
5121  real(sp), intent(out), target :: var(:,:,:,:)
5122 #else
5123  real(sp), intent(out), target, contiguous :: var(:,:,:,:)
5124 #endif
5125  integer, intent( in), optional :: step
5126  logical, intent( in), optional :: allow_missing
5127  real(sp), intent( in), optional :: missing_value
5128  integer, intent( in), optional :: ntypes
5129  integer, intent( in), optional :: dtype
5130  integer, intent( in), optional :: start(:)
5131  integer, intent( in), optional :: count(:)
5132 
5133  integer :: step_
5134  logical(c_bool) :: allow_missing_
5135  real(sp) :: missing_value_
5136 
5137  type(datainfo) :: dinfo
5138  integer :: dim_size(4)
5139 
5140  integer :: error
5141  integer :: n
5142 
5143  intrinsic size, shape
5144  !---------------------------------------------------------------------------
5145 
5146  if ( .not. file_opened(fid) ) then
5147  log_error("FILE_read_var_realSP_4D",*) 'File is not opened. fid = ', fid
5148  call prc_abort
5149  end if
5150 
5151  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
5152 
5153  if ( present(step) ) then
5154  step_ = step
5155  else
5156  step_ = 1
5157  end if
5158 
5159  if ( present(allow_missing) ) then
5160  allow_missing_ = allow_missing
5161  else
5162  allow_missing_ = .false.
5163  end if
5164 
5165  if ( present(missing_value) ) then
5166  missing_value_ = missing_value
5167  else
5168  missing_value_ = 0.0_sp
5169  end if
5170 
5171  !--- get data information
5172  error = file_get_datainfo_c( dinfo, & ! (out)
5173  file_files(fid)%fid, & ! (in)
5174  cstr(varname), & ! (in)
5175  step_, allow_missing_ ) ! (in)
5176 
5177  !--- verify
5178  if ( error /= file_success_code ) then
5179  if ( allow_missing_ ) then
5180  log_info("FILE_read_var_realSP_4D",*) '[INPUT]/[FILE] data not found! : ', &
5181  'varname= ',trim(varname),', step=',step_
5182  log_info("FILE_read_var_realSP_4D",*) '[INPUT]/[FILE] Value is set to ', missing_value_
5183  var(:,:,:,:) = missing_value_
5184  return
5185  else
5186  log_error("FILE_read_var_realSP_4D",*) 'failed to get data information :'//trim(varname)
5187  call prc_abort
5188  end if
5189  end if
5190 
5191  if ( dinfo%rank /= 4 ) then
5192  if ( (.not. present(start)) .and. (.not. present(count)) ) then
5193  log_error("FILE_read_var_realSP_4D",*) 'rank of '//trim(varname)//' is not 4', dinfo%rank
5194  call prc_abort
5195  end if
5196  end if
5197 
5198  if ( present(ntypes) ) then
5199 #if defined(__GFORTRAN__) && __GNUC__ < 7
5200  error = file_read_data_c( cloc(var(1,1,1,1)), & ! (out)
5201 #else
5202  error = file_read_data_c( c_loc(var), & ! (out)
5203 #endif
5204  dinfo, sp, ntypes, dtype, start(:), count(:) ) ! (in)
5205  else if ( present(start) .and. present(count) ) then
5206 #ifdef NVIDIA
5207  block
5208  real(sp), allocatable, target :: work(:,:,:,:)
5209  allocate(work, mold=var)
5210 #endif
5211  error = file_read_data_c( &
5212 #if defined(__GFORTRAN__) && __GNUC__ < 7
5213  cloc(var(1,1,1,1)), & ! (out)
5214 #elif defined(NVIDIA)
5215  c_loc(work), & ! (out)
5216 #else
5217  c_loc(var), & ! (out)
5218 #endif
5219  dinfo, sp, 0, 0, start(:), count(:) ) ! (in)
5220 #ifdef NVIDIA
5221  var = work
5222  end block
5223 #endif
5224  else
5225  dim_size(:) = shape(var)
5226  do n = 1, 4
5227  if ( dinfo%dim_size(n) /= dim_size(n) ) then
5228  log_error("FILE_read_var_realSP_4D",*) 'shape is different: ', trim(varname), n, dinfo%dim_size(n), dim_size(n)
5229  call prc_abort
5230  end if
5231  end do
5232 #ifdef NVIDIA
5233  block
5234  real(sp), allocatable, target :: work(:,:,:,:)
5235  allocate(work, mold=var)
5236 #endif
5237  error = file_read_data_c( &
5238 #if defined(__GFORTRAN__) && __GNUC__ < 7
5239  cloc(var(1,1,1,1)), & ! (out)
5240 #elif defined(NVIDIA)
5241  c_loc(work), & ! (out)
5242 #else
5243  c_loc(var), & ! (out)
5244 #endif
5245  dinfo, sp, 0, 0, (/0/), (/0/) ) ! (in)
5246 #ifdef NVIDIA
5247  var = work
5248  end block
5249 #endif
5250  end if
5251  if ( error /= file_success_code ) then
5252  log_error("FILE_read_var_realSP_4D",*) 'failed to get data value: ', trim(varname)
5253  call prc_abort
5254  end if
5255 
5256  !$acc update device(var) if(acc_is_present(var))
5257 
5258  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
5259 
5260  return
5261  end subroutine file_read_var_realsp_4d
5262  subroutine file_read_var_realdp_4d( &
5263  fid, varname, &
5264  var, &
5265  step, &
5266  allow_missing, &
5267  missing_value, &
5268  ntypes, dtype, &
5269  start, count )
5270  implicit none
5271 
5272  integer, intent( in) :: fid
5273  character(len=*), intent( in) :: varname
5274 #ifdef NVIDIA
5275  real(dp), intent(out), target :: var(:,:,:,:)
5276 #else
5277  real(dp), intent(out), target, contiguous :: var(:,:,:,:)
5278 #endif
5279  integer, intent( in), optional :: step
5280  logical, intent( in), optional :: allow_missing
5281  real(dp), intent( in), optional :: missing_value
5282  integer, intent( in), optional :: ntypes
5283  integer, intent( in), optional :: dtype
5284  integer, intent( in), optional :: start(:)
5285  integer, intent( in), optional :: count(:)
5286 
5287  integer :: step_
5288  logical(c_bool) :: allow_missing_
5289  real(dp) :: missing_value_
5290 
5291  type(datainfo) :: dinfo
5292  integer :: dim_size(4)
5293 
5294  integer :: error
5295  integer :: n
5296 
5297  intrinsic size, shape
5298  !---------------------------------------------------------------------------
5299 
5300  if ( .not. file_opened(fid) ) then
5301  log_error("FILE_read_var_realDP_4D",*) 'File is not opened. fid = ', fid
5302  call prc_abort
5303  end if
5304 
5305  call prof_rapstart('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
5306 
5307  if ( present(step) ) then
5308  step_ = step
5309  else
5310  step_ = 1
5311  end if
5312 
5313  if ( present(allow_missing) ) then
5314  allow_missing_ = allow_missing
5315  else
5316  allow_missing_ = .false.
5317  end if
5318 
5319  if ( present(missing_value) ) then
5320  missing_value_ = missing_value
5321  else
5322  missing_value_ = 0.0_dp
5323  end if
5324 
5325  !--- get data information
5326  error = file_get_datainfo_c( dinfo, & ! (out)
5327  file_files(fid)%fid, & ! (in)
5328  cstr(varname), & ! (in)
5329  step_, allow_missing_ ) ! (in)
5330 
5331  !--- verify
5332  if ( error /= file_success_code ) then
5333  if ( allow_missing_ ) then
5334  log_info("FILE_read_var_realDP_4D",*) '[INPUT]/[FILE] data not found! : ', &
5335  'varname= ',trim(varname),', step=',step_
5336  log_info("FILE_read_var_realDP_4D",*) '[INPUT]/[FILE] Value is set to ', missing_value_
5337  var(:,:,:,:) = missing_value_
5338  return
5339  else
5340  log_error("FILE_read_var_realDP_4D",*) 'failed to get data information :'//trim(varname)
5341  call prc_abort
5342  end if
5343  end if
5344 
5345  if ( dinfo%rank /= 4 ) then
5346  if ( (.not. present(start)) .and. (.not. present(count)) ) then
5347  log_error("FILE_read_var_realDP_4D",*) 'rank of '//trim(varname)//' is not 4', dinfo%rank
5348  call prc_abort
5349  end if
5350  end if
5351 
5352  if ( present(ntypes) ) then
5353 #if defined(__GFORTRAN__) && __GNUC__ < 7
5354  error = file_read_data_c( cloc(var(1,1,1,1)), & ! (out)
5355 #else
5356  error = file_read_data_c( c_loc(var), & ! (out)
5357 #endif
5358  dinfo, dp, ntypes, dtype, start(:), count(:) ) ! (in)
5359  else if ( present(start) .and. present(count) ) then
5360 #ifdef NVIDIA
5361  block
5362  real(dp), allocatable, target :: work(:,:,:,:)
5363  allocate(work, mold=var)
5364 #endif
5365  error = file_read_data_c( &
5366 #if defined(__GFORTRAN__) && __GNUC__ < 7
5367  cloc(var(1,1,1,1)), & ! (out)
5368 #elif defined(NVIDIA)
5369  c_loc(work), & ! (out)
5370 #else
5371  c_loc(var), & ! (out)
5372 #endif
5373  dinfo, dp, 0, 0, start(:), count(:) ) ! (in)
5374 #ifdef NVIDIA
5375  var = work
5376  end block
5377 #endif
5378  else
5379  dim_size(:) = shape(var)
5380  do n = 1, 4
5381  if ( dinfo%dim_size(n) /= dim_size(n) ) then
5382  log_error("FILE_read_var_realDP_4D",*) 'shape is different: ', trim(varname), n, dinfo%dim_size(n), dim_size(n)
5383  call prc_abort
5384  end if
5385  end do
5386 #ifdef NVIDIA
5387  block
5388  real(dp), allocatable, target :: work(:,:,:,:)
5389  allocate(work, mold=var)
5390 #endif
5391  error = file_read_data_c( &
5392 #if defined(__GFORTRAN__) && __GNUC__ < 7
5393  cloc(var(1,1,1,1)), & ! (out)
5394 #elif defined(NVIDIA)
5395  c_loc(work), & ! (out)
5396 #else
5397  c_loc(var), & ! (out)
5398 #endif
5399  dinfo, dp, 0, 0, (/0/), (/0/) ) ! (in)
5400 #ifdef NVIDIA
5401  var = work
5402  end block
5403 #endif
5404  end if
5405  if ( error /= file_success_code ) then
5406  log_error("FILE_read_var_realDP_4D",*) 'failed to get data value: ', trim(varname)
5407  call prc_abort
5408  end if
5409 
5410  !$acc update device(var) if(acc_is_present(var))
5411 
5412  call prof_rapend ('FILE_Read', 2, disable_barrier = .not. file_files(fid)%allnodes )
5413 
5414  return
5415  end subroutine file_read_var_realdp_4d
5416 
5417  !-----------------------------------------------------------------------------
5418  ! interface FILE_write
5419  !-----------------------------------------------------------------------------
5420  subroutine file_write_realsp_1d( &
5421  vid, var, &
5422  t_start, t_end, &
5423  ndims, &
5424  count, &
5425  start )
5426  implicit none
5427 
5428  integer, intent(in) :: vid
5429 #ifdef NVIDIA
5430  real(sp), intent(in) :: var(:)
5431 #else
5432  real(sp), intent(in), target, contiguous :: var(:)
5433 #endif
5434  real(dp), intent(in) :: t_start
5435  real(dp), intent(in) :: t_end
5436  integer, intent(in), optional :: ndims ! when var has been reshaped to 1D
5437  integer, intent(in), optional :: count(:)
5438  integer, intent(in), optional :: start(:)
5439  real(dp) :: ts, te
5440 
5441  integer :: start_(1)
5442 
5443  integer :: fid
5444  integer :: error
5445 
5446  intrinsic shape
5447  !---------------------------------------------------------------------------
5448 
5449  ts = t_start
5450  te = t_end
5451 
5452  fid = file_vars(vid)%fid
5453 
5454  if ( .not. file_opened(fid) ) then
5455  log_error("FILE_write_realSP_1D",*) 'File is not opened. fid = ', fid
5456  call prc_abort
5457  end if
5458 
5459  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5460 
5461  if ( present(ndims) ) then
5462  ! history variable has been reshaped to 1D
5463  ! In this case, start and count must be present
5464 
5465  if ( .not. present(start) ) then
5466  log_error("FILE_write_realSP_1D",*) 'start argument is neccessary when ndims is specified'
5467  call prc_abort
5468  end if
5469  if ( .not. present(count) ) then
5470  log_error("FILE_write_realSP_1D",*) 'count argument is neccessary when ndims is specified'
5471  call prc_abort
5472  end if
5473 
5474  error = file_write_data_c( file_files(fid)%fid, file_vars(vid)%vid, & ! (in)
5475 #if defined(__GFORTRAN__) && __GNUC__ < 7
5476  cloc(var(1)), ts, te, ndims, sp, & ! (in)
5477 #else
5478  c_loc(var), ts, te, ndims, sp, & ! (in)
5479 #endif
5480  start, count ) ! (in)
5481  else
5482  ! this is for restart variable which keeps its original shape
5483  if ( present(start) ) then
5484  start_(:) = start(:)
5485  else
5486  start_(:) = 1
5487  end if
5488 
5489  !$acc update host(var) if(acc_is_present(var))
5490 
5491 #ifdef NVIDIA
5492  block
5493  real(sp), allocatable, target :: work(:)
5494  allocate(work, source=var)
5495 #endif
5496  error = file_write_data_c( file_files(fid)%fid, file_vars(vid)%vid, & ! (in)
5497 #if defined(__GFORTRAN__) && __GNUC__ < 7
5498  cloc(var(1)), & ! (in)
5499 #elif defined(NVIDIA)
5500  c_loc(work), & ! (in)
5501 #else
5502  c_loc(var), & ! (in)
5503 #endif
5504  ts, te, 1, sp, & ! (in)
5505  start_, shape(var) ) ! (in)
5506 #ifdef NVIDIA
5507  end block
5508 #endif
5509  end if
5510  if ( error /= file_success_code ) then
5511  log_error("FILE_write_realSP_1D",*) 'failed to write data: ', trim(file_vars(vid)%name)
5512  call prc_abort
5513  end if
5514 
5515  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5516 
5517  return
5518  end subroutine file_write_realsp_1d
5519  subroutine file_write_realdp_1d( &
5520  vid, var, &
5521  t_start, t_end, &
5522  ndims, &
5523  count, &
5524  start )
5525  implicit none
5526 
5527  integer, intent(in) :: vid
5528 #ifdef NVIDIA
5529  real(dp), intent(in) :: var(:)
5530 #else
5531  real(dp), intent(in), target, contiguous :: var(:)
5532 #endif
5533  real(dp), intent(in) :: t_start
5534  real(dp), intent(in) :: t_end
5535  integer, intent(in), optional :: ndims ! when var has been reshaped to 1D
5536  integer, intent(in), optional :: count(:)
5537  integer, intent(in), optional :: start(:)
5538  real(dp) :: ts, te
5539 
5540  integer :: start_(1)
5541 
5542  integer :: fid
5543  integer :: error
5544 
5545  intrinsic shape
5546  !---------------------------------------------------------------------------
5547 
5548  ts = t_start
5549  te = t_end
5550 
5551  fid = file_vars(vid)%fid
5552 
5553  if ( .not. file_opened(fid) ) then
5554  log_error("FILE_write_realDP_1D",*) 'File is not opened. fid = ', fid
5555  call prc_abort
5556  end if
5557 
5558  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5559 
5560  if ( present(ndims) ) then
5561  ! history variable has been reshaped to 1D
5562  ! In this case, start and count must be present
5563 
5564  if ( .not. present(start) ) then
5565  log_error("FILE_write_realDP_1D",*) 'start argument is neccessary when ndims is specified'
5566  call prc_abort
5567  end if
5568  if ( .not. present(count) ) then
5569  log_error("FILE_write_realDP_1D",*) 'count argument is neccessary when ndims is specified'
5570  call prc_abort
5571  end if
5572 
5573  error = file_write_data_c( file_files(fid)%fid, file_vars(vid)%vid, & ! (in)
5574 #if defined(__GFORTRAN__) && __GNUC__ < 7
5575  cloc(var(1)), ts, te, ndims, dp, & ! (in)
5576 #else
5577  c_loc(var), ts, te, ndims, dp, & ! (in)
5578 #endif
5579  start, count ) ! (in)
5580  else
5581  ! this is for restart variable which keeps its original shape
5582  if ( present(start) ) then
5583  start_(:) = start(:)
5584  else
5585  start_(:) = 1
5586  end if
5587 
5588  !$acc update host(var) if(acc_is_present(var))
5589 
5590 #ifdef NVIDIA
5591  block
5592  real(dp), allocatable, target :: work(:)
5593  allocate(work, source=var)
5594 #endif
5595  error = file_write_data_c( file_files(fid)%fid, file_vars(vid)%vid, & ! (in)
5596 #if defined(__GFORTRAN__) && __GNUC__ < 7
5597  cloc(var(1)), & ! (in)
5598 #elif defined(NVIDIA)
5599  c_loc(work), & ! (in)
5600 #else
5601  c_loc(var), & ! (in)
5602 #endif
5603  ts, te, 1, dp, & ! (in)
5604  start_, shape(var) ) ! (in)
5605 #ifdef NVIDIA
5606  end block
5607 #endif
5608  end if
5609  if ( error /= file_success_code ) then
5610  log_error("FILE_write_realDP_1D",*) 'failed to write data: ', trim(file_vars(vid)%name)
5611  call prc_abort
5612  end if
5613 
5614  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5615 
5616  return
5617  end subroutine file_write_realdp_1d
5618  subroutine file_write_realsp_2d( &
5619  vid, var, &
5620  t_start, t_end, &
5621  start )
5622  implicit none
5623 
5624  integer, intent(in) :: vid
5625 #ifdef NVIDIA
5626  real(sp), intent(in) :: var(:,:)
5627 #else
5628  real(sp), intent(in), target, contiguous :: var(:,:)
5629 #endif
5630  real(dp), intent(in) :: t_start
5631  real(dp), intent(in) :: t_end
5632  integer, intent(in), optional :: start(:)
5633  real(dp) :: ts, te
5634 
5635  integer :: start_(2)
5636 
5637  integer :: fid
5638  integer :: error
5639 
5640  intrinsic shape
5641  !---------------------------------------------------------------------------
5642 
5643  ts = t_start
5644  te = t_end
5645 
5646  fid = file_vars(vid)%fid
5647 
5648  if ( .not. file_opened(fid) ) then
5649  log_error("FILE_write_realSP_2D",*) 'File is not opened. fid = ', fid
5650  call prc_abort
5651  end if
5652 
5653  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5654 
5655  ! this is for restart variable which keeps its original shape
5656  if ( present(start) ) then
5657  start_(:) = start(:)
5658  else
5659  start_(:) = 1
5660  end if
5661 
5662  !$acc update host(var) if(acc_is_present(var))
5663 
5664 #ifdef NVIDIA
5665  block
5666  real(sp), allocatable, target :: work(:,:)
5667  allocate(work, source=var)
5668 #endif
5669  error = file_write_data_c( file_files(fid)%fid, file_vars(vid)%vid, & ! (in)
5670 #if defined(__GFORTRAN__) && __GNUC__ < 7
5671  cloc(var(1,1)), & ! (in)
5672 #elif defined(NVIDIA)
5673  c_loc(work), & ! (in)
5674 #else
5675  c_loc(var), & ! (in)
5676 #endif
5677  ts, te, 2, sp, & ! (in)
5678  start_, shape(var) ) ! (in)
5679 #ifdef NVIDIA
5680  end block
5681 #endif
5682  if ( error /= file_success_code ) then
5683  log_error("FILE_write_realSP_2D",*) 'failed to write data: ', trim(file_vars(vid)%name)
5684  call prc_abort
5685  end if
5686 
5687  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5688 
5689  return
5690  end subroutine file_write_realsp_2d
5691  subroutine file_write_realdp_2d( &
5692  vid, var, &
5693  t_start, t_end, &
5694  start )
5695  implicit none
5696 
5697  integer, intent(in) :: vid
5698 #ifdef NVIDIA
5699  real(dp), intent(in) :: var(:,:)
5700 #else
5701  real(dp), intent(in), target, contiguous :: var(:,:)
5702 #endif
5703  real(dp), intent(in) :: t_start
5704  real(dp), intent(in) :: t_end
5705  integer, intent(in), optional :: start(:)
5706  real(dp) :: ts, te
5707 
5708  integer :: start_(2)
5709 
5710  integer :: fid
5711  integer :: error
5712 
5713  intrinsic shape
5714  !---------------------------------------------------------------------------
5715 
5716  ts = t_start
5717  te = t_end
5718 
5719  fid = file_vars(vid)%fid
5720 
5721  if ( .not. file_opened(fid) ) then
5722  log_error("FILE_write_realDP_2D",*) 'File is not opened. fid = ', fid
5723  call prc_abort
5724  end if
5725 
5726  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5727 
5728  ! this is for restart variable which keeps its original shape
5729  if ( present(start) ) then
5730  start_(:) = start(:)
5731  else
5732  start_(:) = 1
5733  end if
5734 
5735  !$acc update host(var) if(acc_is_present(var))
5736 
5737 #ifdef NVIDIA
5738  block
5739  real(dp), allocatable, target :: work(:,:)
5740  allocate(work, source=var)
5741 #endif
5742  error = file_write_data_c( file_files(fid)%fid, file_vars(vid)%vid, & ! (in)
5743 #if defined(__GFORTRAN__) && __GNUC__ < 7
5744  cloc(var(1,1)), & ! (in)
5745 #elif defined(NVIDIA)
5746  c_loc(work), & ! (in)
5747 #else
5748  c_loc(var), & ! (in)
5749 #endif
5750  ts, te, 2, dp, & ! (in)
5751  start_, shape(var) ) ! (in)
5752 #ifdef NVIDIA
5753  end block
5754 #endif
5755  if ( error /= file_success_code ) then
5756  log_error("FILE_write_realDP_2D",*) 'failed to write data: ', trim(file_vars(vid)%name)
5757  call prc_abort
5758  end if
5759 
5760  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5761 
5762  return
5763  end subroutine file_write_realdp_2d
5764  subroutine file_write_realsp_3d( &
5765  vid, var, &
5766  t_start, t_end, &
5767  start )
5768  implicit none
5769 
5770  integer, intent(in) :: vid
5771 #ifdef NVIDIA
5772  real(sp), intent(in) :: var(:,:,:)
5773 #else
5774  real(sp), intent(in), target, contiguous :: var(:,:,:)
5775 #endif
5776  real(dp), intent(in) :: t_start
5777  real(dp), intent(in) :: t_end
5778  integer, intent(in), optional :: start(:)
5779  real(dp) :: ts, te
5780 
5781  integer :: start_(3)
5782 
5783  integer :: fid
5784  integer :: error
5785 
5786  intrinsic shape
5787  !---------------------------------------------------------------------------
5788 
5789  ts = t_start
5790  te = t_end
5791 
5792  fid = file_vars(vid)%fid
5793 
5794  if ( .not. file_opened(fid) ) then
5795  log_error("FILE_write_realSP_3D",*) 'File is not opened. fid = ', fid
5796  call prc_abort
5797  end if
5798 
5799  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5800 
5801  ! this is for restart variable which keeps its original shape
5802  if ( present(start) ) then
5803  start_(:) = start(:)
5804  else
5805  start_(:) = 1
5806  end if
5807 
5808  !$acc update host(var) if(acc_is_present(var))
5809 
5810 #ifdef NVIDIA
5811  block
5812  real(sp), allocatable, target :: work(:,:,:)
5813  allocate(work, source=var)
5814 #endif
5815  error = file_write_data_c( file_files(fid)%fid, file_vars(vid)%vid, & ! (in)
5816 #if defined(__GFORTRAN__) && __GNUC__ < 7
5817  cloc(var(1,1,1)), & ! (in)
5818 #elif defined(NVIDIA)
5819  c_loc(work), & ! (in)
5820 #else
5821  c_loc(var), & ! (in)
5822 #endif
5823  ts, te, 3, sp, & ! (in)
5824  start_, shape(var) ) ! (in)
5825 #ifdef NVIDIA
5826  end block
5827 #endif
5828  if ( error /= file_success_code ) then
5829  log_error("FILE_write_realSP_3D",*) 'failed to write data: ', trim(file_vars(vid)%name)
5830  call prc_abort
5831  end if
5832 
5833  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5834 
5835  return
5836  end subroutine file_write_realsp_3d
5837  subroutine file_write_realdp_3d( &
5838  vid, var, &
5839  t_start, t_end, &
5840  start )
5841  implicit none
5842 
5843  integer, intent(in) :: vid
5844 #ifdef NVIDIA
5845  real(dp), intent(in) :: var(:,:,:)
5846 #else
5847  real(dp), intent(in), target, contiguous :: var(:,:,:)
5848 #endif
5849  real(dp), intent(in) :: t_start
5850  real(dp), intent(in) :: t_end
5851  integer, intent(in), optional :: start(:)
5852  real(dp) :: ts, te
5853 
5854  integer :: start_(3)
5855 
5856  integer :: fid
5857  integer :: error
5858 
5859  intrinsic shape
5860  !---------------------------------------------------------------------------
5861 
5862  ts = t_start
5863  te = t_end
5864 
5865  fid = file_vars(vid)%fid
5866 
5867  if ( .not. file_opened(fid) ) then
5868  log_error("FILE_write_realDP_3D",*) 'File is not opened. fid = ', fid
5869  call prc_abort
5870  end if
5871 
5872  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5873 
5874  ! this is for restart variable which keeps its original shape
5875  if ( present(start) ) then
5876  start_(:) = start(:)
5877  else
5878  start_(:) = 1
5879  end if
5880 
5881  !$acc update host(var) if(acc_is_present(var))
5882 
5883 #ifdef NVIDIA
5884  block
5885  real(dp), allocatable, target :: work(:,:,:)
5886  allocate(work, source=var)
5887 #endif
5888  error = file_write_data_c( file_files(fid)%fid, file_vars(vid)%vid, & ! (in)
5889 #if defined(__GFORTRAN__) && __GNUC__ < 7
5890  cloc(var(1,1,1)), & ! (in)
5891 #elif defined(NVIDIA)
5892  c_loc(work), & ! (in)
5893 #else
5894  c_loc(var), & ! (in)
5895 #endif
5896  ts, te, 3, dp, & ! (in)
5897  start_, shape(var) ) ! (in)
5898 #ifdef NVIDIA
5899  end block
5900 #endif
5901  if ( error /= file_success_code ) then
5902  log_error("FILE_write_realDP_3D",*) 'failed to write data: ', trim(file_vars(vid)%name)
5903  call prc_abort
5904  end if
5905 
5906  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5907 
5908  return
5909  end subroutine file_write_realdp_3d
5910  subroutine file_write_realsp_4d( &
5911  vid, var, &
5912  t_start, t_end, &
5913  start )
5914  implicit none
5915 
5916  integer, intent(in) :: vid
5917 #ifdef NVIDIA
5918  real(sp), intent(in) :: var(:,:,:,:)
5919 #else
5920  real(sp), intent(in), target, contiguous :: var(:,:,:,:)
5921 #endif
5922  real(dp), intent(in) :: t_start
5923  real(dp), intent(in) :: t_end
5924  integer, intent(in), optional :: start(:)
5925  real(dp) :: ts, te
5926 
5927  integer :: start_(4)
5928 
5929  integer :: fid
5930  integer :: error
5931 
5932  intrinsic shape
5933  !---------------------------------------------------------------------------
5934 
5935  ts = t_start
5936  te = t_end
5937 
5938  fid = file_vars(vid)%fid
5939 
5940  if ( .not. file_opened(fid) ) then
5941  log_error("FILE_write_realSP_4D",*) 'File is not opened. fid = ', fid
5942  call prc_abort
5943  end if
5944 
5945  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5946 
5947  ! this is for restart variable which keeps its original shape
5948  if ( present(start) ) then
5949  start_(:) = start(:)
5950  else
5951  start_(:) = 1
5952  end if
5953 
5954  !$acc update host(var) if(acc_is_present(var))
5955 
5956 #ifdef NVIDIA
5957  block
5958  real(sp), allocatable, target :: work(:,:,:,:)
5959  allocate(work, source=var)
5960 #endif
5961  error = file_write_data_c( file_files(fid)%fid, file_vars(vid)%vid, & ! (in)
5962 #if defined(__GFORTRAN__) && __GNUC__ < 7
5963  cloc(var(1,1,1,1)), & ! (in)
5964 #elif defined(NVIDIA)
5965  c_loc(work), & ! (in)
5966 #else
5967  c_loc(var), & ! (in)
5968 #endif
5969  ts, te, 4, sp, & ! (in)
5970  start_, shape(var) ) ! (in)
5971 #ifdef NVIDIA
5972  end block
5973 #endif
5974  if ( error /= file_success_code ) then
5975  log_error("FILE_write_realSP_4D",*) 'failed to write data: ', trim(file_vars(vid)%name)
5976  call prc_abort
5977  end if
5978 
5979  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
5980 
5981  return
5982  end subroutine file_write_realsp_4d
5983  subroutine file_write_realdp_4d( &
5984  vid, var, &
5985  t_start, t_end, &
5986  start )
5987  implicit none
5988 
5989  integer, intent(in) :: vid
5990 #ifdef NVIDIA
5991  real(dp), intent(in) :: var(:,:,:,:)
5992 #else
5993  real(dp), intent(in), target, contiguous :: var(:,:,:,:)
5994 #endif
5995  real(dp), intent(in) :: t_start
5996  real(dp), intent(in) :: t_end
5997  integer, intent(in), optional :: start(:)
5998  real(dp) :: ts, te
5999 
6000  integer :: start_(4)
6001 
6002  integer :: fid
6003  integer :: error
6004 
6005  intrinsic shape
6006  !---------------------------------------------------------------------------
6007 
6008  ts = t_start
6009  te = t_end
6010 
6011  fid = file_vars(vid)%fid
6012 
6013  if ( .not. file_opened(fid) ) then
6014  log_error("FILE_write_realDP_4D",*) 'File is not opened. fid = ', fid
6015  call prc_abort
6016  end if
6017 
6018  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
6019 
6020  ! this is for restart variable which keeps its original shape
6021  if ( present(start) ) then
6022  start_(:) = start(:)
6023  else
6024  start_(:) = 1
6025  end if
6026 
6027  !$acc update host(var) if(acc_is_present(var))
6028 
6029 #ifdef NVIDIA
6030  block
6031  real(dp), allocatable, target :: work(:,:,:,:)
6032  allocate(work, source=var)
6033 #endif
6034  error = file_write_data_c( file_files(fid)%fid, file_vars(vid)%vid, & ! (in)
6035 #if defined(__GFORTRAN__) && __GNUC__ < 7
6036  cloc(var(1,1,1,1)), & ! (in)
6037 #elif defined(NVIDIA)
6038  c_loc(work), & ! (in)
6039 #else
6040  c_loc(var), & ! (in)
6041 #endif
6042  ts, te, 4, dp, & ! (in)
6043  start_, shape(var) ) ! (in)
6044 #ifdef NVIDIA
6045  end block
6046 #endif
6047  if ( error /= file_success_code ) then
6048  log_error("FILE_write_realDP_4D",*) 'failed to write data: ', trim(file_vars(vid)%name)
6049  call prc_abort
6050  end if
6051 
6052  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
6053 
6054  return
6055  end subroutine file_write_realdp_4d
6056 
6057  !-----------------------------------------------------------------------------
6058  ! exit netCDF define mode and enter data mode
6059  subroutine file_enddef( fid )
6060  implicit none
6061 
6062  integer, intent(in) :: fid
6063 
6064  integer :: error
6065  !---------------------------------------------------------------------------
6066 
6067  if ( .not. file_opened(fid) ) return
6068 
6069  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
6070 
6071  error = file_enddef_c( file_files(fid)%fid )
6072 
6073  if ( error == file_success_code ) then
6074 
6075  log_newline
6076  log_info("FILE_enddef",'(1x,A,I3.3,2A)') &
6077  'End define mode : No.', fid, ', name = ', trim(file_files(fid)%name)
6078 
6079  else
6080  log_error("FILE_enddef",*) 'failed to exit define mode'
6081  call prc_abort
6082  end if
6083 
6084  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
6085 
6086  return
6087  end subroutine file_enddef
6088 
6089  !-----------------------------------------------------------------------------
6090  ! enter netCDF define mode and enter data mode
6091  subroutine file_redef( fid )
6092  implicit none
6093 
6094  integer, intent(in) :: fid
6095 
6096  integer :: error
6097  !---------------------------------------------------------------------------
6098 
6099  if ( .not. file_opened(fid) ) return
6100 
6101  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
6102 
6103  error = file_redef_c( file_files(fid)%fid )
6104 
6105  if ( error == file_success_code ) then
6106 
6107  log_newline
6108  log_info("FILE_redef",'(1x,A,I3.3,2A)') &
6109  'Enter to define mode : No.', fid, ', name = ', trim(file_files(fid)%name)
6110 
6111  else
6112  log_error("FILE_redef",*) 'failed to enter to define mode'
6113  call prc_abort
6114  end if
6115 
6116  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
6117 
6118  return
6119  end subroutine file_redef
6120 
6121  !-----------------------------------------------------------------------------
6122  ! This subroutine is used when PnetCDF I/O method is enabled
6123  subroutine file_attach_buffer( &
6124  fid, &
6125  buf_amount )
6126  implicit none
6127 
6128  integer, intent(in) :: fid
6129  integer(8), intent(in) :: buf_amount
6130 
6131  integer :: error
6132  !---------------------------------------------------------------------------
6133 
6134  if ( .not. file_opened(fid) ) return
6135 
6136  if ( file_files(fid)%buffer_size > 0 ) then
6137  call file_detach_buffer(fid)
6138  end if
6139 
6140  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
6141 
6142  error = file_attach_buffer_c( file_files(fid)%fid, buf_amount )
6143 
6144  if ( error /= file_success_code ) then
6145  log_error("FILE_attach_buffer",*) 'failed to attach buffer in PnetCDF'
6146  call prc_abort
6147  end if
6148 
6149  log_newline
6150  log_info("FILE_attach_buffer",'(1x,A,I3.3,3A,I10)') &
6151  'Attach buffer : No.', fid, ', name = ', trim(file_files(fid)%name), &
6152  ', size = ', buf_amount
6153 
6154  file_files(fid)%buffer_size = buf_amount
6155 
6156  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
6157 
6158  return
6159  end subroutine file_attach_buffer
6160 
6161  !-----------------------------------------------------------------------------
6162  ! This subroutine is used when PnetCDF I/O method is enabled
6163  subroutine file_detach_buffer( fid )
6164  implicit none
6165 
6166  integer, intent(in) :: fid
6167 
6168  integer :: error
6169  !---------------------------------------------------------------------------
6170 
6171  if ( .not. file_opened(fid) ) return
6172 
6173  if ( file_files(fid)%fid < 0 ) return ! already closed
6174 
6175  if ( file_files(fid)%buffer_size < 0 ) return ! not attached
6176 
6177  call prof_rapstart('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
6178 
6179  error = file_detach_buffer_c( file_files(fid)%fid )
6180 
6181  if ( error /= file_success_code ) then
6182  log_error("FILE_detach_buffer",*) 'failed to detach buffer in PnetCDF'
6183  call prc_abort
6184  end if
6185 
6186  log_newline
6187  log_info("FILE_detach_buffer",'(1x,A,I3.3,2A)') &
6188  'Detach buffer : No.', fid, ', name = ', trim(file_files(fid)%name)
6189 
6190  file_files(fid)%buffer_size = -1
6191 
6192  call prof_rapend ('FILE_Write', 2, disable_barrier = .not. file_files(fid)%allnodes )
6193 
6194  return
6195  end subroutine file_detach_buffer
6196 
6197  !-----------------------------------------------------------------------------
6198  ! flush data
6199  subroutine file_flush( fid )
6200  implicit none
6201 
6202  integer, intent(in) :: fid
6203 
6204  integer :: error
6205  !---------------------------------------------------------------------------
6206 
6207  if ( .not. file_opened(fid) ) return
6208 
6209  if ( file_files(fid)%fid < 0 ) return ! already closed
6210 
6211  call prof_rapstart('FILE', 2, disable_barrier = .not. file_files(fid)%allnodes )
6212 
6213  error = file_flush_c( file_files(fid)%fid )
6214 
6215  if ( error == file_success_code ) then
6216 
6217 !!$ LOG_NEWLINE
6218 !!$ LOG_INFO("FILE_flush",'(1xA,I3.3,2A)') &
6219 !!$ 'Flush : No.', fid, ', name = ', trim(FILE_files(fid)%name)
6220 
6221  else
6222  log_error("FILE_flush",*) 'failed to flush data to netcdf file'
6223  call prc_abort
6224  end if
6225 
6226  call prof_rapend ('FILE', 2, disable_barrier = .not. file_files(fid)%allnodes )
6227 
6228  return
6229  end subroutine file_flush
6230 
6231  !-----------------------------------------------------------------------------
6232  subroutine file_close( fid, abort )
6233  implicit none
6234  integer, intent(in) :: fid
6235  logical, intent(in), optional :: abort
6236 
6237  logical(c_bool) :: abort_
6238  integer :: error
6239  integer :: n
6240  !---------------------------------------------------------------------------
6241 
6242  if ( .not. file_opened(fid) ) return
6243 
6244  if ( file_files(fid)%fid < 0 ) return ! already closed
6245 
6246  call prof_rapstart('FILE', 2, disable_barrier = .not. file_files(fid)%allnodes )
6247 
6248  if ( present(abort) ) then
6249  abort_ = abort
6250  else
6251  abort_ = .false.
6252  end if
6253 
6254  error = file_close_c( file_files(fid)%fid, abort_ )
6255 
6256  if ( error == file_success_code ) then
6257 
6258  log_newline
6259  log_info("FILE_close",'(1x,A,I3.3,2A)') &
6260  'Close : No.', fid, ', name = ', trim(file_files(fid)%name)
6261 
6262  elseif( error /= file_already_closed_code ) then
6263  log_error("FILE_close",*) 'failed to close file: ', trim(file_files(fid)%name)
6264  if ( .not. abort_ ) call prc_abort
6265  end if
6266 
6267  file_files(fid)%fid = -1
6268  file_files(fid)%name = ''
6269  file_files(fid)%aggregate = .false.
6270  file_files(fid)%buffer_size = -1
6271 
6272  do n = 1, file_nvars
6273  if ( file_vars(n)%fid == fid ) then
6274  file_vars(n)%vid = -1
6275  file_vars(n)%name = ''
6276  end if
6277  end do
6278 
6279  call prof_rapend ('FILE', 2, disable_barrier = .not. file_files(fid)%allnodes )
6280 
6281  return
6282  end subroutine file_close
6283  !-----------------------------------------------------------------------------
6284  subroutine file_close_all( &
6285  skip_abort )
6286  implicit none
6287  logical, intent(in), optional :: skip_abort
6288 
6289  integer :: fid
6290  !---------------------------------------------------------------------------
6291 
6292  do fid = 1, file_nfiles
6293  call file_close( fid, skip_abort )
6294  enddo
6295 
6296  return
6297  end subroutine file_close_all
6298 
6299  !-----------------------------------------------------------------------------
6301  !-----------------------------------------------------------------------------
6302  subroutine file_get_cftunits(date, tunits)
6303  implicit none
6304 
6305  integer, intent(in) :: date(6)
6306  character(len=*), intent(out) :: tunits
6307  !---------------------------------------------------------------------------
6308 
6309  write(tunits,'(a,i4.4,"-",i2.2,"-",i2.2," ",i2.2,":",i2.2,":",i2.2)') 'seconds since ', date
6310 
6311  return
6312  end subroutine file_get_cftunits
6313 
6314  function file_get_aggregate( fid )
6315  integer, intent(in) :: fid
6316  logical :: file_get_aggregate
6317 
6318  if ( .not. file_opened(fid) ) then
6319  file_get_aggregate = .false.
6320  else
6321  file_get_aggregate = file_files(fid)%aggregate
6322  end if
6323 
6324  return
6325  end function file_get_aggregate
6326 
6327  !-----------------------------------------------------------------------------
6328  ! private
6329  !-----------------------------------------------------------------------------
6330 
6331  !-----------------------------------------------------------------------------
6332  subroutine file_get_fid( &
6333  basename, &
6334  mode, &
6335  rankid, &
6336  single, &
6337  fid, &
6338  existed, &
6339  allnodes, &
6340  aggregate, &
6341  postfix )
6342  use scale_prc, only: &
6345  implicit none
6346 
6347  character(len=*), intent( in) :: basename
6348  integer, intent( in) :: mode
6349  integer, intent( in) :: rankid
6350  logical, intent( in) :: single
6351 
6352  integer, intent(out) :: fid
6353  logical, intent(out) :: existed
6354 
6355  logical, intent( in), optional :: allnodes
6356  logical, intent( in), optional :: aggregate
6357  character(len=*), intent( in), optional :: postfix
6358 
6359  character(len=FILE_HSHORT) :: rwname(0:2)
6360  data rwname / 'READ','WRITE','APPEND' /
6361 
6362  character(len=FILE_HLONG) :: fname
6363  integer :: n
6364 
6365  logical :: allnodes_
6366  logical :: aggregate_
6367  integer :: cfid
6368  integer :: error
6369  integer :: mpi_comm
6370  !---------------------------------------------------------------------------
6371 
6372  !--- check aggregate (parallel I/O on a single shared netCDF file)
6373 
6374  if ( present(allnodes) ) then
6375  allnodes_ = allnodes
6376  else
6377  allnodes_ = .true.
6378  end if
6379 
6380  ! check to do PnetCDF I/O
6381  if ( present(aggregate) ) then
6382  aggregate_ = aggregate
6383  else
6384  aggregate_ = file_aggregate
6385  end if
6386 
6387  if ( aggregate_ ) then
6388  mpi_comm = prc_local_comm_world
6389  else
6390  mpi_comm = prc_comm_null
6391  end if
6392 
6393  if ( present(postfix) ) then
6394  call io_get_fname(fname, trim(basename)//trim(postfix))
6395  elseif ( aggregate_ ) then
6396  call io_get_fname(fname, basename)
6397  elseif ( single ) then
6398  call io_get_fname(fname, basename, rank=-1)
6399  else
6400  call io_get_fname(fname, basename, rank=rankid)
6401  endif
6402 
6403  !--- search existing file
6404  fid = -1
6405  do n = 1, file_nfiles
6406  if ( fname == file_files(n)%name ) then
6407  fid = n
6408  exit
6409  end if
6410  enddo
6411 
6412  if ( file_opened(fid) ) then
6413  existed = .true.
6414  return
6415  end if
6416 
6417  call prof_rapstart('FILE', 2, disable_barrier = ( .not. allnodes_ ) .or. single )
6418 
6419  error = file_open_c( cfid, & ! (out)
6420  cstr(fname), mode, mpi_comm ) ! (in)
6421 
6422  if ( error /= file_success_code ) then
6423  log_error("FILE_get_fid",*) 'failed to open file :'//trim(fname)//'.nc'
6424  call prc_abort
6425  end if
6426 
6427  file_nfiles = file_nfiles + 1
6428  fid = file_nfiles
6429 
6430  file_files(fid)%name = fname
6431  file_files(fid)%fid = cfid
6432  file_files(fid)%aggregate = aggregate_
6433  file_files(fid)%single = single
6434  file_files(fid)%allnodes = allnodes_ .and. (.not. single)
6435  file_files(fid)%buffer_size = -1
6436 
6437  log_newline
6438  log_info("FILE_get_fid",'(1x,A,A6,A,I3.3,2A)') &
6439  'Registration (', trim(rwname(mode)), ') : No.', fid, ', name = ', trim(fname)
6440 
6441  existed = .false.
6442 
6443  call prof_rapend ('FILE', 2, disable_barrier = .not. file_files(fid)%allnodes )
6444 
6445  return
6446  end subroutine file_get_fid
6447 
6448 #if defined(__GFORTRAN__) && __GNUC__ < 7
6449  function cloc_sp( x )
6450  use iso_c_binding
6451  implicit none
6452  real(sp), target, intent(in) :: x
6453  type(c_ptr) :: cloc_sp
6454  cloc_sp = c_loc(x)
6455  return
6456  end function cloc_sp
6457  function cloc_dp( x )
6458  use iso_c_binding
6459  implicit none
6460  real(dp), target, intent(in) :: x
6461  type(c_ptr) :: cloc_dp
6462  cloc_dp = c_loc(x)
6463  return
6464  end function cloc_dp
6465 #endif
6466 
6467 end module scale_file
6468 !-------------------------------------------------------------------------------
6469 
6470 
6471 !--
6472 ! vi:set readonly sw=4 ts=8
6473 !
6474 !Local Variables:
6475 !mode: f90
6476 !buffer-read-only: t
6477 !End:
6478 !
6479 !++
scale_precision::sp
integer, parameter, public sp
Definition: scale_precision.F90:31
scale_file::file_get_stepsize
subroutine, public file_get_stepsize(fid, varname, len, error)
get number of steps
Definition: scale_file.F90:3334
scale_prc::prc_abort
subroutine, public prc_abort
Abort Process.
Definition: scale_prc.F90:349
file_add_associatedvariable_c
int file_add_associatedvariable_c(const int fid, const char *vname)
Definition: scale_file_netcdf.c:1204
file_def_axis_c
int file_def_axis_c(const int fid, const char *name, const char *desc, const char *units, const char *dim_name, const int dtype, const int dim_size, const int bounds)
Definition: scale_file_netcdf.c:1286
scale_file::file_close_all
subroutine, public file_close_all(skip_abort)
Definition: scale_file.F90:6286
scale_file::file_open
subroutine, public file_open(basename, fid, mode, single, allnodes, aggregate, rankid, postfix)
Definition: scale_file.F90:535
file_read_data_c
int file_read_data_c(void *var, const datainfo_t *dinfo, const int precision, const int ntypes, const int dtype, const int *start, const int *count)
Definition: scale_file_netcdf.c:697
scale_file::file_enddef
subroutine, public file_enddef(fid)
Definition: scale_file.F90:6060
file_write_associatedcoordinate_c
int file_write_associatedcoordinate_c(const int fid, const char *name, const void *val, const int ndims, const int precision, const int *start, const int *count)
Definition: scale_file_netcdf.c:1500
file_detach_buffer_c
int file_detach_buffer_c(const int fid)
Definition: scale_file_netcdf.c:1854
scale_prc::prc_set_file_closer
subroutine, public prc_set_file_closer(routine)
Definition: scale_prc.F90:1001
scale_precision
module PRECISION
Definition: scale_precision.F90:14
file_set_attribute_float_c
int file_set_attribute_float_c(const int fid, const char *vname, const char *key, const float *value, const int len)
Definition: scale_file_netcdf.c:1124
scale_prc::prc_local_comm_world
integer, public prc_local_comm_world
local communicator
Definition: scale_prc.F90:88
scale_file::file_attach_buffer
subroutine, public file_attach_buffer(fid, buf_amount)
Definition: scale_file.F90:6126
file_get_dim_length_c
int file_get_dim_length_c(int *len, const int fid, const char *dimname, const bool suppress)
Definition: scale_file_netcdf.c:258
scale_file::file_flush
subroutine, public file_flush(fid)
Definition: scale_file.F90:6200
scale_prof::prof_rapstart
subroutine, public prof_rapstart(rapname_base, level, disable_barrier)
Start raptime.
Definition: scale_prof.F90:174
scale_file::file_allnodes
logical function, public file_allnodes(fid)
check if the file is allnodes
Definition: scale_file.F90:611
file_redef_c
int file_redef_c(const int fid)
Definition: scale_file_netcdf.c:1829
file_close_c
int file_close_c(const int fid, const bool abort)
Definition: scale_file_netcdf.c:2006
scale_file::file_get_dimlength
subroutine, public file_get_dimlength(fid, dimname, len, error)
get length of dimension
Definition: scale_file.F90:632
scale_file::file_opened
logical function, public file_opened(fid)
check if the file is opened?
Definition: scale_file.F90:577
scale_file
module file
Definition: scale_file.F90:15
file_get_attribute_double_c
int file_get_attribute_double_c(double *value, const int fid, const char *vname, const char *key, const bool suppress, const int len)
Definition: scale_file_netcdf.c:997
scale_file::file_def_axis
subroutine, public file_def_axis(fid, name, desc, units, dim_name, dtype, dim_size, bounds)
Definition: scale_file.F90:769
file_get_step_size_c
int file_get_step_size_c(int *len, const int fid, const char *varname)
Definition: scale_file_netcdf.c:643
file_get_varname_c
int file_get_varname_c(char *name, const int fid, const int vid, const int len)
Definition: scale_file_netcdf.c:320
scale_prc
module PROCESS
Definition: scale_prc.F90:11
file_get_attribute_int_c
int file_get_attribute_int_c(int *value, const int fid, const char *vname, const char *key, const bool suppress, const int len)
Definition: scale_file_netcdf.c:911
scale_io
module STDIO
Definition: scale_io.F90:10
scale_prc::prc_comm_null
integer, parameter, public prc_comm_null
Definition: scale_prc.F90:68
scale_file::file_close
subroutine, public file_close(fid, abort)
Definition: scale_file.F90:6233
scale_file::file_def_associatedcoordinate
subroutine, public file_def_associatedcoordinate(fid, name, desc, units, dim_names, dtype)
Definition: scale_file.F90:1471
scale_file::i
logical, public i
Definition: scale_file.F90:196
file_set_attribute_text_c
int file_set_attribute_text_c(const int fid, const char *vname, const char *key, const char *value)
Definition: scale_file_netcdf.c:1040
file_put_associatedcoordinate_c
int file_put_associatedcoordinate_c(const int fid, const char *name, const char *desc, const char *units, const char **dim_names, const int ndims, const int dtype, const void *val, const int precision)
Definition: scale_file_netcdf.c:1397
scale_file_h::file_already_existed_code
integer, parameter, public file_already_existed_code
Definition: scale_file_h.F90:42
scale_prof
module profiler
Definition: scale_prof.F90:11
file_get_datainfo_c
int file_get_datainfo_c(datainfo_t *dinfo, const int fid, const char *varname, const int step, const bool suppress)
Definition: scale_file_netcdf.c:345
scale_precision::dp
integer, parameter, public dp
Definition: scale_precision.F90:32
file_set_attribute_double_c
int file_set_attribute_double_c(const int fid, const char *vname, const char *key, const double *value, const int len)
Definition: scale_file_netcdf.c:1166
scale_file_h
module file_h
Definition: scale_file_h.F90:11
scale_file_h::file_fappend
integer, parameter, public file_fappend
Definition: scale_file_h.F90:36
scale_file::file_add_associatedvariable
subroutine, public file_add_associatedvariable(fid, vname, existed)
Definition: scale_file.F90:463
file_write_data_c
int file_write_data_c(const int fid, const int vid, const void *var, const double t_start, const double t_end, const int ndims, const int precision, const int *start, const int *count)
Definition: scale_file_netcdf.c:1882
file_open_c
int file_open_c(int *fid, const char *fname, const int mode, const int comm)
Definition: scale_file_netcdf.c:170
scale_file::file_single
logical function, public file_single(fid)
check if the file is single
Definition: scale_file.F90:594
scale_file::file_get_cftunits
subroutine, public file_get_cftunits(date, tunits)
get unit of time
Definition: scale_file.F90:6303
file_get_attribute_float_c
int file_get_attribute_float_c(float *value, const int fid, const char *vname, const char *key, const bool suppress, const int len)
Definition: scale_file_netcdf.c:954
scale_file::file_aggregate
logical, public file_aggregate
Definition: scale_file.F90:196
file_attach_buffer_c
int file_attach_buffer_c(const int fid, const int64_t buf_amount)
Definition: scale_file_netcdf.c:1840
file_write_axis_c
int file_write_axis_c(const int fid, const char *name, const void *val, const int precision, const int *start, const int *count)
Definition: scale_file_netcdf.c:1351
scale_file_h::file_fread
integer, parameter, public file_fread
Definition: scale_file_h.F90:34
scale_file_h::file_success_code
integer, parameter, public file_success_code
Definition: scale_file_h.F90:40
scale_file::file_def_variable
subroutine, public file_def_variable(fid, varname, desc, units, standard_name, ndims, dims, dtype, vid, time_int, time_stats, existed)
Definition: scale_file.F90:2380
file_get_attribute_text_c
int file_get_attribute_text_c(char *value, const int fid, const char *vname, const char *key, const bool suppress, const int len)
Definition: scale_file_netcdf.c:864
scale_file::file_redef
subroutine, public file_redef(fid)
Definition: scale_file.F90:6092
scale_file_h::file_var_max
integer, parameter, public file_var_max
Definition: scale_file_h.F90:46
scale_file::file_create
subroutine, public file_create(basename, title, source, institution, fid, existed, rankid, single, aggregate, time_units, calendar, allnodes, append)
create file fid is >= 1
Definition: scale_file.F90:295
file_def_associatedcoordinate_c
int file_def_associatedcoordinate_c(const int fid, const char *name, const char *desc, const char *units, const char **dim_names, const int ndims, const int dtype)
Definition: scale_file_netcdf.c:1450
scale_file_h::cstr
character(:, c_char) function, allocatable, target, public cstr(str)
Definition: scale_file_h.F90:94
scale_file::file_get_aggregate
logical function, public file_get_aggregate(fid)
Definition: scale_file.F90:6315
scale_file::file_finalize
subroutine, public file_finalize
finalize
Definition: scale_file.F90:277
file_add_variable_c
int file_add_variable_c(int *vid, const int fid, const char *varname, const char *desc, const char *units, const char *stdname, const char **dims, const int ndims, const int dtype, const double tint, const char *tstats)
Definition: scale_file_netcdf.c:1550
file_set_tunits_c
int file_set_tunits_c(const int fid, const char *time_units, const char *calendar)
Definition: scale_file_netcdf.c:1227
scale_prof::prof_rapend
subroutine, public prof_rapend(rapname_base, level, disable_barrier)
Save raptime.
Definition: scale_prof.F90:246
scale_file::file_detach_buffer
subroutine, public file_detach_buffer(fid)
Definition: scale_file.F90:6164
file_put_axis_c
int file_put_axis_c(const int fid, const char *name, const char *desc, const char *units, const char *dim_name, const int dtype, const void *val, const int size, const int precision)
Definition: scale_file_netcdf.c:1237
file_set_option_c
int file_set_option_c(const int fid, const char *filetype, const char *key, const char *val)
Definition: scale_file_netcdf.c:287
scale_file::file_setup
subroutine, public file_setup(myrank)
setup
Definition: scale_file.F90:236
file_get_nvars_c
int file_get_nvars_c(int *nvars, const int fid)
Definition: scale_file_netcdf.c:303
scale_file_h::file_file_max
integer, parameter, public file_file_max
Definition: scale_file_h.F90:45
file_set_attribute_int_c
int file_set_attribute_int_c(const int fid, const char *vname, const char *key, const int *value, const int len)
Definition: scale_file_netcdf.c:1081
scale_io::io_fid_conf
integer, public io_fid_conf
Config file ID.
Definition: scale_io.F90:57
file_enddef_c
int file_enddef_c(const int fid)
Definition: scale_file_netcdf.c:1818
scale_file::file_set_option
subroutine, public file_set_option(fid, filetype, key, val)
Definition: scale_file.F90:500
scale_file_h::file_fwrite
integer, parameter, public file_fwrite
Definition: scale_file_h.F90:35
file_flush_c
int file_flush_c(const int fid)
Definition: scale_file_netcdf.c:1867