Line data Source code
1 : !> \file mo_nml.f90
2 : !> \brief \copybrief mo_nml
3 : !> \details \copydetails mo_nml
4 :
5 : !> \brief Deal with namelist files.
6 : !> \details This module provides routines to open, close and position namelist files.
7 : !! - Adapted from Echam5, (C) MPI-MET, Hamburg, Germany
8 : !> \author L. Kornblueh, MPI, March 2001, original source
9 : !> \changelog
10 : !! - Jan 2011, Matthias Cuntz
11 : !! - compatible with gfortran <= version 4.3
12 : !! - all integer(i4)
13 : !! - quiet
14 : !! - Jan 2013, Matthias Cuntz
15 : !! - close_nml with unit, open_nml quiet=.true. default position_nml swap first and status
16 : !> \authors Matthias Cuntz
17 : !> \date Jan 2011
18 : !> \copyright Copyright 2005-\today, the CHS Developers, Sabine Attinger: All rights reserved.
19 : !! FORCES is released under the LGPLv3+ license \license_note
20 : MODULE mo_nml
21 :
22 : USE mo_kind, ONLY : i4
23 : USE mo_string_utils, ONLY : tolower
24 : USE mo_message, ONLY : message, error_message
25 :
26 : IMPLICIT NONE
27 :
28 : PRIVATE
29 :
30 : PUBLIC :: open_nml ! open namelist file
31 : PUBLIC :: close_nml ! close namelist file
32 : PUBLIC :: position_nml ! position namelist file
33 : PUBLIC :: nunitnml ! namelist unit
34 : PUBLIC :: POSITIONED, MISSING, LENGTH_ERROR, READ_ERROR ! return values from position_nml
35 :
36 : ! return values in optinal status of function 'position_nml'
37 : !> Information: file pointer set to namelist group
38 : INTEGER(i4), PARAMETER :: POSITIONED = 0
39 : !> Error: namelist group is missing
40 : INTEGER(i4), PARAMETER :: MISSING = 1
41 : !> Error: namelist group name too long
42 : INTEGER(i4), PARAMETER :: LENGTH_ERROR = 2
43 : !> Error occured during read of namelist file
44 : INTEGER(i4), PARAMETER :: READ_ERROR = 3
45 :
46 : !> default namelist unit
47 : INTEGER, SAVE :: nunitnml = -1
48 :
49 : ! ------------------------------------------------------------------
50 :
51 : CONTAINS
52 :
53 : ! ------------------------------------------------------------------
54 :
55 : !> \brief Open a namelist file.
56 :
57 : !> \details Open a namelist file.
58 : !!
59 : !! \b Example
60 : !!
61 : !! \code{.f90}
62 : !! call open_nml('namelist.txt',nnml)
63 : !! \endcode
64 : !! See also example in test directory
65 :
66 : !> \param[in] "character(len=*) :: file" namelist filename
67 : !> \param[in] "integer :: unit" namelist unit
68 : !> \param[in] "logical, optional :: quiet" Be verbose or not (default: .true.)\n
69 : !! .true.: no messages\n
70 : !! .false.: write out messages
71 :
72 : !> \author Matthias Cuntz
73 : !> \date Dec 2011
74 : !! - modified from Echam5, (C) MPI-MET, Hamburg, Germany
75 : !> \date Jan 2013
76 : !! - quiet=.true. default
77 : !> \author Luis Samaniego
78 : !> \date Nov 2013
79 : !! - comparison statements == -> .eq., etc
80 :
81 1 : SUBROUTINE open_nml(file, unit, quiet)
82 :
83 : IMPLICIT NONE
84 :
85 : CHARACTER(len = *), INTENT(IN) :: file
86 : INTEGER, INTENT(IN) :: unit
87 : LOGICAL, INTENT(IN), OPTIONAL :: quiet
88 : INTEGER :: istat
89 : LOGICAL :: iquiet
90 :
91 1 : iquiet = .false.
92 0 : if (present(quiet)) iquiet = quiet
93 :
94 1 : nunitnml = unit
95 1 : if (.not. iquiet) CALL message(' This is namelist ', trim(file))
96 1 : OPEN (nunitnml, file = file, iostat = istat, status = 'old', action = 'read', delim = 'apostrophe')
97 :
98 1 : IF (istat .ne. 0) THEN
99 0 : CALL error_message('OPEN_NML: Could not open namelist file ', trim(file))
100 : END IF
101 :
102 1 : END SUBROUTINE open_nml
103 :
104 : ! ------------------------------------------------------------------
105 :
106 : !> \brief Close a namelist file.
107 :
108 : !> \details Close a namelist file.
109 : !!
110 : !! \b Example
111 : !!
112 : !! \code{.f90}
113 : !! call close_nml()
114 : !! ! or
115 : !! call close_nml(unml)
116 : !! \endcode
117 : !! See also example in test directory
118 :
119 : !> \param[in] "integer, optional :: unit" namelist unit
120 :
121 : !> \note
122 : !! open_nml remembers the namelist unit in the public, save variable nunitnml.\n
123 : !! close_nml uses nunitnml if unit is not given.
124 :
125 : !> \author Matthias Cuntz
126 : !> \date Dec 2011
127 : !! - modified from Echam5, (C) MPI-MET, Hamburg, Germany
128 : !> \date Jan 2013
129 : !! - unit
130 1 : SUBROUTINE close_nml(unit)
131 :
132 : IMPLICIT NONE
133 :
134 : INTEGER, INTENT(IN), OPTIONAL :: unit
135 :
136 : INTEGER :: istat, nnml
137 :
138 1 : nnml = nunitnml
139 0 : if (present(unit)) nnml = unit
140 :
141 1 : IF (nnml .lt. 0) CALL error_message('CLOSE_NML: No namelist file opened.')
142 :
143 1 : CLOSE(nnml, IOSTAT = istat)
144 :
145 1 : IF (istat .ne. 0) CALL error_message('CLOSE_NML: Could not close namelist file.')
146 :
147 1 : if (.not. present(unit)) nunitnml = -1
148 :
149 1 : END SUBROUTINE close_nml
150 :
151 : ! ------------------------------------------------------------------
152 :
153 : !> \brief Position a namlist file.
154 :
155 : !> \details Position namelist file pointer for reading a new namelist next.\n
156 : !! It positions the namelist file at the correct place for reading\n
157 : !! namelist /name/ (case independent).
158 : !!
159 : !! \b Example
160 : !!
161 : !! \code{.f90}
162 : !! call position_nml('myname',nnml)
163 : !! \endcode
164 :
165 : !> \param[in] "character(len=*) :: name" namelist name (case independent)
166 : !> \param[in] "integer, optional :: unit" namelist unit (default: nunitnml)
167 : !> \param[in] "logical, optional :: first" start search at beginning,
168 : !! i.e. rewind the namelist first (default: .true.)\n
169 : !! .true.: rewind\n
170 : !! .false.: continue search from current file pointer
171 : !> \param[out] "integer(i4), optional :: status" Set on output to either of\n
172 : !! POSITIONED (0) - correct\n
173 : !! MISSING (1) - name not found\n
174 : !! LENGTH_ERROR (2) - namelist length longer then 256 characters\n
175 : !! READ_ERROR (3) - error while reading namelist file
176 :
177 : !> \author Matthias Cuntz
178 : !> \date Dec 2011
179 : !! - modified from Echam5, (C) MPI-MET, Hamburg, Germany
180 : !> \date Jan 2013
181 : !! - swap first and status in call list
182 3 : SUBROUTINE position_nml(name, unit, status, first)
183 :
184 : IMPLICIT NONE
185 :
186 : CHARACTER(len = *), INTENT(in) :: name ! namelist group name
187 : INTEGER, INTENT(in), OPTIONAL :: unit ! file unit number
188 : INTEGER(i4), INTENT(out), OPTIONAL :: status ! error return value
189 : LOGICAL, INTENT(in), OPTIONAL :: first ! default: true
190 :
191 : CHARACTER(len = 256) :: yline ! line read
192 : CHARACTER(len = 256) :: test ! uppercase namelist group name
193 : INTEGER(i4) :: stat ! local copy of status variable
194 : INTEGER :: ios ! status variable from read operation
195 : LOGICAL :: lrew ! local copy of rewind flag
196 : INTEGER(i4) :: iunit ! local copy of unit number
197 : INTEGER(i4) :: len_name ! length of requested namelist group name
198 : CHARACTER :: ytest ! character to test for delimiter
199 : CHARACTER(len = 12) :: code ! error code printed
200 : INTEGER(i4) :: ind ! index from index routine
201 : INTEGER(i4) :: indc ! index of comment character (!)
202 :
203 3 : lrew = .TRUE.
204 3 : IF (PRESENT(first)) lrew = first
205 3 : iunit = nunitnml
206 3 : IF (PRESENT(unit)) iunit = unit
207 3 : stat = MISSING
208 3 : code = 'MISSING'
209 :
210 3 : len_name = LEN_TRIM(name)
211 :
212 3 : IF (len_name .gt. LEN(test)) THEN
213 0 : stat = LENGTH_ERROR
214 0 : code = 'LENGTH_ERROR'
215 : END IF
216 :
217 : !test = '&'//tolower(name)
218 3 : write(test, '(A,A)') '&', tolower(name)
219 :
220 : ! Reposition file at beginning:
221 3 : IF (lrew) REWIND(iunit)
222 :
223 : ! Search start of namelist
224 : DO
225 24 : IF (stat .ne. MISSING) EXIT
226 :
227 24 : yline = ' '
228 :
229 24 : READ (iunit, *, IOSTAT = ios) yline
230 24 : IF (ios .lt. 0) THEN
231 : EXIT ! MISSING
232 24 : ELSE IF (ios .gt. 0) THEN
233 0 : stat = READ_ERROR
234 0 : code = 'READ_ERROR'
235 0 : EXIT
236 : END IF
237 :
238 24 : yline = tolower(yline)
239 :
240 24 : ind = INDEX(yline, TRIM(test))
241 :
242 24 : IF (ind .eq. 0) CYCLE
243 :
244 3 : indc = INDEX(yline, '!')
245 :
246 3 : IF (indc .gt. 0 .AND. indc .lt. ind) CYCLE
247 :
248 : ! test for delimiter
249 3 : ytest = yline(ind + len_name + 1 : ind + len_name + 1)
250 :
251 : IF ((LGE(ytest, '0') .AND. LLE(ytest, '9')) .OR. &
252 : (LGE(ytest, 'a') .AND. LLE(ytest, 'z')) .OR. &
253 3 : ytest .eq. '_' .OR. &
254 0 : (LGE(ytest, 'A') .AND. LLE(ytest, 'Z'))) THEN
255 : CYCLE
256 : ELSE
257 3 : stat = POSITIONED
258 3 : BACKSPACE(iunit)
259 24 : EXIT
260 : END IF
261 : END DO
262 :
263 3 : IF (PRESENT(status)) status = stat
264 : SELECT CASE (stat)
265 : CASE (POSITIONED)
266 0 : RETURN
267 : CASE (MISSING)
268 3 : IF (PRESENT(status)) RETURN
269 : END SELECT
270 :
271 : ! Error if it reaches here
272 0 : CALL error_message('POSITION_NML: namelist /', trim(name) , '/ ', trim(code))
273 :
274 4 : END SUBROUTINE position_nml
275 :
276 : END MODULE mo_nml
|
