input_aux.F90 coverage: 88.68 %func 71.28 %block
1) module Input_Aux_module
2)
3) use Option_module
4)
5) use PFLOTRAN_Constants_module
6)
7) implicit none
8)
9) private
10)
11) #include "petsc/finclude/petscsys.h"
12)
13) type, public :: input_type
14) PetscInt :: fid
15) PetscErrorCode :: ierr
16) character(len=MAXWORDLENGTH) :: filename
17) character(len=MAXSTRINGLENGTH) :: buf
18) character(len=MAXSTRINGLENGTH) :: err_buf
19) character(len=MAXSTRINGLENGTH) :: err_buf2
20) PetscBool :: broadcast_read
21) PetscBool :: force_units ! force user to declare units on datasets
22) type(input_type), pointer :: parent
23) end type input_type
24)
25) type :: input_dbase_type
26) character(len=MAXWORDLENGTH), pointer :: icard(:)
27) character(len=MAXWORDLENGTH), pointer :: rcard(:)
28) character(len=MAXWORDLENGTH), pointer :: ccard(:)
29) PetscInt, pointer :: ivalue(:)
30) PetscReal, pointer :: rvalue(:)
31) character(len=MAXWORDLENGTH), pointer :: cvalue(:)
32) end type input_dbase_type
33)
34) type(input_dbase_type), pointer, public :: dbase => null()
35)
36) interface InputReadWord
37) module procedure InputReadWord1
38) module procedure InputReadWord2
39) end interface
40)
41) interface InputReadNChars
42) module procedure InputReadNChars1
43) module procedure InputReadNChars2
44) end interface
45)
46) interface InputReadInt
47) module procedure InputReadInt1
48) module procedure InputReadInt2
49) #if defined(PETSC_USE_64BIT_INDICES) && (PETSC_SIZEOF_MPI_FINT * PETSC_BITS_PER_BYTE != 64)
50) ! If PetscInt and PetscMPIInt have different sizes (occurs for some builds
51) ! with 64 bit indices), then we need to have additional routines for the
52) ! InputReadInt() generic subroutine. (We use the above check instead of
53) ! directly checking to see if PetscInt and PetscMPIInt have the same size
54) ! because the size of PetscInt is not included in the
55) ! $PETSC_DIR/$PETSC_ARCH/include/petscconf.h file.) If the two types have
56) ! the same size, then these additional routines for type PetscMPIInt must
57) ! *not* be defined, because then the interface becomes ambiguous, since
58) ! Fortran doesn't know the difference between PetscInt and PetscMPIInt if
59) ! they are identically sized integers. --RTM
60) module procedure InputReadInt3
61) module procedure InputReadInt4
62) #endif
63) end interface
64)
65) interface InputReadDouble
66) module procedure InputReadDouble1
67) module procedure InputReadDouble2
68) end interface
69)
70) interface InputReadNDoubles
71) module procedure InputReadNDoubles1
72) module procedure InputReadNDoubles2
73) end interface
74)
75) interface InputError
76) module procedure InputError1
77) module procedure InputError2
78) end interface
79)
80) interface InputErrorMsg
81) module procedure InputErrorMsg1
82) module procedure InputErrorMsg2
83) end interface
84)
85) interface InputDefaultMsg
86) module procedure InputDefaultMsg1
87) module procedure InputDefaultMsg2
88) end interface
89)
90) interface InputReadStringErrorMsg
91) module procedure InputReadStringErrorMsg1
92) module procedure InputReadStringErrorMsg2
93) end interface
94)
95) interface InputFindStringInFile
96) module procedure InputFindStringInFile1
97) module procedure InputFindStringInFile2
98) end interface
99)
100) interface InputKeywordUnrecognized
101) module procedure InputKeywordUnrecognized1
102) module procedure InputKeywordUnrecognized2
103) end interface
104)
105) public :: InputCreate, InputDestroy, InputReadPflotranString, &
106) InputReadWord, InputReadDouble, InputReadInt, InputCheckExit, &
107) InputReadNDoubles, &
108) InputSkipToEND, InputFindStringInFile, InputErrorMsg, &
109) InputDefaultMsg, InputReadStringErrorMsg, &
110) InputFindStringErrorMsg, InputError, &
111) InputReadNChars, InputReadQuotedWord, &
112) InputReadPath, &
113) InputGetCommandLineInt, &
114) InputGetCommandLineReal, &
115) InputGetCommandLineTruth, &
116) InputGetCommandLineString, &
117) InputReadFilenames, &
118) InputGetLineCount, &
119) InputReadToBuffer, &
120) InputReadASCIIDbase, &
121) InputKeywordUnrecognized, &
122) InputCheckMandatoryUnits, &
123) InputDbaseDestroy, &
124) InputPushExternalFile, &
125) InputReadWordDbaseCompatible, &
126) InputReadAndConvertUnits
127)
128) contains
129)
130) ! ************************************************************************** !
131)
132) function InputCreate(fid,filename,option)
133) !
134) ! Allocates and initializes a new Input object
135) !
136) ! Author: Glenn Hammond
137) ! Date: 11/10/08
138) !
139)
140) use Option_module
141)
142) implicit none
143)
144) PetscInt :: fid
145) character(len=*) :: filename
146) type(option_type) :: option
147)
148) type(input_type), pointer :: InputCreate
149) PetscInt :: status
150) type(input_type), pointer :: input
151)
152) allocate(input)
153)
154) input%fid = fid
155) input%filename = filename
156) input%ierr = 0
157) input%buf = ''
158) input%err_buf = ''
159) input%err_buf2 = ''
160) input%broadcast_read = PETSC_FALSE
161) input%force_units = PETSC_FALSE
162) nullify(input%parent)
163)
164) if (fid == MAX_IN_UNIT) then
165) option%io_buffer = 'MAX_IN_UNIT in pflotran_constants.h must be increased to' // &
166) ' accommodate a larger number of embedded files.'
167) call printErrMsg(option)
168) endif
169)
170) open(unit=input%fid,file=filename,status="old",iostat=status)
171) if (status /= 0) then
172) if (len_trim(filename) == 0) filename = '<blank>'
173) option%io_buffer = 'File: "' // trim(filename) // '" not found.'
174) call printErrMsg(option)
175) endif
176)
177) InputCreate => input
178)
179) end function InputCreate
180)
181) ! ************************************************************************** !
182)
183) subroutine InputDefaultMsg1(input,option,buffer)
184) !
185) ! If ierr /= 0, informs user that default value will be used.
186) !
187) ! Author: Glenn Hammond
188) ! Date: 11/10/08
189) !
190)
191) implicit none
192)
193) type(input_type) :: input
194) type(option_type) :: option
195) character(len=*) :: buffer
196)
197) if (InputError(input)) then
198) input%err_buf = buffer
199) call InputDefaultMsg(input,option)
200) endif
201)
202) end subroutine InputDefaultMsg1
203)
204) ! ************************************************************************** !
205)
206) subroutine InputDefaultMsg2(input,option)
207) !
208) ! If ierr /= 0, informs user that default value will be used.
209) !
210) ! Author: Glenn Hammond
211) ! Date: 11/10/08
212) !
213)
214) implicit none
215)
216) type(input_type) :: input
217) type(option_type) :: option
218)
219) if (InputError(input)) then
220) option%io_buffer = '"' // trim(input%err_buf) // &
221) '" set to default value.'
222) call printMsg(option)
223) input%ierr = 0
224) endif
225)
226) end subroutine InputDefaultMsg2
227)
228) ! ************************************************************************** !
229)
230) subroutine InputErrorMsg1(input,option,buffer1,buffer2)
231) !
232) ! If ierr /= 0, If ierr /= 0, informs user of error and stops.
233) !
234) ! Author: Glenn Hammond
235) ! Date: 11/10/08
236) !
237)
238) implicit none
239)
240) type(input_type) :: input
241) type(option_type) :: option
242) character(len=*) :: buffer1, buffer2
243)
244) if (InputError(input)) then
245) input%err_buf = buffer1
246) input%err_buf2 = buffer2
247) call InputErrorMsg(input,option)
248) endif
249)
250) end subroutine InputErrorMsg1
251)
252) ! ************************************************************************** !
253)
254) subroutine InputErrorMsg2(input,option)
255) !
256) ! InputErrorMsg: If ierr /= 0, If ierr /= 0, informs user of error and stops.
257) !
258) ! Author: Glenn Hammond
259) ! Date: 11/10/08
260) !
261)
262) implicit none
263)
264) type(input_type) :: input
265) type(option_type) :: option
266)
267) if (InputError(input)) then
268) option%io_buffer = 'While reading "' // trim(input%err_buf) // &
269) '" under keyword: ' // trim(input%err_buf2) // '.'
270) call printErrMsg(option)
271) endif
272)
273) end subroutine InputErrorMsg2
274)
275) ! ************************************************************************** !
276)
277) subroutine InputReadStringErrorMsg1(input, option, buffer)
278) !
279) ! If ierr /= 0, informs user of error and stops.
280) !
281) ! Author: Glenn Hammond
282) ! Date: 11/10/08
283) !
284)
285) implicit none
286)
287) type(input_type) :: input
288) type(option_type) :: option
289) character(len=*) :: buffer
290)
291) if (InputError(input)) then
292) input%err_buf = buffer
293) call InputReadStringErrorMsg(input, option)
294) endif
295)
296) end subroutine InputReadStringErrorMsg1
297)
298) ! ************************************************************************** !
299)
300) subroutine InputReadStringErrorMsg2(input, option)
301) !
302) ! If ierr /= 0, informs user of error and stops.
303) !
304) ! Author: Glenn Hammond
305) ! Date: 11/10/08
306) !
307)
308) implicit none
309)
310) type(input_type) :: input
311) type(option_type) :: option
312)
313) if (InputError(input)) then
314) option%io_buffer = 'While reading in string in "' // &
315) trim(input%err_buf) // '".'
316) call printErrMsg(option)
317) endif
318)
319) end subroutine InputReadStringErrorMsg2
320)
321) ! ************************************************************************** !
322)
323) subroutine InputFindStringErrorMsg(input, option, string)
324) !
325) ! If ierr /= 0, informs user of error and stops.
326) !
327) ! Author: Glenn Hammond
328) ! Date: 11/10/08
329) !
330)
331) implicit none
332)
333) type(input_type) :: input
334) type(option_type) :: option
335) character(len=*) :: string
336)
337) if (InputError(input)) then
338) option%io_buffer = 'Card (' // trim(string) // ') not &
339) &found in file.'
340) call printErrMsg(option)
341) endif
342)
343) end subroutine InputFindStringErrorMsg
344)
345) ! ************************************************************************** !
346)
347) subroutine InputReadInt1(input, option, int)
348) !
349) ! reads and removes an integer value from a string
350) !
351) ! Author: Glenn Hammond
352) ! Date: 11/10/08
353) !
354)
355) implicit none
356)
357) type(input_type) :: input
358) type(option_type) :: option
359) PetscInt :: int
360)
361) character(len=MAXWORDLENGTH) :: word
362) PetscBool :: found
363)
364) found = PETSC_FALSE
365) if (associated(dbase)) then
366) call InputParseDbaseForInt(input%buf,int,found,input%ierr)
367) endif
368)
369) if (.not.found) then
370) call InputReadWord(input%buf,word,PETSC_TRUE,input%ierr)
371)
372) if (.not.InputError(input)) then
373) read(word,*,iostat=input%ierr) int
374) endif
375) endif
376)
377) end subroutine InputReadInt1
378)
379) ! ************************************************************************** !
380)
381) subroutine InputReadInt2(string, option, int, ierr)
382) !
383) ! reads and removes an integer value from a string
384) !
385) ! Author: Glenn Hammond
386) ! Date: 11/10/08
387) !
388)
389) implicit none
390)
391) character(len=MAXSTRINGLENGTH) :: string
392) type(option_type) :: option
393) PetscInt :: int
394) PetscErrorCode :: ierr
395)
396) character(len=MAXWORDLENGTH) :: word
397) PetscBool :: found
398)
399) ierr = 0
400)
401) found = PETSC_FALSE
402) if (associated(dbase)) then
403) call InputParseDbaseForInt(string,int,found,ierr)
404) endif
405)
406) if (.not.found) then
407) call InputReadWord(string,word,PETSC_TRUE,ierr)
408)
409) if (.not.InputError(ierr)) then
410) read(word,*,iostat=ierr) int
411) endif
412) endif
413)
414) end subroutine InputReadInt2
415)
416) #if defined(PETSC_USE_64BIT_INDICES) && (PETSC_SIZEOF_MPI_FINT * PETSC_BITS_PER_BYTE != 64)
417)
418) ! ************************************************************************** !
419)
420) subroutine InputReadInt3(input, option, int)
421) !
422) ! InputReadInt3() and InputReadInt4() must only be defined if PetscInt and
423) ! PetscMPIInt differ in size. See notes above in the interface definition.
424) ! --RTM
425) ! reads and removes an integer value from a string
426) ! authors: Glenn Hammond, Richard Mills
427) !
428) ! Date: 2/3/2012
429) !
430)
431) implicit none
432)
433) type(input_type) :: input
434) type(option_type) :: option
435) PetscMPIInt :: int
436)
437) character(len=MAXWORDLENGTH) :: word
438)
439) call InputReadWord(input%buf,word,PETSC_TRUE,input%ierr)
440)
441) if (.not.InputError(input)) then
442) read(word,*,iostat=input%ierr) int
443) endif
444)
445) end subroutine InputReadInt3
446)
447) ! ************************************************************************** !
448)
449) subroutine InputReadInt4(string, option, int, ierr)
450) !
451) ! reads and removes an integer value from a string
452) ! authors: Glenn Hammond, Richard Mills
453) !
454) ! Date: 2/3/2012
455) !
456)
457) implicit none
458)
459) character(len=MAXSTRINGLENGTH) :: string
460) type(option_type) :: option
461) PetscMPIInt :: int
462) PetscErrorCode :: ierr
463)
464) character(len=MAXWORDLENGTH) :: word
465)
466) ierr = 0
467) call InputReadWord(string,word,PETSC_TRUE,ierr)
468)
469) if (.not.InputError(ierr)) then
470) read(word,*,iostat=ierr) int
471) endif
472)
473) end subroutine InputReadInt4
474)
475) #endif
476) ! End of defined(PETSC_USE_64BIT_INDICES) &&
477) ! (PETSC_SIZEOF_MPI_FINT * PETSC_BITS_PER_BYTE != 64) conditional
478)
479) ! ************************************************************************** !
480)
481) subroutine InputReadDouble1(input, option, double)
482) !
483) ! reads and removes a real value from a string
484) !
485) ! Author: Glenn Hammond
486) ! Date: 11/10/08
487) !
488)
489) implicit none
490)
491) type(input_type) :: input
492) type(option_type) :: option
493) PetscReal :: double
494)
495) character(len=MAXWORDLENGTH) :: word
496) PetscBool :: found
497)
498) found = PETSC_FALSE
499) if (associated(dbase)) then
500) call InputParseDbaseForDouble(input%buf,double,found,input%ierr)
501) endif
502)
503) if (.not.found) then
504) call InputReadWord(input%buf,word,PETSC_TRUE,input%ierr)
505)
506) if (.not.InputError(input)) then
507) read(word,*,iostat=input%ierr) double
508) endif
509) endif
510)
511) end subroutine InputReadDouble1
512)
513) ! ************************************************************************** !
514)
515) subroutine InputReadDouble2(string, option, double, ierr)
516) !
517) ! reads and removes a real value from a string
518) !
519) ! Author: Glenn Hammond
520) ! Date: 11/10/08
521) !
522)
523) implicit none
524)
525) character(len=MAXSTRINGLENGTH) :: string
526) type(option_type) :: option
527) PetscReal :: double
528) PetscErrorCode :: ierr
529)
530) character(len=MAXWORDLENGTH) :: word
531) PetscBool :: found
532)
533) ierr = 0
534)
535) found = PETSC_FALSE
536) if (associated(dbase)) then
537) call InputParseDbaseForDouble(string,double,found,ierr)
538) endif
539)
540) if (.not.found) then
541) call InputReadWord(string,word,PETSC_TRUE,ierr)
542)
543) if (.not.InputError(ierr)) then
544) read(word,*,iostat=ierr) double
545) endif
546) endif
547)
548) end subroutine InputReadDouble2
549)
550) ! ************************************************************************** !
551)
552) subroutine InputReadNDoubles1(input, option, double, n)
553) !
554) ! reads and removes "n" real value from a string
555) !
556) ! Author: Glenn Hammond
557) ! Date: 08/29/11
558) !
559)
560) implicit none
561)
562) type(input_type) :: input
563) type(option_type) :: option
564) PetscInt :: n
565) PetscReal :: double(n)
566)
567) PetscInt :: i
568)
569) do i = 1, n
570) call InputReadDouble(input,option,double(i))
571) if (InputError(input)) return
572) enddo
573)
574) end subroutine InputReadNDoubles1
575)
576) ! ************************************************************************** !
577)
578) subroutine InputReadNDoubles2(string, option, double, n, ierr)
579) !
580) ! reads and removes "n" real values from a string
581) !
582) ! Author: Glenn Hammond
583) ! Date: 08/29/11
584) !
585)
586) implicit none
587)
588) character(len=MAXSTRINGLENGTH) :: string
589) type(option_type) :: option
590) PetscInt :: n
591) PetscReal :: double(n)
592) PetscErrorCode :: ierr
593)
594) PetscInt :: i
595)
596) do i = 1, n
597) call InputReadDouble(string,option,double(i),ierr)
598) if (InputError(ierr)) return
599) enddo
600)
601) end subroutine InputReadNDoubles2
602)
603) ! ************************************************************************** !
604)
605) subroutine InputReadPflotranString(input, option)
606) !
607) ! Reads a string (strlen characters long) from a
608) ! file while avoiding commented or skipped lines.
609) !
610) ! Author: Glenn Hammond
611) ! Date: 11/10/08
612) !
613)
614) implicit none
615)
616) type(input_type), pointer :: input
617) type(option_type) :: option
618)
619) PetscErrorCode :: ierr
620) PetscInt :: flag
621)
622) if (input%broadcast_read) then
623) if (option%myrank == option%io_rank) then
624) call InputReadPflotranStringSlave(input, option)
625) endif
626) flag = input%ierr
627) call MPI_Bcast(flag,ONE_INTEGER_MPI,MPIU_INTEGER,option%io_rank, &
628) option%mycomm,ierr)
629) input%ierr = flag
630) if (.not.InputError(input)) then
631) call MPI_Bcast(input%buf,MAXSTRINGLENGTH,MPI_CHARACTER, &
632) option%io_rank,option%mycomm,ierr)
633) endif
634) else
635) call InputReadPflotranStringSlave(input, option)
636) endif
637)
638) end subroutine InputReadPflotranString
639)
640) ! ************************************************************************** !
641)
642) subroutine InputReadPflotranStringSlave(input, option)
643) !
644) ! Reads a string (strlen characters long) from a
645) ! file while avoiding commented or skipped lines.
646) !
647) ! Author: Glenn Hammond
648) ! Date: 11/10/08
649) !
650)
651) use String_module
652)
653) implicit none
654)
655) type(input_type), pointer :: input
656) type(option_type) :: option
657) character(len=MAXSTRINGLENGTH) :: tempstring
658) character(len=MAXWORDLENGTH) :: word
659) PetscInt :: i
660) PetscInt :: skip_count
661)
662) input%ierr = 0
663)
664) ! we initialize the word to blanks to avoid error reported by valgrind
665) ! do i=1,MAXWORDLENGTH
666) ! word(i:i) = ' '
667) ! enddo
668) word = ''
669)
670) do
671) read(input%fid,'(a512)',iostat=input%ierr) input%buf
672) call StringAdjustl(input%buf)
673)
674) if (InputError(input)) then
675) ! check to see if another file is on the stack
676) if (InputPopExternalFile(input)) then
677) cycle
678) else
679) exit
680) endif
681) endif
682)
683) if (input%buf(1:1) == '#' .or. input%buf(1:1) == '!') cycle
684)
685) tempstring = input%buf
686) call InputReadWord(tempstring,word,PETSC_TRUE,input%ierr)
687) call StringToUpper(word)
688)
689) if (word(1:13) == 'EXTERNAL_FILE') then
690) ! have to stip the card 'EXTERNAL_FILE' from the buffer
691) call InputReadWord(input,option,word,PETSC_TRUE)
692) ! push a new input file to stack
693) call InputPushExternalFile(input,option)
694) cycle
695) else if (word(1:4) == 'SKIP') then
696) skip_count = 1
697) do
698) read(input%fid,'(a512)',iostat=input%ierr) tempstring
699) if (InputError(input)) then
700) option%io_buffer = 'End of file reached in ' // &
701) 'InputReadPflotranStringSlave. SKIP encountered ' // &
702) 'without a matching NOSKIP.'
703) call printErrMsg(option)
704) endif
705) call InputReadWord(tempstring,word,PETSC_FALSE,input%ierr)
706) call StringToUpper(word)
707) if (word(1:4) == 'SKIP') skip_count = skip_count + 1
708) if (word(1:4) == 'NOSK') then
709) skip_count = skip_count - 1
710) if (skip_count == 0) exit
711) endif
712) enddo
713) if (InputError(input)) exit
714) else if (word(1:1) /= ' ' .and. word(1:4) /= 'NOSK') then
715) exit
716) endif
717) enddo
718)
719) ! Check for comment midway along a string
720) if (.not.InputError(input)) then
721) tempstring = input%buf
722) input%buf = repeat(' ',MAXSTRINGLENGTH)
723) do i=1,len_trim(tempstring)
724) if (tempstring(i:i) /= '#' .and. tempstring(i:i) /= '!') then
725) input%buf(i:i) = tempstring(i:i)
726) else
727) exit
728) endif
729) enddo
730) endif
731)
732) end subroutine InputReadPflotranStringSlave
733)
734) ! ************************************************************************** !
735)
736) subroutine InputReadWord1(input, option, word, return_blank_error)
737) !
738) ! reads and removes a word (consecutive characters) from a string
739) !
740) ! Author: Glenn Hammond
741) ! Date: 11/10/08
742) !
743)
744) implicit none
745)
746) type(input_type) :: input
747) type(option_type) :: option
748) character(len=MAXWORDLENGTH) :: word
749) PetscBool :: return_blank_error
750)
751) if (InputError(input)) return
752)
753) call InputReadWord2(input%buf, word, return_blank_error, input%ierr)
754)
755) end subroutine InputReadWord1
756)
757) ! ************************************************************************** !
758)
759) subroutine InputReadWord2(string, word, return_blank_error, ierr)
760) !
761) ! reads and removes a word (consecutive characters) from a
762) ! string
763) !
764) ! Author: Glenn Hammond
765) ! Date: 11/10/08
766) !
767)
768) implicit none
769)
770) character(len=*) :: string
771) character(len=*) :: word
772) PetscBool :: return_blank_error
773) PetscErrorCode :: ierr
774)
775) PetscInt :: i, begins, ends, length
776) character(len=1), parameter :: tab = achar(9), backslash = achar(92)
777)
778) if (ierr /= 0) return
779)
780) ! Initialize character string to blank.
781) ! Initialize character string to blank. len_trim(word) is not
782) ! defined if word is allocated but not initialized. This works on
783) ! most compilers, but may not work on some? Holler if it
784) ! errors... - etc
785) word = ''
786) ! do i=1,len_trim(word)
787) ! word(i:i) = ' '
788) ! enddo
789)
790) length = len_trim(string)
791)
792) if (length == 0) then
793) if (return_blank_error) then
794) ierr = 1
795) else
796) ierr = 0
797) endif
798) return
799) else
800) ierr = 0
801)
802) ! Remove leading blanks and tabs
803) i=1
804) do while((string(i:i) == ' ' .or. string(i:i) == ',' .or. &
805) string(i:i) == tab) .and. i <= length)
806) i=i+1
807) enddo
808)
809) if (i > length) then
810) if (return_blank_error) then
811) ierr = 1
812) else
813) ierr = 0
814) endif
815) return
816) endif
817)
818) begins=i
819)
820) ! Count # of continuous characters (no blanks, commas, etc. in between)
821) do while (string(i:i) /= ' ' .and. string(i:i) /= ',' .and. &
822) string(i:i) /= tab .and. &
823) (i == begins .or. string(i:i) /= backslash))
824) i=i+1
825) enddo
826)
827) ends=i-1
828)
829) ! Avoid copying beyond the end of the word (32 characters).
830) if (ends-begins > (MAXWORDLENGTH-1)) ends = begins + (MAXWORDLENGTH-1)
831)
832) ! Copy (ends-begins) characters to 'word'
833) word = string(begins:ends)
834) ! Remove chars from string
835) string = string(ends+1:)
836)
837) endif
838)
839) end subroutine InputReadWord2
840)
841) ! ************************************************************************** !
842)
843) subroutine InputReadWordDbaseCompatible(input, option, word, &
844) return_blank_error)
845) !
846) ! reads a word and checks whether there is an entry in the Dbase with which
847) ! to swap
848) !
849) ! Author: Glenn Hammond
850) ! Date: 05/22/16
851) !
852)
853) implicit none
854)
855) type(input_type) :: input
856) type(option_type) :: option
857) character(len=MAXWORDLENGTH) :: word
858) PetscBool :: return_blank_error
859)
860) PetscBool :: found
861)
862) if (InputError(input)) return
863)
864) found = PETSC_FALSE
865) if (associated(dbase)) then
866) call InputParseDbaseForWord(input%buf,word,found,input%ierr)
867) endif
868)
869) if (.not.found) then
870) call InputReadWord(input%buf,word,PETSC_TRUE,input%ierr)
871) endif
872)
873) end subroutine InputReadWordDbaseCompatible
874)
875) ! ************************************************************************** !
876)
877) subroutine InputReadNChars1(input, option, chars, n, return_blank_error)
878) !
879) ! reads and removes a specified number of characters from a
880) ! string
881) !
882) ! Author: Glenn Hammond
883) ! Date: 11/02/00
884) !
885)
886) implicit none
887)
888) type(input_type) :: input
889) type(option_type) :: option
890) PetscBool :: return_blank_error ! Return an error for a blank line
891) ! Therefore, a blank line is not acceptable.
892)
893) PetscInt :: i, n, begins, ends
894) character(len=n) :: chars
895) character(len=1) :: tab, backslash
896)
897) if (InputError(input)) return
898)
899) call InputReadNChars2(input%buf, chars, n, return_blank_error, input%ierr)
900)
901) end subroutine InputReadNChars1
902)
903) ! ************************************************************************** !
904)
905) subroutine InputReadNChars2(string, chars, n, return_blank_error, ierr)
906) !
907) ! reads and removes a specified number of characters from a
908) ! string
909) !
910) ! Author: Glenn Hammond
911) ! Date: 11/02/00
912) !
913)
914) implicit none
915)
916) character(len=MAXSTRINGLENGTH) :: string
917) PetscBool :: return_blank_error ! Return an error for a blank line
918) ! Therefore, a blank line is not acceptable.
919)
920) PetscInt :: i, n, begins, ends
921) character(len=n) :: chars
922) PetscErrorCode :: ierr
923) character(len=1), parameter :: tab = achar(9), backslash = achar(92)
924)
925) if (InputError(ierr)) return
926)
927) ! Initialize character string to blank.
928) chars(1:n) = repeat(' ',n)
929)
930) ierr = len_trim(string)
931) if (.not.InputError(ierr)) then
932) if (return_blank_error) then
933) ierr = 1
934) else
935) ierr = 0
936) endif
937) return
938) else
939) ierr = 0
940)
941) ! Remove leading blanks and tabs
942) i=1
943) do while(string(i:i) == ' ' .or. string(i:i) == tab)
944) i=i+1
945) enddo
946)
947) begins=i
948)
949) ! Count # of continuous characters (no blanks, commas, etc. in between)
950) do while (string(i:i) /= ' ' .and. string(i:i) /= ',' .and. &
951) string(i:i) /= tab .and. &
952) (i == begins .or. string(i:i) /= backslash))
953) i=i+1
954) enddo
955)
956) ends=i-1
957)
958) if (ends-begins+1 > n) then ! string read is too large for 'chars'
959) ierr = 1
960) return
961) endif
962)
963) ! Copy (ends-begins) characters to 'chars'
964) chars = string(begins:ends)
965) ! Remove chars from string
966) string = string(ends+1:)
967)
968) endif
969)
970) end subroutine InputReadNChars2
971)
972) ! ************************************************************************** !
973)
974) subroutine InputReadQuotedWord(input, option, word, return_blank_error)
975) !
976) ! reads and removes a word from a string, that is
977) ! delimited by "'".
978) !
979) ! Author: Glenn Hammond
980) ! Date: 11/07/00
981) !
982)
983) implicit none
984)
985) type(input_type) :: input
986) type(option_type) :: option
987) PetscInt :: i, begins, ends, realends, len_trim_word
988) PetscBool :: return_blank_error ! Return an error for a blank line
989) ! Therefore, a blank line is not acceptable.
990) character(len=*) :: word
991) PetscBool :: openquotefound
992) character(len=1), parameter :: tab = achar(9), backslash = achar(92)
993)
994) if (InputError(input)) return
995)
996) openquotefound = PETSC_FALSE
997) ! Initialize character string to blank.
998) len_trim_word = len_trim(word)
999) word(1:len_trim_word) = repeat(' ',len_trim_word)
1000)
1001) if (len_trim(input%buf) == 0) then
1002) if (return_blank_error) then
1003) input%ierr = 1
1004) else
1005) input%ierr = 0
1006) endif
1007) return
1008) else
1009) input%ierr = 0
1010)
1011) ! Remove leading blanks and tabs
1012) i=1
1013) do while(input%buf(i:i) == ' ' .or. input%buf(i:i) == tab)
1014) i=i+1
1015) enddo
1016)
1017) if (input%buf(i:i) == "'") then
1018) openquotefound = PETSC_TRUE
1019) i=i+1
1020) endif
1021)
1022) begins=i
1023)
1024) if (openquotefound) then
1025) do while (input%buf(i:i) /= "'")
1026) if (i > (MAXWORDLENGTH-1)) exit
1027) i=i+1
1028) enddo
1029) else
1030) ! Count # of continuous characters (no blanks, commas, etc. in between)
1031) do while (input%buf(i:i) /= ' ' .and. input%buf(i:i) /= ',' .and. &
1032) input%buf(i:i) /= tab .and. &
1033) (i == begins .or. input%buf(i:i) /= backslash))
1034) i=i+1
1035) enddo
1036) endif
1037)
1038) realends = i
1039) ends=i-1
1040)
1041) ! Avoid copying beyond the end of the word (32 characters).
1042) if (ends-begins > (MAXWORDLENGTH-1)) ends = begins + (MAXWORDLENGTH-1)
1043)
1044) ! Copy (ends-begins) characters to 'chars'
1045) word = input%buf(begins:ends)
1046) ! Remove chars from string
1047) input%buf = input%buf(realends+1:)
1048) endif
1049)
1050) end subroutine InputReadQuotedWord
1051)
1052) ! ************************************************************************** !
1053)
1054) subroutine InputReadPath(string, word, return_blank_error, ierr)
1055) !
1056) ! reads and removes a words from a path
1057) !
1058) ! Author: Glenn Hammond
1059) ! Date: 01/14/10
1060) !
1061)
1062) implicit none
1063)
1064) character(len=*) :: string
1065) character(len=*) :: word
1066) PetscBool :: return_blank_error
1067) PetscErrorCode :: ierr
1068)
1069) PetscInt :: i, begins, ends, len_trim_word
1070) character(len=1), parameter :: slash = achar(47), backslash = achar(92)
1071)
1072) if (ierr /= 0) return
1073)
1074) ! Initialize character string to blank.
1075) len_trim_word = len_trim(word)
1076) word(1:len_trim_word) = repeat(' ',len_trim_word)
1077)
1078) ierr = len_trim(string)
1079)
1080) if (ierr == 0) then
1081) if (return_blank_error) then
1082) ierr = 1
1083) else
1084) ierr = 0
1085) endif
1086) return
1087) else
1088) ierr = 0
1089)
1090) ! Remove leading blanks and tabs
1091) i=1
1092) do while(string(i:i) == ' ' .and. string(i:i) == slash)
1093) i=i+1
1094) enddo
1095)
1096) begins=i
1097)
1098) ! Count # of characters (no slashes in between)
1099) do while (string(i:i) /= slash .and. &
1100) (i == begins .or. string(i:i) /= backslash))
1101) i=i+1
1102) enddo
1103)
1104) ends=i-1
1105)
1106) ! Avoid copying beyond the end of the word (32 characters).
1107) if (ends-begins > (MAXWORDLENGTH-1)) ends = begins + (MAXWORDLENGTH-1)
1108)
1109) ! Copy (ends-begins) characters to 'word'
1110) word = string(begins:ends)
1111) ! Remove chars from string
1112) string = string(ends+1:)
1113)
1114) endif
1115)
1116) end subroutine InputReadPath
1117)
1118) ! ************************************************************************** !
1119)
1120) subroutine InputFindStringInFile1(input, option, string)
1121) !
1122) ! Rewinds file and finds the first occurrence of
1123) ! 'string'. Note that the line must start with 'string'
1124) ! in order to match and that line is NOT returned
1125) !
1126) ! Author: Glenn Hammond
1127) ! Date: 03/07/07
1128) !
1129)
1130) use String_module
1131)
1132) implicit none
1133)
1134) type(input_type), pointer :: input
1135) type(option_type) :: option
1136) character(len=MAXSTRINGLENGTH) :: string
1137)
1138) call InputFindStringInFile2(input, option, string, PETSC_TRUE)
1139)
1140) end subroutine InputFindStringInFile1
1141)
1142) ! ************************************************************************** !
1143)
1144) subroutine InputFindStringInFile2(input, option, string, print_warning)
1145) !
1146) ! Rewinds file and finds the first occurrence of
1147) ! 'string'. Note that the line must start with 'string'
1148) ! in order to match and that line is NOT returned
1149) !
1150) ! Author: Glenn Hammond
1151) ! Date: 03/07/07
1152) !
1153)
1154) use String_module
1155)
1156) implicit none
1157)
1158) type(input_type), pointer :: input
1159) type(option_type) :: option
1160) character(len=MAXSTRINGLENGTH) :: string
1161) PetscBool :: print_warning
1162)
1163) character(len=MAXWORDLENGTH) :: word
1164) PetscBool :: found = PETSC_FALSE
1165) PetscInt :: length1, length2, i
1166)
1167) input%ierr = 0
1168)
1169) length1 = len_trim(string)
1170)
1171) do
1172) call InputReadPflotranString(input,option)
1173) if (InputError(input)) exit
1174) call InputReadWord(input,option,word,PETSC_TRUE)
1175) if (InputError(input)) exit
1176) length2 = len_trim(word)
1177) if (length1 == length2 .and. StringCompare(string,word,length1)) then
1178) found = PETSC_TRUE
1179) exit
1180) endif
1181) enddo
1182)
1183) ! if not found, rewind once and try again. this approach avoids excessive
1184) ! reading if successive searches for strings are in descending order in
1185) ! the file.
1186) if (InputError(input)) then
1187) input%ierr = 0
1188) rewind(input%fid)
1189) do
1190) call InputReadPflotranString(input,option)
1191) if (InputError(input)) exit
1192) call InputReadWord(input,option,word,PETSC_TRUE)
1193) if (InputError(input)) exit
1194) length2 = len_trim(word)
1195) if (length1 == length2 .and. StringCompare(string,word,length1)) then
1196) found = PETSC_TRUE
1197) exit
1198) endif
1199) enddo
1200) endif
1201)
1202) if (.not.found .and. print_warning) then
1203) option%io_buffer = 'Card (' // trim(string) // ') not found in input file.'
1204) call printWrnMsg(option)
1205) input%ierr = 1
1206) endif
1207)
1208) end subroutine InputFindStringInFile2
1209)
1210) ! ************************************************************************** !
1211)
1212) subroutine InputSkipToEND(input,option,string)
1213) !
1214) ! Skips to keyword END
1215) !
1216) ! Author: Glenn Hammond
1217) ! Date: 10/26/07
1218) !
1219)
1220) implicit none
1221)
1222) type(input_type), pointer :: input
1223) type(option_type) :: option
1224) character(len=*) :: string
1225)
1226) do
1227) call InputReadPflotranString(input,option)
1228) input%err_buf = 'End of file found before end of card ' // trim(string)
1229) call InputReadStringErrorMsg(input,option)
1230) if (InputCheckExit(input,option)) exit
1231) enddo
1232)
1233) end subroutine InputSkipToEND
1234)
1235) ! ************************************************************************** !
1236)
1237) function InputCheckExit(input,option)
1238) !
1239) ! Checks whether an end character (.,/,'END') has been found
1240) !
1241) ! Author: Glenn Hammond
1242) ! Date: 10/14/08
1243) !
1244)
1245) use String_module
1246)
1247) implicit none
1248)
1249) type(input_type) :: input
1250) type(option_type) :: option
1251) PetscInt :: i
1252) character(len=1) :: tab
1253)
1254) PetscBool :: InputCheckExit
1255)
1256) ! We must remove leading blanks and tabs. --RTM
1257) tab = achar(9)
1258) i=1
1259) do while(input%buf(i:i) == ' ' .or. input%buf(i:i) == tab)
1260) i=i+1
1261) enddo
1262)
1263) if (input%buf(i:i) == '/' .or. &
1264) !geh: this fails when the keyword starts with END
1265) !geh StringCompare(input%buf(i:),'END',THREE_INTEGER)) then
1266) StringCompare(input%buf(i:),'END') .or. &
1267) ! to end a block, e.g. END_SUBSURFACE
1268) StringStartsWith(input%buf(i:),'END_')) then
1269) InputCheckExit = PETSC_TRUE
1270) else
1271) InputCheckExit = PETSC_FALSE
1272) endif
1273)
1274) end function InputCheckExit
1275)
1276) ! ************************************************************************** !
1277)
1278) function InputError1(input)
1279) !
1280) ! Returns true if an error has occurred
1281) !
1282) ! Author: Glenn Hammond
1283) ! Date: 12/10/08
1284) !
1285)
1286) implicit none
1287)
1288) type(input_type) :: input
1289)
1290) PetscBool :: InputError1
1291)
1292) if (input%ierr == 0) then
1293) InputError1 = PETSC_FALSE
1294) else
1295) InputError1 = PETSC_TRUE
1296) endif
1297)
1298) end function InputError1
1299)
1300) ! ************************************************************************** !
1301)
1302) function InputError2(ierr)
1303) !
1304) ! Returns true if an error has occurred
1305) !
1306) ! Author: Glenn Hammond
1307) ! Date: 12/10/08
1308) !
1309)
1310) implicit none
1311)
1312) PetscErrorCode :: ierr
1313)
1314) PetscBool :: InputError2
1315)
1316) if (ierr == 0) then
1317) InputError2 = PETSC_FALSE
1318) else
1319) InputError2 = PETSC_TRUE
1320) endif
1321)
1322) end function InputError2
1323)
1324) ! ************************************************************************** !
1325)
1326) subroutine InputGetCommandLineInt(string,int_value,found,option)
1327) !
1328) ! Returns integer value associated with a command
1329) ! line argument
1330) !
1331) ! Author: Glenn Hammond
1332) ! Date: 02/05/09
1333) !
1334)
1335) use String_module
1336) use Option_module
1337)
1338) implicit none
1339)
1340) character(len=MAXSTRINGLENGTH) :: string
1341) type(option_type) :: option
1342) PetscBool :: found
1343) PetscInt :: int_value
1344)
1345) PetscInt :: iarg, narg
1346) character(len=MAXSTRINGLENGTH) :: string2
1347) PetscErrorCode :: ierr
1348)
1349) ierr = 0
1350) ! do not initialize int_value, as it may already have a value
1351) found = PETSC_FALSE
1352) narg = getCommandLineArgumentCount()
1353) string = adjustl(string)
1354) do iarg = 1, narg
1355) call getCommandLineArgument(iarg,string2)
1356) if (StringCompare(string,string2)) then
1357) found = PETSC_TRUE
1358) if (iarg+1 <= narg) then
1359) call getCommandLineArgument(iarg+1,string2)
1360) call InputReadInt(string2,option,int_value,ierr)
1361) else
1362) ierr = 1
1363) endif
1364) if (InputError(ierr)) then
1365) option%io_buffer = 'Integer argument for command line argument "' // &
1366) trim(adjustl(string)) // '" not found.'
1367) call printErrMsg(option)
1368) endif
1369) exit
1370) endif
1371) enddo
1372)
1373) end subroutine InputGetCommandLineInt
1374)
1375) ! ************************************************************************** !
1376)
1377) subroutine InputGetCommandLineReal(string,double_value,found,option)
1378) !
1379) ! Returns real*8 value associated with a command
1380) ! line argument
1381) !
1382) ! Author: Glenn Hammond
1383) ! Date: 02/05/09
1384) !
1385)
1386) use String_module
1387) use Option_module
1388)
1389) implicit none
1390)
1391) character(len=MAXSTRINGLENGTH) :: string
1392) type(option_type) :: option
1393) PetscBool :: found
1394) PetscReal :: double_value
1395)
1396) PetscInt :: iarg, narg
1397) character(len=MAXSTRINGLENGTH) :: string2
1398) PetscErrorCode :: ierr
1399)
1400) ierr = 0
1401) ! do not initialize int_value, as it may already have a value
1402) found = PETSC_FALSE
1403) narg = getCommandLineArgumentCount()
1404) string = adjustl(string)
1405) do iarg = 1, narg
1406) call getCommandLineArgument(iarg,string2)
1407) if (StringCompare(string,string2)) then
1408) found = PETSC_TRUE
1409) if (iarg+1 <= narg) then
1410) call getCommandLineArgument(iarg+1,string2)
1411) call InputReadDouble(string2,option,double_value,ierr)
1412) else
1413) ierr = 1
1414) endif
1415) if (InputError(ierr)) then
1416) option%io_buffer = 'Real argument for command line argument "' // &
1417) trim(adjustl(string)) // '" not found.'
1418) call printErrMsg(option)
1419) endif
1420) exit
1421) endif
1422) enddo
1423)
1424) end subroutine InputGetCommandLineReal
1425)
1426) ! ************************************************************************** !
1427)
1428) subroutine InputGetCommandLineString(string,string_value,found,option)
1429) !
1430) ! Returns a string associated with a command
1431) ! line argument
1432) !
1433) ! Author: Glenn Hammond
1434) ! Date: 02/05/09
1435) !
1436)
1437) use String_module
1438) use Option_module
1439)
1440) implicit none
1441)
1442) character(len=MAXSTRINGLENGTH) :: string
1443) type(option_type) :: option
1444) PetscBool :: found
1445) character(len=MAXSTRINGLENGTH) :: string_value
1446)
1447) PetscInt :: iarg, narg
1448) character(len=MAXSTRINGLENGTH) :: string2
1449) PetscErrorCode :: ierr
1450)
1451) ierr = 0
1452) ! do not initialize int_value, as it may already have a value
1453) found = PETSC_FALSE
1454) narg = getCommandLineArgumentCount()
1455) string = adjustl(string)
1456) do iarg = 1, narg
1457) call getCommandLineArgument(iarg,string2)
1458) if (StringCompare(string,string2)) then
1459) found = PETSC_TRUE
1460) if (iarg+1 <= narg) then
1461) call getCommandLineArgument(iarg+1,string2)
1462) call InputReadNChars(string2,string_value,MAXSTRINGLENGTH, &
1463) PETSC_TRUE,ierr)
1464) if (string_value(1:1) == '-') then
1465) ! no argument exists
1466) option%io_buffer = 'String argument (' // &
1467) trim(adjustl(string_value)) // &
1468) ') for command line argument "' // &
1469) trim(adjustl(string)) // '" not recognized.'
1470) call printErrMsg(option)
1471) endif
1472) else
1473) ierr = 1
1474) endif
1475) if (InputError(ierr)) then
1476) option%io_buffer = 'String argument for command line argument "' // &
1477) trim(adjustl(string)) // '" not found.'
1478) call printErrMsg(option)
1479) endif
1480) exit
1481) endif
1482) enddo
1483)
1484) end subroutine InputGetCommandLineString
1485)
1486) ! ************************************************************************** !
1487)
1488) subroutine InputGetCommandLineTruth(string,truth_value,found,option)
1489) !
1490) ! Returns logical associated with a command
1491) ! line argument
1492) !
1493) ! Author: Glenn Hammond
1494) ! Date: 02/05/09
1495) !
1496)
1497) use String_module
1498) use Option_module
1499)
1500) implicit none
1501)
1502) character(len=MAXSTRINGLENGTH) :: string
1503) type(option_type) :: option
1504) PetscBool :: found
1505) PetscBool :: truth_value
1506)
1507) PetscInt :: iarg, narg
1508) character(len=MAXSTRINGLENGTH) :: string2
1509) character(len=MAXWORDLENGTH) :: word
1510) PetscErrorCode :: ierr
1511)
1512) ierr = 0
1513) ! do not initialize int_value, as it may already have a value
1514) found = PETSC_FALSE
1515) narg = getCommandLineArgumentCount()
1516) string = adjustl(string)
1517) do iarg = 1, narg
1518) call getCommandLineArgument(iarg,string2)
1519) if (StringCompare(string,string2)) then
1520) found = PETSC_TRUE
1521) if (iarg+1 <= narg) then
1522) call getCommandLineArgument(iarg+1,string2)
1523) call InputReadWord(string2,word,PETSC_TRUE,ierr)
1524) else
1525) ! check if no argument exists, which is valid and means 'true'
1526) truth_value = PETSC_TRUE
1527) exit
1528) endif
1529) if (word(1:1) == '-') then
1530) ! no argument exists, which is valid and means 'true'
1531) truth_value = PETSC_TRUE
1532) exit
1533) endif
1534) call StringToLower(word)
1535) select case(trim(word))
1536) case('yes','true','1','on')
1537) truth_value = PETSC_TRUE
1538) case('no','false','0','off')
1539) truth_value = PETSC_FALSE
1540) case default
1541) option%io_buffer = 'Truth argument for command line argument "' // &
1542) trim(adjustl(string)) // '" not recognized.'
1543) call printErrMsg(option)
1544) end select
1545) endif
1546) enddo
1547)
1548) end subroutine InputGetCommandLineTruth
1549)
1550) ! ************************************************************************** !
1551)
1552) function getCommandLineArgumentCount()
1553) !
1554) ! Returns the number of command line arguments
1555) !
1556) ! Author: Glenn Hammond
1557) ! Date: 02/05/10
1558) !
1559)
1560) implicit none
1561)
1562) integer :: iargc
1563)
1564) PetscInt :: getCommandLineArgumentCount
1565)
1566) ! initialize to zero
1567) getCommandLineArgumentCount = 0
1568)
1569) #if defined(PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT)
1570) getCommandLineArgumentCount = command_argument_count()
1571) #elif defined(PETSC_HAVE_GETARG)
1572) getCommandLineArgumentCount = iargc()
1573) #endif
1574)
1575) end function getCommandLineArgumentCount
1576)
1577) ! ************************************************************************** !
1578)
1579) subroutine getCommandLineArgument(i,arg)
1580) !
1581) ! Returns the ith command line argument
1582) !
1583) ! Author: Glenn Hammond
1584) ! Date: 02/05/10
1585) !
1586)
1587) implicit none
1588)
1589) PetscInt :: i
1590) character(len=*) :: arg
1591)
1592) integer*4 :: fortran_int
1593)
1594) fortran_int = i
1595) #if defined(PETSC_HAVE_FORTRAN_GET_COMMAND_ARGUMENT)
1596) call get_command_argument(fortran_int,arg)
1597) #elif defined(PETSC_HAVE_GETARG)
1598) call getarg(fortran_int,arg)
1599) #endif
1600)
1601) end subroutine getCommandLineArgument
1602)
1603) ! ************************************************************************** !
1604)
1605) subroutine InputReadFilenames(option,filenames)
1606) !
1607) ! Reads filenames for multi-simulation runs
1608) !
1609) ! Author: Glenn Hammond
1610) ! Date: 08/11/09
1611) !
1612)
1613) use Option_module
1614)
1615) type(option_type) :: option
1616) character(len=MAXSTRINGLENGTH), pointer :: filenames(:)
1617)
1618) character(len=MAXSTRINGLENGTH) :: string
1619) character(len=MAXSTRINGLENGTH) :: filename
1620) PetscInt :: filename_count
1621) type(input_type), pointer :: input
1622) PetscBool :: card_found
1623)
1624) input => InputCreate(IN_UNIT,option%input_filename,option)
1625)
1626) string = "FILENAMES"
1627) call InputFindStringInFile(input,option,string)
1628)
1629) card_found = PETSC_FALSE
1630) if (InputError(input)) then
1631) ! if the FILENAMES card is not included, we will assume that only
1632) ! filenames exist in the file.
1633) rewind(input%fid)
1634) else
1635) card_found = PETSC_TRUE
1636) endif
1637)
1638) filename_count = 0
1639) do
1640) call InputReadPflotranString(input,option)
1641) if (InputError(input)) exit
1642) if (InputCheckExit(input,option)) exit
1643) call InputReadNChars(input,option,filename,MAXSTRINGLENGTH,PETSC_FALSE)
1644) filename_count = filename_count + 1
1645) enddo
1646)
1647) allocate(filenames(filename_count))
1648) filenames = ''
1649) rewind(input%fid)
1650)
1651) if (card_found) then
1652) string = "FILENAMES"
1653) call InputFindStringInFile(input,option,string)
1654) endif
1655)
1656) filename_count = 0
1657) do
1658) call InputReadPflotranString(input,option)
1659) if (InputError(input)) exit
1660) if (InputCheckExit(input,option)) exit
1661) call InputReadNChars(input,option,filename,MAXSTRINGLENGTH,PETSC_FALSE)
1662) filename_count = filename_count + 1
1663) filenames(filename_count) = filename
1664) enddo
1665)
1666) call InputDestroy(input)
1667)
1668) end subroutine InputReadFilenames
1669)
1670) ! ************************************************************************** !
1671)
1672) function InputGetLineCount(input)
1673)
1674) implicit none
1675)
1676) type(input_type), pointer :: input
1677) PetscInt :: line_count
1678) PetscInt :: InputGetLineCount
1679)
1680) rewind(input%fid)
1681)
1682) line_count = 0
1683) do
1684) read(input%fid, '(a512)', iostat=input%ierr)
1685) if (InputError(input)) exit
1686) line_count = line_count + 1
1687) enddo
1688)
1689) InputGetLineCount = line_count
1690)
1691) end function InputGetLineCount
1692)
1693) ! ************************************************************************** !
1694)
1695) subroutine InputReadToBuffer(input, buffer)
1696)
1697) implicit none
1698)
1699) type(input_type), pointer :: input
1700) character(len=MAXSTRINGLENGTH) :: buffer(:)
1701) character(len=MAXSTRINGLENGTH) :: string
1702) PetscInt :: line
1703)
1704) rewind(input%fid)
1705) line = 0
1706) do
1707) read(input%fid, '(a512)', iostat=input%ierr) string
1708) if (InputError(input)) exit
1709) line = line + 1
1710) buffer(line) = string
1711) end do
1712)
1713) end subroutine InputReadToBuffer
1714)
1715) ! ************************************************************************** !
1716)
1717) subroutine InputReadASCIIDbase(filename,option)
1718) !
1719) ! Read in an ASCII database
1720) !
1721) ! Author: Glenn Hammond
1722) ! Date: 08/19/14
1723) !
1724) use Option_module
1725) use String_module
1726)
1727) implicit none
1728)
1729) character(len=MAXWORDLENGTH) :: filename
1730) type(option_type) :: option
1731)
1732) character(len=MAXSTRINGLENGTH) :: string
1733) character(len=MAXWORDLENGTH) :: word
1734) character(len=MAXWORDLENGTH), allocatable :: words(:)
1735) character(len=MAXWORDLENGTH) :: object_name
1736) type(input_type), pointer :: input
1737) PetscInt :: icount
1738) PetscInt :: value_count
1739) PetscInt :: value_index
1740) PetscInt :: value_type
1741) PetscInt :: num_values_in_dataset
1742) PetscInt :: num_words, num_ints, num_reals
1743)
1744) input => InputCreate(IUNIT_TEMP,filename,option)
1745)
1746) icount = 0
1747) num_values_in_dataset = 0
1748) num_ints = 0
1749) num_reals = 0
1750) num_words = 0
1751) do
1752) call InputReadPflotranString(input,option)
1753) if (InputError(input)) exit
1754) call InputReadWord(input,option,word,PETSC_FALSE)
1755) if (StringStartsWithAlpha(word)) then
1756) icount = icount + 1
1757) if (icount == 1) then
1758) string = input%buf
1759) do
1760) call InputReadWord(input,option,word,PETSC_TRUE)
1761) if (input%ierr /= 0) exit
1762) num_values_in_dataset = num_values_in_dataset + 1
1763) enddo
1764) input%buf = string
1765) endif
1766) input%ierr = 0
1767) call InputReadWord(input,option,word,PETSC_TRUE)
1768) call InputErrorMsg(input,option,'value','ASCII Dbase')
1769) select case(StringIntegerDoubleOrWord(word))
1770) case(STRING_IS_INTEGER)
1771) num_ints = num_ints + 1
1772) case(STRING_IS_DOUBLE)
1773) num_reals = num_reals + 1
1774) case(STRING_IS_WORD)
1775) num_words = num_words + 1
1776) end select
1777) endif
1778) enddo
1779)
1780) value_index = 1
1781) if (option%id > 0) then
1782) if (option%id > num_values_in_dataset) then
1783) write(word,*) num_values_in_dataset
1784) option%io_buffer = 'Data in DBASE_FILENAME "' // &
1785) trim(filename) // &
1786) '" is too small (' // trim(adjustl(word)) // &
1787) ') for number of realizations.'
1788) call printErrMsg(option)
1789) endif
1790) value_index = option%id
1791) endif
1792) allocate(words(num_values_in_dataset))
1793) words = ''
1794)
1795) rewind(input%fid)
1796) allocate(dbase)
1797) if (num_ints > 0) then
1798) allocate(dbase%icard(num_ints))
1799) dbase%icard = ''
1800) allocate(dbase%ivalue(num_ints))
1801) dbase%ivalue = UNINITIALIZED_INTEGER
1802) endif
1803) if (num_reals > 0) then
1804) allocate(dbase%rcard(num_reals))
1805) dbase%rcard = ''
1806) allocate(dbase%rvalue(num_reals))
1807) dbase%rvalue = UNINITIALIZED_DOUBLE
1808) endif
1809) if (num_words > 0) then
1810) allocate(dbase%ccard(num_words))
1811) dbase%ccard = ''
1812) allocate(dbase%cvalue(num_words))
1813) dbase%cvalue = '-999'
1814) endif
1815) num_ints = 0
1816) num_reals = 0
1817) num_words = 0
1818) do
1819) call InputReadPflotranString(input,option)
1820) if (InputError(input)) exit
1821) call InputReadWord(input,option,word,PETSC_FALSE)
1822) if (StringStartsWithAlpha(word)) then
1823) object_name = word
1824) words = ''
1825) value_count = 0
1826) do
1827) call InputReadWord(input,option,word,PETSC_TRUE)
1828) if (input%ierr /= 0) exit
1829) value_count = value_count + 1
1830) if (value_count <= num_values_in_dataset) &
1831) words(value_count) = word
1832) enddo
1833) if (value_count /= num_values_in_dataset) then
1834) write(word,*) value_count
1835) option%io_buffer = 'Data in DBASE_FILENAME "' // &
1836) trim(object_name) // &
1837) '" has an inconsistent number of values (' // &
1838) trim(adjustl(word)) // &
1839) ') for number of realizations ('
1840) write(word,*) num_values_in_dataset
1841) option%io_buffer = trim(option%io_buffer) // &
1842) trim(adjustl(word)) // ').'
1843) call printErrMsg(option)
1844) endif
1845) call StringToUpper(object_name)
1846) string = words(value_index)
1847) value_type = StringIntegerDoubleOrWord(string)
1848) string = words(value_index)
1849) select case(value_type)
1850) case(STRING_IS_INTEGER)
1851) num_ints = num_ints + 1
1852) dbase%icard(num_ints) = adjustl(object_name)
1853) call InputReadInt(string,option,dbase%ivalue(num_ints),input%ierr)
1854) call InputErrorMsg(input,option,'ivalue','ASCII Dbase '//object_name)
1855) case(STRING_IS_DOUBLE)
1856) num_reals = num_reals + 1
1857) dbase%rcard(num_reals) = adjustl(object_name)
1858) call InputReadDouble(string,option,dbase%rvalue(num_reals),input%ierr)
1859) call InputErrorMsg(input,option,'rvalue','ASCII Dbase '//object_name)
1860) case(STRING_IS_WORD)
1861) num_words = num_words + 1
1862) dbase%ccard(num_words) = adjustl(object_name)
1863) dbase%cvalue(num_words) = words(value_index)
1864) end select
1865) endif
1866) enddo
1867) deallocate(words)
1868)
1869) call InputDestroy(input)
1870)
1871) end subroutine InputReadASCIIDbase
1872)
1873) ! ************************************************************************** !
1874)
1875) subroutine InputParseDbaseForInt(buffer,value,found,ierr)
1876) !
1877) ! Parses database for an integer value
1878) !
1879) ! Author: Glenn Hammond
1880) ! Date: 08/19/14
1881) !
1882) use String_module
1883)
1884) implicit none
1885)
1886) character(len=MAXSTRINGLENGTH) :: buffer
1887) PetscInt :: value
1888) PetscBool :: found
1889) PetscErrorCode :: ierr
1890)
1891) character(len=MAXSTRINGLENGTH) :: buffer_save
1892) character(len=MAXWORDLENGTH) :: word
1893) character(len=MAXWORDLENGTH) :: dbase_keyword = 'DBASE_VALUE'
1894)
1895) buffer_save = buffer
1896) found = PETSC_FALSE
1897) call InputReadWord(buffer,word,PETSC_TRUE,ierr)
1898) if (StringCompareIgnoreCase(word,dbase_keyword)) then
1899) call InputReadWord(buffer,word,PETSC_TRUE,ierr)
1900) call DbaseLookupInt(word,value,ierr)
1901) if (ierr == 0) then
1902) found = PETSC_TRUE
1903) endif
1904) else
1905) buffer = buffer_save
1906) endif
1907)
1908) end subroutine InputParseDbaseForInt
1909)
1910) ! ************************************************************************** !
1911)
1912) subroutine InputParseDbaseForDouble(buffer,value,found,ierr)
1913) !
1914) ! Parses database for an double precision value
1915) !
1916) ! Author: Glenn Hammond
1917) ! Date: 08/19/14
1918) !
1919) use String_module
1920)
1921) implicit none
1922)
1923) character(len=MAXSTRINGLENGTH) :: buffer
1924) PetscReal :: value
1925) PetscBool :: found
1926) PetscErrorCode :: ierr
1927)
1928) character(len=MAXSTRINGLENGTH) :: buffer_save
1929) character(len=MAXWORDLENGTH) :: word
1930) character(len=MAXWORDLENGTH) :: dbase_keyword = 'DBASE_VALUE'
1931)
1932) buffer_save = buffer
1933) found = PETSC_FALSE
1934) call InputReadWord(buffer,word,PETSC_TRUE,ierr)
1935) if (StringCompareIgnoreCase(word,dbase_keyword)) then
1936) call InputReadWord(buffer,word,PETSC_TRUE,ierr)
1937) call DbaseLookupDouble(word,value,ierr)
1938) if (ierr == 0) then
1939) found = PETSC_TRUE
1940) endif
1941) else
1942) buffer = buffer_save
1943) endif
1944)
1945) end subroutine InputParseDbaseForDouble
1946)
1947) ! ************************************************************************** !
1948)
1949) subroutine InputParseDbaseForWord(buffer,value,found,ierr)
1950) !
1951) ! Parses database for a word
1952) !
1953) ! Author: Glenn Hammond
1954) ! Date: 05/22/16
1955) !
1956) use String_module
1957)
1958) implicit none
1959)
1960) character(len=MAXSTRINGLENGTH) :: buffer
1961) character(len=MAXWORDLENGTH) :: value
1962) PetscBool :: found
1963) PetscErrorCode :: ierr
1964)
1965) character(len=MAXSTRINGLENGTH) :: buffer_save
1966) character(len=MAXWORDLENGTH) :: word
1967) character(len=MAXWORDLENGTH) :: dbase_keyword = 'DBASE_VALUE'
1968)
1969) buffer_save = buffer
1970) found = PETSC_FALSE
1971) call InputReadWord(buffer,word,PETSC_TRUE,ierr)
1972) if (StringCompareIgnoreCase(word,dbase_keyword)) then
1973) call InputReadWord(buffer,word,PETSC_TRUE,ierr)
1974) call DbaseLookupWord(word,value,ierr)
1975) if (ierr == 0) then
1976) found = PETSC_TRUE
1977) endif
1978) else
1979) buffer = buffer_save
1980) endif
1981)
1982) end subroutine InputParseDbaseForWord
1983)
1984) ! ************************************************************************** !
1985)
1986) subroutine DbaseLookupInt(keyword,value,ierr)
1987) !
1988) ! Looks up double precision value in database
1989) !
1990) ! Author: Glenn Hammond
1991) ! Date: 08/19/14
1992) !
1993) use String_module
1994)
1995) implicit none
1996)
1997) character(len=MAXWORDLENGTH) :: keyword
1998) PetscInt :: value
1999) PetscErrorCode :: ierr
2000)
2001) PetscInt :: i
2002) PetscBool :: found
2003)
2004) ierr = 0
2005)
2006) call StringToUpper(keyword)
2007)
2008) found = PETSC_FALSE
2009) if (associated(dbase%icard)) then
2010) do i = 1, size(dbase%icard)
2011) if (StringCompare(keyword,dbase%icard(i))) then
2012) found = PETSC_TRUE
2013) value = dbase%ivalue(i)
2014) exit
2015) endif
2016) enddo
2017) endif
2018)
2019) if (.not.found) then
2020) ierr = 1
2021) endif
2022)
2023) end subroutine DbaseLookupInt
2024)
2025) ! ************************************************************************** !
2026)
2027) subroutine DbaseLookupDouble(keyword,value,ierr)
2028) !
2029) ! Looks up double precision value in database
2030) !
2031) ! Author: Glenn Hammond
2032) ! Date: 08/19/14
2033) !
2034) use String_module
2035)
2036) implicit none
2037)
2038) character(len=MAXWORDLENGTH) :: keyword
2039) PetscReal :: value
2040) PetscErrorCode :: ierr
2041)
2042) PetscInt :: i
2043) PetscBool :: found
2044)
2045) ierr = 0
2046)
2047) call StringToUpper(keyword)
2048)
2049) found = PETSC_FALSE
2050) if (associated(dbase%rcard)) then
2051) do i = 1, size(dbase%rcard)
2052) if (StringCompare(keyword,dbase%rcard(i))) then
2053) found = PETSC_TRUE
2054) value = dbase%rvalue(i)
2055) exit
2056) endif
2057) enddo
2058) endif
2059)
2060) if (.not.found) then
2061) ierr = 1
2062) endif
2063)
2064) end subroutine DbaseLookupDouble
2065)
2066) ! ************************************************************************** !
2067)
2068) subroutine DbaseLookupWord(keyword,value,ierr)
2069) !
2070) ! Looks up double precision value in database
2071) !
2072) ! Author: Glenn Hammond
2073) ! Date: 08/19/14
2074) !
2075) use String_module
2076)
2077) implicit none
2078)
2079) character(len=MAXWORDLENGTH) :: keyword
2080) character(len=MAXWORDLENGTH) :: value
2081) PetscErrorCode :: ierr
2082)
2083) PetscInt :: i
2084) PetscBool :: found
2085)
2086) ierr = 0
2087)
2088) call StringToUpper(keyword)
2089)
2090) found = PETSC_FALSE
2091) if (associated(dbase%ccard)) then
2092) do i = 1, size(dbase%ccard)
2093) if (StringCompare(keyword,dbase%ccard(i))) then
2094) found = PETSC_TRUE
2095) value = dbase%cvalue(i)
2096) exit
2097) endif
2098) enddo
2099) endif
2100)
2101) if (.not.found) then
2102) ierr = 1
2103) endif
2104)
2105) end subroutine DbaseLookupWord
2106)
2107) ! ************************************************************************** !
2108)
2109) subroutine InputKeywordUnrecognized1(keyword,string,option)
2110) !
2111) ! Looks up double precision value in database
2112) !
2113) ! Author: Glenn Hammond
2114) ! Date: 08/19/14
2115) !
2116) use Option_module
2117)
2118) implicit none
2119)
2120) character(len=*) :: keyword
2121) character(len=*) :: string
2122) type(option_type) :: option
2123)
2124) character(len=1) :: null_string
2125)
2126) null_string = ''
2127) call InputKeywordUnrecognized2(keyword,string,null_string,option)
2128)
2129) end subroutine InputKeywordUnrecognized1
2130)
2131) ! ************************************************************************** !
2132)
2133) subroutine InputKeywordUnrecognized2(keyword,string,string2,option)
2134) !
2135) ! Looks up double precision value in database
2136) !
2137) ! Author: Glenn Hammond
2138) ! Date: 08/19/14
2139) !
2140) use Option_module
2141)
2142) implicit none
2143)
2144) character(len=*) :: keyword
2145) character(len=*) :: string
2146) character(len=*) :: string2
2147) type(option_type) :: option
2148)
2149) option%io_buffer = 'Keyword "' // &
2150) trim(keyword) // &
2151) '" not recognized in ' // &
2152) trim(string) // '.'
2153) if (len_trim(string2) > 0) then
2154) option%io_buffer = trim(option%io_buffer) // ' ' // &
2155) trim(string2) // '.'
2156) endif
2157) call printErrMsg(option)
2158)
2159) end subroutine InputKeywordUnrecognized2
2160)
2161) ! ************************************************************************** !
2162)
2163) subroutine InputCheckMandatoryUnits(input,option)
2164) !
2165) ! Looks up double precision value in database
2166) !
2167) ! Author: Glenn Hammond
2168) ! Date: 08/19/14
2169) !
2170) use Option_module
2171)
2172) implicit none
2173)
2174) type(input_type) :: input
2175) type(option_type) :: option
2176)
2177) if (input%force_units) then
2178) option%io_buffer = 'Missing units'
2179) if (len_trim(input%err_buf) > 1) then
2180) option%io_buffer = trim(option%io_buffer) // ' in ' // &
2181) trim(input%err_buf) // '.'
2182) endif
2183) call printErrMsg(option)
2184) endif
2185)
2186) end subroutine InputCheckMandatoryUnits
2187)
2188) ! ************************************************************************** !
2189)
2190) subroutine InputReadAndConvertUnits(input,double_value,internal_units, &
2191) keyword_string,option)
2192) !
2193) ! Reads units if they exist and returns the units conversion factor.
2194) !
2195) ! Author: Glenn Hammond
2196) ! Date: 07/26/16
2197) !
2198) use Option_module
2199) use Units_module
2200)
2201) implicit none
2202)
2203) type(input_type) :: input
2204) PetscReal :: double_value
2205) character(len=*) :: internal_units
2206) character(len=*) :: keyword_string
2207) type(option_type) :: option
2208)
2209) character(len=MAXWORDLENGTH) :: units
2210) character(len=MAXWORDLENGTH) :: internal_units_word
2211)
2212) call InputReadWord(input,option,units,PETSC_TRUE)
2213) if (input%ierr == 0) then
2214) if (len_trim(internal_units) < 1) then
2215) option%io_buffer = 'No internal units provided in &
2216) &InputReadAndConvertUnits()'
2217) call printErrMsg(option)
2218) endif
2219) internal_units_word = trim(internal_units)
2220) double_value = double_value * &
2221) UnitsConvertToInternal(units,internal_units_word,option)
2222) else
2223) call InputDefaultMsg(input,option,keyword_string)
2224) endif
2225)
2226) end subroutine InputReadAndConvertUnits
2227)
2228) ! ************************************************************************** !
2229)
2230) subroutine InputPushExternalFile(input,option)
2231) !
2232) ! Looks up double precision value in database
2233) !
2234) ! Author: Glenn Hammond
2235) ! Date: 08/19/14
2236) !
2237) use Option_module
2238)
2239) implicit none
2240)
2241) type(input_type), pointer :: input
2242) type(option_type) :: option
2243)
2244) character(len=MAXSTRINGLENGTH) :: string
2245) type(input_type), pointer :: input_child
2246)
2247) call InputReadNChars(input,option,string,MAXSTRINGLENGTH,PETSC_TRUE)
2248) call InputErrorMsg(input,option,'filename','EXTERNAL_FILE')
2249) input_child => InputCreate(input%fid+1,string,option)
2250) input_child%parent => input
2251) input => input_child
2252)
2253) end subroutine InputPushExternalFile
2254)
2255) ! ************************************************************************** !
2256)
2257) function InputPopExternalFile(input)
2258) !
2259) ! Looks up double precision value in database
2260) !
2261) ! Author: Glenn Hammond
2262) ! Date: 08/19/14
2263) !
2264)
2265) implicit none
2266)
2267) type(input_type), pointer :: input
2268)
2269) PetscBool :: InputPopExternalFile
2270) type(input_type), pointer :: input_parent
2271)
2272) InputPopExternalFile = PETSC_FALSE
2273) if (associated(input%parent)) then
2274) input_parent => input%parent
2275) call InputDestroy(input)
2276) input => input_parent
2277) nullify(input_parent)
2278) InputPopExternalFile = PETSC_TRUE
2279) endif
2280)
2281) end function InputPopExternalFile
2282)
2283) ! ************************************************************************** !
2284)
2285) subroutine InputDbaseDestroy()
2286) !
2287) ! Destroys the input dbase and members
2288) !
2289) ! Author: Glenn Hammond
2290) ! Date: 08/20/14
2291) !
2292)
2293) implicit none
2294)
2295) if (associated(dbase)) then
2296) ! due to circular dependencies, cannot use Utilty_module::DeallocateArray
2297) if (associated(dbase%icard)) deallocate(dbase%icard)
2298) nullify(dbase%icard)
2299) if (associated(dbase%rcard)) deallocate(dbase%rcard)
2300) nullify(dbase%rcard)
2301) if (associated(dbase%ccard)) deallocate(dbase%ccard)
2302) nullify(dbase%ccard)
2303) if (associated(dbase%ivalue)) deallocate(dbase%ivalue)
2304) nullify(dbase%ivalue)
2305) if (associated(dbase%rvalue)) deallocate(dbase%rvalue)
2306) nullify(dbase%rvalue)
2307) if (associated(dbase%cvalue)) deallocate(dbase%cvalue)
2308) nullify(dbase%cvalue)
2309) deallocate(dbase)
2310) nullify(dbase)
2311) endif
2312)
2313) end subroutine InputDbaseDestroy
2314)
2315) ! ************************************************************************** !
2316)
2317) subroutine InputDestroy(input)
2318) !
2319) ! Deallocates an input object
2320) !
2321) ! Author: Glenn Hammond
2322) ! Date: 11/10/08
2323) !
2324)
2325) implicit none
2326)
2327) type(input_type), pointer :: input
2328)
2329) if (input%fid /= 0) close(input%fid)
2330) input%fid = 0
2331) deallocate(input)
2332) nullify(input)
2333)
2334) end subroutine InputDestroy
2335)
2336) end module Input_Aux_module