1 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
2 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
3 | !----------------------------------------------------------------------- |
---|
4 | ! CVS m_StrTemplate.F90,v 1.6 2004-04-21 22:54:46 jacob Exp |
---|
5 | ! CVS MCT_2_8_0 |
---|
6 | !BOP ------------------------------------------------------------------- |
---|
7 | ! |
---|
8 | ! !MODULE: m_StrTemplate - A template formatting a string with variables |
---|
9 | ! |
---|
10 | ! !DESCRIPTION: |
---|
11 | ! |
---|
12 | ! A template resolver formatting a string with a string variable |
---|
13 | ! and time variables. The format descriptors are similar to those |
---|
14 | ! used in the GrADS. |
---|
15 | ! |
---|
16 | ! "%y4" substitute with a 4 digit year |
---|
17 | ! "%y2" a 2 digit year |
---|
18 | ! "%m1" a 1 or 2 digit month |
---|
19 | ! "%m2" a 2 digit month |
---|
20 | ! "%mc" a 3 letter month in lower cases |
---|
21 | ! "%Mc" a 3 letter month with a leading letter in upper case |
---|
22 | ! "%MC" a 3 letter month in upper cases |
---|
23 | ! "%d1" a 1 or 2 digit day |
---|
24 | ! "%d2" a 2 digit day |
---|
25 | ! "%h1" a 1 or 2 digit hour |
---|
26 | ! "%h2" a 2 digit hour |
---|
27 | ! "%h3" a 3 digit hour (?) |
---|
28 | ! "%n2" a 2 digit minute |
---|
29 | ! "%s" a string variable |
---|
30 | ! "%%" a "%" |
---|
31 | ! |
---|
32 | ! !INTERFACE: |
---|
33 | |
---|
34 | module m_StrTemplate |
---|
35 | implicit none |
---|
36 | private ! except |
---|
37 | |
---|
38 | public :: StrTemplate ! Substitute variables in a template |
---|
39 | |
---|
40 | interface StrTemplate |
---|
41 | module procedure strTemplate_ |
---|
42 | end interface |
---|
43 | |
---|
44 | ! !REVISION HISTORY: |
---|
45 | ! 01Jun99 - Jing Guo <guo@dao.gsfc.nasa.gov> |
---|
46 | ! - initial prototype/prolog/code |
---|
47 | ! 19Jan01 - Jay Larson <larson@mcs.anl.gov> - removed numerous |
---|
48 | ! double-quote characters appearing inside single-quote |
---|
49 | ! blocks. This was done to comply with pgf90. Also, |
---|
50 | ! numerous double-quote characters were removed from |
---|
51 | ! within comment blocks because pgf90 kept trying to |
---|
52 | ! interpret them (spooky). |
---|
53 | !EOP ___________________________________________________________________ |
---|
54 | |
---|
55 | character(len=*),parameter :: myname='MCT(MPEU)::m_StrTemplate' |
---|
56 | |
---|
57 | character(len=3),parameter,dimension(12) :: mon_lc = (/ & |
---|
58 | 'jan','feb','mar','apr','may','jun', & |
---|
59 | 'jul','aug','sep','oct','nov','dec' /) |
---|
60 | |
---|
61 | character(len=3),parameter,dimension(12) :: mon_wd = (/ & |
---|
62 | 'Jan','Feb','Mar','Apr','May','Jun', & |
---|
63 | 'Jul','Aug','Sep','Oct','Nov','Dec' /) |
---|
64 | |
---|
65 | character(len=3),parameter,dimension(12) :: mon_uc = (/ & |
---|
66 | 'JAN','FEB','MAR','APR','MAY','JUN', & |
---|
67 | 'JUL','AUG','SEP','OCT','NOV','DEC' /) |
---|
68 | |
---|
69 | contains |
---|
70 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
71 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
72 | !BOP ------------------------------------------------------------------- |
---|
73 | ! |
---|
74 | ! !IROUTINE: strTemplate_ - expanding a format template to a string |
---|
75 | ! |
---|
76 | ! !DESCRIPTION: |
---|
77 | ! |
---|
78 | ! !INTERFACE: |
---|
79 | |
---|
80 | subroutine strTemplate_(str,tmpl,class,xid,nymd,nhms,stat) |
---|
81 | use m_chars, only : uppercase |
---|
82 | use m_stdio, only : stderr |
---|
83 | use m_die, only : die |
---|
84 | implicit none |
---|
85 | |
---|
86 | character(len=*),intent(out) :: str ! the output |
---|
87 | |
---|
88 | character(len=*),intent(in ) :: tmpl ! a "format" |
---|
89 | |
---|
90 | character(len=*),intent(in ),optional :: class |
---|
91 | ! choose a UNIX or a GrADS(defulat) type format |
---|
92 | |
---|
93 | character(len=*),intent(in ),optional :: xid |
---|
94 | ! a string substituting a '%s'. Trailing |
---|
95 | ! spaces will be ignored |
---|
96 | |
---|
97 | integer,intent(in ),optional :: nymd |
---|
98 | ! yyyymmdd, substituting '%y4', '%y2', '%m1', |
---|
99 | ! '%m2', '%mc', '%Mc', and '%MC' |
---|
100 | |
---|
101 | integer,intent(in ),optional :: nhms |
---|
102 | ! hhmmss, substituting '%h1', '%h2', '%h3', |
---|
103 | ! and '%n2' |
---|
104 | |
---|
105 | integer,intent(out),optional :: stat |
---|
106 | ! error code |
---|
107 | |
---|
108 | ! !REVISION HISTORY: |
---|
109 | ! 03Jun99 - Jing Guo <guo@dao.gsfc.nasa.gov> |
---|
110 | ! - initial prototype/prolog/code |
---|
111 | ! 08Jan03 - R. Jacob <jacob@mcs.anl.gov> Small change to get |
---|
112 | ! around IBM compiler bug. Cant have character valued functions |
---|
113 | ! in case statements. Fix found by Everest Ong. |
---|
114 | !EOP ___________________________________________________________________ |
---|
115 | |
---|
116 | character(len=*),parameter :: myname_=myname//'::strTemplate_' |
---|
117 | character(len=16) :: tmpl_class |
---|
118 | character(len=16) :: tmp_upper |
---|
119 | |
---|
120 | tmpl_class="GX" |
---|
121 | if(present(class)) tmpl_class=class |
---|
122 | |
---|
123 | tmp_upper = uppercase(tmpl_class) |
---|
124 | select case(tmp_upper) |
---|
125 | |
---|
126 | case("GX","GRADS") |
---|
127 | call GX_(str,tmpl,xid,nymd,nhms,stat) |
---|
128 | |
---|
129 | !case("UX","UNIX") ! yet to be implemented |
---|
130 | ! call UX_(str,tmpl,xid,nymd,nhms,stat) |
---|
131 | |
---|
132 | case default |
---|
133 | write(stderr,'(4a)') myname_,': unknown class: ', & |
---|
134 | trim(tmpl_class),'.' |
---|
135 | if(.not.present(stat)) call die(myname_) |
---|
136 | stat=-1 |
---|
137 | return |
---|
138 | end select |
---|
139 | |
---|
140 | end subroutine strTemplate_ |
---|
141 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
142 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
143 | !BOP ------------------------------------------------------------------- |
---|
144 | ! |
---|
145 | ! !IROUTINE: GX_ - evaluate a GrADS style string template |
---|
146 | ! |
---|
147 | ! !DESCRIPTION: |
---|
148 | ! |
---|
149 | ! !INTERFACE: |
---|
150 | |
---|
151 | subroutine GX_(str,tmpl,xid,nymd,nhms,stat) |
---|
152 | use m_stdio,only : stderr |
---|
153 | use m_die, only : die,perr |
---|
154 | implicit none |
---|
155 | character(len=*),intent(out) :: str |
---|
156 | character(len=*),intent(in ) :: tmpl |
---|
157 | character(len=*),optional,intent(in) :: xid |
---|
158 | integer,optional,intent(in) :: nymd |
---|
159 | integer,optional,intent(in) :: nhms |
---|
160 | integer,optional,intent(out) :: stat |
---|
161 | |
---|
162 | ! !REVISION HISTORY: |
---|
163 | ! 01Jun99 - Jing Guo <guo@dao.gsfc.nasa.gov> |
---|
164 | ! - initial prototype/prolog/code |
---|
165 | ! 19Jan01 - Jay Larson <larson@mcs.anl.gov> - added |
---|
166 | ! variable c1c2, to store c1//c2, which pgf90 |
---|
167 | ! would not allow as an argument to the 'select case' |
---|
168 | ! statement. |
---|
169 | !EOP ___________________________________________________________________ |
---|
170 | |
---|
171 | character(len=*),parameter :: myname_=myname//'::GX_' |
---|
172 | |
---|
173 | integer :: iy4,iy2,imo,idy |
---|
174 | integer :: ihr,imn |
---|
175 | integer :: i,i1,i2,m,k |
---|
176 | integer :: ln_tmpl,ln_str |
---|
177 | integer :: istp,kstp |
---|
178 | |
---|
179 | character(len=1) :: c0,c1,c2 |
---|
180 | character(len=2) :: c1c2 |
---|
181 | character(len=4) :: sbuf |
---|
182 | !________________________________________ |
---|
183 | ! Determine iyr, imo, and idy |
---|
184 | iy4=-1 |
---|
185 | iy2=-1 |
---|
186 | imo=-1 |
---|
187 | idy=-1 |
---|
188 | if(present(nymd)) then |
---|
189 | if(nymd < 0) then |
---|
190 | call perr(myname_,'nymd < 0',nymd) |
---|
191 | if(.not.present(stat)) call die(myname_) |
---|
192 | stat=1 |
---|
193 | return |
---|
194 | endif |
---|
195 | |
---|
196 | i=nymd |
---|
197 | iy4=i/10000 |
---|
198 | iy2=mod(iy4,100) |
---|
199 | i=mod(i,10000) |
---|
200 | imo=i/100 |
---|
201 | i=mod(i,100) |
---|
202 | idy=i |
---|
203 | endif |
---|
204 | !________________________________________ |
---|
205 | ! Determine ihr and imn |
---|
206 | ihr=-1 |
---|
207 | imn=-1 |
---|
208 | if(present(nhms)) then |
---|
209 | if(nhms < 0) then |
---|
210 | call perr(myname_,'nhms < 0',nhms) |
---|
211 | if(.not.present(stat)) call die(myname_) |
---|
212 | stat=1 |
---|
213 | return |
---|
214 | endif |
---|
215 | |
---|
216 | i=nhms |
---|
217 | ihr=i/10000 |
---|
218 | i=mod(i,10000) |
---|
219 | imn=i/100 |
---|
220 | endif |
---|
221 | !________________________________________ |
---|
222 | |
---|
223 | ln_tmpl=len_trim(tmpl) ! size of the format template |
---|
224 | ln_str =len(str) ! size of the output string |
---|
225 | !________________________________________ |
---|
226 | |
---|
227 | if(present(stat)) stat=0 |
---|
228 | |
---|
229 | str="" |
---|
230 | |
---|
231 | i=0; istp=1 |
---|
232 | k=1; kstp=1 |
---|
233 | |
---|
234 | do while( i+istp <= ln_tmpl ) ! A loop over all tokens in (tmpl) |
---|
235 | |
---|
236 | if(k>ln_Str) exit ! truncate the output here. |
---|
237 | |
---|
238 | i=i+istp |
---|
239 | c0=tmpl(i:i) |
---|
240 | |
---|
241 | select case(c0) |
---|
242 | case ("%") |
---|
243 | !________________________________________ |
---|
244 | |
---|
245 | c1="" |
---|
246 | i1=i+1 |
---|
247 | if(i1 <= ln_Tmpl) c1=tmpl(i1:i1) |
---|
248 | !________________________________________ |
---|
249 | |
---|
250 | select case(c1) |
---|
251 | |
---|
252 | case("s") |
---|
253 | if(.not.present(xid)) then |
---|
254 | write(stderr,'(2a)') myname_, & |
---|
255 | ': optional argument expected, "xid="' |
---|
256 | if(.not.present(stat)) call die(myname_) |
---|
257 | stat=1 |
---|
258 | return |
---|
259 | endif |
---|
260 | |
---|
261 | istp=2 |
---|
262 | m=min(k+len_trim(xid)-1,ln_str) |
---|
263 | str(k:m)=xid |
---|
264 | k=m+1 |
---|
265 | cycle |
---|
266 | |
---|
267 | case("%") |
---|
268 | |
---|
269 | istp=2 |
---|
270 | str(k:k)="%" |
---|
271 | k=k+1 ! kstp=1 |
---|
272 | cycle |
---|
273 | |
---|
274 | case default |
---|
275 | |
---|
276 | c2="" |
---|
277 | i2=i+2 |
---|
278 | if(i2 <= ln_Tmpl) c2=tmpl(i2:i2) |
---|
279 | !________________________________________ |
---|
280 | |
---|
281 | c1c2 = c1 // c2 |
---|
282 | select case(c1c2) |
---|
283 | |
---|
284 | case("y4","y2","m1","m2","mc","Mc","MC","d1","d2") |
---|
285 | if(.not.present(nymd)) then |
---|
286 | write(stderr,'(2a)') myname_, & |
---|
287 | ': optional argument expected, "nymd="' |
---|
288 | if(.not.present(stat)) call die(myname_) |
---|
289 | stat=1 |
---|
290 | return |
---|
291 | endif |
---|
292 | istp=3 |
---|
293 | |
---|
294 | case("h1","h2","h3","n2") |
---|
295 | if(.not.present(nhms)) then |
---|
296 | write(stderr,'(2a)') myname_, & |
---|
297 | ': optional argument expected, "nhms="' |
---|
298 | if(.not.present(stat)) call die(myname_) |
---|
299 | stat=1 |
---|
300 | return |
---|
301 | endif |
---|
302 | istp=3 |
---|
303 | |
---|
304 | case default |
---|
305 | |
---|
306 | write(stderr,'(4a)') myname_, & |
---|
307 | ': invalid template entry: ',trim(tmpl(i:)),'.' |
---|
308 | if(.not.present(stat)) call die(myname_) |
---|
309 | stat=2 |
---|
310 | return |
---|
311 | |
---|
312 | end select ! case(c1//c2) |
---|
313 | end select ! case(c1) |
---|
314 | !________________________________________ |
---|
315 | |
---|
316 | select case(c1) |
---|
317 | |
---|
318 | case("y") |
---|
319 | select case(c2) |
---|
320 | case("2") |
---|
321 | write(sbuf,'(i2.2)') iy2 |
---|
322 | kstp=2 |
---|
323 | case("4") |
---|
324 | write(sbuf,'(i4.4)') iy4 |
---|
325 | kstp=4 |
---|
326 | case default |
---|
327 | write(stderr,'(4a)') myname_, & |
---|
328 | ': invalid template entry: ',trim(tmpl(i:)),'.' |
---|
329 | if(.not.present(stat)) call die(myname_) |
---|
330 | stat=2 |
---|
331 | return |
---|
332 | end select |
---|
333 | |
---|
334 | case("m") |
---|
335 | select case(c2) |
---|
336 | case("1") |
---|
337 | if(imo < 10) then |
---|
338 | write(sbuf,'(i1)') imo |
---|
339 | kstp=1 |
---|
340 | else |
---|
341 | write(sbuf,'(i2)') imo |
---|
342 | kstp=2 |
---|
343 | endif |
---|
344 | case("2") |
---|
345 | write(sbuf,'(i2.2)') imo |
---|
346 | kstp=2 |
---|
347 | case("c") |
---|
348 | sbuf=mon_lc(imo) |
---|
349 | kstp=3 |
---|
350 | case default |
---|
351 | write(stderr,'(4a)') myname_, & |
---|
352 | ': invalid template entry: ',trim(tmpl(i:)),'.' |
---|
353 | if(.not.present(stat)) call die(myname_) |
---|
354 | stat=2 |
---|
355 | return |
---|
356 | end select |
---|
357 | |
---|
358 | case("M") |
---|
359 | select case(c2) |
---|
360 | case("c") |
---|
361 | sbuf=mon_wd(imo) |
---|
362 | kstp=3 |
---|
363 | case("C") |
---|
364 | sbuf=mon_uc(imo) |
---|
365 | kstp=3 |
---|
366 | case default |
---|
367 | write(stderr,'(4a)') myname_, & |
---|
368 | ': invalid template entry: ',trim(tmpl(i:)),'.' |
---|
369 | if(.not.present(stat)) call die(myname_) |
---|
370 | stat=2 |
---|
371 | return |
---|
372 | end select |
---|
373 | |
---|
374 | case("d") |
---|
375 | select case(c2) |
---|
376 | case("1") |
---|
377 | if(idy < 10) then |
---|
378 | write(sbuf,'(i1)') idy |
---|
379 | kstp=1 |
---|
380 | else |
---|
381 | write(sbuf,'(i2)') idy |
---|
382 | kstp=2 |
---|
383 | endif |
---|
384 | case("2") |
---|
385 | write(sbuf,'(i2.2)') idy |
---|
386 | kstp=2 |
---|
387 | case default |
---|
388 | write(stderr,'(4a)') myname_, & |
---|
389 | ': invalid template entry: ',trim(tmpl(i:)),'.' |
---|
390 | if(.not.present(stat)) call die(myname_) |
---|
391 | stat=2 |
---|
392 | return |
---|
393 | end select |
---|
394 | |
---|
395 | case("h") |
---|
396 | select case(c2) |
---|
397 | case("1") |
---|
398 | if(ihr < 10) then |
---|
399 | write(sbuf,'(i1)') ihr |
---|
400 | kstp=1 |
---|
401 | else |
---|
402 | write(sbuf,'(i2)') ihr |
---|
403 | kstp=2 |
---|
404 | endif |
---|
405 | case("2") |
---|
406 | write(sbuf,'(i2.2)') ihr |
---|
407 | kstp=2 |
---|
408 | case("3") |
---|
409 | write(sbuf,'(i3.3)') ihr |
---|
410 | kstp=3 |
---|
411 | case default |
---|
412 | write(stderr,'(4a)') myname_, & |
---|
413 | ': invalid template entry: ',trim(tmpl(i:)),'.' |
---|
414 | if(.not.present(stat)) call die(myname_) |
---|
415 | stat=2 |
---|
416 | return |
---|
417 | end select |
---|
418 | |
---|
419 | case("n") |
---|
420 | select case(c2) |
---|
421 | case("2") |
---|
422 | write(sbuf,'(i2.2)') imn |
---|
423 | kstp=2 |
---|
424 | case default |
---|
425 | write(stderr,'(4a)') myname_, & |
---|
426 | ': invalid template entry: ',trim(tmpl(i:)),'.' |
---|
427 | if(.not.present(stat)) call die(myname_) |
---|
428 | stat=2 |
---|
429 | return |
---|
430 | end select |
---|
431 | |
---|
432 | case default |
---|
433 | write(stderr,'(4a)') myname_, & |
---|
434 | ': invalid template entry: ',trim(tmpl(i:)),'.' |
---|
435 | if(.not.present(stat)) call die(myname_) |
---|
436 | stat=2 |
---|
437 | return |
---|
438 | end select ! case(c1) |
---|
439 | |
---|
440 | m=min(k+kstp-1,ln_Str) |
---|
441 | str(k:m)=sbuf |
---|
442 | k=m+1 |
---|
443 | |
---|
444 | case default |
---|
445 | |
---|
446 | istp=1 |
---|
447 | str(k:k)=tmpl(i:i) |
---|
448 | k=k+1 |
---|
449 | |
---|
450 | end select ! case(c0) |
---|
451 | end do |
---|
452 | |
---|
453 | end subroutine GX_ |
---|
454 | end module m_StrTemplate |
---|