scale_stdio.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
module scale_stdio
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use gtool_file_h, only: &
     file_hshort, &
     file_hmid,   &
     file_hlong
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ included parameters
  !
#include "scalelib.h"
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: io_setup
  public :: io_log_setup
  public :: io_get_available_fid
  public :: io_make_idstr
  public :: io_arg_getfname
  public :: io_cnf_open

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  integer,               public, parameter :: h_short     = file_hshort  
  integer,               public, parameter :: h_mid       = file_hmid    
  integer,               public, parameter :: h_long      = file_hlong   

  character(len=H_MID),  public            :: h_modelname
  character(len=H_MID),  public            :: h_libname
  character(len=H_MID),  public            :: h_source
  character(len=H_MID),  public            :: h_institute = 'AICS/RIKEN'

  character(len=6),      public, parameter :: io_stdout     = "STDOUT"
  integer,               public, parameter :: io_fid_stdout = 6
  integer,               public            :: io_fid_conf   = 7
  integer,               public            :: io_fid_log    = 8

  character(len=H_LONG), public            :: io_log_basename     = 'LOG'
  logical,               public            :: io_l                = .false. 
  logical,               public            :: io_lnml             = .false. 
  logical,               public            :: io_log_suppress     = .false. 
  logical,               public            :: io_log_allnode      = .false. 
  logical,               public            :: io_log_nml_suppress = .false. 

  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  integer, private, parameter :: io_minfid    = 10
  integer, private, parameter :: io_maxfid    = 99

  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine io_setup( &
       MODELNAME,          &
       call_from_launcher, &
       fname_in            )
    implicit none

    namelist / param_io / &
       h_source,            &
       h_institute,         &
       io_log_basename,     &
       io_log_suppress,     &
       io_log_allnode,      &
       io_log_nml_suppress

    character(len=H_MID),  intent(in) :: MODELNAME
    logical,               intent(in) :: call_from_launcher
    character(len=H_LONG), intent(in), optional :: fname_in

    character(len=H_LONG) :: fname
    integer :: ierr
    !---------------------------------------------------------------------------

    if ( call_from_launcher ) then
       if ( present(fname_in) ) then
          fname = fname_in
       else
          write(*,*) ' xxx Not imported name of config file! STOP.'
          stop 1
       endif
    else
       fname = io_arg_getfname( is_master=.true. )
    endif

    !--- Open config file till end
    io_fid_conf = io_cnf_open( fname,           & ! [IN]
                               is_master=.true. ) ! [IN]

    h_modelname = trim(modelname)
    h_libname   = 'SCALE Library ver. '//trim(libversion)
    h_source    = trim(modelname)

    !--- read PARAM
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_io,iostat=ierr)
    if ( ierr > 0 ) then !--- fatal error
       write(*,*) ' xxx Not appropriate names in namelist PARAM_IO . Check!'
       stop 1
    endif

    return
  end subroutine io_setup

  !-----------------------------------------------------------------------------
  subroutine io_log_setup( &
       myrank,   &
       is_master )
    implicit none

    integer, intent(in) :: myrank
    logical, intent(in) :: is_master

    character(len=H_LONG) :: fname
    integer :: ierr
    !---------------------------------------------------------------------------

    if ( .NOT. io_log_suppress ) then
       if ( is_master ) then ! master node
          io_l = .true.
       else
          io_l = io_log_allnode
       endif
    endif

    if ( io_log_nml_suppress ) then
       io_lnml = .false.
    else
       io_lnml = io_l
    endif

    if ( io_l ) then

       !--- Open logfile
       if ( io_log_basename == io_stdout ) then
          io_fid_log = io_fid_stdout
       else
          io_fid_log = io_get_available_fid()
          call io_make_idstr(fname,trim(io_log_basename),'pe',myrank)
          open( unit   = io_fid_log,  &
                file   = trim(fname), &
                form   = 'formatted', &
                iostat = ierr         )
          if ( ierr /= 0 ) then
             write(*,*) 'xxx File open error! :', trim(fname)
             stop 1
          endif
       endif

       write(io_fid_log,*) ''
       write(io_fid_log,*) '                                               -+++++++++;              '
       write(io_fid_log,*) '                                             ++++++++++++++=            '
       write(io_fid_log,*) '                                           ++++++++++++++++++-          '
       write(io_fid_log,*) '                                          +++++++++++++++++++++         '
       write(io_fid_log,*) '                                        .+++++++++++++++++++++++        '
       write(io_fid_log,*) '                                        +++++++++++++++++++++++++       '
       write(io_fid_log,*) '                                       +++++++++++++++++++++++++++      '
       write(io_fid_log,*) '                                      =++++++=x######+++++++++++++;     '
       write(io_fid_log,*) '                                     .++++++X####XX####++++++++++++     '
       write(io_fid_log,*) '         =+xxx=,               ++++  +++++=##+       .###++++++++++-    '
       write(io_fid_log,*) '      ,xxxxxxxxxx-            +++++.+++++=##           .##++++++++++    '
       write(io_fid_log,*) '     xxxxxxxxxxxxx           -+++x#;+++++#+              ##+++++++++.   '
       write(io_fid_log,*) '    xxxxxxxx##xxxx,          ++++# +++++XX                #+++++++++-   '
       write(io_fid_log,*) '   xxxxxxx####+xx+x         ++++#.++++++#                  #+++++++++   '
       write(io_fid_log,*) '  +xxxxxX#X   #Xx#=        =+++#x=++++=#.                  x=++++++++   '
       write(io_fid_log,*) '  xxxxxx#,    x###        .++++#,+++++#=                    x++++++++   '
       write(io_fid_log,*) ' xxxxxx#.                 ++++# +++++x#                     #++++++++   '
       write(io_fid_log,*) ' xxxxxx+                 ++++#-+++++=#                      #++++++++   '
       write(io_fid_log,*) ',xxxxxX                 -+++XX-+++++#,                      +++++++++   '
       write(io_fid_log,*) '=xxxxxX                .++++#.+++++#x                       -++++++++   '
       write(io_fid_log,*) '+xxxxx=                ++++#.++++++#                        ++++++++#   '
       write(io_fid_log,*) 'xxxxxx;               ++++#+=++++=#                         ++++++++#   '
       write(io_fid_log,*) 'xxxxxxx              ,+++x#,+++++#-                        ;++++++++-   '
       write(io_fid_log,*) '#xxxxxx              +++=# +++++xX                         ++++++++#    '
       write(io_fid_log,*) 'xxxxxxxx            ++++#-+++++=#                         +++++++++X    '
       write(io_fid_log,*) '-+xxxxxx+          ++++X#-++++=#.            -++;        =++++++++#     '
       write(io_fid_log,*) ' #xxxxxxxx.      .+++++# +++++#x            =++++-      +++++++++XX     '
       write(io_fid_log,*) ' #xxxxxxxxxx=--=++++++#.++++++#             ++++++    -+++++++++x#      '
       write(io_fid_log,*) '  #+xxxxxxxxxx+++++++#x=++++=#              ++++++;=+++++++++++x#       '
       write(io_fid_log,*) '  =#+xxxxxxxx+++++++##,+++++#=             =++++++++++++++++++##.       '
       write(io_fid_log,*) '   X#xxxxxxxx++++++## +++++x#              ;x++++++++++++++++##.        '
       write(io_fid_log,*) '    x##+xxxx+++++x## +++++=#                ##++++++++++++x##X          '
       write(io_fid_log,*) '     ,###Xx+++x###x -++++=#,                .####x+++++X####.           '
       write(io_fid_log,*) '       -########+   -#####x                   .X#########+.             '
       write(io_fid_log,*) '           .,.      ......                         .,.                  '
       write(io_fid_log,*) '                                                                        '
       write(io_fid_log,*) '    .X#######     +###-        =###+           ###x         x########   '
       write(io_fid_log,*) '   .#########    ######X      #######         ####        .#########x   '
       write(io_fid_log,*) '   ####+++++=   X#######.    -#######x       .###;        ####x+++++.   '
       write(io_fid_log,*) '   ###          ###= ####    #### x###       ####        -###.          '
       write(io_fid_log,*) '  .###         ####   ###+  X###   ###X     =###.        ####           '
       write(io_fid_log,*) '   ###-       ;###,        .###+   -###     ####        x##########+    '
       write(io_fid_log,*) '   +####x     ####         ####     ####   ####         ###########.    '
       write(io_fid_log,*) '    x######. =###          ###,     .###-  ###+        x###--------     '
       write(io_fid_log,*) '      =##### X###         -###       #### ,###         ####             '
       write(io_fid_log,*) '        .###=x###;        .###+       ###X ###X        ####.            '
       write(io_fid_log,*) ' ###########; ###########+ ###########     ########### ,##########.     '
       write(io_fid_log,*) '-###########  ,##########,  #########X      ##########  +#########      '
       write(io_fid_log,*) ',,,,,,,,,,.     ,,,,,,,,,    .,,,,,,,.       .,,,,,,,,    ,,,,,,,,      '
       write(io_fid_log,*) '                                                                        '
       write(io_fid_log,*) '    SCALE : Scalable Computing by Advanced Library and Environment      '
       write(io_fid_log,*) ''
       write(io_fid_log,*) trim(h_libname)
       write(io_fid_log,*) trim(h_modelname)
       write(io_fid_log,*) ''
       write(io_fid_log,*) '++++++ Module[STDIO] / Categ[IO] / Origin[SCALElib]'
       write(io_fid_log,*) ''
       write(io_fid_log,*) '*** Open config file, FID = ', io_fid_conf
       write(io_fid_log,*) '*** Open log    file, FID = ', io_fid_log
       write(io_fid_log,*) '*** basename of log file  = ', trim(io_log_basename)
       write(io_fid_log,*) '*** detailed log output   = ', io_lnml

    else
       if( is_master ) write(*,*) '*** Log report is suppressed.'
    endif

    return
  end subroutine io_log_setup

  !-----------------------------------------------------------------------------
  function io_get_available_fid() result(fid)
    implicit none

    integer :: fid
    logical :: i_opened
    !---------------------------------------------------------------------------

    do fid = io_minfid, io_maxfid
       inquire(fid,opened=i_opened)
       if ( .NOT. i_opened ) return
    enddo

  end function io_get_available_fid

  !-----------------------------------------------------------------------------
  subroutine io_make_idstr( &
       outstr, &
       instr,  &
       ext,    &
       rank,   &
       isrgn   )
    implicit none

    character(len=*), intent(out) :: outstr
    character(len=*), intent(in)  :: instr
    character(len=*), intent(in)  :: ext
    integer,          intent(in)  :: rank
    logical,          intent(in), optional :: isrgn

    character(len=H_SHORT) :: srank
    !---------------------------------------------------------------------------

    write(srank,'(I6.6)') rank

    if ( present(isrgn) ) then
       if(isrgn) write(srank,'(I8.8)') rank-1
    endif

    outstr = trim(instr)//'.'//trim(ext)//trim(srank)

    return
  end subroutine io_make_idstr

  !-----------------------------------------------------------------------------
  function io_arg_getfname( is_master ) result(fname)
    implicit none

    logical, intent(in)   :: is_master
    character(len=H_LONG) :: fname
    !---------------------------------------------------------------------------

    if ( command_argument_count() < 1 ) then
       if(is_master) write(*,*) 'xxx Program needs config file from argument! STOP.'
       stop 1
    else
       call get_command_argument(1,fname)
    endif

  end function io_arg_getfname

  !-----------------------------------------------------------------------------
  function io_cnf_open( &
       fname,    &
       is_master ) &
       result(fid)
    implicit none

    character(len=*), intent(in) :: fname
    logical,          intent(in) :: is_master
    integer                      :: fid

    integer :: ierr
    !---------------------------------------------------------------------------

    fid = io_get_available_fid()

    open( unit   = fid,         &
          file   = trim(fname), &
          form   = 'formatted', &
          status = 'old',       &
          iostat = ierr         )

    if ( ierr /= 0 ) then
       if(is_master) write(*,*) 'xxx Failed to open config file! STOP.'
       if(is_master) write(*,*) 'xxx filename : ', trim(fname)
       stop 1
    endif

  end function io_cnf_open

end module scale_stdio