Screamer Project  V3.3.1
Screamer Structure
 All Files Functions Variables
getfield.f
Go to the documentation of this file.
1  subroutine get_field (text, field, max_fields)
2 c
3  character text*(*)
4  character*(*) field(*)
5  integer max_fields
6 c
7 c **************************************************************************
8 c Subroutine to take the character string TEXT and extract the first
9 c MAX_FIELDS character fields and put them in FIELD.
10 c The character fields are assumed to be any string of characters not
11 c containing a blank or comma since it is assumed that blanks and commas
12 c separate the character fields.
13 c All lowercase letters are changed to uppercase after they are placed in
14 c FIELD.
15 c The fields in FIELD are left justified and padded on the right with blanks
16 c to fill the characters in each array element.
17 c
18 c For example, if:
19 c TEXT is ' TRLINE 2.0e3 , 3.1E1 DATA'
20 c NUM_FIELDS is 3
21 c then,
22 c FIELD(1) is 'TRLINE'
23 c FIELD(2) is '2.0E3'
24 c FIELD(3) is '3.1E1' .
25 c
26 c Modifications:
27 c 2014-05-01 RBS: the passed character vector "field" has been changed to pass
28 c the vector size. The character length is passed via *(*).
29 c The parameter definition for max_fields is no longer needed
30 c tp define the size of the vector.
31 c **************************************************************************
32 c
33  character blank*1, comma*1
34  parameter(blank = ' ', comma = ',')
35  parameter(no_text = 0)
36 c
37  character curr_char*1
38 c
39 c Find the character length of TEXT and FIELD, then set all fields
40 c to blanks.
41 c
42  lentext = len(text)
43  do j = 1, max_fields
44  field(j) = blank
45  end do
46 c
47 c Check to see that NUM_FIELDS is within prescribed limits.
48 c
49  if (max_fields .lt. 1) then
50  return
51  end if
52 c
53 c Strip leading and trailing blanks and commas in TEXT, then make sure there
54 c are some characters
55 c
56  call strip_blanks_commas(text, istart, iend)
57  if (istart .eq. no_text) then
58  return
59  end if
60 c
61 c Fill the FIELD array by looking for the first blank or comma which
62 c signals the end of one field and the first character other than a
63 c blank or comma which signals the beginning of the next field.
64 c J is the current FIELD element index.
65 c I is the current TEXT character (byte) position.
66 c
67  j = 0
68  i = istart
69 c
70 c At this point, I points to the character in TEXT which
71 c corresponds to first character of character field J.
72 c Note that I could equal IEND.
73 c
74  do while ((j .lt. max_fields) .and. (i .le. iend))
75  j = j + 1
76 c
77 c Look until we find a blank or a comma.
78 c
79  istart_temp = i
80  curr_char = text(i:i)
81  do while ((curr_char .ne. blank)
82  & .and. (curr_char .ne. comma)
83  & .and. (i .lt. iend))
84  i = i + 1
85  curr_char = text(i:i)
86  end do
87 c
88 c I is set to IEND if this is the last field or to the position of
89 c the first blank or comma encountered after the field. So reset I,
90 c if not the last field, to signal the end of the character field.
91 c
92  if (i .lt. iend) then
93  i = i - 1
94  end if
95 c
96 c Fill the FIELD array element and convert it to uppercase.
97 c
98  do k = istart_temp, i
99  kfield = k - istart_temp + 1
100  field(j)(kfield:kfield) = text(k:k)
101  end do
102  call conv_to_ucase(field(j))
103 c
104 c Look for the next character which is not a blank or comma.
105 c Increment I by 1 because we decremented it above by one and
106 c so I currently points to the position of the last character in the
107 c current field. (Note: I does not equal IEND-1 at this point.)
108 c
109  i = i + 1
110 c
111 c At this point, I could be greater than IEND, so check for TEXT(I:I)
112 c bounds. (Note: I does not equal IEND because I points to a blank or
113 c comma or is greater than IEND.)
114 c
115  if (i .lt. iend) then
116  curr_char = text(i:i)
117  do while ((curr_char .eq. blank) .or. (curr_char .eq. comma))
118  i = i + 1
119  curr_char = text(i:i)
120  end do
121  end if
122 c
123 c End of J loop.
124 c
125  end do
126 c
127  return
128  end
subroutine conv_to_ucase(text)
Definition: cnv2ucas.f:1
subroutine strip_blanks_commas(text, start, end)
Definition: strpbkcm.f:1
subroutine get_field(text, field, max_fields)
Definition: getfield.f:1