hstnmlinfoenddefine.f90

Go to the documentation of this file.

 
 
  subroutine hstnmlinfoenddefine( gthstnml, err )
    use gtool_history_nmlinfo_types, only: gthst_nmlinfo, gthst_nmlinfo_entry
    use gtool_history_nmlinfo_internal, only: listnext, listsearch
    use gtool_history_nmlinfo_internal, only: opened_files
    use dc_trace, only: beginsub, endsub
    use dc_string, only: putline, printf, split, strinclude, stoa, joinchar
    use dc_types, only: string, sp_eps
    use dc_hash, only: hash, dchashput, dchashget, dchashrewind, dchashnext, dchashnumber
    use dc_error, only: storeerror, dc_noerr, dc_enotinit, &
      & hst_enotindefine, hst_eintfile, hst_ebadorigin, hst_ebadterminus, &
      & hst_ebadslice, hst_ebadnewfileint
    use dc_message, only: messagenotify
    implicit none
    type(gthst_nmlinfo), intent(inout):: gthstnml
    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. 
 
    !-----------------------------------
    !  複数の変数を一つのファイルへ出力するためのチェック用変数
    !  Variables for checking for output multiple variables to one file
    character(STRING):: opname, opfile
    logical:: end
 
    !-----------------------------------
    !  作業変数
    !  Work variables
    character(STRING):: fullfilename
    type(gthst_nmlinfo_entry), pointer:: hptr =>null()
    type(gthst_nmlinfo_entry), pointer:: hptr_prev =>null()
    integer:: stat
    character(STRING):: cause_c
    character(*), parameter:: subname = 'HstNmlInfoEndDefine'
  continue
    call beginsub( subname )
    stat = dc_noerr
    cause_c = ''
 
    !-----------------------------------------------------------------
    !  初期設定のチェック
    !  Check initialization
    !-----------------------------------------------------------------
    if ( .not. gthstnml % initialized ) then
      stat = dc_enotinit
      cause_c = 'GTHST_NMLINFO'
      goto 999
    end if
 
    if ( .not. gthstnml % define_mode ) then
      stat = hst_enotindefine
      cause_c = 'EndDefine'
      goto 999
    end if
 
    !-----------------------------------------------------------------
    !  gtool_history_types#GT_HISTORY 変数の割付
    !  Allocate "gtool_history_types#GT_HISTORY" variables
    !-----------------------------------------------------------------
    hptr => gthstnml % gthstnml_list
    if ( .not. associated( hptr % history ) ) then
      allocate( hptr % history )
    end if
    wholeloop : do while ( associated( hptr % next ) )
      call listnext( gthstnml_list = hptr ) ! (inout)
      if ( trim(hptr % name) == '' .or. trim(hptr % file) == '' ) &
        & cycle wholeloop
 
      fullfilename = trim( hptr % fileprefix ) // hptr % file
 
      !---------------------------------------------------------------
      !  以前に同一ファイル名の gtool_history_types#GT_HISTORY 変数がある場合, そちらに結合
      !  If "gtool_history_types#GT_HISTORY" that has same filename exist already, associate to it
      !---------------------------------------------------------------
      nullify( hptr_prev )
      call dchashrewind(opened_files) ! (inout)
      searchloop : do
        call dchashnext( opened_files, & ! (inout)
          & opname, opfile, end )  ! (out)
        if ( end ) exit searchloop
        if ( trim(opfile) /= trim(fullfilename) ) cycle searchloop
        hptr_prev => gthstnml % gthstnml_list
 
        call listsearch( gthstnml_list = hptr_prev, & ! (inout)
          &              name = opname )              ! (in)
        if ( .not. associated( hptr_prev ) ) cycle searchloop
        if ( trim(hptr % name) == trim(hptr_prev % name) ) cycle searchloop
 
        ! interval_value, interval_unit の同一性をチェック
        ! Check consistency of "interval_value", "interval_unit"
        !
        if ( abs(hptr % interval_value - hptr_prev % interval_value) > sp_eps ) then
          call messagenotify( 'W', subname, &
            & '@interval_value=%r (var=%a) and @interval_value=%r (var=%a) are applied to a file "%a"', &
            & r = (/hptr % interval_value, hptr_prev % interval_value/), &
            & ca = stoa(hptr % name, hptr_prev % name, fullfilename) )
          stat = hst_eintfile
          cause_c = fullfilename
          goto 999
        elseif ( hptr % interval_unit /= hptr_prev % interval_unit ) then
          call messagenotify( 'W', subname, &
            & '@interval_unit=%a (var=%a) and @interval_unit=%a (var=%a) are applied to a file "%a"', &
            & ca = stoa(hptr % interval_unit, hptr % name, &
            &           hptr_prev % interval_unit, hptr_prev % name, &
            &           fullfilename) )
          stat = hst_eintfile
          cause_c = fullfilename
          goto 999
        end if
 
        ! origin_value, origin_unit の同一性をチェック
        ! Check consistency of "origin_value", "origin_unit"
        !
        if ( abs(hptr % origin_value - hptr_prev % origin_value) > sp_eps ) then
          call messagenotify( 'W', subname, &
            & '@origin_value=%r (var=%a) and @origin_value=%r (var=%a) are applied to a file "%a"', &
            & r = (/hptr % origin_value, hptr_prev % origin_value/), &
            & ca = stoa(hptr % name, hptr_prev % name, fullfilename) )
          stat = hst_ebadorigin
          cause_c = fullfilename
          goto 999
        elseif ( hptr % origin_unit /= hptr_prev % origin_unit ) then
          call messagenotify( 'W', subname, &
            & '@origin_unit=%a (var=%a) and @origin_unit=%a (var=%a) are applied to a file "%a"', &
            & ca = stoa(hptr % origin_unit, hptr % name, &
            &           hptr_prev % origin_unit, hptr_prev % name, &
            &           fullfilename) )
          stat = hst_ebadorigin
          cause_c = fullfilename
          goto 999
        end if
 
        ! terminus_value, terminus_unit の同一性をチェック
        ! Check consistency of "terminus_value", "terminus_unit"
        !
        if ( abs(hptr % terminus_value - hptr_prev % terminus_value) > sp_eps ) then
          call messagenotify( 'W', subname, &
            & '@terminus_value=%r (var=%a) and @terminus_value=%r (var=%a) are applied to a file "%a"', &
            & r = (/hptr % terminus_value, hptr_prev % terminus_value/), &
            & ca = stoa(hptr % name, hptr_prev % name, fullfilename) )
          stat = hst_ebadterminus
          cause_c = fullfilename
          goto 999
        elseif ( hptr % terminus_unit /= hptr_prev % terminus_unit ) then
          call messagenotify( 'W', subname, &
            & '@terminus_unit=%a (var=%a) and @terminus_unit=%a (var=%a) are applied to a file "%a"', &
            & ca = stoa(hptr % terminus_unit, hptr % name, &
            &           hptr_prev % terminus_unit, hptr_prev % name, &
            &           fullfilename) )
          stat = hst_ebadterminus
          cause_c = fullfilename
          goto 999
        end if
 
        ! newfile_intvalue が有効な場合はエラーを返す. 
        ! Error is occurred when "newfile_intvalue" is valid
        !
        if (      ( hptr % newfile_intvalue > 0.0 ) &
          &  .or. ( hptr_prev % newfile_intvalue > 0.0 ) ) then
          call messagenotify( 'W', subname, &
            & 'when @newfile_intvalue=%d (var=%a) > 0 or' // &
            & ' @newfile_intvalue=%d (var=%a) > 0, multiple variables can not be output to one file "%a"', &
            & i = (/hptr % newfile_intvalue, hptr_prev % newfile_intvalue/), &
            & ca = stoa(hptr % name, hptr_prev % name, fullfilename) )
          stat = hst_ebadnewfileint
          cause_c = fullfilename
          goto 999
        end if
 
        ! newfile_intvalue, newfile_intunit の同一性をチェック
        ! Check consistency of "newfile_intvalue", "newfile_intunit"
        !
        if ( hptr % newfile_intvalue /= hptr_prev % newfile_intvalue ) then
          call messagenotify( 'W', subname, &
            & '@newfile_intvalue=%d (var=%a) and @newfile_intvalue=%d (var=%a) are applied to a file "%a"', &
            & i = (/hptr % newfile_intvalue, hptr_prev % newfile_intvalue/), &
            & ca = stoa(hptr % name, hptr_prev % name, fullfilename) )
          stat = hst_ebadnewfileint
          cause_c = fullfilename
          goto 999
        elseif ( hptr % newfile_intunit /= hptr_prev % newfile_intunit ) then
          call messagenotify( 'W', subname, &
            & '@newfile_intunit=%a (var=%a) and @newfile_intunit=%a (var=%a) are applied to a file "%a"', &
            & ca = stoa(hptr % newfile_intunit, hptr % name, &
            &           hptr_prev % newfile_intunit, hptr_prev % name, &
            &           fullfilename) )
          stat = hst_ebadnewfileint
          cause_c = fullfilename
          goto 999
        end if
 
 
        ! slice_start, slice_end, slice_stride, space_average の同一性チェック
        ! Check consistency of "slice_start", "slice_end", "slice_stride", "space_average"
        !
        if ( any( hptr % slice_start /= hptr_prev % slice_start ) ) then
          call messagenotify( 'W', subname, &
            & '@slice_start=%*d (var=%a) and @slice_start=%*d (var=%a) are applied to a file "%a"', &
            & i = (/hptr % slice_start(1:10), hptr_prev % slice_start(1:10)/), &
            & n = (/10, 10/), &
            & ca = stoa(hptr % name, hptr_prev % name, fullfilename) )
          stat = hst_ebadslice
          cause_c = fullfilename
          goto 999
        elseif ( any( hptr % slice_end /= hptr_prev % slice_end ) ) then
          call messagenotify( 'W', subname, &
            & '@slice_end=%*d (var=%a) and @slice_end=%*d (var=%a) are applied to a file "%a"', &
            & i = (/hptr % slice_end(1:10), hptr_prev % slice_end(1:10)/), &
            & n = (/10, 10/), &
            & ca = stoa(hptr % name, hptr_prev % name, fullfilename) )
          stat = hst_ebadslice
          cause_c = fullfilename
          goto 999
        elseif ( any( hptr % slice_stride /= hptr_prev % slice_stride ) ) then
          call messagenotify( 'W', subname, &
            & '@slice_stride=%*d (var=%a) and @slice_stride=%*d (var=%a) are applied to a file "%a"', &
            & i = (/hptr % slice_stride(1:10), hptr_prev % slice_stride(1:10)/), &
            & n = (/10, 10/), &
            & ca = stoa(hptr % name, hptr_prev % name, fullfilename) )
          stat = hst_ebadslice
          cause_c = fullfilename
          goto 999
        end if
 
        !
        ! GT_HISTORY 変数の結合
        ! Associate "GT_HISTORY" variable
        !
        hptr % history => hptr_prev % history
        exit searchloop
      end do searchloop
 
      !---------------------------------------------------------------
      !  新規に割付
      !  Allocate newly
      !---------------------------------------------------------------
      if ( .not. associated( hptr % history ) ) then
        allocate( hptr % history )
        hptr % history % initialized = .false.
      end if
 
      !---------------------------------------------------------------
      !  割り付けられた名前とファイル名を登録
      !  Regist allocated name and filename
      !---------------------------------------------------------------
      call dchashput( opened_files, &       ! (inout)
        & hptr % name, fullfilename ) ! (in)
 
    end do wholeloop
 
    nullify( hptr )
    nullify( hptr_prev )
 
    !-----------------------------------------------------------------
    !  終了処理, 例外処理
    !  Termination and Exception handling
    !-----------------------------------------------------------------
    gthstnml % define_mode = .false.
999 continue
    call storeerror( stat, subname, err, cause_c )
    call endsub( subname )
  end subroutine hstnmlinfoenddefine