historyputline.f90

Go to the documentation of this file.

 
 
  subroutine historyputline( history, unit, indent, err )
    !
    use gtool_history_types, only: gt_history
    use gtool_history_internal, only: default
    use gtool_history_generic, only: historyinquire
    use gtdata_generic, only: gtputline => putline
    use dc_trace, only: beginsub, endsub
    use dc_string, only: printf, joinchar, strputline => putline
    use dc_types, only: string, token, stdout, dp
    use dc_error, only: storeerror, dc_noerr
    implicit none
    type(gt_history), intent(in), target, optional:: history
    integer, intent(in), optional:: unit
                              ! 出力先の装置番号. 
                              ! デフォルトの出力先は標準出力. 
                              !
                              ! Unit number for output. 
                              ! Default value is standard output. 
    character(*), intent(in), optional:: indent
                              ! 表示されるメッセージの字下げ. 
                              !
                              ! Indent of displayed messages. 
    logical, intent(out), optional:: err
                              ! 例外処理用フラグ. 
                              ! デフォルトでは, この手続き内でエラーが
                              ! 生じた場合, プログラムは強制終了します. 
                              ! 引数 *err* が与えられる場合, 
                              ! プログラムは強制終了せず, 代わりに
                              ! *err* に .true. が代入されます. 
                              !
                              ! Exception handling flag. 
                              ! By default, when error occur in 
                              ! this procedure, the program aborts. 
                              ! If this *err* argument is given, 
                              ! .true. is substituted to *err* and 
                              ! the program does not abort. 
 
    !-----------------------------------
    !  作業変数
    !  Work variables
    type(gt_history), pointer:: hst =>null()
    integer:: i, max
    integer:: stat
    character(STRING):: cause_c
    integer:: out_unit
    integer:: indent_len
    character(STRING):: indent_str
 
    character(STRING):: file, title, source, institution
    character(STRING):: conventions, gt_version
    character(TOKEN), pointer:: dims(:) =>null()
    integer, pointer:: dimsizes(:) =>null()
    character(STRING), pointer:: longnames(:) =>null()
    character(TOKEN), pointer:: units(:) =>null()
    character(TOKEN), pointer:: xtypes(:) =>null()
 
    real(DP):: origin, interval, newest, oldest
    character(*), parameter:: subname = 'HistoryPutLine'
  continue
    call beginsub( subname )
    stat = dc_noerr
    cause_c = ''
 
    !-----------------------------------------------------------------
    !  出力先装置番号と字下げの設定
    !  Configure output unit number and indents
    !-----------------------------------------------------------------
    if ( present(unit) ) then
      out_unit = unit
    else
      out_unit = stdout
    end if
 
    indent_len = 0
    indent_str = ''
    if ( present(indent) ) then
      if ( len(indent) /= 0 ) then
        indent_len = len(indent)
        indent_str(1:indent_len) = indent
      end if
    end if
 
    if (present(history)) then
      hst => history
    else
      hst => default
    endif
 
    !-----------------------------------------------------------------
    !  "GT_HISTORY" の設定の印字
    !  Print the settings for "GT_HISTORY"
    !-----------------------------------------------------------------
    if ( hst % initialized ) then
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & '#<GT_HISTORY:: @initialized=%y', &
        & l = (/hst % initialized/) )
 
      call historyinquire( history = hst, &             ! (in)
        & err = err, &                                  ! (out)
        & file = file, title = title, &                 ! (out)
        & source = source, institution = institution, & ! (out)
        & dims = dims, dimsizes = dimsizes, &           ! (out)
        & longnames = longnames, &                      ! (out)
        & units = units, xtypes = xtypes, &             ! (out)
        & conventions = conventions, &                  ! (out)
        & gt_version = gt_version )                     ! (out)
 
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & ' @file=%c @title=%c', &
        & c1 = trim(file), c2 = trim(title) )
 
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & ' @source=%c @institution=%c', &
        & c1 = trim(source), c2 = trim(institution) )
 
      max = size( dims )
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & ' @dims=%c @dimsizes=%*d', &
        & c1 = trim( joinchar(dims, ',') ), &
        & i = dimsizes, n = (/max/) )
      deallocate( dims, dimsizes )
 
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & ' @longnames=%c', &
        & c1 = trim( joinchar(longnames, ',') ) )
      deallocate( longnames )
 
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & ' @units=%c @xtypes=%c', &
        & c1 = trim( joinchar(units, ',') ), &
        & c2 = trim( joinchar(xtypes, ',') ) )
      deallocate( units, xtypes )
 
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & ' @conventions=%c @gt_version=%c', &
        & c1 = trim(conventions), c2 = trim(gt_version) )
 
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & ' @unlimited_index=%d', &
        & i = (/hst % unlimited_index/) )
 
      max = size( hst % dim_value_written )
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & ' @dim_value_written=%*y', &
        & l = hst % dim_value_written, n = (/max/) )
 
      origin   = real(hst % origin, kind=kind(origin))
      interval = real(hst % interval, kind=kind(interval))
      newest   = real(hst % newest, kind=kind(newest))
      oldest   = real(hst % oldest, kind=kind(oldest))
 
