Oasis3-MCT
 All Classes Files Functions Variables Macros Pages
mod_oasis_string.F90
Go to the documentation of this file.
1 
2 !> Character string manipulation methods
3 
4 !> These methods work generally on character strings, but also, more particularly
5 !> on lists. A list is a character string that contains substrings separated by
6 !> a delimeter. That delimeter can be set by the user but the default is ":".
7 !> Colon delimeted lists are used in OASIS and MCT mainly to instantiate a list
8 !> of fields, such as "temperature:humidity:zonal_velocity:meridiona_velocity".
9 
10 #define NEW_LGI_METHOD2a
11 !!#define NEW_LGI_METHOD2b
12 !===============================================================================
13 !BOP ===========================================================================
14 !
15 ! !MODULE: mod_oasis_string -- string and list methods
16 !
17 ! !DESCRIPTION:
18 ! General string and specific list method. A list is a single string
19 ! that is delimited by a character forming multiple fields, ie,
20 ! character(len=*) :: mylist = "t:s:u1:v1:u2:v2:taux:tauy"
21 ! The delimiter is called listDel in this module, is default ":",
22 ! but can be set by a call to oasis_string_listSetDel.
23 !
24 !
25 ! !INTERFACE: ------------------------------------------------------------------
26 
28 
29 ! !USES:
30 
31  use mod_oasis_kinds
33  use mod_oasis_data
34  use mod_oasis_sys
35  use mod_oasis_timer
36 
37  implicit none
38  private
39 
40 ! !PUBLIC TYPES:
41 
42  ! no public types
43 
44 ! !PUBLIC MEMBER FUNCTIONS:
45 
46  public :: oasis_string_countchar ! Count number of char in string, fn
47  public :: oasis_string_toupper ! Convert string to upper-case
48  public :: oasis_string_tolower ! Convert string to lower-case
49  public :: oasis_string_getparentdir ! For a pathname get the parent directory name
50  public :: oasis_string_lastindex ! Index of last substr in str
51  public :: oasis_string_endindex ! Index of end of substr in str
52  public :: oasis_string_leftalign ! remove leading white space
53  public :: oasis_string_alphanum ! remove all non alpha-numeric characters
54  public :: oasis_string_betweentags ! get the substring between the two tags
55  public :: oasis_string_parsecftunit ! parse CF time units
56  public :: oasis_string_clean ! Set string to all white space
57 
58  public :: oasis_string_listisvalid ! test for a valid "list"
59  public :: oasis_string_listgetnum ! Get number of fields in list, fn
60  public :: oasis_string_listgetindex ! Get index of field
61  public :: oasis_string_listgetindexf ! function version of listGetIndex
62  public :: oasis_string_listgetname ! get k-th field name
63  public :: oasis_string_listintersect ! get intersection of two field lists
64  public :: oasis_string_listunion ! get union of two field lists
65  public :: oasis_string_listmerge ! merge two lists to form third
66  public :: oasis_string_listappend ! append list at end of another
67  public :: oasis_string_listprepend ! prepend list in front of another
68  public :: oasis_string_listsetdel ! Set field delimeter in lists
69  public :: oasis_string_listgetdel ! Get field delimeter in lists
70 
71  public :: oasis_string_setabort ! set local abort flag
72  public :: oasis_string_setdebug ! set local debug flag
73 
74 ! !PUBLIC DATA MEMBERS:
75 
76  ! no public data members
77 
78 !EOP
79 
80  character(len=1) ,save :: listdel = ":" ! note single exec implications
81  character(len=2) ,save :: listdel2 = "::" ! note single exec implications
82  logical ,save :: doabort = .true.
83  integer(ip_i4_p),save :: debug = 0
84 
85 !===============================================================================
86 contains
87 !===============================================================================
88 
89 !===============================================================================
90 !BOP ===========================================================================
91 !
92 ! !IROUTINE: oasis_string_countChar -- Count number of occurances of a character
93 !
94 ! !DESCRIPTION:
95 !> Count number of occurances of a single character in a string
96 ! \newline
97 ! n = shr\_string\_countChar(string,character)
98 !
99 !
100 ! !INTERFACE: ------------------------------------------------------------------
101 
102 integer function oasis_string_countchar(str,char,rc)
103 
104 
105  implicit none
106 
107 ! !INPUT/OUTPUT PARAMETERS:
108 
109  character(*) ,intent(in) :: str !< string to search
110  character(1) ,intent(in) :: char !< char to search for
111  integer(ip_i4_p),intent(out),optional :: rc !< return code
112 
113 !EOP
114 
115  !----- local -----
116  integer(ip_i4_p) :: count ! counts occurances of char
117  integer(ip_i4_p) :: n ! generic index
118 
119  !----- formats -----
120  character(*),parameter :: subName = "(oasis_string_countChar) "
121 
122 !-------------------------------------------------------------------------------
123 ! Notes:
124 !-------------------------------------------------------------------------------
125 
126  call oasis_debug_enter(subname)
127 
128  count = 0
129  do n = 1, len_trim(str)
130  if (str(n:n) == char) count = count + 1
131  end do
132  oasis_string_countchar = count
133 
134  if (present(rc)) rc = 0
135 
136  call oasis_debug_exit(subname)
137 
138 end function oasis_string_countchar
139 
140 !===============================================================================
141 !BOP ===========================================================================
142 ! !IROUTINE: oasis_string_toUpper -- Convert string to upper case
143 !
144 ! !DESCRIPTION:
145 !> Convert the input string to upper-case.
146 ! Use achar and iachar intrinsics to ensure use of ascii collating sequence.
147 !
148 !
149 ! !INTERFACE: ------------------------------------------------------------------
150 
151 function oasis_string_toupper(str)
152 
153  implicit none
154 
155 ! !INPUT/OUTPUT PARAMETERS:
156  character(len=*), intent(in) :: str !< input string to convert to upper case
157  character(len=len(str)) :: oasis_string_toUpper !< output converted string
158 
159  !----- local -----
160  integer(ip_i4_p) :: i ! Index
161  integer(ip_i4_p) :: aseq ! ascii collating sequence
162  integer(ip_i4_p) :: LowerToUpper ! integer to convert case
163  character(len=1) :: ctmp ! Character temporary
164 
165  !----- formats -----
166  character(*),parameter :: subName = "(oasis_string_toUpper) "
167 
168 !-------------------------------------------------------------------------------
169 !
170 !-------------------------------------------------------------------------------
171 
172  call oasis_debug_enter(subname)
173 
174  lowertoupper = iachar("A") - iachar("a")
175 
176  do i = 1, len(str)
177  ctmp = str(i:i)
178  aseq = iachar(ctmp)
179  if ( aseq >= iachar("a") .and. aseq <= iachar("z") ) &
180  ctmp = achar(aseq + lowertoupper)
181  oasis_string_toupper(i:i) = ctmp
182  end do
183 
184  call oasis_debug_exit(subname)
185 
186 end function oasis_string_toupper
187 
188 !===============================================================================
189 !BOP ===========================================================================
190 ! !IROUTINE: oasis_string_toLower -- Convert string to lower case
191 !
192 ! !DESCRIPTION:
193 !> Convert the input string to lower-case.
194 ! Use achar and iachar intrinsics to ensure use of ascii collating sequence.
195 !
196 !
197 ! !INTERFACE: ------------------------------------------------------------------
198 function oasis_string_tolower(str)
199 
200  implicit none
201 
202 ! !INPUT/OUTPUT PARAMETERS:
203  character(len=*), intent(in) :: str !< input string to convert to lower case
204  character(len=len(str)) :: oasis_string_toLower !< output converted string
205 
206  !----- local -----
207  integer(ip_i4_p) :: i ! Index
208  integer(ip_i4_p) :: aseq ! ascii collating sequence
209  integer(ip_i4_p) :: UpperToLower ! integer to convert case
210  character(len=1) :: ctmp ! Character temporary
211 
212  !----- formats -----
213  character(*),parameter :: subName = "(oasis_string_toLower) "
214 
215 !-------------------------------------------------------------------------------
216 !
217 !-------------------------------------------------------------------------------
218 
219  call oasis_debug_enter(subname)
220 
221  uppertolower = iachar("a") - iachar("A")
222 
223  do i = 1, len(str)
224  ctmp = str(i:i)
225  aseq = iachar(ctmp)
226  if ( aseq >= iachar("A") .and. aseq <= iachar("Z") ) &
227  ctmp = achar(aseq + uppertolower)
228  oasis_string_tolower(i:i) = ctmp
229  end do
230 
231  call oasis_debug_exit(subname)
232 
233 end function oasis_string_tolower
234 
235 !===============================================================================
236 !BOP ===========================================================================
237 ! !IROUTINE: oasis_string_getParentDir -- For pathname get the parent directory name
238 !
239 ! !DESCRIPTION:
240 !> Get the parent directory pathname.
241 !
242 !
243 ! !INTERFACE: ------------------------------------------------------------------
244 
246 
247  implicit none
248 
249 ! !INPUT/OUTPUT PARAMETERS:
250  character(len=*), intent(in) :: str !< input string
251  character(len=len(str)) :: oasis_string_getParentDir !< return directory path
252 
253  !----- local -----
254  integer(ip_i4_p) :: i ! Index
255  integer(ip_i4_p) :: nlen ! Length of string
256 
257  !----- formats -----
258  character(*),parameter :: subName = "(oasis_string_getParentDir) "
259 
260 !-------------------------------------------------------------------------------
261 !
262 !-------------------------------------------------------------------------------
263 
264  call oasis_debug_enter(subname)
265 
266  nlen = len_trim(str)
267  if ( str(nlen:nlen) == "/" ) nlen = nlen - 1
268  i = index( str(1:nlen), "/", back=.true. )
269  if ( i == 0 )then
270  oasis_string_getparentdir = str
271  else
272  oasis_string_getparentdir = str(1:i-1)
273  end if
274 
275  call oasis_debug_exit(subname)
276 
277 end function oasis_string_getparentdir
278 
279 !===============================================================================
280 !BOP ===========================================================================
281 !
282 !
283 ! !IROUTINE: oasis_string_lastIndex -- Get index of last substr within string
284 !
285 ! !DESCRIPTION:
286 !> Get the index of the last occurance of a substring within a string
287 ! \newline
288 ! n = shr\_string\_lastIndex(string,substring)
289 !
290 !
291 ! !INTERFACE: ------------------------------------------------------------------
292 
293 integer function oasis_string_lastindex(string,substr,rc)
294 
295  implicit none
296 
297 ! !INPUT/OUTPUT PARAMETERS:
298 
299  character(*) ,intent(in) :: string !< input string to search
300  character(*) ,intent(in) :: substr !< sub-string to search for
301  integer(ip_i4_p),intent(out),optional :: rc !< return code
302 
303 !EOP
304 
305  !--- local ---
306 
307  !----- formats -----
308  character(*),parameter :: subName = "(oasis_string_lastIndex) "
309 
310 !-------------------------------------------------------------------------------
311 ! Note:
312 ! - "new" F90 back option to index function makes this home-grown solution obsolete
313 !-------------------------------------------------------------------------------
314 
315  call oasis_debug_enter(subname)
316 
317  oasis_string_lastindex = index(string,substr,.true.)
318 
319  if (present(rc)) rc = 0
320 
321  call oasis_debug_exit(subname)
322 
323 end function oasis_string_lastindex
324 
325 !===============================================================================
326 !BOP ===========================================================================
327 !
328 ! !IROUTINE: oasis_string_endIndex -- Get the ending index of substr within string
329 !
330 ! !DESCRIPTION:
331 !> Get the ending index of the first occurance of a substring within string
332 ! \newline
333 ! n = shr\_string\_endIndex(string,substring)
334 !
335 !
336 ! !INTERFACE: ------------------------------------------------------------------
337 
338 integer function oasis_string_endindex(string,substr,rc)
339 
340  implicit none
341 
342 ! !INPUT/OUTPUT PARAMETERS:
343 
344  character(*) ,intent(in) :: string !< string to search
345  character(*) ,intent(in) :: substr !< sub-string to search for
346  integer(ip_i4_p),intent(out),optional :: rc !< return code
347 
348 !EOP
349 
350  !--- local ---
351  integer(ip_i4_p) :: i ! generic index
352 
353  !----- formats -----
354  character(*),parameter :: subName = "(oasis_string_endIndex) "
355 
356 !-------------------------------------------------------------------------------
357 ! Notes:
358 ! * returns zero if substring not found, uses len_trim() intrinsic
359 ! * very similar to: i = index(str,substr,back=.true.)
360 ! * do we need this function?
361 !-------------------------------------------------------------------------------
362 
363  call oasis_debug_enter(subname)
364 
365  i = index(trim(string),trim(substr))
366  if ( i == 0 ) then
367  oasis_string_endindex = 0 ! substr is not in string
368  else
369  oasis_string_endindex = i + len_trim(substr) - 1
370  end if
371 
372 ! -------------------------------------------------------------------
373 ! i = index(trim(string),trim(substr),back=.true.)
374 ! if (i == len(string)+1) i = 0
375 ! oasis_string_endIndex = i
376 ! -------------------------------------------------------------------
377 
378  if (present(rc)) rc = 0
379 
380  call oasis_debug_exit(subname)
381 
382 end function oasis_string_endindex
383 
384 !===============================================================================
385 !BOP ===========================================================================
386 !
387 ! !IROUTINE: oasis_string_leftAlign -- remove leading white space
388 !
389 ! !DESCRIPTION:
390 !> Remove leading white space
391 ! \newline
392 ! call shr\_string\_leftAlign(string)
393 !
394 !
395 ! !INTERFACE: ------------------------------------------------------------------
396 
397 subroutine oasis_string_leftalign(str,rc)
398 
399  implicit none
400 
401 ! !INPUT/OUTPUT PARAMETERS:
402 
403  character(*) ,intent(inout) :: str !< input and returned string
404  integer(ip_i4_p),intent(out) ,optional :: rc !< return code
405 
406 !EOP
407 
408  !----- local ----
409  integer(ip_i4_p) :: rCode ! return code
410 
411  !----- formats -----
412  character(*),parameter :: subName = "(oasis_string_leftAlign) "
413 
414 !-------------------------------------------------------------------------------
415 ! note:
416 ! * ?? this routine isn't needed, use the intrisic adjustL instead ??
417 !-------------------------------------------------------------------------------
418 
419 ! -------------------------------------------------------------------
420 ! --- used this until I discovered the intrinsic function below
421 ! do while (len_trim(str) > 0 )
422 ! if (str(1:1) /= ' ') exit
423 ! str = str(2:len_trim(str))
424 ! end do
425 ! rCode = 0
426 ! !! (len_trim(str) == 0 ) rCode = 1 ! ?? appropriate ??
427 ! -------------------------------------------------------------------
428 
429  call oasis_debug_enter(subname)
430 
431  str = adjustl(str)
432  if (present(rc)) rc = 0
433 
434  call oasis_debug_exit(subname)
435 
436 end subroutine oasis_string_leftalign
437 
438 !===============================================================================
439 !BOP ===========================================================================
440 !
441 ! !IROUTINE: oasis_string_alphanum -- remove non alpha numeric characters
442 !
443 ! !DESCRIPTION:
444 !> Remove all non alpha numeric characters from string
445 ! \newline
446 ! call shr\_string\_alphanum(string)
447 !
448 !
449 ! !INTERFACE: ------------------------------------------------------------------
450 
451 subroutine oasis_string_alphanum(str,rc)
452 
453  implicit none
454 
455 ! !INPUT/OUTPUT PARAMETERS:
456 
457  character(*) ,intent(inout) :: str !< input and output string
458  integer(ip_i4_p),intent(out) ,optional :: rc !< return code
459 
460 !EOP
461 
462  !----- local ----
463  integer(ip_i4_p) :: rCode ! return code
464  integer(ip_i4_p) :: n,icnt ! counters
465 
466  !----- formats -----
467  character(*),parameter :: subName = "(oasis_string_alphaNum) "
468 
469 !-------------------------------------------------------------------------------
470 !
471 !-------------------------------------------------------------------------------
472 
473  call oasis_debug_enter(subname)
474 
475  icnt = 0
476  do n=1,len_trim(str)
477  if ((str(n:n) >= 'a' .and. str(n:n) <= 'z') .or. &
478  (str(n:n) >= 'A' .and. str(n:n) <= 'Z') .or. &
479  (str(n:n) >= '0' .and. str(n:n) <= '9')) then
480  icnt = icnt + 1
481  str(icnt:icnt) = str(n:n)
482  endif
483  enddo
484  do n=icnt+1,len(str)
485  str(n:n) = ' '
486  enddo
487 
488  if (present(rc)) rc = 0
489 
490  call oasis_debug_exit(subname)
491 
492 end subroutine oasis_string_alphanum
493 
494 !===============================================================================
495 !BOP ===========================================================================
496 !
497 ! !IROUTINE: oasis_string_betweenTags -- Get the substring between the two tags.
498 !
499 ! !DESCRIPTION:
500 !> Get the substring found between the start and end strings.
501 ! \newline
502 ! call shr\_string\_betweenTags(string,startTag,endTag,substring,rc)
503 !
504 !
505 ! !INTERFACE: ------------------------------------------------------------------
506 
507 subroutine oasis_string_betweentags(string,startTag,endTag,substr,rc)
508 
509  implicit none
510 
511 ! !INPUT/OUTPUT PARAMETERS:
512 
513  character(*) ,intent(in) :: string !< input string to search
514  character(*) ,intent(in) :: startTag !< start string
515  character(*) ,intent(in) :: endTag !< end string
516  character(*) ,intent(out) :: substr !< output sub-string between tags
517  integer(ip_i4_p),intent(out),optional :: rc !< return code
518 
519 !EOP
520 
521  !--- local ---
522  integer(ip_i4_p) :: iStart ! substring start index
523  integer(ip_i4_p) :: iEnd ! substring end index
524  integer(ip_i4_p) :: rCode ! return code
525 
526  !----- formats -----
527  character(*),parameter :: subName = "(oasis_string_betweenTags) "
528 
529 !-------------------------------------------------------------------------------
530 ! Notes:
531 ! * assumes the leading/trailing white space is not part of start & end tags
532 !-------------------------------------------------------------------------------
533 
534  call oasis_debug_enter(subname)
535 
536  istart = oasis_string_endindex(string,trim(adjustl(starttag))) ! end of start tag
537  iend = index(string,trim(adjustl(endtag ))) ! start of end tag
538 
539  rcode = 0
540  substr = ""
541 
542  if (istart < 1) then
543  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
544  WRITE(nulprt,*) subname,estr,"can't find start tag in string"
545  WRITE(nulprt,*) subname,estr,"start tag = ",trim(starttag)
546  WRITE(nulprt,*) subname,estr,"string = ",trim(string)
547  CALL oasis_flush(nulprt)
548  rcode = 1
549  else if (iend < 1) then
550  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
551  WRITE(nulprt,*) subname,estr,"can't find end tag in string"
552  WRITE(nulprt,*) subname,estr,"end tag = ",trim( endtag)
553  WRITE(nulprt,*) subname,estr,"string = ",trim(string)
554  CALL oasis_flush(nulprt)
555  rcode = 2
556  else if ( iend <= istart) then
557  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
558  WRITE(nulprt,*) subname,estr,"start tag not before end tag"
559  WRITE(nulprt,*) subname,estr,"start tag = ",trim(starttag)
560  WRITE(nulprt,*) subname,estr,"end tag = ",trim( endtag)
561  WRITE(nulprt,*) subname,estr,"string = ",trim(string)
562  CALL oasis_flush(nulprt)
563  rcode = 3
564  else if ( istart+1 == iend ) then
565  substr = ""
566  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
567  WRITE(nulprt,*) subname,wstr,"zero-length substring found in ",trim(string)
568  CALL oasis_flush(nulprt)
569  else
570  substr = string(istart+1:iend-1)
571  IF (len_trim(substr) == 0) THEN
572  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
573  WRITE(nulprt,*) subname,wstr,"white-space substring found in ",trim(string)
574  CALL oasis_flush(nulprt)
575  ENDIF
576  end if
577 
578  if (present(rc)) rc = rcode
579 
580  call oasis_debug_exit(subname)
581 
582 end subroutine oasis_string_betweentags
583 
584 !===============================================================================
585 !BOP ===========================================================================
586 !
587 ! !IROUTINE: oasis_string_parseCFtunit -- Parse CF time unit
588 !
589 ! !DESCRIPTION:
590 !> Parse CF time unit into a delta string name and a base time in yyyymmdd
591 ! and seconds (nearest integer actually).
592 ! \newline
593 ! call shr\_string\_parseCFtunit(string,substring)
594 ! \newline
595 ! Input string is like "days since 0001-06-15 15:20:45.5 -6:00"
596 ! - recognizes "days", "hours", "minutes", "seconds"
597 ! - must have at least yyyy-mm-dd, hh:mm:ss.s is optional
598 ! - expects a "since" in the string
599 ! - ignores time zone part
600 !
601 !
602 ! !INTERFACE: ------------------------------------------------------------------
603 
604 subroutine oasis_string_parsecftunit(string,unit,bdate,bsec,rc)
605 
606  implicit none
607 
608 ! !INPUT/OUTPUT PARAMETERS:
609 
610  character(*) ,intent(in) :: string !< string to search
611  character(*) ,intent(out) :: unit !< delta time unit
612  integer(ip_i4_p),intent(out) :: bdate !< base date yyyymmdd
613  real(ip_r8_p) ,intent(out) :: bsec !< base seconds
614  integer(ip_i4_p),intent(out),optional :: rc !< return code
615 
616 !EOP
617 
618  !--- local ---
619  integer(ip_i4_p) :: i,i1,i2 ! generic index
620  character(ic_long) :: tbase ! baseline time
621  character(ic_long) :: lstr ! local string
622  integer(ip_i4_p) :: yr,mo,da,hr,min ! time stuff
623  real(ip_r8_p) :: sec ! time stuff
624 
625  !----- formats -----
626  character(*),parameter :: subName = "(oasis_string_parseCFtunit) "
627 
628 !-------------------------------------------------------------------------------
629 ! Notes:
630 ! o assume length of CF-1.0 time attribute char string < ic_long
631 ! This is a reasonable assumption.
632 !-------------------------------------------------------------------------------
633 
634  call oasis_debug_enter(subname)
635 
636  unit = 'none'
637  bdate = 0
638  bsec = 0.0_ip_r8_p
639 
640  i = oasis_string_lastindex(string,'days ')
641  if (i > 0) unit = 'days'
642  i = oasis_string_lastindex(string,'hours ')
643  if (i > 0) unit = 'hours'
644  i = oasis_string_lastindex(string,'minutes ')
645  if (i > 0) unit = 'minutes'
646  i = oasis_string_lastindex(string,'seconds ')
647  if (i > 0) unit = 'seconds'
648 
649  if (trim(unit) == 'none') then
650  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
651  WRITE(nulprt,*) subname,estr,'time unit unknown'
652  CALL oasis_flush(nulprt)
653  CALL oasis_string_abort(subname//' time unit unknown')
654  endif
655 
656  i = oasis_string_lastindex(string,' since ')
657  if (i < 1) then
658  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
659  WRITE(nulprt,*) subname,estr,'since does not appear in unit attribute for time '
660  CALL oasis_flush(nulprt)
661  CALL oasis_string_abort(subname//' no since in attr name')
662  endif
663  tbase = trim(string(i+6:))
664  call oasis_string_leftalign(tbase)
665 
666  if (debug > 0 .and. nulprt > 0) then
667  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
668  WRITE(nulprt,*) trim(subname)//' '//'unit '//trim(unit)
669  WRITE(nulprt,*) trim(subname)//' '//'tbase '//trim(tbase)
670  CALL oasis_flush(nulprt)
671  endif
672 
673  yr=0; mo=0; da=0; hr=0; min=0; sec=0
674  i1 = 1
675 
676  i2 = index(tbase,'-') - 1
677  lstr = tbase(i1:i2)
678  read(lstr,*,err=200,end=200) yr
679  tbase = tbase(i2+2:)
680  call oasis_string_leftalign(tbase)
681 
682  i2 = index(tbase,'-') - 1
683  lstr = tbase(i1:i2)
684  read(lstr,*,err=200,end=200) mo
685  tbase = tbase(i2+2:)
686  call oasis_string_leftalign(tbase)
687 
688  i2 = index(tbase,' ') - 1
689  lstr = tbase(i1:i2)
690  read(lstr,*,err=200,end=200) da
691  tbase = tbase(i2+2:)
692  call oasis_string_leftalign(tbase)
693 
694  i2 = index(tbase,':') - 1
695  lstr = tbase(i1:i2)
696  read(lstr,*,err=200,end=100) hr
697  tbase = tbase(i2+2:)
698  call oasis_string_leftalign(tbase)
699 
700  i2 = index(tbase,':') - 1
701  lstr = tbase(i1:i2)
702  read(lstr,*,err=200,end=100) min
703  tbase = tbase(i2+2:)
704  call oasis_string_leftalign(tbase)
705 
706  i2 = index(tbase,' ') - 1
707  lstr = tbase(i1:i2)
708  read(lstr,*,err=200,end=100) sec
709 
710 100 continue
711 
712  IF (debug > 0 ) THEN
713  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
714  WRITE(nulprt,*) trim(subname),'ymdhms:',yr,mo,da,hr,min,sec
715  CALL oasis_flush(nulprt)
716  ENDIF
717 
718  bdate = abs(yr)*10000 + mo*100 + da
719  if (yr < 0) bdate = -bdate
720  bsec = real(hr*3600 + min*60,ip_r8_p) + sec
721 
722  if (present(rc)) rc = 0
723 
724  call oasis_debug_exit(subname)
725  return
726 
727 200 continue
728  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
729  write(nulprt,*) subname,estr,'200 on char num read '
730  CALL oasis_flush(nulprt)
731  call oasis_string_abort(subname//estr//'on char num read')
732  call oasis_debug_exit(subname)
733 
734 end subroutine oasis_string_parsecftunit
735 
736 !===============================================================================
737 !BOP ===========================================================================
738 !
739 ! !IROUTINE: oasis_string_clean -- Clean a string, set it to "blank"
740 !
741 ! !DESCRIPTION:
742 !> Clean a string, set it to blank
743 ! \newline
744 ! call shr\_string\_clean(string,rc)
745 !
746 !
747 ! !INTERFACE: ------------------------------------------------------------------
748 
749 subroutine oasis_string_clean(string,rc)
750 
751  implicit none
752 
753 ! !INPUT/OUTPUT PARAMETERS:
754 
755  character(*) ,intent(inout) :: string !< string
756  integer(ip_i4_p),optional,intent(out) :: rc !< return code
757 
758 !EOP
759 
760  !----- local -----
761  integer(ip_i4_p) :: n ! counter
762  integer(ip_i4_p) :: rCode ! return code
763 
764  !----- formats -----
765  character(*),parameter :: subName = "(oasis_string_clean) "
766 
767 !-------------------------------------------------------------------------------
768 ! Notes:
769 !-------------------------------------------------------------------------------
770 
771  call oasis_debug_enter(subname)
772 
773  rcode = 0
774  string = ' '
775  if (present(rc)) rc = rcode
776 
777  call oasis_debug_exit(subname)
778 
779 end subroutine oasis_string_clean
780 
781 !===============================================================================
782 !BOP ===========================================================================
783 !
784 ! !IROUTINE: oasis_string_listIsValid -- determine whether string is a valid list
785 !
786 ! !DESCRIPTION:
787 !> Determine whether string is a valid list
788 ! \newline
789 ! logical_var = shr\_string\_listIsValid(list,rc)
790 !
791 !
792 ! !INTERFACE: ------------------------------------------------------------------
793 
794 logical function oasis_string_listisvalid(list,rc)
795 
796  implicit none
797 
798 ! !INPUT/OUTPUT PARAMETERS:
799 
800  character(*) ,intent(in) :: list !< list/string
801  integer(ip_i4_p),optional,intent(out) :: rc !< return code
802 
803 !EOP
804 
805  !----- local -----
806  integer (ip_i4_p) :: nChar ! lenth of list
807  integer (ip_i4_p) :: rCode ! return code
808 
809  !----- formats -----
810  character(*),parameter :: subName = "(oasis_string_listIsValid) "
811 
812 !-------------------------------------------------------------------------------
813 ! check that the list conforms to the list format
814 !-------------------------------------------------------------------------------
815 
816  call oasis_debug_enter(subname)
817 
818  rcode = 0
819  oasis_string_listisvalid = .true.
820 
821  nchar = len_trim(list)
822  if (nchar < 1) then ! list is an empty string
823  rcode = 1
824  else if ( list(1:1) == listdel ) then ! first char is delimiter
825  rcode = 2
826  else if (list(nchar:nchar) == listdel ) then ! last char is delimiter
827  rcode = 3
828  else if (index(trim(list)," " ) > 0) then ! white-space in a field name
829  rcode = 4
830  else if (index(trim(list),listdel2) > 0) then ! found zero length field
831  rcode = 5
832  end if
833 
834  if (rcode /= 0) then
835  oasis_string_listisvalid = .false.
836  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
837  write(nulprt,*) subname,wstr,"invalid list = ",trim(list)
838  CALL oasis_flush(nulprt)
839  endif
840 
841  if (present(rc)) rc = rcode
842 
843  call oasis_debug_exit(subname)
844 
845 end function oasis_string_listisvalid
846 
847 !===============================================================================
848 !BOP ===========================================================================
849 !
850 ! !IROUTINE: oasis_string_listGetName -- Get name of k-th field in list
851 !
852 ! !DESCRIPTION:
853 !> Get name of k-th field in list
854 ! \newline
855 ! call shr\_string\_listGetName(list,k,name,rc)
856 !
857 !
858 ! !INTERFACE: ------------------------------------------------------------------
859 
860 subroutine oasis_string_listgetname(list,k,name,rc)
861 
862  implicit none
863 
864 ! !INPUT/OUTPUT PARAMETERS:
865 
866  character(*) ,intent(in) :: list !< input list
867  integer(ip_i4_p) ,intent(in) :: k !< index of field
868  character(*) ,intent(out) :: name !< k-th name in list
869  integer(ip_i4_p),optional,intent(out) :: rc !< return code
870 
871 !EOP
872 
873  !----- local -----
874  integer(ip_i4_p) :: i,j,n ! generic indecies
875  integer(ip_i4_p) :: kFlds ! number of fields in list
876  integer(ip_i4_p) :: i0,i1 ! name = list(i0:i1)
877  integer(ip_i4_p) :: rCode ! return code
878 
879  !----- formats -----
880  character(*),parameter :: subName = "(oasis_string_listGetName) "
881 
882 !-------------------------------------------------------------------------------
883 ! Notes:
884 !-------------------------------------------------------------------------------
885 
886  call oasis_debug_enter(subname)
887 
888  rcode = 0
889 
890  !--- check that this is a valid list ---
891  if (.not. oasis_string_listisvalid(list,rcode) ) then
892  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
893  write(nulprt,*) subname,estr,"invalid list = ",trim(list)
894  CALL oasis_flush(nulprt)
895  call oasis_string_abort(subname//estr//"invalid list = "//trim(list))
896  end if
897 
898  !--- check that this is a valid index ---
899  kflds = oasis_string_listgetnum(list)
900  if (k<1 .or. kflds<k) then
901  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
902  WRITE(nulprt,*) subname,estr,"invalid index = ",k
903  WRITE(nulprt,*) subname,estr," list = ",trim(list)
904  CALL oasis_flush(nulprt)
905  CALL oasis_string_abort(subname//estr//"invalid index")
906  end if
907 
908  !--- start with whole list, then remove fields before and after desired field ---
909  i0 = 1
910  i1 = len_trim(list)
911 
912  !--- remove field names before desired field ---
913  do n=2,k
914  i = index(list(i0:i1),listdel)
915  i0 = i0 + i
916  end do
917 
918  !--- remove field names after desired field ---
919  if ( k < kflds ) then
920  i = index(list(i0:i1),listdel)
921  i1 = i0 + i - 2
922  end if
923 
924  !--- copy result into output variable ---
925  name = list(i0:i1)//" "
926 
927  if (present(rc)) rc = rcode
928 
929  call oasis_debug_exit(subname)
930 
931 end subroutine oasis_string_listgetname
932 
933 !===============================================================================
934 !BOP ===========================================================================
935 !
936 ! !IROUTINE: oasis_string_listIntersect -- Get intersection of two field lists
937 !
938 ! !DESCRIPTION:
939 !> Get intersection of two fields lists, write into third list
940 ! \newline
941 ! call shr\_string\_listIntersect(list1,list2,listout)
942 !
943 !
944 ! !INTERFACE: ------------------------------------------------------------------
945 
946 subroutine oasis_string_listintersect(list1,list2,listout,rc)
947 
948  implicit none
949 
950 ! !INPUT/OUTPUT PARAMETERS:
951 
952  character(*) ,intent(in) :: list1 !< input list 1
953  character(*) ,intent(in) :: list2 !< input list 2
954  character(*) ,intent(out) :: listout !< output list
955  integer(ip_i4_p),optional,intent(out) :: rc !< return code
956 
957 !EOP
958 
959  !----- local -----
960  integer(ip_i4_p) :: nf,n1,n2 ! counters
961  character(ic_med) :: name ! field name
962  integer(ip_i4_p) :: rCode ! return code
963 
964  !----- formats -----
965  character(*),parameter :: subName = "(oasis_string_listIntersect) "
966 
967 !-------------------------------------------------------------------------------
968 ! Notes:
969 !-------------------------------------------------------------------------------
970 
971  call oasis_debug_enter(subname)
972 
973  rcode = 0
974 
975  nf = oasis_string_listgetnum(list1)
976  call oasis_string_clean(listout)
977  do n1 = 1,nf
978  call oasis_string_listgetname(list1,n1,name,rcode)
979  n2 = oasis_string_listgetindexf(list2,name)
980  if (n2 > 0) then
981  call oasis_string_listappend(listout,name)
982  endif
983  enddo
984 
985  if (present(rc)) rc = rcode
986 
987  call oasis_debug_exit(subname)
988 
989 end subroutine oasis_string_listintersect
990 
991 !===============================================================================
992 !BOP ===========================================================================
993 !
994 ! !IROUTINE: oasis_string_listUnion -- Get union of two field lists
995 !
996 ! !DESCRIPTION:
997 !> Get union of two fields lists, write into third list
998 ! \newline
999 ! call shr\_string\_listUnion(list1,list2,listout)
1000 !
1001 !
1002 ! !INTERFACE: ------------------------------------------------------------------
1003 
1004 subroutine oasis_string_listunion(list1,list2,listout,rc)
1005 
1006  implicit none
1007 
1008 ! !INPUT/OUTPUT PARAMETERS:
1009 
1010  character(*) ,intent(in) :: list1 !< input list 1
1011  character(*) ,intent(in) :: list2 !< input list 2
1012  character(*) ,intent(out) :: listout !< output list 3
1013  integer(ip_i4_p),optional,intent(out) :: rc !< return code
1014 
1015 !EOP
1016 
1017  !----- local -----
1018  integer(ip_i4_p) :: nf,n1,n2 ! counters
1019  character(ic_med) :: name ! field name
1020  integer(ip_i4_p) :: rCode ! return code
1021 
1022  !----- formats -----
1023  character(*),parameter :: subName = "(oasis_string_listUnion) "
1024 
1025 !-------------------------------------------------------------------------------
1026 ! Notes:
1027 !-------------------------------------------------------------------------------
1028 
1029  call oasis_debug_enter(subname)
1030 
1031  rcode = 0
1032 
1033  call oasis_string_clean(listout)
1034 
1035  nf = oasis_string_listgetnum(list1)
1036  do n1 = 1,nf
1037  call oasis_string_listgetname(list1,n1,name,rcode)
1038  n2 = oasis_string_listgetindexf(listout,name)
1039  if (n2 < 1) then
1040  call oasis_string_listappend(listout,name)
1041  endif
1042  enddo
1043 
1044  nf = oasis_string_listgetnum(list2)
1045  do n1 = 1,nf
1046  call oasis_string_listgetname(list2,n1,name,rcode)
1047  n2 = oasis_string_listgetindexf(listout,name)
1048  if (n2 < 1) then
1049  call oasis_string_listappend(listout,name)
1050  endif
1051  enddo
1052 
1053  if (present(rc)) rc = rcode
1054 
1055  call oasis_debug_exit(subname)
1056 
1057 end subroutine oasis_string_listunion
1058 
1059 !===============================================================================
1060 !BOP ===========================================================================
1061 !
1062 ! !IROUTINE: oasis_string_listMerge -- Merge lists two list to third
1063 !
1064 ! !DESCRIPTION:
1065 !> Merge two lists into a third list
1066 ! \newline
1067 ! call shr\_string\_listMerge(list1,list2,listout)
1068 ! call shr\_string\_listMerge(list1,list2,list1)
1069 !
1070 !
1071 ! !INTERFACE: ------------------------------------------------------------------
1072 
1073 subroutine oasis_string_listmerge(list1,list2,listout,rc)
1074 
1075  implicit none
1076 ! !INPUT/OUTPUT PARAMETERS:
1077 
1078  character(*) ,intent(in) :: list1 !< input list 1
1079  character(*) ,intent(in) :: list2 !< input list 2
1080  character(*) ,intent(out) :: listout !< output list
1081  integer(ip_i4_p),optional,intent(out) :: rc !< return code
1082 
1083 !EOP
1084 
1085  !----- local -----
1086  character(ic_xl) :: l1,l2 ! local char strings
1087  integer(ip_i4_p) :: rCode ! return code
1088 
1089  !----- formats -----
1090  character(*),parameter :: subName = "(oasis_string_listMerge) "
1091 
1092 !-------------------------------------------------------------------------------
1093 ! Notes:
1094 ! - no input or output string should be longer than ic_xl
1095 !-------------------------------------------------------------------------------
1096 
1097  call oasis_debug_enter(subname)
1098 
1099  rcode = 0
1100 
1101  !--- make sure temp strings are large enough ---
1102  if ( (len(l1) < len_trim(list1)) .or. (len(l2) < len_trim(list2))) then
1103  call oasis_string_abort(subname//estr//"temp string not large enough")
1104  end if
1105 
1106  call oasis_string_clean(l1)
1107  call oasis_string_clean(l2)
1108  call oasis_string_clean(listout)
1109  l1 = trim(list1)
1110  l2 = trim(list2)
1111  call oasis_string_leftalign(l1,rcode)
1112  call oasis_string_leftalign(l2,rcode)
1113  if (len_trim(l1)+len_trim(l2)+1 > len(listout)) &
1114  call oasis_string_abort(subname//estr//"output list string not large enough")
1115  if (len_trim(l1) == 0) then
1116  listout = trim(l2)
1117  else
1118  listout = trim(l1)//":"//trim(l2)
1119  endif
1120 
1121  if (present(rc)) rc = rcode
1122 
1123  call oasis_debug_exit(subname)
1124 
1125 end subroutine oasis_string_listmerge
1126 
1127 !===============================================================================
1128 !BOP ===========================================================================
1129 !
1130 ! !IROUTINE: oasis_string_listAppend -- Append one list to another
1131 !
1132 ! !DESCRIPTION:
1133 !> Append one list to another
1134 ! \newline
1135 ! call shr\_string\_listAppend(list,listadd)
1136 !
1137 !
1138 ! !INTERFACE: ------------------------------------------------------------------
1139 
1140 subroutine oasis_string_listappend(list,listadd,rc)
1141 
1142  implicit none
1143 
1144 ! !INPUT/OUTPUT PARAMETERS:
1145 
1146  character(*) ,intent(inout) :: list !< input and output list
1147  character(*) ,intent(in) :: listadd !< list to append
1148  integer(ip_i4_p),optional,intent(out) :: rc !< return code
1149 
1150 !EOP
1151 
1152  !----- local -----
1153  character(ic_xl) :: l1 ! local string
1154  integer(ip_i4_p) :: rCode ! return code
1155 
1156  !----- formats -----
1157  character(*),parameter :: subName = "(oasis_string_listAppend) "
1158 
1159 !-------------------------------------------------------------------------------
1160 ! Notes:
1161 ! - no input or output string should be longer than ic_xl
1162 !-------------------------------------------------------------------------------
1163 
1164  call oasis_debug_enter(subname)
1165 
1166  rcode = 0
1167 
1168  !--- make sure temp string is large enough ---
1169  if (len(l1) < len_trim(listadd)) then
1170  call oasis_string_abort(subname//estr//'temp string not large enough')
1171  end if
1172 
1173  call oasis_string_clean(l1)
1174  l1 = trim(listadd)
1175  call oasis_string_leftalign(l1,rcode)
1176  if (len_trim(list)+len_trim(l1)+1 > len(list)) &
1177  call oasis_string_abort(subname//estr//'output list string not large enough')
1178  if (len_trim(list) == 0) then
1179  list = trim(l1)
1180  else
1181  list = trim(list)//":"//trim(l1)
1182  endif
1183 
1184  if (present(rc)) rc = rcode
1185 
1186  call oasis_debug_exit(subname)
1187 
1188 end subroutine oasis_string_listappend
1189 
1190 !===============================================================================
1191 !BOP ===========================================================================
1192 !
1193 ! !IROUTINE: oasis_string_listPrepend -- Prepend one list to another
1194 !
1195 ! !DESCRIPTION:
1196 !> Prepend one list to another
1197 ! \newline
1198 ! call shr\_string\_listPrepend(listadd,list)
1199 ! \newline
1200 ! results in listadd:list
1201 !
1202 !
1203 ! !INTERFACE: ------------------------------------------------------------------
1204 
1205 subroutine oasis_string_listprepend(listadd,list,rc)
1206 
1207  implicit none
1208 
1209 ! !INPUT/OUTPUT PARAMETERS:
1210 
1211  character(*) ,intent(in) :: listadd ! input and output list
1212  character(*) ,intent(inout) :: list ! list to prepend
1213  integer(ip_i4_p),optional,intent(out) :: rc ! return code
1214 
1215 !EOP
1216 
1217  !----- local -----
1218  character(ic_xl) :: l1 ! local string
1219  integer(ip_i4_p) :: rCode ! return code
1220 
1221  !----- formats -----
1222  character(*),parameter :: subName = "(oasis_string_listPrepend) "
1223 
1224 !-------------------------------------------------------------------------------
1225 ! Notes:
1226 ! - no input or output string should be longer than ic_xl
1227 !-------------------------------------------------------------------------------
1228 
1229  call oasis_debug_enter(subname)
1230 
1231  rcode = 0
1232 
1233  !--- make sure temp string is large enough ---
1234  if (len(l1) < len_trim(listadd)) then
1235  call oasis_string_abort(subname//estr//'temp string not large enough')
1236  end if
1237 
1238  call oasis_string_clean(l1)
1239  l1 = trim(listadd)
1240  call oasis_string_leftalign(l1,rcode)
1241  call oasis_string_leftalign(list,rcode)
1242  if (len_trim(list)+len_trim(l1)+1 > len(list)) &
1243  call oasis_string_abort(subname//estr//"output list string not large enough")
1244  if (len_trim(l1) == 0) then
1245  list = trim(list)
1246  else
1247  list = trim(l1)//":"//trim(list)
1248  endif
1249 
1250  if (present(rc)) rc = rcode
1251 
1252  call oasis_debug_exit(subname)
1253 
1254 end subroutine oasis_string_listprepend
1255 
1256 !===============================================================================
1257 !BOP ===========================================================================
1258 !
1259 ! !IROUTINE: oasis_string_listGetIndexF -- Get index of field in string
1260 !
1261 ! !DESCRIPTION:
1262 !> Get the index of a field in a list
1263 ! \newline
1264 ! k = shr\_string\_listGetIndex(str,"taux")
1265 !
1266 !
1267 ! !INTERFACE: ------------------------------------------------------------------
1268 
1269 integer function oasis_string_listgetindexf(string,fldStr)
1270 
1271  implicit none
1272 
1273 ! !INPUT/OUTPUT PARAMETERS:
1274 
1275  character(*),intent(in) :: string !< input string
1276  character(*),intent(in) :: fldStr !< name of field
1277 
1278 !EOP
1279 
1280  !----- local -----
1281  integer(ip_i4_p) :: k ! local index variable
1282  integer(ip_i4_p) :: rc ! error code
1283 
1284  !----- formats -----
1285  character(*),parameter :: subName = "(oasis_string_listGetIndexF) "
1286 
1287 !-------------------------------------------------------------------------------
1288 
1289  call oasis_debug_enter(subname)
1290 
1291  call oasis_string_listgetindex(string,fldstr,k,print=.false.,rc=rc)
1293 
1294  call oasis_debug_exit(subname)
1295 
1296 end function oasis_string_listgetindexf
1297 
1298 #if (defined NEW_LGI_METHOD2a || defined NEW_LGI_METHOD2b)
1299 !===============================================================================
1300 !BOP ===========================================================================
1301 !
1302 ! !IROUTINE: oasis_string_listGetIndex -- Get index of field in string
1303 !
1304 ! !DESCRIPTION:
1305 !> Get the index of a field in a string
1306 ! \newline
1307 ! call shr\_string\_listGetIndex(str,"taux",k,rc)
1308 !
1309 !
1310 ! !INTERFACE: ------------------------------------------------------------------
1311 
1312 subroutine oasis_string_listgetindex(string,fldStr,kFld,print,rc)
1313 
1314  implicit none
1315 
1316 ! !INPUT/OUTPUT PARAMETERS:
1317 
1318  character(*) ,intent(in) :: string !< input list
1319  character(*) ,intent(in) :: fldStr !< name of field
1320  integer(ip_i4_p),intent(out) :: kFld !< index of field in list
1321  logical ,intent(in) ,optional :: print !< print switch
1322  integer(ip_i4_p),intent(out),optional :: rc !< return code
1323 
1324 !EOP
1325 
1326  !----- local -----
1327  integer(ip_i4_p) :: n,n1,n2 ! index for colon position
1328  integer(ip_i4_p) :: lens ! length of string
1329  logical :: found ! T => field found in fieldNames
1330  logical :: lprint ! local print flag
1331 
1332  !----- formats -----
1333  character(*),parameter :: subName = "(oasis_string_listGetIndex) "
1334 
1335 !-------------------------------------------------------------------------------
1336 !-------------------------------------------------------------------------------
1337 
1338  call oasis_debug_enter(subname)
1339 ! call oasis_timer_start('tcx_slgi0')
1340 
1341 ! call oasis_timer_start('tcx_slgia')
1342  if (present(rc)) rc = 0
1343 
1344  kfld = 0
1345  found = .false.
1346 
1347  lprint = .false.
1348  if (present(print)) lprint = print
1349 
1350  !--- confirm proper size of input data ---
1351  if (len_trim(fldstr) < 1) then
1352  IF (lprint) THEN
1353  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
1354  WRITE(nulprt,*) subname,estr,"input field name has 0 length"
1355  CALL oasis_flush(nulprt)
1356  ENDIF
1357  CALL oasis_string_abort(subname//"invalid field name")
1358  end if
1359 
1360 ! call oasis_timer_stop('tcx_slgia')
1361 ! call oasis_timer_start('tcx_slgib')
1362 
1363  lens = len_trim(string)
1364 
1365 ! write(nulprt,*) subname,' tcx1 ',string
1366 ! write(nulprt,*) subname,' tcx2 ',fldStr
1367 
1368  n = index(string,listdel,back=.false.)
1369 ! write(nulprt,*) subname,' tcx3 ',n
1370 ! call oasis_timer_start('tcx_slgib')
1371 ! call oasis_timer_start('tcx_slgic')
1372  if (n <= 0) then ! single field only
1373 ! call oasis_timer_start('tcx_slgic1')
1374  if (trim(fldstr) == string(1:lens)) then
1375  found = .true.
1376  kfld = 1
1377  endif
1378 ! call oasis_timer_stop('tcx_slgic1')
1379 ! write(nulprt,*) subname,' tcx4a ',found,kfld
1380  elseif (n > 0) then
1381  !--- check first string ---
1382 ! call oasis_timer_start('tcx_slgic2')
1383  if (trim(fldstr) == string(1:n-1)) then
1384  found = .true.
1385  kfld = 1
1386  endif
1387 ! write(nulprt,*) subname,' tcx4b ',found,kfld
1388 ! call oasis_timer_stop('tcx_slgic2')
1389  !--- check last string ---
1390  if (.not.found) then
1391 ! call oasis_timer_start('tcx_slgic3')
1392  n = index(string,listdel,back=.true.)
1393  if (trim(fldstr) == string(n+1:lens)) then
1394  found = .true.
1395  kfld = oasis_string_listgetnum(string)
1396  endif
1397 ! call oasis_timer_stop('tcx_slgic3')
1398 ! write(nulprt,*) subname,' tcx4c ',found,kfld
1399  endif
1400  !--- check other strings ---
1401  if (.not.found) then
1402 ! call oasis_timer_start('tcx_slgic4')
1403  n = index(string,':'//trim(fldstr)//':',back=.false.)
1404 ! write(nulprt,*) subname,' tcx5a ',n
1405  if (n > 0) then
1406  found = .true.
1407 #if defined NEW_LGI_METHOD2a
1408  if (n <= lens) then
1409 #endif
1410 #if defined NEW_LGI_METHOD2b
1411  if (n <= lens/2) then
1412 #endif
1413 ! call oasis_timer_start('tcx_slgic4a')
1414  n1 = 0
1415  kfld = 1
1416  do while (n1 < n)
1417  kfld = kfld + 1
1418  n2 = index(string(n1+1:lens),listdel,back=.false.)
1419  n1 = n1 + n2
1420 ! write(nulprt,*) subname,' tcx5b ',kfld,n2,n1,n
1421  enddo
1422 ! call oasis_timer_stop('tcx_slgic4a')
1423  else
1424 ! call oasis_timer_start('tcx_slgic4b')
1425  n1 = lens+1
1426  kfld = oasis_string_listgetnum(string) + 1
1427 ! call oasis_timer_stop('tcx_slgic4b')
1428 ! call oasis_timer_start('tcx_slgic4c')
1429  do while (n1 > n)
1430  kfld = kfld - 1
1431  n2 = index(string(1:n1-1),listdel,back=.true.)
1432  n1 = n2
1433 ! write(nulprt,*) subname,' tcx5c ',kfld,n2,n1,n
1434  enddo
1435 ! call oasis_timer_stop('tcx_slgic4c')
1436  endif
1437  endif
1438 ! write(nulprt,*) subname,' tcx4d ',found,kfld
1439 ! call oasis_timer_stop('tcx_slgic4')
1440  endif
1441  endif
1442 
1443 ! call oasis_timer_stop('tcx_slgic')
1444 
1445 ! call oasis_timer_start('tcx_slgid')
1446 
1447  !--- not finding a field is not a fatal error ---
1448  if (.not. found) then
1449  IF (lprint) THEN
1450  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
1451  WRITE(nulprt,*) subname,"FYI: field ",trim(fldstr)," not found in list ",trim(string)
1452  CALL oasis_flush(nulprt)
1453  ENDIF
1454  if (present(rc)) rc = 1
1455  end if
1456 
1457 ! call oasis_timer_stop('tcx_slgid')
1458 ! call oasis_timer_stop('tcx_slgi0')
1459  call oasis_debug_exit(subname)
1460 
1461 end subroutine oasis_string_listgetindex
1462 #endif
1463 !===============================================================================
1464 !BOP ===========================================================================
1465 !
1466 ! !IROUTINE: oasis_string_listGetNum -- get number of fields in a string list
1467 !
1468 ! !DESCRIPTION:
1469 !> return number of fields in string list
1470 !
1471 !
1472 ! !INTERFACE: ------------------------------------------------------------------
1473 
1474 integer function oasis_string_listgetnum(str)
1475 
1476  implicit none
1477 
1478 ! !INPUT/OUTPUT PARAMETERS:
1479 
1480  character(*),intent(in) :: str !< input list
1481 
1482 !EOP
1483 
1484  !----- local -----
1485  integer(ip_i4_p) :: count ! counts occurances of char
1486 
1487  !----- formats -----
1488  character(*),parameter :: subName = "(oasis_string_listGetNum) "
1489 
1490 !-------------------------------------------------------------------------------
1491 ! Notes:
1492 !-------------------------------------------------------------------------------
1493 
1494  call oasis_debug_enter(subname)
1495 
1497 
1498  if (len_trim(str) > 0) then
1499  count = oasis_string_countchar(str,listdel)
1500  oasis_string_listgetnum = count + 1
1501  endif
1502 
1503  call oasis_debug_exit(subname)
1504 
1505 end function oasis_string_listgetnum
1506 
1507 !===============================================================================
1508 !BOP ===========================================================================
1509 !
1510 ! !IROUTINE: oasis_string_listSetDel -- Set list delimeter character
1511 !
1512 ! !DESCRIPTION:
1513 !> Set field delimeter character in lists
1514 ! \newline
1515 ! call shr\_string\_listSetDel(":")
1516 !
1517 !
1518 ! !INTERFACE: ------------------------------------------------------------------
1519 
1520 subroutine oasis_string_listsetdel(cflag)
1521 
1522  implicit none
1523 
1524 ! !INPUT/OUTPUT PARAMETERS:
1525 
1526  character(len=1),intent(in) :: cflag !< field delimeter
1527 
1528 !EOP
1529 
1530  !--- formats ---
1531  character(*),parameter :: subName = "(oasis_string_listSetDel) "
1532 
1533 !-------------------------------------------------------------------------------
1534 
1535  call oasis_debug_enter(subname)
1536 
1537  IF (debug > 0) THEN
1538  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
1539  WRITE(nulprt,*) subname,' changing listDel from '//trim(listdel)//' to '//trim(cflag)
1540  CALL oasis_flush(nulprt)
1541  ENDIF
1542  listdel = trim(cflag)
1543  listdel2 = listdel//listdel
1544 
1545  call oasis_debug_exit(subname)
1546 
1547 end subroutine oasis_string_listsetdel
1548 
1549 !===============================================================================
1550 !BOP ===========================================================================
1551 !
1552 ! !IROUTINE: oasis_string_listGetDel -- Get list delimeter character
1553 !
1554 ! !DESCRIPTION:
1555 !> Get field delimeter character in lists
1556 ! \newline
1557 ! call shr\_string\_listGetDel(del)
1558 !
1559 !
1560 ! !INTERFACE: ------------------------------------------------------------------
1561 
1563 
1564  implicit none
1565 
1566 ! !INPUT/OUTPUT PARAMETERS:
1567 
1568  character(*),intent(out) :: del !< field delimeter
1569 
1570 !EOP
1571 
1572  !--- formats ---
1573  character(*),parameter :: subName = "(oasis_string_listGetDel) "
1574 
1575 !-------------------------------------------------------------------------------
1576 
1577  call oasis_debug_enter(subname)
1578 
1579  del = trim(listdel)
1580 
1581  call oasis_debug_exit(subname)
1582 
1583 end subroutine oasis_string_listgetdel
1584 
1585 !===============================================================================
1586 !BOP ===========================================================================
1587 !
1588 ! !IROUTINE: oasis_string_setAbort -- Set local oasis_string abort flag
1589 !
1590 ! !DESCRIPTION:
1591 !> Set local oasis_string abort flag, true = abort, false = print and continue
1592 ! \newline
1593 ! call shr\_string\_setAbort(.false.)
1594 !
1595 !
1596 ! !INTERFACE: ------------------------------------------------------------------
1597 
1598 subroutine oasis_string_setabort(flag)
1599 
1600  implicit none
1601 
1602 ! !INPUT/OUTPUT PARAMETERS:
1603 
1604  logical,intent(in) :: flag !< abort flag
1605 
1606 !EOP
1607 
1608  !--- formats ---
1609  character(*),parameter :: subName = "(oasis_string_setAbort) "
1610 
1611 !-------------------------------------------------------------------------------
1612 
1613  call oasis_debug_enter(subname)
1614 
1615  if (debug > 0) then
1616  if (flag) then
1617  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
1618  WRITE(nulprt,*) subname,' setting abort to true'
1619  CALL oasis_flush(nulprt)
1620  else
1621  WRITE(nulprt,*) subname,' model :',compid,' proc :',mpi_rank_local
1622  WRITE(nulprt,*) subname,' setting abort to false'
1623  CALL oasis_flush(nulprt)
1624  endif
1625  endif
1626 
1627  doabort = flag
1628 
1629  call oasis_debug_exit(subname)
1630 
1631 end subroutine oasis_string_setabort
1632 
1633 !===============================================================================
1634 !BOP ===========================================================================
1635 !
1636 ! !IROUTINE: oasis_string_setDebug -- Set local oasis_string debug level
1637 !
1638 ! !DESCRIPTION:
1639 !> Set local oasis_string debug level, 0 = production
1640 ! \newline
1641 ! call shr\_string\_setDebug(2)
1642 !
1643 !
1644 ! !INTERFACE: ------------------------------------------------------------------
1645 
1646 subroutine oasis_string_setdebug(iFlag)
1647 
1648  implicit none
1649 
1650 ! !INPUT/OUTPUT PARAMETERS:
1651 
1652  integer(ip_i4_p),intent(in) :: iFlag !< requested debug level
1653 
1654 !EOP
1655 
1656  !--- local ---
1657 
1658  !--- formats ---
1659  character(*),parameter :: subName = "(oasis_string_setDebug) "
1660 
1661 !-------------------------------------------------------------------------------
1662 ! NTOE: write statement can be expensive if called many times.
1663 !-------------------------------------------------------------------------------
1664 
1665  call oasis_debug_enter(subname)
1666 
1667 ! if (OASIS_debug > 0) write(nulprt,*) subname,' changing debug level from ',debug,' to ',iflag
1668  debug = iflag
1669 
1670  call oasis_debug_exit(subname)
1671 
1672 end subroutine oasis_string_setdebug
1673 
1674 !===============================================================================
1675 !===============================================================================
1676 
1677 !> Supports aborts in the string module
1678 
1679 subroutine oasis_string_abort(string)
1680 
1681  implicit none
1682 
1683 ! !INPUT/OUTPUT PARAMETERS:
1684 
1685  character(*),optional,intent(in) :: string !< error string
1686 
1687 !EOP
1688 
1689  !--- local ---
1690  character(ic_xl) :: lstring
1691  character(*),parameter :: subName = "(oasis_string_abort)"
1692 
1693 !-------------------------------------------------------------------------------
1694 ! NOTE:
1695 ! - no input or output string should be longer than ic_xl
1696 !-------------------------------------------------------------------------------
1697 
1698  call oasis_debug_enter(subname)
1699 
1700  lstring = ''
1701  if (present(string)) lstring = string
1702 
1703  if (doabort) then
1704  WRITE(nulprt,*) subname,estr,'abort for ',trim(lstring)
1705  call oasis_abort()
1706  else
1707  write(nulprt,*) subname,wstr,'no abort for '//trim(lstring)
1708  CALL oasis_flush(nulprt)
1709  endif
1710 
1711  call oasis_debug_exit(subname)
1712 
1713 end subroutine oasis_string_abort
1714 
1715 !===============================================================================
1716 !===============================================================================
1717 
1718 end module mod_oasis_string
subroutine oasis_string_abort(string)
Supports aborts in the string module.
subroutine, public oasis_debug_exit(string)
Used when a subroutine is exited, write info to log file at some debug level.
subroutine, public oasis_string_listgetdel(del)
Get field delimeter character in lists.
System type methods.
integer function, public oasis_string_lastindex(string, substr, rc)
Get the index of the last occurance of a substring within a string.
subroutine, public oasis_string_clean(string, rc)
Clean a string, set it to blank.
Provides a common location for several OASIS variables.
subroutine, public oasis_debug_enter(string)
Used when a subroutine is entered, write info to log file at some debug level.
subroutine, public oasis_string_setabort(flag)
Set local oasis_string abort flag, true = abort, false = print and continue.
Defines kinds for OASIS.
subroutine, public oasis_flush(nu)
Flushes output to file.
subroutine, public oasis_string_listappend(list, listadd, rc)
Append one list to another.
character(len=len(str)) function, public oasis_string_toupper(str)
Convert the input string to upper-case.
Character string manipulation methods.
character(len=len(str)) function, public oasis_string_getparentdir(str)
Get the parent directory pathname.
subroutine, public oasis_string_listmerge(list1, list2, listout, rc)
Merge two lists into a third list.
integer function, public oasis_string_endindex(string, substr, rc)
Get the ending index of the first occurance of a substring within string.
subroutine, public oasis_string_parsecftunit(string, unit, bdate, bsec, rc)
Parse CF time unit into a delta string name and a base time in yyyymmdd.
integer function, public oasis_string_countchar(str, char, rc)
Count number of occurances of a single character in a string.
Performance timer methods.
subroutine, public oasis_string_listintersect(list1, list2, listout, rc)
Get intersection of two fields lists, write into third list.
subroutine, public oasis_abort(id_compid, cd_routine, cd_message)
OASIS abort method, publically available to users.
subroutine, public oasis_string_listgetname(list, k, name, rc)
Get name of k-th field in list.
subroutine, public oasis_string_setdebug(iFlag)
Set local oasis_string debug level, 0 = production.
subroutine, public oasis_string_listunion(list1, list2, listout, rc)
Get union of two fields lists, write into third list.
logical function, public oasis_string_listisvalid(list, rc)
Determine whether string is a valid list.
subroutine, public oasis_string_leftalign(str, rc)
Remove leading white space.
subroutine, public oasis_string_listgetindex(string, fldStr, kFld, print, rc)
Get the index of a field in a string.
subroutine, public oasis_string_betweentags(string, startTag, endTag, substr, rc)
Get the substring found between the start and end strings.
integer function, public oasis_string_listgetnum(str)
return number of fields in string list
Defines parameters for OASIS.
integer function, public oasis_string_listgetindexf(string, fldStr)
Get the index of a field in a list.
subroutine, public oasis_string_alphanum(str, rc)
Remove all non alpha numeric characters from string.
character(len=len(str)) function, public oasis_string_tolower(str)
Convert the input string to lower-case.
subroutine, public oasis_string_listprepend(listadd, list, rc)
Prepend one list to another.
subroutine, public oasis_string_listsetdel(cflag)
Set field delimeter character in lists.