dataset_ascii.F90       coverage:  90.00 %func     79.15 %block


     1) module Dataset_Ascii_class
     2)  
     3)   use Dataset_Base_class
     4)   
     5)   use PFLOTRAN_Constants_module
     6) 
     7)   implicit none
     8) 
     9)   private
    10) 
    11) #include "petsc/finclude/petscsys.h"
    12) 
    13)   type, public, extends(dataset_base_type) :: dataset_ascii_type
    14)     PetscInt :: array_width
    15)   end type dataset_ascii_type
    16)   
    17)   interface DatasetAsciiRead
    18)     module procedure DatasetAsciiOpenAndLoad
    19)     module procedure DatasetAsciiLoad
    20)   end interface
    21)   
    22)   public :: DatasetAsciiCreate, &
    23)             DatasetAsciiInit, &
    24)             DatasetAsciiVerify, &
    25)             DatasetAsciiCast, &
    26)             DatasetAsciiRead, &
    27)             DatasetAsciiUpdate, &
    28)             DatasetAsciiPrint, &
    29)             DatasetAsciiDestroy
    30)   
    31) contains
    32) 
    33) ! ************************************************************************** !
    34) 
    35) function DatasetAsciiCreate()
    36)   ! 
    37)   ! Creates ascii dataset class
    38)   ! 
    39)   ! Author: Glenn Hammond
    40)   ! Date: 10/03/13
    41)   ! 
    42)   
    43)   implicit none
    44)   
    45)   class(dataset_ascii_type), pointer :: dataset
    46) 
    47)   class(dataset_ascii_type), pointer :: DatasetAsciiCreate
    48)   
    49)   allocate(dataset)
    50)   call DatasetAsciiInit(dataset)
    51) 
    52)   DatasetAsciiCreate => dataset
    53)     
    54) end function DatasetAsciiCreate
    55) 
    56) ! ************************************************************************** !
    57) 
    58) function DatasetAsciiCast(this)
    59)   ! 
    60)   ! Casts a dataset_base_type to database_ascii_type
    61)   ! 
    62)   ! Author: Glenn Hammond
    63)   ! Date: 10/03/13
    64)   ! 
    65) 
    66)   use Dataset_Base_class
    67)   
    68)   implicit none
    69) 
    70)   class(dataset_base_type), pointer :: this
    71) 
    72)   class(dataset_ascii_type), pointer :: DatasetAsciiCast
    73)   
    74)   nullify(DatasetAsciiCast)
    75)   if (.not.associated(this)) return
    76)   select type (this)
    77)     class is (dataset_ascii_type)
    78)       DatasetAsciiCast => this
    79)     class default
    80)       !geh: have default here to pass a null pointer if not of type ascii
    81)   end select
    82)     
    83) end function DatasetAsciiCast
    84) 
    85) ! ************************************************************************** !
    86) 
    87) subroutine DatasetAsciiInit(this)
    88)   ! 
    89)   ! Initializes members of ascii dataset class
    90)   ! 
    91)   ! Author: Glenn Hammond
    92)   ! Date: 10/03/13
    93)   ! 
    94)   
    95)   implicit none
    96)   
    97)   class(dataset_ascii_type) :: this
    98)   
    99)   call DatasetBaseInit(this)
   100)   this%array_width = 0
   101)     
   102) end subroutine DatasetAsciiInit
   103) 
   104) ! ************************************************************************** !
   105) 
   106) subroutine DatasetAsciiOpenandLoad(this,filename,data_units_category,option)
   107)   ! 
   108)   ! Opens a file and calls the load routine.
   109)   ! 
   110)   ! Author: Glenn Hammond
   111)   ! Date: 10/03/13
   112)   ! 
   113) 
   114)   use Input_Aux_module
   115)   use Option_module
   116)   
   117)   implicit none
   118)   
   119)   class(dataset_ascii_type) :: this
   120)   character(len=MAXSTRINGLENGTH) :: filename
   121)   character(len=MAXSTRINGLENGTH) :: data_units_category
   122)   type(option_type) :: option
   123)   
   124)   type(input_type), pointer :: input
   125)   
   126)   input => InputCreate(IUNIT_TEMP,filename,option)
   127)   call DatasetAsciiLoad(this,input,data_units_category,option)
   128)   call InputDestroy(input)
   129) 
   130) end subroutine DatasetAsciiOpenandLoad
   131) 
   132) ! ************************************************************************** !
   133) 
   134) subroutine DatasetAsciiLoad(this,input,data_internal_units,option)
   135)   ! 
   136)   ! Reads a text-based dataset from an ASCII file.
   137)   ! 
   138)   ! Author: Glenn Hammond
   139)   ! Date: 10/03/13
   140)   ! 
   141) 
   142)   use Input_Aux_module
   143)   use String_module
   144)   use Utility_module, only : reallocateRealArray
   145)   use Option_module
   146)   use Units_module, only : UnitsConvertToInternal
   147)   use Time_Storage_module  
   148) 
   149)   implicit none
   150)   
   151)   class(dataset_ascii_type) :: this
   152)   type(input_type), pointer :: input
   153)   character(len=*) :: data_internal_units
   154)   type(option_type) :: option
   155) 
   156)   character(len=MAXWORDLENGTH) :: time_units
   157)   character(len=MAXSTRINGLENGTH) :: string, data_units
   158)   character(len=MAXSTRINGLENGTH), pointer :: internal_unit_strings(:) 
   159)   character(len=MAXWORDLENGTH) :: word, internal_units
   160)   PetscReal, pointer :: temp_array(:,:)
   161)   PetscReal :: temp_time
   162)   PetscReal :: conversion
   163)   PetscInt :: max_size, offset
   164)   PetscInt :: row_count, column_count, data_count, i, k
   165)   PetscInt :: default_interpolation_method
   166)   PetscBool :: force_units_for_all_data
   167)   PetscErrorCode :: ierr
   168)   
   169)   time_units = ''
   170)   data_units = ''
   171)   max_size = 1000
   172)   
   173)   internal_unit_strings => StringSplit(data_internal_units,',')
   174) 
   175)   row_count = 0
   176)   ierr = 0
   177)   k = 0
   178)   default_interpolation_method = INTERPOLATION_NULL
   179)   do
   180)     call InputReadPflotranString(input,option)
   181)     ! reach the end of file or close out block
   182)     if (InputError(input)) exit  ! check for end of file
   183)     if (InputCheckExit(input,option)) exit  ! check for end of list
   184)     ! check for units on first or second line
   185)     if (row_count == 0) then
   186)       string = input%buf
   187)       ierr = 0
   188)       call InputReadWord(string,word,PETSC_TRUE,ierr)
   189)       call InputErrorMsg(input,option,'KEYWORD','CONDITION (LIST or FILE)')
   190)       call StringToUpper(word)
   191)       select case(word)
   192)         case('HEADER')
   193)           call InputReadWord(string,word,PETSC_TRUE,ierr)
   194)           call InputErrorMsg(input,option,'header','CONDITION (LIST or FILE)')
   195)           this%header = trim(input%buf)
   196)           cycle
   197)         case('TIME_UNITS')
   198)           call InputReadWord(string,time_units,PETSC_TRUE,ierr)
   199)           input%ierr = ierr
   200)           call InputErrorMsg(input,option,'TIME_UNITS', &
   201)                              'CONDITION (LIST or FILE)')
   202)           cycle
   203)         case('INTERPOLATION')
   204)           call InputReadWord(string,word,PETSC_TRUE,ierr)
   205)           input%ierr = ierr
   206)           call InputErrorMsg(input,option,'INTERPOLATION','CONDITION')   
   207)           call StringToUpper(word)
   208)           select case(word)
   209)             case('STEP')
   210)               default_interpolation_method = INTERPOLATION_STEP
   211)             case('LINEAR') 
   212)               default_interpolation_method = INTERPOLATION_LINEAR
   213)             case default
   214)               call InputKeywordUnrecognized(word,'CONDITION,INTERPOLATION', &
   215)                                             option)
   216)           end select
   217)           cycle
   218)         case('DATA_UNITS')
   219)           ! it is possible to have more than one data unit. therefore, read the
   220)           ! entire string
   221)           data_units = adjustl(string)
   222)           if (len_trim(data_units) < 1) then
   223)             call InputErrorMsg(input,option,'DATA_UNITS', &
   224)                                'CONDITION (LIST or FILE)')
   225)           endif
   226)           cycle
   227)         case default
   228)           ! copy the first row of actual data and count up the number of 
   229)           ! columns.
   230)           string = input%buf
   231)           column_count = 0
   232)           do
   233)             ierr = 0
   234)             call InputReadWord(string,word,PETSC_TRUE,ierr)
   235)             if (ierr /= 0) exit   
   236)             column_count = column_count + 1
   237)           enddo
   238)           ! allocate the 2d array to max_size rows and col_count columns.
   239)           allocate(temp_array(column_count,max_size))
   240)           temp_array = 0.d0
   241)           ! do not cycle, as we now need to proceed.
   242)       end select
   243)     endif
   244) 
   245)     row_count = row_count + 1
   246)     
   247)     ! read columns of data, including the time in the first column
   248)     do i = 1, column_count
   249)       call InputReadDouble(input,option,temp_array(i,row_count))
   250)       call InputErrorMsg(input,option,'column data','ascii dataset file') 
   251)     enddo
   252)     
   253)     ! enlarge the array as needed.
   254)     if (row_count+1 > max_size) then
   255)       call reallocateRealArray(temp_array,max_size) 
   256)     endif  
   257)   enddo
   258)   
   259)   if (row_count == 0) then
   260)     option%io_buffer = 'No values provided in Ascii Dataset.'
   261)     call printErrMsg(option)
   262)   endif
   263)   
   264)   this%data_type = DATASET_REAL
   265)   this%rank = 2
   266)   allocate(this%dims(this%rank))
   267)   data_count = column_count - 1 ! subtract 1 for time column
   268)   this%dims(1) = data_count
   269)   this%dims(2) = row_count
   270)   this%time_storage => TimeStorageCreate()
   271)   this%time_storage%max_time_index = row_count
   272)   allocate(this%time_storage%times(row_count))
   273)   this%time_storage%times = temp_array(1,1:row_count)
   274)   allocate(this%rbuffer(data_count*row_count))
   275)   this%rbuffer = 0.d0 ! we copy after units conversion for efficiency sake
   276)   
   277)   ! time units conversion
   278)   if (len_trim(time_units) > 0) then
   279)     internal_units = 'sec'
   280)     conversion = UnitsConvertToInternal(time_units,internal_units,option)
   281)     this%time_storage%times(:) = conversion * &
   282)                                  this%time_storage%times(:)
   283)   endif
   284)   ! data units conversion
   285)   if (len_trim(data_units) > 0) then
   286)     ! set flag to determine whether we check for data units for each
   287)     ! data column.  if only one data unit is provided, it is applied
   288)     ! to all columns by default.  otherwise, data units must be defined
   289)     ! for each column - geh.
   290)     force_units_for_all_data = PETSC_FALSE
   291)     do i = 1, data_count ! number of data columns
   292)       if (len_trim(data_units) > 0 .or. force_units_for_all_data) then
   293)         ! the conditional immediately below will force 'conversion' to be
   294)         ! calculated for each column. if a unit does not exist, the input
   295)         ! error below will be spawned.
   296)         if (i > 1) force_units_for_all_data = PETSC_TRUE 
   297)         ierr = 0
   298)         call InputReadWord(data_units,word,PETSC_TRUE,ierr)
   299)         input%ierr = ierr
   300)         call InputErrorMsg(input,option,'DATA_UNITS','CONDITION FILE')
   301)         conversion = UnitsConvertToInternal(word,internal_unit_strings(i), &
   302)                                             option)
   303)       endif
   304)       temp_array(i+1,:) = conversion * temp_array(i+1,:)
   305)     enddo
   306)     deallocate(internal_unit_strings)
   307)     nullify(internal_unit_strings)
   308)   else
   309)     call InputCheckMandatoryUnits(input,option)
   310)   endif
   311) 
   312)   ! now that the data units conversion has taken place with temp_array, copy
   313)   ! over to rbuffer.
   314)   offset = 0
   315)   do i = 1, row_count
   316)     this%rbuffer(offset + 1:offset + data_count) = &
   317)       temp_array(2:column_count,i)
   318)     offset = offset + data_count
   319)   enddo
   320)   
   321)   deallocate(temp_array)
   322)   nullify(temp_array)
   323) 
   324)   if (this%array_width > 0) then
   325)     if (this%array_width /= data_count) then
   326)       write(word,*) this%array_width
   327)       option%io_buffer = 'Inconsistency between dataset prescribed rank (' // &
   328)         trim(word) // ') and rank in file ('
   329)       write(word,*) data_count
   330)       option%io_buffer = trim(option%io_buffer) // trim(word) // ').'
   331)       call printErrMsg(option)
   332)     endif
   333)   else
   334)     this%array_width = data_count
   335)   endif
   336)   
   337)   if (default_interpolation_method /= INTERPOLATION_NULL) then
   338)     this%time_storage%time_interpolation_method = default_interpolation_method
   339)   endif
   340)   
   341) end subroutine DatasetAsciiLoad
   342) 
   343) ! ************************************************************************** !
   344) 
   345) subroutine DatasetAsciiUpdate(this,option)
   346)   ! 
   347)   ! Updates an ascii dataset
   348)   ! 
   349)   ! Author: Glenn Hammond
   350)   ! Date: 10/08/13
   351)   ! 
   352) 
   353)   use Option_module
   354)   use Time_Storage_module
   355)   
   356)   implicit none
   357)   
   358)   class(dataset_ascii_type) :: this
   359)   type(option_type) :: option
   360)   
   361)   if (.not. associated(this%time_storage)) return
   362)   
   363)   call TimeStorageUpdate(this%time_storage)
   364)   call DatasetBaseInterpolateTime(this)
   365) 
   366) end subroutine DatasetAsciiUpdate
   367) 
   368) ! ************************************************************************** !
   369) 
   370) subroutine DatasetAsciiVerify(this,option)
   371)   ! 
   372)   ! Verifies that data structure is properly set up.
   373)   ! 
   374)   ! Author: Glenn Hammond
   375)   ! Date: 10/08/13
   376)   ! 
   377)   
   378)   use Option_module
   379)   
   380)   implicit none
   381)   
   382)   class(dataset_ascii_type) :: this
   383)   type(option_type) :: option
   384)   
   385)   if (len_trim(this%name) < 1) then
   386)     this%name = 'Unnamed Ascii Dataset'
   387)   endif
   388)   call DatasetBaseVerify(this,option)
   389)   if (associated(this%rbuffer)) then
   390)     if (this%array_width /= this%dims(1)) then
   391)       option%io_buffer = &
   392)         '"array_width" is not equal to "dims(1)" in dataset: ' // &
   393)         trim(this%name)
   394)       call printErrMsg(option)
   395)     endif
   396)     ! set initial values
   397)     this%rarray(:) = this%rbuffer(1:this%array_width)
   398)   endif
   399)     
   400) end subroutine DatasetAsciiVerify
   401) 
   402) ! ************************************************************************** !
   403) 
   404) subroutine DatasetAsciiPrint(this,option)
   405)   ! 
   406)   ! Prints dataset info
   407)   ! 
   408)   ! Author: Glenn Hammond
   409)   ! Date: 10/22/13
   410)   ! 
   411) 
   412)   use Option_module
   413) 
   414)   implicit none
   415)   
   416)   class(dataset_ascii_type) :: this
   417)   type(option_type) :: option
   418)   
   419)   write(option%fid_out,'(10x,''Array Rank: '',i2)') this%array_width
   420)   
   421) end subroutine DatasetAsciiPrint
   422) 
   423) ! ************************************************************************** !
   424) 
   425) subroutine DatasetAsciiStrip(this)
   426)   ! 
   427)   ! Strips allocated objects within Ascii dataset object
   428)   ! 
   429)   ! Author: Glenn Hammond
   430)   ! Date: 10/03/13
   431)   ! 
   432) 
   433)   implicit none
   434)   
   435)   class(dataset_ascii_type) :: this
   436)   
   437)   call DatasetBaseStrip(this)
   438)   
   439) end subroutine DatasetAsciiStrip
   440) 
   441) ! ************************************************************************** !
   442) 
   443) subroutine DatasetAsciiDestroy(this)
   444)   ! 
   445)   ! Destroys a dataset
   446)   ! 
   447)   ! Author: Glenn Hammond
   448)   ! Date: 10/03/13
   449)   ! 
   450) 
   451)   implicit none
   452)   
   453)   class(dataset_ascii_type), pointer :: this
   454)   
   455)   if (.not.associated(this)) return
   456)   
   457)   call DatasetAsciiStrip(this)
   458)   
   459)   deallocate(this)
   460)   nullify(this)
   461)   
   462) end subroutine DatasetAsciiDestroy
   463) 
   464) end module Dataset_Ascii_class

generated by
Intel(R) C++/Fortran Compiler code-coverage tool
Web-Page Owner: Nobody