!!$      origin   = EvalByUnit( hst % origin, '', hst % unlimited_units_symbol )
!!$      interval = EvalByUnit( hst % interval, '', hst % unlimited_units_symbol )
!!$      newest   = EvalByUnit( hst % newest, '', hst % unlimited_units_symbol )
!!$      oldest   = EvalByUnit( hst % oldest, '', hst % unlimited_units_symbol )
 
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & ' @origin=%r @interval=%r @newest=%r @oldest=%r', &
        & d = (/origin, interval, newest, oldest/) )
 
      if ( associated( hst % growable_indices ) ) then
        max = size( hst % growable_indices )
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @growable_indices=%*d', &
          & i = hst % growable_indices, n = (/max/) )
      else
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @growable_indices=<null>' )
      end if
 
      if ( associated( hst % count ) ) then
        max = size( hst % count )
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @count=%*d', &
          & i = hst % count, n = (/max/) )
      else
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @count=<null>' )
      end if
 
      if ( associated( hst % dimvars ) ) then
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @dimvars=' )
        max = size( hst % dimvars )
        do i = 1, max
          call gtputline( hst % dimvars(i), out_unit, &
            & indent_str(1:indent_len) // '  ', err )
        end do
      else
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @dimvars=<null>' )
      end if
 
      if ( associated( hst % vars ) ) then
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @vars=' )
        max = size( hst % vars )
        do i = 1, max
          call gtputline( hst % vars(i), out_unit, &
            & indent_str(1:indent_len) // '  ', err )
        end do
      else
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @vars=<null>' )
      end if
 
      if ( associated( hst % var_avr_count ) ) then
        max = size( hst % var_avr_count )
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @var_avr_count=%*d', &
          & i = hst % var_avr_count, n = (/max/) )
      else
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @var_avr_count=<null>' )
      end if
 
      if ( associated( hst % var_avr_firstput ) ) then
        max = size( hst % var_avr_firstput )
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @var_avr_firstput=%*b', &
          & l = hst % var_avr_firstput, n = (/max/) )
      else
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @var_avr_firstput=<null>' )
      end if
 
      if ( associated( hst % var_avr_coefsum ) ) then
        max = size( hst % var_avr_coefsum )
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @var_avr_coefsum=%*f', &
          & d = hst % var_avr_coefsum, n = (/max/) )
      else
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @var_avr_coefsum=<null>' )
      end if
 
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & '  @time_bnds=%*f, @time_bnds_output_count=%d', &
        & i = (/hst % time_bnds_output_count/), &
        & d = hst % time_bnds, &
        & n = (/ size(hst % time_bnds) /) )
 
      if ( associated( hst % var_avr_data ) ) then
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @var_avr_data=' )
        max = size( hst % var_avr_data )
        do i = 1, max
          call printf( out_unit, &
            & indent_str(1:indent_len) // &
            & '  #<GT_HISTORY_AVRDATA:: @length=%d', &
            & i = (/hst % var_avr_data(i) % length/) )
          call strputline( hst % var_avr_data(i) % a_DataAvr, unit = out_unit, &
            & lbounds = lbound(hst % var_avr_data(i) % a_DataAvr), &
            & ubounds = ubound(hst % var_avr_data(i) % a_DataAvr), &
            & indent = indent_str(1:indent_len) // &
            & '    @a_DataAvr=' )
        end do
      else
        call printf( out_unit, &
          & indent_str(1:indent_len) // &
          & ' @var_avr_data=<null>' )
      end if
 
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & '>' )
    else
      call printf( out_unit, &
        & indent_str(1:indent_len) // &
        & '#<GT_HISTORY:: @initialized=%y>', &
        & l = (/hst % initialized/) )
    end if
 
    !-----------------------------------------------------------------
    !  終了処理, 例外処理
    !  Termination and Exception handling
    !-----------------------------------------------------------------
    call storeerror( stat, subname, err, cause_c )
    call endsub( subname )
  end subroutine historyputline