hstnmlinfoenddefine.f90 File Reference

Transit from define mode to output mode . More...

Go to the source code of this file.

Functions/Subroutines
subroutine	hstnmlinfoenddefine (gthstnml, err)

Detailed Description

Transit from define mode to output mode

.

Author

Yasuhiro MORIKAWA

Copyright

Copyright (C) GFD Dennou Club, 2007-2026. All rights reserved.
License is BSD-2-Clause. See COPYRIGHT in detail

Definition in file hstnmlinfoenddefine.f90.

Function/Subroutine Documentation

hstnmlinfoenddefine()

subroutine hstnmlinfoenddefine	(	type(gthst_nmlinfo), intent(inout)	gthstnml,
		logical, intent(out), optional	err
	)

Transit from define mode to output mode

Transit from define mode to output mode, and determine information configured in gthstnml. Use this subroutine before HstNmlInfoAssocGTHist is used. If HstNmlInfoAdd, HstNmlInfoDelete, HstNmlInfoResetDefault are used after this subroutine is used, error is occurred.

If gthstnml is not initialized by HstNmlInfoCreate yet, error is occurred.

Parameters

[in,out]	gthstnml	gtool_history_nmlinfo_types::GTHST_NMLINFO 型変数
[out]	err	例外処理用フラグ. Exception handling flag.

Definition at line 46 of file hstnmlinfoenddefine.f90.

    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 )

References dc_trace::beginsub(), dc_error::dc_enotinit, dc_error::dc_noerr, dc_trace::endsub(), dc_error::hst_ebadnewfileint, dc_error::hst_ebadorigin, dc_error::hst_ebadslice, dc_error::hst_ebadterminus, dc_error::hst_eintfile, dc_error::hst_enotindefine, dc_string::joinchar(), gtool_history_nmlinfo_internal::opened_files, dc_types::sp_eps, dc_error::storeerror(), and dc_types::string.

Here is the call graph for this function: