mod_newinp.f90

Go to the documentation of this file.

!=======================================================================
! OSCAR Input Utility Module         
!
! Copyright:    2005(c)
!
! THIS IS A DEMONSTRATION RELEASE. THE AUTHOR(S) MAKE NO REPRESENTATION
! ABOUT THE SUITABILITY OF THIS SOFTWARE FOR ANY OTHER PURPOSE. IT IS
! PROVIDED "AS IS" WITHOUT EXPRESSED OR IMPLIED WARRANTY.
!
! THIS ORIGINAL HEADER MUST BE MAINTAINED IN ALL DISTRIBUTED VERSIONS
!
! Authors:      G. Cowles 
!               School for Marine Science and Technology     
!               University of Massachusetts-Dartmouth
!
! Comments:     OSCAR Input Module  
!=======================================================================

Module input_util

Use mod_prec 
Use mod_utils
Implicit None

character(len=1), parameter :: com_char = '!'



!----------------------------------------
! interface definition: Overload Get_Val
!----------------------------------------
Interface get_val
  Module Procedure get_float_val
  Module Procedure get_string_val
  Module Procedure get_logical_val
  Module Procedure get_integer_val
End Interface

Interface get_val_array
  Module Procedure get_float_val_array
  Module Procedure get_string_val_array
  Module Procedure get_logical_val_array
  Module Procedure get_integer_val_array
End Interface

!----------------------------------------
! functions    
!----------------------------------------

contains
  
  !---------------------------------------------------------------------
  !Get_Integer_Val -> Return Integer Value                    
  !---------------------------------------------------------------------
  Subroutine get_integer_val(ival,filename,argname,line,echo,start,finish)  
  implicit none
  integer,          intent(out) :: ival 
  character(len=*), intent(in ) :: filename
  character(len=*), intent(in ) :: argname
  integer,          intent(out) :: line
  logical, optional,intent(in)  :: echo
  integer, optional,intent(in)  :: start
  integer, optional,intent(in)  :: finish 

  character(len=80) :: argval
  character(len=80) :: argtype
  integer           :: ierr

  !make sure file exists
  if(.not.check_exist(filename))then
    call error('Get_Val','halt','error reading: '//trim(argname), &
              'file: '//trim(filename)//' does not exist') 
  endif

  !check start and finish lines
  if(present(start) .and. present(finish))then
    if(finish < start)then
    call error('Get_Val','halt','finish must be greater than or equal to start')
    endif
  endif

  !parse file for argument line 
  call extract_val_string(filename,argname,argval,ierr,line,start,finish)
  if(ierr == 1)then
    call error('Get_Val','halt','error reading variable: '//trim(argname), &
              'does not exist in file: '//trim(filename)) 
  endif

  !check argument type
  call check_arg_type(argval,argtype)
  if(trim(argtype) /= 'integer')then
    call error('Get_Val','halt','error reading variable: '//trim(argname), &
              'in file: '//trim(filename), &        
              'should be integer but is: '//trim(argtype))
  endif

  ! set return value
  read(argval,*)ival   

  ! echo to screen
  if(present(echo))then
    if(echo)then 
      write(*,'(A20,I10)')trim(argname)//': ',ival
    endif
  endif
  
  End Subroutine get_integer_val


  !---------------------------------------------------------------------
  !Get_Float_Val -> Return Float
  !---------------------------------------------------------------------
  Subroutine get_float_val(fval,filename,argname,line,echo,start,finish)  
  implicit none
  real(sp),         intent(out) :: fval
  character(len=*), intent(in ) :: filename
  character(len=*), intent(in ) :: argname
  integer,          intent(out) :: line
  logical, optional,intent(in)  :: echo
  integer, optional,intent(in)  :: start
  integer, optional,intent(in)  :: finish 

  character(len=80) :: argval
  character(len=80) :: argtype
  integer           :: ierr


  !make sure file exists
  if(.not.check_exist(filename))then
    call error('Get_Val','halt','error reading: '//trim(argname), &
              'file: '//trim(filename)//' does not exist') 
  endif

  !check start and finish lines
  if(present(start) .and. present(finish))then
    if(finish < start)then
    call error('Get_Val','halt','finish must be greater than or equal to start')
    endif
  endif

  !parse file for argument line 
  call extract_val_string(filename,argname,argval,ierr,line,start,finish)
  if(ierr == 1)then
    call error('Get_Val','halt','error reading variable: '//trim(argname), &
              'does not exist in file: '//trim(filename)) 
  endif

  !check argument type
  call check_arg_type(argval,argtype)
  if(trim(argtype) /= 'float')then
    call error('Get_Val','halt','error reading variable: '//trim(argname), &
              'in file: '//trim(filename), &        
              'should be float but is: '//trim(argtype))
  endif

  ! set return value
  read(argval,*)fval  

  ! echo to screen 
  if(present(echo))then
    if(echo)then 
      write(*,'(A20,F10.4)')trim(argname)//': ',fval
    endif
  end if
    
  
  End Subroutine get_float_val


  !---------------------------------------------------------------------
  !Get_Logical_Val -> Return Logical 
  !---------------------------------------------------------------------
  Subroutine get_logical_val(lval,filename,argname,line,echo,start,finish)  
  implicit none
  logical,          intent(out) :: lval
  character(len=*), intent(in ) :: filename
  character(len=*), intent(in ) :: argname
  integer,          intent(out) :: line
  logical, optional,intent(in)  :: echo
  integer, optional,intent(in)  :: start
  integer, optional,intent(in)  :: finish 

  character(len=80) :: argval
  character(len=80) :: argtype
  integer           :: ierr

  !make sure file exists
  if(.not.check_exist(filename))then
    call error('Get_Val','halt','error reading: '//trim(argname), &
              'file: '//trim(filename)//' does not exist') 
  endif

  !check start and finish lines
  if(present(start) .and. present(finish))then
    if(finish < start)then
    call error('Get_Val','halt','finish must be greater than or equal to start')
    endif
  endif

  !parse file for argument line 
  call extract_val_string(filename,argname,argval,ierr,line,start,finish)
  if(ierr == 1)then
    call error('Get_Val','halt','error reading variable: '//trim(argname), &
              'does not exist in file: '//trim(filename)) 
  endif

  !check argument type
  call check_arg_type(argval,argtype)
  if(trim(argtype) /= 'logical')then
    call error('Get_Val','halt','error reading variable: '//trim(argname), &
              'in file: '//trim(filename), &        
              'should be logical but is: '//trim(argtype))
  endif

  ! set return value
  lval = .false.
  if(argval(1:1) == 'T') lval = .true.

  ! echo to screen 
  if(present(echo))then
    if(echo)then 
      write(*,'(A20,L10)')trim(argname)//': ',lval  
    endif
  endif
  
  End Subroutine get_logical_val


  !---------------------------------------------------------------------
  !Get_String_Val -> Return String 
  !---------------------------------------------------------------------
  Subroutine get_string_val(sval,filename,argname,line,echo,start,finish)  
  implicit none
  character(len=*), intent(out) :: sval
  character(len=*), intent(in ) :: filename
  character(len=*), intent(in ) :: argname
  integer,          intent(out) :: line
  logical, optional,intent(in)  :: echo
  integer, optional,intent(in)  :: start
  integer, optional,intent(in)  :: finish 

  character(len=80) :: argval
  character(len=80) :: argtype
  integer           :: ierr

  !make sure file exists
  if(.not.check_exist(filename))then
    call error('Get_Val','halt','error reading: '//trim(argname), &
              'file: '//trim(filename)//' does not exist') 
  endif

  !check start and finish lines
  if(present(start) .and. present(finish))then
    if(finish < start)then
    call error('Get_Val','halt','finish must be greater than or equal to start')
    endif
  endif

  !parse file for argument line 
  call extract_val_string(filename,argname,argval,ierr,line,start,finish)
  if(ierr == 1)then
    call error('Get_Val','halt','error reading variable: '//trim(argname), &
              'does not exist in file: '//trim(filename)) 
  endif

  !check argument type
  call check_arg_type(argval,argtype)
  if(trim(argtype) /= 'string')then
    call error('Get_Val','halt','error reading variable: '//trim(argname), &
              'in file: '//trim(filename), &        
              'should be string but is: '//trim(argtype))
  endif

  ! set return value
  sval = adjustl(trim(argval))
  
  ! echo to screen 
  if(present(echo))then
    if(echo)then 
      write(*,'(A20,A20)') trim(argname)//': ',trim(sval)
    endif
  endif
  End Subroutine get_string_val


  !---------------------------------------------------------------------
  !Get_Float_Val_Array -> Return Float Array
  !---------------------------------------------------------------------
  Subroutine get_float_val_array(fval,filename,argname,size,echo)  
  implicit none

  character(len=*), intent(in ) :: filename
  character(len=*), intent(in ) :: argname
  integer,intent(in)            :: SIZE
  real(sp),dimension(size), intent(out) :: fval
  logical, optional,intent(in)  :: echo
 
 

  character(len=80) :: argval
  character(len=80) :: argtype
  integer           :: ierr
  integer           :: iscan
  integer           :: ntemp
  real(sp)          :: ftemp
  real(sp)          :: REALVEC(150)

  if(dbg_set(dbg_sbr)) write(ipt,*) "Start:Get_Float_Val_Array "

  !make sure file exists
  if(.not.check_exist(filename))then
    call error('Get_Val','halt','error reading: '//trim(argname), &
              'file: '//trim(filename)//' does not exist') 
  endif

  !read in 
  iscan = scan_file3(filename,argname,fvec = realvec,nsze = ntemp)
  IF(iscan /= 0)THEN
     WRITE(ipt,*)'ERROR READING: ',trim(argname),': ',iscan
     call error('Get_Val','halt','error reading variable: '//trim(argname), &
        'does not exist in file: '//trim(filename)) 
  END IF

  IF(ntemp > size)THEN
    WRITE(*,*)'EXPECTED SIZE:',SIZE
    WRITE(*,*)'AND READ: ',realvec(1:ntemp)
    call error('Get_Val','warning','warning reading variable: '//trim(argname), &
        'number of specified size in : '//trim(filename)//' in not eq&
        &ual to expected size,specified size is used in the model  ')
  ELSEIF(ntemp < size)THEN
    WRITE(*,*)'EXPECTED SIZE:',SIZE
    WRITE(*,*)'AND READ: ',realvec
    call error('Get_Val','halt','error reading variable: '//trim(argname), &
        'number of specified size in : '//trim(filename)//' in not eq&
        &ual to expected size ')
  END IF
  
  fval(1:size)= realvec(1:size)

  ! echo to screen 
  if(present(echo))then
    if(echo)then 
      write(*,'(A20,<size>F10.4)')trim(argname)//': ',fval(1:size)
    endif
  end if
    
  if(dbg_set(dbg_sbr)) write(ipt,*) "End: Get_Float_Val_Array "  

  End Subroutine get_float_val_array





  !---------------------------------------------------------------------
  !Get_Float_Val_Array -> Return Float Array
  !---------------------------------------------------------------------
  Subroutine get_integer_val_array(ival,filename,argname,size,echo)  
  implicit none

  character(len=*), intent(in ) :: filename
  character(len=*), intent(in ) :: argname
  integer,intent(in)            :: SIZE
  integer,dimension(size), intent(out) :: ival
  logical, optional,intent(in)  :: echo
 
 

  character(len=80) :: argval
  character(len=80) :: argtype
  integer           :: ierr
  integer           :: iscan
  integer           :: ntemp
  real(sp)          :: ftemp
  real(sp)          :: REALVEC(150)

  if(dbg_set(dbg_sbr)) write(ipt,*) "Start: Get_Integer_Val_Array"

  !make sure file exists
  if(.not.check_exist(filename))then
    call error('Get_Val','halt','error reading: '//trim(argname), &
              'file: '//trim(filename)//' does not exist') 
  endif

  !read in 
  iscan = scan_file3(filename,argname,fvec = realvec,nsze = ntemp)
  IF(iscan /= 0)THEN
     WRITE(ipt,*)'ERROR READING',trim(argname),': ',iscan
     call error('Get_Val','halt','error reading variable: '//trim(argname), &
        'does not exist in file: '//trim(filename)) 
  END IF
  print*,ntemp, size
  IF(ntemp > size)THEN
    WRITE(*,*)'EXPECTED SIZE:',SIZE
    WRITE(*,*)'AND READ: ',realvec(1:ntemp)
    call error('Get_Val','warning','warning reading variable: '//trim(argname), &
        'number of specified size in : '//trim(filename)//' in not eq&
        &ual to expected size,specified size is used in the model  ')
  ELSEIF(ntemp < size)THEN
    WRITE(*,*)'EXPECTED SIZE:',SIZE
    WRITE(*,*)'AND READ: ',realvec
    call error('Get_Val','halt','error reading variable: '//trim(argname), &
        'number of specified size in : '//trim(filename)//' in not eq&
        &ual to expected size ')
  END IF

  ival(1:size)= realvec(1:size)

  ! echo to screen 
  if(present(echo))then
    if(echo)then 
      write(*,'(A20,<size>I10)')trim(argname)//': ',ival(1:size)
    endif
  end if

  if(dbg_set(dbg_sbr)) write(ipt,*) "End: Get_Integer_Val_Array"    

  End Subroutine get_integer_val_array




  !---------------------------------------------------------------------
  !Get_Float_Val_Array -> Return Float Array
  !---------------------------------------------------------------------
  Subroutine get_logical_val_array(cval,filename,argname,size,echo)  
  implicit none

  character(len=*), intent(in ) :: filename
  character(len=*), intent(in ) :: argname
  integer,intent(in)            :: SIZE
  logical,dimension(size), intent(out) :: cval
  logical, optional,intent(in)  :: echo
 
 

  character(len=80) :: argval
  character(len=80) :: argtype
  integer           :: ierr,i
  integer           :: iscan
  integer           :: ntemp
  real(sp)          :: ftemp
  character(len=80), dimension(100):: CHARVEC

  if(dbg_set(dbg_sbr)) write(ipt,*) "Start: Get_Logical_Val_Array" 

  !make sure file exists
  if(.not.check_exist(filename))then
    call error('Get_Val','halt','error reading: '//trim(argname), &
              'file: '//trim(filename)//' does not exist') 
  endif

  !read in 
  iscan = scan_file3(filename,argname,cvec = charvec,nsze = ntemp)
  IF(iscan /= 0)THEN
     WRITE(ipt,*)'ERROR READING:',trim(argname),': ',iscan
     call error('Get_Val','halt','error reading variable: '//trim(argname), &
        'does not exist in file: '//trim(filename)) 
  END IF
 
  IF(ntemp > size)THEN
    WRITE(*,*)'EXPECTED SIZE:',SIZE
    WRITE(*,*)'AND READ: ',charvec(1:ntemp)
    call error('Get_Val','warning','warning reading variable: '//trim(argname), &
        'number of specified size in : '//trim(filename)//' in not eq&
        &ual to expected size,specified size is used in the model  ')
  ELSEIF(ntemp < size)THEN
    WRITE(*,*)'EXPECTED SIZE:',SIZE
    WRITE(*,*)'AND READ: ',charvec
    call error('Get_Val','halt','error reading variable: '//trim(argname), &
        'number of specified size in : '//trim(filename)//' in not eq&
        &ual to expected size ')
  END IF

  do i=1,size
     IF((trim(charvec(i))== "T" .OR. trim(charvec(i))=="F").and.(len(trim(charvec(i)))==1))THEN
        if(trim(charvec(i)) == "T")cval(i)=.true.
        if(trim(charvec(i)) == "F")cval(i)=.false.
     end if
  end do

  ! echo to screen 
  if(present(echo))then
    if(echo)then 
      write(*,'(A20,<size>L10)')trim(argname)//': ',cval(1:size)
    endif
  end if
    
  if(dbg_set(dbg_sbr)) write(ipt,*) "End: Get_Logical_Val_Array"   

  End Subroutine get_logical_val_array








  !---------------------------------------------------------------------
  !Get_String_Val_Array -> Return String Array
  !---------------------------------------------------------------------
  Subroutine get_string_val_array(sval,filename,argname,size,echo)  
  implicit none

  character(len=*), intent(in ) :: filename
  character(len=*), intent(in ) :: argname
  integer,intent(in)            :: SIZE
  character(len=*),dimension(size), intent(out) :: sval
  logical, optional,intent(in)  :: echo
 
 

  character(len=80) :: argval
  character(len=80) :: argtype
  integer           :: ierr,i
  integer           :: iscan
  integer           :: ntemp
  real(sp)          :: ftemp
  character(len=80), dimension(100):: CHARVEC

  if(dbg_set(dbg_sbr)) write(ipt,*) "Start: Get_String_Val_Array" 

  !make sure file exists
  if(.not.check_exist(filename))then
    call error('Get_Val','halt','error reading: '//trim(argname), &
              'file: '//trim(filename)//' does not exist') 
  endif

  !read in 
  iscan = scan_file3(filename,argname,cvec = charvec,nsze = ntemp)
  IF(iscan /= 0)THEN
     WRITE(ipt,*)'ERROR READING:',trim(argname),': ',iscan
     call error('Get_Val','halt','error reading variable: '//trim(argname), &
        'does not exist in file: '//trim(filename)) 
  END IF
 
  IF(ntemp > size)THEN
    WRITE(*,*)'EXPECTED SIZE:',SIZE
    WRITE(*,*)'AND READ: ',charvec(1:ntemp)
    call error('Get_Val','warning','warning reading variable: '//trim(argname), &
        'number of specified size in : '//trim(filename)//' in not eq&
        &ual to expected size,specified size is used in the model  ')
  ELSEIF(ntemp < size)THEN
    WRITE(*,*)'EXPECTED SIZE:',SIZE
    WRITE(*,*)'AND READ: ',charvec
    call error('Get_Val','halt','error reading variable: '//trim(argname), &
        'number of specified size in : '//trim(filename)//' in not eq&
        &ual to expected size ')
  END IF


  sval(1:size)= charvec(1:size)

  ! echo to screen 
  if(present(echo))then
    if(echo)then 
      write(*,'(A20,<size>A10)')trim(argname)//': ',sval(1:size)
    endif
  end if
    
  if(dbg_set(dbg_sbr)) write(ipt,*) "End: Get_String_Val_Array"   

  End Subroutine get_string_val_array



  !---------------------------------------------------------------------
  !Extract_Val_String: 
  !   Parse Input File for Value String Assigned to Desired Variable
  !---------------------------------------------------------------------
  Subroutine extract_val_string(fname,argname,argval,ierr,line,start,finish)
  implicit none
  character(len=* ), intent(in ) :: fname 
  character(len=* ), intent(in ) :: argname 
  character(len=80), intent(out) :: argval 
  integer,           intent(out) :: ierr
  integer,           intent(out) :: line 
  integer, optional, intent(in ) :: start
  integer, optional, intent(in ) :: finish 
  !------------------------------------------
  character(len=80)  :: temp,temp2,text_line,inpline
  integer            :: locex,eqloc,length,i,linecnt

  ierr   = 0
  open(10,file=trim(fname)) ; rewind(10) 

  linecnt = 0
  !move forward to start line if present
  if(present(start))then
    do i=1,start-1
      read(10,*)
      linecnt = linecnt + 1
    end do
  endif

   do while(.true.)
     read(10,'(A)',end=20) inpline 
     linecnt = linecnt + 1

    ! determine location of comment character and remove blanks
    locex = index(inpline,com_char)
    if(locex == 0)locex = len_trim(inpline)+1
    temp = inpline(1:locex-1)
    text_line = temp

    ! set line length
    length = len_trim(text_line)
   
    ! ensure "=" exist and determine location
    eqloc = index(text_line,"=")


    ! split off variable name and value strings
    temp2 = text_line(1:eqloc-1)
    if(adjustl(trim(temp2)) == trim(argname))then
      argval  = adjustl(text_line(eqloc+1:length))
      line    = linecnt
      close(10)
      return
    endif

    ! exit if finish is present
    if(present(finish))then
      if(linecnt==finish)exit
    endif
  end do

  ! not found, return error = 1
  20 continue
  ierr = 1
  close(10)

  End Subroutine extract_val_string  

  !---------------------------------------------------------------------
  !check argument type (string,float,integer,logical)         
  !---------------------------------------------------------------------
  Subroutine check_arg_type(argval,argtype)
  implicit none
  character(len=80), intent(out) :: argtype 
  character(len=80), intent(in ) :: argval  

  character(len=16) :: numchars 
  integer           :: largval
  integer           :: dotloc
  integer           :: i
  numchars = "0123456789+-Ee. " 

  ! argument length
  largval = len_trim(adjustl(argval))

  ! check if logical
  if(largval == 1)then
  if(argval(1:1) == "T" .or. argval(1:1) == "F")then 
    argtype = 'logical' 
    return
  endif
  endif
    
  ! check if it is a string  (contains characters other than 0-9,+,-,E,e,.)
  do i=1,largval
    if(index(numchars,argval(i:i)) == 0)then
      argtype = "string" 
      return
    endif
  end do

  ! check if it is a float
  dotloc = index(argval,".")
  if(dotloc /= 0) then
    argtype = "float"
  else
    argtype = "integer"
  end if

  End Subroutine check_arg_type


  !-------------------------------------------------------
  !Error
  !Write Error Message to Screen
  !-------------------------------------------------------
  Subroutine error(subname,errtype,err1,err2,err3)
    character(len=*)           :: subname
    character(len=*)           :: errtype
    character(len=*)           :: err1    
    character(len=*), optional :: err2 
    character(len=*), optional :: err3 

    if(errtype == 'halt')then
      write(*,*)
      write(*,*)'FATAL ERROR in subroutine: ',trim(subname)
      write(*,*)trim(err1)
      if(present(err2)) write(*,*)trim(err2)
      if(present(err2)) write(*,*)trim(err3)
      stop
    else if(errtype == 'warning')then
      write(*,*)
      write(*,*)'WARNING from subroutine: ',trim(subname)
      write(*,*)trim(err1)
      if(present(err2)) write(*,*)trim(err2)
      if(present(err2)) write(*,*)trim(err3)
    else
      write(*,*)'incorrect usage of subroutine Error'
      write(*,*)'called from subroutine: ',trim(subname)
      write(*,*)'errtype must be halt or warning'
      stop
    endif

  End Subroutine error

  !-------------------------------------------------------
  !Check_Exist
  !Check for Existence of a File
  !-------------------------------------------------------
  Function check_exist(filein) Result(fexist) 
    implicit none
    character(len=*)           :: filein 
    logical fexist 
    inquire(exist=fexist,file=filein)
  End Function check_exist  

  !-------------------------------------------------------
  !Check_Alloc
  !Check For Successfull Allocation of Data
  !-------------------------------------------------------
  Subroutine check_alloc(errorin,dsize,varname,subname) 
    implicit none
    integer,          intent(in) :: errorin
    integer,          intent(in) :: dsize 
    character(len=*), intent(in) :: varname
    character(len=*), intent(in) :: subname

    if(errorin /= 0)then
      write(*,*)'insufficient space to allocate array: '//trim(varname)
      write(*,*)'in subroutine: '//trim(subname)
      write(*,*)'tried to allocate ',dsize,' units'
      stop
    endif
   
  End Subroutine check_alloc  


  !-------------------------------------------------------
  !Check_IOError
  !Check For Successfull R/W 
  !-------------------------------------------------------
  Subroutine check_ioerror(errorin,filename,varname) 
    implicit none
    integer,          intent(in) :: errorin
    character(len=*), intent(in) :: filename
    character(len=*), intent(in) :: varname

    if(errorin /= 0)then
      write(*,*)'failed read/write of: '//trim(varname)  
      write(*,*)'from file: '//trim(filename)    
      stop
    endif
   
  End Subroutine check_ioerror

End Module input_util