Line data Source code
1 : !------------------------------------------------------------------------------
2 : ! Harmonized Emissions Component (HEMCO) !
3 : !------------------------------------------------------------------------------
4 : !BOP
5 : !
6 : ! !MODULE: HCO_charpak_mod.F90
7 : !
8 : ! !DESCRIPTION: Module HCO\_CHARPAK\_MOD contains routines from the CHARPAK
9 : ! string and character manipulation package used by GEOS-Chem.
10 : !\\
11 : !\\
12 : ! !INTERFACE:
13 : !
14 : MODULE HCO_Charpak_Mod
15 : !
16 : ! !USES:
17 : !
18 : IMPLICIT NONE
19 : PRIVATE
20 : !
21 : ! !PUBLIC MEMBER FUNCTIONS:
22 : !
23 : PUBLIC :: CleanText
24 : PUBLIC :: CntMat
25 : PUBLIC :: CopyTxt
26 : PUBLIC :: CStrip
27 : PUBLIC :: IsDigit
28 : PUBLIC :: ReadOneLine
29 : PUBLIC :: Str2Hash14
30 : PUBLIC :: Str2Hash31
31 : PUBLIC :: StrRepl
32 : PUBLIC :: StrSplit
33 : PUBLIC :: StrSqueeze
34 : PUBLIC :: To_UpperCase
35 : PUBLIC :: TranLc
36 : PUBLIC :: TranUc
37 : PUBLIC :: Txtext
38 : PUBLIC :: WordWrapPrint
39 : !
40 : ! !PRIVATE MEMBER FUNCTIONS
41 : !
42 : !
43 : ! !REMARKS:
44 : ! CHARPAK routines by Robert D. Stewart, 1992. Subsequent modifications
45 : ! made for GEOS-CHEM by Bob Yantosca (1998, 2002, 2004).
46 : !
47 : ! !REVISION HISTORY:
48 : ! See https://github.com/geoschem/hemco for complete history
49 : !EOP
50 : !------------------------------------------------------------------------------
51 : !BOC
52 : !
53 : ! !DEFINED PARAMETERS
54 : !
55 : ! Maximum string length
56 : INTEGER, PARAMETER, PUBLIC :: MAXSTRLEN = 500
57 :
58 : CONTAINS
59 : !EOC
60 : !------------------------------------------------------------------------------
61 : ! Harmonized Emissions Component (HEMCO) !
62 : !------------------------------------------------------------------------------
63 : !BOP
64 : !
65 : ! !IROUTINE: CntMat
66 : !
67 : ! !DESCRIPTION: Counts the number of characters in str1 that match
68 : ! a character in str2.
69 : !\\
70 : !\\
71 : ! !INTERFACE:
72 : !
73 0 : SUBROUTINE CntMat( Str1, Str2, Imat, Locations )
74 : !
75 : ! !INPUT PARAMETERS:
76 : !
77 : CHARACTER(LEN=*), INTENT(IN) :: Str1 ! Text to scan
78 : CHARACTER(LEN=*), INTENT(IN) :: Str2 ! Character to match
79 : !
80 : ! !OUTPUT PARAMETERS:
81 : !
82 : INTEGER, INTENT(OUT) :: imat ! Number of matches
83 : INTEGER, OPTIONAL :: Locations(255) ! Positions of matches
84 : !
85 : ! !REVISION HISTORY:
86 : ! DATE: JAN. 6, 1995
87 : ! AUTHOR: R.D. STEWART
88 : ! COMMENTS: Revised slightly (2-5-1996) so that trailing
89 : ! blanks in str1 are ignored. Revised again
90 : ! on 3-6-1996.
91 : ! See https://github.com/geoschem/hemco for complete history
92 : !EOP
93 : !------------------------------------------------------------------------------
94 : !BOC
95 : !
96 : ! !LOCAL VARIABLES:
97 : !
98 : ! Scalars
99 : INTEGER :: L1, L2, i, j
100 : LOGICAL :: again
101 :
102 : ! Arrays
103 : INTEGER :: TmpLocations(255)
104 :
105 : ! Initialize
106 0 : TmpLocations = 0
107 0 : L1 = MAX(1,LEN_TRIM(str1))
108 0 : L2 = LEN(str2)
109 0 : imat = 0
110 :
111 0 : DO i=1,L1
112 : again = .true.
113 : j = 1
114 0 : DO WHILE (again)
115 0 : IF (str2(j:j).EQ.str1(i:i)) THEN
116 0 : imat = imat+1
117 0 : TmpLocations(imat) = i
118 0 : again = .false.
119 0 : ELSEIF (j.LT.L2) THEN
120 0 : j=j+1
121 : ELSE
122 : again = .false.
123 : ENDIF
124 : ENDDO
125 : ENDDO
126 :
127 : ! Return positions where matches occured (OPTIONAL)
128 0 : IF ( PRESENT( Locations ) ) Locations = TmpLocations
129 :
130 0 : END SUBROUTINE CntMat
131 : !EOC
132 : !------------------------------------------------------------------------------
133 : ! Harmonized Emissions Component (HEMCO) !
134 : !------------------------------------------------------------------------------
135 : !BOP
136 : !
137 : ! !IROUTINE: CopyTxt
138 : !
139 : ! !DESCRIPTION: Write all of the characters in str1 into variable
140 : ! str2 beginning at column, col. If the length of str1
141 : ! + col is longer than the number of characters str2
142 : ! can store, some characters will not be transfered to
143 : ! str2. Any characters already existing in str2 will
144 : ! will be overwritten.
145 : !\\
146 : !\\
147 : ! !INTERFACE:
148 : !
149 0 : SUBROUTINE CopyTxt( col, str1, str2 )
150 : !
151 : ! !INPUT PARAMETERS:
152 : !
153 : INTEGER, INTENT(IN) :: col
154 : CHARACTER(LEN=*), INTENT(IN) :: str1
155 : !
156 : ! !OUTPUT PARAMETERS:
157 : !
158 : CHARACTER(LEN=*), INTENT(INOUT) :: str2
159 : !
160 : ! !REVISION HISTORY:
161 : ! DATE: DEC. 24, 1993
162 : ! AUTHOR: R.D. STEWART
163 : ! See https://github.com/geoschem/hemco for complete history
164 : !EOP
165 : !------------------------------------------------------------------------------
166 : !BOC
167 : !
168 : ! !LOCAL VARIABLES:
169 : !
170 : INTEGER :: ilt1,i1,i,j,ic
171 :
172 0 : i1 = LEN(str2)
173 0 : IF (i1.GT.0) THEN
174 0 : ilt1 = LEN(str1)
175 0 : IF (ilt1.GT.0) THEN
176 0 : ic = MAX0(col,1)
177 0 : i = 1
178 0 : j = ic
179 0 : DO WHILE ((i.LE.ilt1).and.(j.LE.i1))
180 0 : str2(j:j) = str1(i:i)
181 0 : i = i + 1
182 0 : j = ic + (i-1)
183 : ENDDO
184 : ENDIF
185 : ENDIF
186 :
187 0 : END SUBROUTINE CopyTxt
188 : !EOC
189 : !------------------------------------------------------------------------------
190 : ! Harmonized Emissions Component (HEMCO) !
191 : !------------------------------------------------------------------------------
192 : !BOP
193 : !
194 : ! !IROUTINE: Cstrip
195 : !
196 : ! !DESCRIPTION: Strip blanks and null characters for the variable TEXT.
197 : !\\
198 : !\\
199 : ! !INTERFACE:
200 : !
201 0 : SUBROUTINE CStrip( text, KeepSpaces )
202 : !
203 : ! !INPUT PARAMETERS:
204 : !
205 : LOGICAL, OPTIONAL :: KeepSpaces ! If =T, then keep spaces
206 : ! but skip all other
207 : ! non-printing chars
208 : !
209 : ! !INPUT/OUTPUT PARAMETERS:
210 : !
211 : CHARACTER(LEN=*), INTENT(INOUT) :: TEXT ! Text to be modified
212 : !
213 : ! !REMARKS:
214 : ! The original "text" is destroyed upon exit.
215 : !
216 : ! !REVISION HISTORY:
217 : ! AUTHOR: Robert D. Stewart
218 : ! DATE: May 19, 1992
219 : ! See https://github.com/geoschem/hemco for complete history
220 : !EOP
221 : !------------------------------------------------------------------------------
222 : !BOC
223 : !
224 : ! !LOCAL VARIABLES:
225 : !
226 : INTEGER :: ilen, iasc, icnt, i, Start
227 : CHARACTER(LEN=1) :: ch
228 :
229 : ! Default: Skip space characters
230 0 : Start = 32
231 :
232 : ! If KEEPSPACES=T then skip all non-printing characters,
233 : ! but keep space characters. (bmy, 1/30/18)
234 0 : IF ( PRESENT( KeepSpaces ) ) THEN
235 0 : IF ( KeepSpaces ) Start = 31
236 : ENDIF
237 :
238 0 : ilen = LEN(text)
239 0 : IF (ilen.GT.1) THEN
240 : icnt = 1
241 0 : DO i=1,ilen
242 0 : iasc = ICHAR(text(i:i))
243 :
244 : ! Keep characters between these limits
245 0 : IF ( ( iasc > Start ).AND. (iasc < 255 ) ) THEN
246 0 : ch = text(i:i)
247 0 : text(icnt:icnt) = ch
248 0 : icnt = icnt + 1
249 : ENDIF
250 : ENDDO
251 : ! Fill remainder of text with blanks
252 0 : DO i=icnt,ilen
253 0 : text(i:i) = ' '
254 : ENDDO
255 : ENDIF
256 :
257 0 : END SUBROUTINE CStrip
258 : !EOC
259 : !------------------------------------------------------------------------------
260 : ! Harmonized Emissions Component (HEMCO) !
261 : !------------------------------------------------------------------------------
262 : !BOP
263 : !
264 : ! !IROUTINE: IsDigit
265 : !
266 : ! !DESCRIPTION: Returned as true if ch is a numeric character (i.e., one of
267 : ! the numbers from 0 to 9).
268 : !\\
269 : !\\
270 : ! !INTERFACE:
271 : !
272 0 : FUNCTION IsDigit( ch ) RESULT( lnum )
273 : !
274 : ! !INPUT PARAMETERS:
275 : !
276 : CHARACTER(LEN=1), INTENT(IN) :: ch
277 : !
278 : ! !RETURN VALUE:
279 : !
280 : LOGICAL :: lnum
281 : !
282 : ! !REMARKS:
283 : ! NOTE: Changed name from ISNUM to ISDIGIT (bmy, 7/15/04)
284 : !
285 : ! !REVISION HISTORY:
286 : ! DATE: NOV. 11, 1993
287 : ! AUTHOR: R.D. STEWART
288 : ! See https://github.com/geoschem/hemco for complete history
289 : !EOP
290 : !------------------------------------------------------------------------------
291 : !BOC
292 : !
293 : ! !LOCAL VARIABLES:
294 : !
295 : INTEGER iasc
296 :
297 0 : iasc = ICHAR(ch)
298 0 : lnum = .FALSE.
299 0 : IF ((iasc.GE.48).AND.(iasc.LE.57)) THEN
300 0 : lnum = .TRUE.
301 : ENDIF
302 :
303 0 : END FUNCTION IsDigit
304 : !EOC
305 : !------------------------------------------------------------------------------
306 : ! Harmonized Emissions Component (HEMCO) !
307 : !------------------------------------------------------------------------------
308 : !BOP
309 : !
310 : ! !IROUTINE: StrRepl
311 : !
312 : ! !DESCRIPTION: Subroutine StrRepl replaces all instances of PATTERN within
313 : ! a string STR with replacement text REPLTXT.
314 : !\\
315 : !\\
316 : ! !INTERFACE:
317 : !
318 0 : SUBROUTINE StrRepl( Str, Pattern, ReplTxt )
319 : !
320 : ! !INPUT PARAMETERS:
321 : !
322 : CHARACTER(LEN=*), INTENT(IN) :: Pattern ! Pattern to search for
323 : CHARACTER(LEN=*), INTENT(IN) :: ReplTxt ! Text to replace
324 : !
325 : ! !INPUT/OUTPUT PARAMETERS:
326 : !
327 : CHARACTER(LEN=*), INTENT(INOUT) :: Str ! String to be manipulated
328 : !
329 : ! !REMARKS:
330 : ! PATTERN and REPLTXT can now have a different number of characters.
331 : !
332 : ! !REVISION HISTORY:
333 : ! 25 Jun 2002 - R. Yantosca - Initial version
334 : ! See https://github.com/geoschem/hemco for complete history
335 : !EOP
336 : !------------------------------------------------------------------------------
337 : !BOC
338 : !
339 : ! !LOCAL VARIABLES:
340 : !
341 : ! Local variables
342 : INTEGER :: I1, I2
343 :
344 : !=================================================================
345 : ! StrRepl begins here!
346 : !=================================================================
347 0 : DO
348 :
349 : ! I1 is the first character that matches the search pattern;
350 : ! it must be 1 or larger. Otherwise exit the routine.
351 0 : I1 = INDEX( Str, Pattern )
352 0 : IF ( I1 < 1 ) RETURN
353 :
354 : ! Replace the text. I2 is the starting position of the
355 : ! string following the point of text replacement.
356 0 : I2 = I1 + LEN( Pattern )
357 0 : Str = Str(1:I1-1) // ReplTxt // Str(I2:)
358 :
359 : ENDDO
360 :
361 0 : END SUBROUTINE StrRepl
362 : !EOC
363 : !------------------------------------------------------------------------------
364 : ! Harmonized Emissions Component (HEMCO) !
365 : !------------------------------------------------------------------------------
366 : !BOP
367 : !
368 : ! !IROUTINE: StrSplit
369 : !
370 : ! !DESCRIPTION: Subroutine STRSPLIT returns substrings in a string, separated
371 : ! by a separator character (similar to IDL's StrSplit function). This is
372 : ! mainly a convenience wrapper for CHARPAK routine TxtExt.
373 : !\\
374 : !\\
375 : ! !INTERFACE:
376 : !
377 0 : SUBROUTINE StrSplit( Str, Sep, Result, N_SubStrs )
378 : !
379 : ! !INPUT PARAMETERS:
380 : !
381 : CHARACTER(LEN=*), INTENT(IN) :: STR ! String to be searched
382 : CHARACTER(LEN=1), INTENT(IN) :: SEP ! Separator character
383 : !
384 : ! !OUTPUT PARAMETERS:
385 : !
386 : CHARACTER(LEN=*), INTENT(OUT) :: Result(255) ! Returned substrings
387 : INTEGER, OPTIONAL :: N_SubStrs ! # of substrings
388 : !
389 : ! !REVISION HISTORY:
390 : ! 11 Jul 2002 - R. Yantosca - Initial version
391 : ! See https://github.com/geoschem/hemco for complete history
392 : !EOP
393 : !------------------------------------------------------------------------------
394 : !BOC
395 : !
396 : ! !LOCAL VARIABLES:
397 : !
398 : INTEGER :: I, IFLAG, COL
399 : CHARACTER(LEN=2047) :: WORD
400 :
401 : !=======================================================================
402 : ! STRSPLIT begins here!
403 : !=======================================================================
404 :
405 : ! Initialize
406 0 : I = 0
407 0 : COL = 1
408 0 : IFLAG = 0
409 0 : RESULT(:) = ''
410 :
411 : ! Loop until all matches found, or end of string
412 0 : DO WHILE ( IFLAG == 0 )
413 :
414 : ! Look for strings beteeen separator string
415 0 : CALL TXTEXT ( SEP, TRIM( STR ), COL, WORD, IFLAG )
416 :
417 : ! Store substrings in RESULT array
418 0 : I = I + 1
419 0 : RESULT(I) = TRIM( WORD )
420 :
421 : ENDDO
422 :
423 : ! Optional argument: return # of substrings found
424 0 : IF ( PRESENT( N_SUBSTRS ) ) N_SUBSTRS = I
425 :
426 0 : END SUBROUTINE StrSplit
427 : !EOC
428 : !------------------------------------------------------------------------------
429 : ! Harmonized Emissions Component (HEMCO) !
430 : !------------------------------------------------------------------------------
431 : !BOP
432 : !
433 : ! !IROUTINE: StrSqueeze
434 : !
435 : ! !DESCRIPTION: Subroutine STRSQUEEZE strips white space from both ends of a
436 : ! string. White space in the middle of the string (i.e. between characters)
437 : ! will be preserved as-is. Somewhat similar (though not exactly) to IDL's
438 : ! STRCOMPRESS function.
439 : !\\
440 : !\\
441 : ! !INTERFACE:
442 : !
443 0 : SUBROUTINE StrSqueeze( Str )
444 : !
445 : ! !INPUT/OUTPUT PARAMETERS:
446 : !
447 : CHARACTER(LEN=*), INTENT(INOUT) :: Str ! String to be squeezed
448 : !
449 : ! !REVISION HISTORY:
450 : ! 11 Jul 2002 - R. Yantosca - Initial version
451 : ! See https://github.com/geoschem/hemco for complete history
452 : !EOP
453 : !------------------------------------------------------------------------------
454 : !BOC
455 : !=================================================================
456 : ! STRSQUEEZE begins here!
457 : !=================================================================
458 0 : Str = ADJUSTR( TRIM( Str ) )
459 0 : Str = ADJUSTL( TRIM( Str ) )
460 :
461 0 : END SUBROUTINE StrSqueeze
462 : !EOC
463 : !------------------------------------------------------------------------------
464 : ! Harmonized Emissions Component (HEMCO) !
465 : !------------------------------------------------------------------------------
466 : !BOP
467 : !
468 : ! !IROUTINE: TranLc
469 : !
470 : ! !DESCRIPTION: Tranlate a character variable to all lowercase letters.
471 : ! Non-alphabetic characters are not affected.
472 : !\\
473 : !\\
474 : ! !INTERFACE:
475 : !
476 0 : SUBROUTINE TranLc( text )
477 : !
478 : ! !INPUT/OUTPUT PARAMETERS:
479 : !
480 : CHARACTER(LEN=*) :: text
481 : !
482 : ! !REMARKS:
483 : ! The original "text" is destroyed.
484 : !
485 : ! !REVISION HISTORY:
486 : ! AUTHOR: Robert D. Stewart
487 : ! DATE: May 19, 1992
488 : ! See https://github.com/geoschem/hemco for complete history
489 : !EOP
490 : !------------------------------------------------------------------------------
491 : !BOC
492 : !
493 : ! !LOCAL VARIABLES:
494 : !
495 : INTEGER :: iasc,i,ilen
496 :
497 0 : ilen = LEN(text)
498 0 : DO I=1,ilen
499 0 : iasc = ICHAR(text(i:i))
500 0 : IF ((iasc.GT.64).AND.(iasc.LT.91)) THEN
501 0 : text(i:i) = CHAR(iasc+32)
502 : ENDIF
503 : ENDDO
504 :
505 0 : END SUBROUTINE TRANLC
506 : !EOC
507 : !------------------------------------------------------------------------------
508 : ! Harmonized Emissions Component (HEMCO) !
509 : !------------------------------------------------------------------------------
510 : !BOP
511 : !
512 : ! !IROUTINE: TranUc
513 : !
514 : ! !DESCRIPTION: Tranlate a character variable to all upper case letters.
515 : ! Non-alphabetic characters are not affected.
516 : !\\
517 : !\\
518 : ! !INTERFACE:
519 : !
520 0 : SUBROUTINE TranUc( text )
521 : !
522 : ! !INPUT/OUTPUT PARAMETERS:
523 : !
524 : CHARACTER(LEN=*) :: text
525 : !
526 : ! !REMARKS:
527 : ! The original "text" is destroyed.
528 : !
529 : ! !REVISION HISTORY:
530 : ! AUTHOR: Robert D. Stewart
531 : ! DATE: May 19, 1992
532 : ! See https://github.com/geoschem/hemco for complete history
533 : !EOP
534 : !------------------------------------------------------------------------------
535 : !BOC
536 : !
537 : ! !LOCAL VARIABLES:
538 : !
539 : INTEGER :: iasc,i,ilen
540 :
541 0 : ilen = LEN(text)
542 0 : DO i=1,ilen
543 0 : iasc = ICHAR(text(i:i))
544 0 : IF ((iasc.GT.96).AND.(iasc.LT.123)) THEN
545 0 : text(i:i) = CHAR(iasc-32)
546 : ENDIF
547 : ENDDO
548 :
549 0 : END SUBROUTINE TRANUC
550 : !EOC
551 : !------------------------------------------------------------------------------
552 : ! Harmonized Emissions Component (HEMCO) !
553 : !------------------------------------------------------------------------------
554 : !BOP
555 : !
556 : ! !IROUTINE: TxtExt
557 : !
558 : ! !DESCRIPTION: TxtExt extracts a sequence of characters from
559 : ! text and transfers them to word. The extraction
560 : ! procedure uses a set of character "delimiters"
561 : ! to denote the desired sequence of characters.
562 : ! For example if ch=' ', the first character sequence
563 : ! bracketed by blank spaces will be returned in word.
564 : ! The extraction procedure begins in column, col,
565 : ! of TEXT. If text(col:col) = ch (any character in
566 : ! the character string), the text is returned beginning
567 : ! with col+1 in text (i.e., the first match with ch
568 : ! is ignored).
569 : !\\
570 : !\\
571 : ! After completing the extraction, col is incremented to
572 : ! the location of the first character following the
573 : ! end of the extracted text.
574 : !\\
575 : !\\
576 : ! A status flag is also returned with the following
577 : ! meaning(s)
578 : !\\
579 : !\\
580 : ! IF iflg = -1, found a text block, but no more characters
581 : ! are available in TEXT
582 : ! iflg = 0, task completed sucessfully (normal term)
583 : ! iflg = 1, ran out of text before finding a block of
584 : ! text.
585 : !\\
586 : !\\
587 : ! !INTERFACE:
588 : !
589 0 : SUBROUTINE TxtExt(ch,text,col,word,iflg)
590 : !
591 : ! !INPUT PARAMETERS:
592 : !
593 : CHARACTER(LEN=*), INTENT(IN) :: ch,text
594 : !
595 : ! !INPUT/OUTPUT PARAMETERS:
596 : !
597 : INTEGER, INTENT(INOUT) :: col
598 : !
599 : ! !OUTPUT PARAMETERS:
600 : !
601 : CHARACTER(LEN=*), INTENT(OUT) :: word
602 : INTEGER :: iflg
603 : !
604 : ! !REMARKS:
605 : ! TxtExt is short for Text Extraction. This routine provides a set of
606 : ! powerful line-by-line text search and extraction capabilities in
607 : ! standard FORTRAN.
608 : !
609 : ! !REVISION HISTORY:
610 : ! AUTHOR: Robert D. Stewart
611 : ! DATE: Jan. 1st, 1995
612 : ! See https://github.com/geoschem/hemco for complete history
613 : !EOP
614 : !------------------------------------------------------------------------------
615 : !BOC
616 : !
617 : ! !LOCAL VARIABLES:
618 : !
619 : INTEGER :: Tmax,T1,T2,imat
620 : LOGICAL :: again,prev
621 :
622 : ! Length of text
623 0 : Tmax = LEN(text)
624 :
625 : ! Fill Word with blanks
626 0 : WORD = REPEAT( ' ', LEN( WORD ) )
627 :
628 0 : IF (col.GT.Tmax) THEN
629 : ! Text does not contain any characters past Tmax.
630 : ! Reset col to one and return flag = {error condition}
631 0 : iflg = 1
632 0 : col = 1
633 0 : ELSEIF (col.EQ.Tmax) THEN
634 : ! End of TEXT reached
635 0 : CALL CntMat(ch,text(Tmax:Tmax),imat)
636 0 : IF (imat.EQ.0) THEN
637 : ! Copy character into Word and set col=1
638 0 : CALL CopyTxt(1,Text(Tmax:Tmax),Word)
639 0 : col = 1
640 0 : iflg = -1
641 : ELSE
642 : ! Same error condition as if col.GT.Tmax
643 0 : iflg = 1
644 : ENDIF
645 : ELSE
646 : ! Make sure column is not less than 1
647 0 : IF (col.LT.1) col=1
648 0 : CALL CntMat(ch,text(col:col),imat)
649 0 : IF (imat.GT.0) THEN
650 : prev=.true.
651 : ELSE
652 0 : prev=.false.
653 : ENDIF
654 0 : T1=col
655 0 : T2 = T1
656 :
657 0 : again = .true.
658 0 : DO WHILE (again)
659 : ! Check for a match with a character in ch
660 0 : CALL CntMat(ch,text(T2:T2),imat)
661 0 : IF (imat.GT.0) THEN
662 : ! Current character in TEXT matches one (or more) of the
663 : ! characters in ch.
664 0 : IF (prev) THEN
665 0 : IF (T2.LT.Tmax) THEN
666 : ! Keep searching for a block of text
667 0 : T2=T2+1
668 0 : T1=T2
669 : ELSE
670 : ! Did not find any text blocks before running
671 : ! out of characters in TEXT.
672 0 : again=.false.
673 0 : iflg=1
674 : ENDIF
675 : ELSE
676 : ! Previous character did not match ch, so terminate.
677 : ! NOTE: This is "NORMAL" termination of the loop
678 0 : again=.false.
679 0 : T2=T2-1
680 0 : iflg = 0
681 : ENDIF
682 0 : ELSEIF (T2.LT.Tmax) THEN
683 : ! Add a letter to the current block of text
684 0 : prev = .false.
685 0 : T2=T2+1
686 : ELSE
687 : ! Reached the end of the characters in TEXT before reaching
688 : ! another delimiting character. A text block was identified
689 : ! however.
690 0 : again=.false.
691 0 : iflg=-1
692 : ENDIF
693 : ENDDO
694 :
695 0 : IF (iflg.EQ.0) THEN
696 : ! Copy characters into WORD and set col for return
697 0 : CALL CopyTxt(1,Text(T1:T2),Word)
698 0 : col = T2+1
699 : ELSE
700 : ! Copy characters into WORD and set col for return
701 0 : CALL CopyTxt(1,Text(T1:T2),Word)
702 0 : col = 1
703 : ENDIF
704 : ENDIF
705 :
706 0 : END SUBROUTINE TxtExt
707 : !EOC
708 : !------------------------------------------------------------------------------
709 : ! Harmonized Emissions Component (HEMCO) !
710 : !------------------------------------------------------------------------------
711 : !BOP
712 : !
713 : ! !IROUTINE: Str2Hash14
714 : !
715 : ! !DESCRIPTION: Returns a unique integer hash for a given character string.
716 : ! This allows us to implement a fast name lookup algorithm.
717 : !\\
718 : !\\
719 : ! !INTERFACE:
720 : !
721 0 : FUNCTION Str2Hash14( Str ) RESULT( Hash )
722 : !
723 : ! !INPUT PARAMETERS:
724 : !
725 : CHARACTER(LEN=14), INTENT(IN) :: Str ! String (14 chars long)
726 : !
727 : ! !RETURN VALUE:
728 : !
729 : INTEGER :: Hash ! Hash value from string
730 : !
731 : ! !REMARKS:
732 : ! (1) Algorithm taken from this web page:
733 : ! https://fortrandev.wordpress.com/2013/07/06/fortran-hashing-algorithm/
734 : !
735 : ! (2) For now, we only use the first 14 characers of the character string
736 : ! to compute the hash value. Most GEOS-Chem species names only use
737 : ! at most 14 unique characters. We can change this later if need be.
738 : !
739 : ! !REVISION HISTORY:
740 : ! 04 May 2016 - R. Yantosca - Initial version
741 : ! See https://github.com/geoschem/hemco for complete history
742 : !EOP
743 : !------------------------------------------------------------------------------
744 : !BOC
745 : !
746 : ! !LOCAL VARIABLES:
747 : !
748 : ! Initialize
749 0 : Hash = 5381
750 :
751 : !-----------------------------------------------------------------------
752 : ! Construct the hash from the first 14 characters of the string,
753 : ! which is about the longest species name for GEOS-Chem.
754 : !
755 : ! NOTE: It's MUCH faster to explicitly write these statements
756 : ! instead of writing them using a DO loop (bmy, 5/4/16)
757 : !-----------------------------------------------------------------------
758 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 1: 1) )
759 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 2: 2) )
760 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 3: 3) )
761 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 4: 4) )
762 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 5: 5) )
763 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 6: 6) )
764 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 7: 7) )
765 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 8: 8) )
766 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 9: 9) )
767 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(10:10) )
768 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(11:11) )
769 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(12:12) )
770 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(13:13) )
771 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(14:14) )
772 :
773 0 : END FUNCTION Str2Hash14
774 : !EOC
775 : !------------------------------------------------------------------------------
776 : ! Harmonized Emissions Component (HEMCO) !
777 : !------------------------------------------------------------------------------
778 : !BOP
779 : !
780 : ! !IROUTINE: Str2Hash
781 : !
782 : ! !DESCRIPTION: Returns a unique integer hash for a given character string.
783 : ! This allows us to implement a fast name lookup algorithm.
784 : !\\
785 : !\\
786 : ! !INTERFACE:
787 : !
788 0 : FUNCTION Str2Hash31( Str ) RESULT( Hash )
789 : !
790 : ! !INPUT PARAMETERS:
791 : !
792 : CHARACTER(LEN=31), INTENT(IN) :: Str ! String (31 chars long)
793 : !
794 : ! !RETURN VALUE:
795 : !
796 : INTEGER :: Hash ! Hash value from string
797 : !
798 : ! !REMARKS:
799 : ! (1) Algorithm taken from this web page:
800 : ! https://fortrandev.wordpress.com/2013/07/06/fortran-hashing-algorithm/
801 : !
802 : ! (2) For now, we only use the first 31 characers of the character string
803 : ! to compute the hash value. Most GEOS-Chem variable names only use
804 : ! up to 31 unique characters. We can change this later if need be.
805 : !
806 : ! !REVISION HISTORY:
807 : ! 26 Jun 2017 - R. Yantosca - Initial version
808 : ! See https://github.com/geoschem/hemco for complete history
809 : !EOP
810 : !------------------------------------------------------------------------------
811 : !BOC
812 : !
813 : ! !LOCAL VARIABLES:
814 : !
815 : ! Initialize
816 0 : Hash = 5381
817 :
818 : !-----------------------------------------------------------------------
819 : ! Construct the hash from the first 31 characters of the string,
820 : ! which is about the longest variable name for GEOS-Chem.
821 : !
822 : ! NOTE: It's MUCH faster to explicitly write these statements
823 : ! instead of writing them using a DO loop.
824 : !-----------------------------------------------------------------------
825 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 1: 1) )
826 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 2: 2) )
827 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 3: 3) )
828 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 4: 4) )
829 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 5: 5) )
830 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 6: 6) )
831 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 7: 7) )
832 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 8: 8) )
833 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str( 9: 9) )
834 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(10:10) )
835 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(11:11) )
836 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(12:12) )
837 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(13:13) )
838 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(14:14) )
839 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(15:15) )
840 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(16:16) )
841 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(17:17) )
842 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(18:18) )
843 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(19:19) )
844 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(20:20) )
845 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(21:21) )
846 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(22:22) )
847 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(23:23) )
848 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(24:24) )
849 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(25:25) )
850 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(26:26) )
851 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(27:27) )
852 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(28:28) )
853 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(29:29) )
854 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(30:30) )
855 0 : Hash = ( ISHFT( Hash, 5 ) + Hash ) + ICHAR( Str(31:31) )
856 :
857 0 : END FUNCTION Str2Hash31
858 : !EOC
859 : !------------------------------------------------------------------------------
860 : ! Harmonized Emissions Component (HEMCO) !
861 : !------------------------------------------------------------------------------
862 : !BOP
863 : !
864 : ! !IROUTINE: To_Uppercase
865 : !
866 : ! !DESCRIPTION: Converts a string to uppercase, so that we can reliably
867 : ! do string matching.
868 : !\\
869 : !\\
870 : ! !INTERFACE:
871 : !
872 0 : FUNCTION To_UpperCase( Text ) RESULT( UpCaseText )
873 : !
874 : ! !INPUT PARAMETERS:
875 : !
876 : CHARACTER(LEN=*), INTENT(IN) :: Text ! Input test
877 : !
878 : ! !RETURN VALUE:
879 : !
880 : CHARACTER(LEN=255) :: UpCaseText ! Output text, uppercase
881 : !
882 : ! !REMARKS:
883 : ! Code originally from routine TRANUC (Author: R. D. Stewart, 19 May 1992)
884 : !
885 : ! !REVISION HISTORY:
886 : ! 26 Jun 2017 - R. Yantosca - Initial version
887 : ! See https://github.com/geoschem/hemco for complete history
888 : !EOP
889 : !------------------------------------------------------------------------------
890 : !BOC
891 : !
892 : ! !LOCAL VARIABLES:
893 : !
894 : ! Scalars
895 : INTEGER :: C, Ascii
896 :
897 : !=======================================================================
898 : ! Convert to uppercase
899 : !=======================================================================
900 :
901 : ! Initialize
902 0 : UpCaseText = Text
903 :
904 : ! Loop over all characters
905 0 : DO C = 1, LEN_TRIM( UpCaseText )
906 :
907 : ! Get the ASCII code for each character
908 0 : Ascii = ICHAR( UpCaseText(C:C) )
909 :
910 : ! If lowercase, convert to uppercase
911 0 : IF ( Ascii > 96 .and. Ascii < 123 ) THEN
912 0 : UpCaseText(C:C) = CHAR( Ascii - 32 )
913 : ENDIF
914 : ENDDO
915 :
916 0 : END FUNCTION To_UpperCase
917 : !EOC
918 : !------------------------------------------------------------------------------
919 : ! Harmonized Emissions Component (HEMCO) !
920 : !------------------------------------------------------------------------------
921 : !BOP
922 : !
923 : ! !IROUTINE: ReadOneLine
924 : !
925 : ! !DESCRIPTION: Subroutine READ\_ONE\_LINE reads a line from the input file.
926 : ! If the global variable VERBOSE is set, the line will be printed to stdout.
927 : ! READ\_ONE\_LINE can trap an unexpected EOF if LOCATION is passed.
928 : ! Otherwise, it will pass a logical flag back to the calling routine,
929 : ! where the error trapping will be done.
930 : !\\
931 : !\\
932 : ! !INTERFACE:
933 : !
934 0 : FUNCTION ReadOneLine( fId, EndOfFile, IoStatus, Squeeze ) RESULT( Line )
935 : !
936 : ! !INPUT PARAMETERS:
937 : !
938 : INTEGER, INTENT(IN) :: fId ! File unit number
939 : LOGICAL, OPTIONAL :: Squeeze ! Call Strsqueeze?
940 : !
941 : ! !OUTPUT PARAMETERS:
942 : !
943 : LOGICAL, INTENT(OUT) :: EndOfFile ! Denotes EOF condition
944 : INTEGER, INTENT(OUT) :: IoStatus ! I/O status code
945 : !
946 : ! !RETURN VALUE:
947 : !
948 : CHARACTER(LEN=MAXSTRLEN) :: Line ! Single line from the input file
949 : !
950 : ! !REMARKS:
951 : ! Mostly used by routines in the History/ folder.
952 : !
953 : ! !REVISION HISTORY:
954 : ! 16 Jun 2017 - R. Yantosca - Initial version, based on GEOS-Chem
955 : ! See https://github.com/geoschem/hemco for complete history
956 : !EOP
957 : !------------------------------------------------------------------------------
958 : !BOC
959 :
960 : !=================================================================
961 : ! Initialize
962 : !=================================================================
963 0 : EndOfFile = .FALSE.
964 0 : IoStatus = 0
965 0 : Line = ''
966 :
967 : !=================================================================
968 : ! Read data from the file
969 : !=================================================================
970 :
971 : ! Read a line from the file
972 0 : READ( fId, '(a)', IOSTAT=IoStatus ) Line
973 :
974 : ! IO Status < 0: EOF condition
975 0 : IF ( IoStatus < 0 ) THEN
976 0 : EndOfFile = .TRUE.
977 0 : RETURN
978 : ENDIF
979 :
980 : ! If desired, call StrSqueeze to strip leading and trailing blanks
981 0 : IF ( PRESENT( Squeeze ) ) THEN
982 0 : IF ( Squeeze ) THEN
983 0 : CALL StrSqueeze( Line )
984 : ENDIF
985 : ENDIF
986 :
987 : END FUNCTION ReadOneLine
988 : !EOC
989 : !------------------------------------------------------------------------------
990 : ! Harmonized Emissions Component (HEMCO) !
991 : !------------------------------------------------------------------------------
992 : !BOP
993 : !
994 : ! !IROUTINE: CleanText
995 : !
996 : ! !DESCRIPTION: Strips commas, apostrophes, spaces, and tabs from a string.
997 : !\\
998 : !\\
999 : ! !INTERFACE:
1000 : !
1001 0 : FUNCTION CleanText( Str ) RESULT( CleanStr )
1002 : !
1003 : ! !INPUT PARAMETERS:
1004 : !
1005 : CHARACTER(LEN=*), INTENT(IN) :: Str ! Original string
1006 : !
1007 : ! !RETURN VALUE
1008 : !
1009 : CHARACTER(LEN=255) :: CleanStr ! Cleaned-up string
1010 : !
1011 : ! !REMARKS:
1012 : ! Mostly used by routines in the History/ folder.
1013 : !
1014 : ! !REVISION HISTORY:
1015 : ! 06 Jan 2015 - R. Yantosca - Initial version
1016 : ! See https://github.com/geoschem/hemco for complete history
1017 : !EOP
1018 : !------------------------------------------------------------------------------
1019 : !BOC
1020 :
1021 : ! Initialize
1022 0 : CleanStr = Str
1023 :
1024 : ! Strip out non-printing characters (e.g. tabs)
1025 0 : CALL CStrip ( CleanStr )
1026 :
1027 : ! Remove commas and quotes
1028 0 : CALL StrRepl ( CleanStr, ",", " " )
1029 0 : CALL StrRepl ( CleanStr, "'", " " )
1030 :
1031 : ! Remove leading and trailing spaces
1032 0 : CALL StrSqueeze( CleanStr )
1033 :
1034 0 : END FUNCTION CleanText
1035 : !EOC
1036 : !------------------------------------------------------------------------------
1037 : ! Harmonized Emissions Component (HEMCO) !
1038 : !------------------------------------------------------------------------------
1039 : !BOP
1040 : !
1041 : ! !IROUTINE: WordWrapPrint
1042 : !
1043 : ! !DESCRIPTION: Prints a text string wrapped to a specified line width.
1044 : ! Useful for displaying error and warning messages.
1045 : !\\
1046 : !\\
1047 : ! !INTERFACE:
1048 : !
1049 0 : SUBROUTINE WordWrapPrint( Text, LineWidth, Delimiter )
1050 : !
1051 : ! !INPUT PARAMETERS:
1052 : !
1053 : CHARACTER(LEN=*), INTENT(IN) :: Text ! Text to print
1054 : INTEGER, INTENT(IN) :: LineWidth ! Width (characters) of lines
1055 : CHARACTER(LEN=1), OPTIONAL :: Delimiter ! Delimiter between words
1056 : !
1057 : ! !REMARKS:
1058 : ! The default DELIMITER is the space (" ") character.
1059 : !
1060 : ! !REVISION HISTORY:
1061 : ! 20 Dec 2015 - R. Yantosca - Initial version
1062 : ! See https://github.com/geoschem/hemco for complete history
1063 : !EOP
1064 : !------------------------------------------------------------------------------
1065 : !BOC
1066 : !
1067 : ! !LOCAL VARIABLES:
1068 : !
1069 : ! Scalars
1070 : INTEGER :: C, S, B, Matches, Length
1071 :
1072 : ! Arrays
1073 : INTEGER :: BreakPts(100)
1074 : INTEGER :: SpaceLoc(500)
1075 :
1076 : ! Strings
1077 : CHARACTER(LEN=1) :: Delim
1078 :
1079 : !=======================================================================
1080 : ! WordWrapPrint begins here!
1081 : !=======================================================================
1082 :
1083 : ! SpaceLoc is the array of where delimiters (usually the " "
1084 : ! character) occur in the text, and S is its index.
1085 0 : S = 1
1086 0 : SpaceLoc = 0
1087 :
1088 : ! BreakPts is the array of where line breaks occur
1089 : ! and B is its index.
1090 0 : BreakPts = 0
1091 0 : B = 1
1092 0 : BreakPts(B) = 1
1093 :
1094 : ! Delimiter for separating words (will be the space character by default)
1095 0 : IF ( PRESENT( Delimiter ) ) THEN
1096 0 : Delim = Delimiter
1097 : ELSE
1098 0 : Delim = ' '
1099 : ENDIF
1100 :
1101 : ! Find the Location of spaces in the text
1102 0 : CALL CntMat( Text, ' ', Matches, SpaceLoc )
1103 :
1104 : ! Loop through the number of matches
1105 : DO
1106 :
1107 : ! Move to the next delimiter location
1108 0 : S = S + 1
1109 :
1110 : ! Compute the length of the line
1111 0 : Length = SpaceLoc(S) - BreakPts(B)
1112 :
1113 : ! If the length of this segment is greater than the requested
1114 : ! line length, store the position of this line break
1115 0 : IF ( Length > LineWidth ) THEN
1116 0 : B = B + 1
1117 0 : BreakPts(B) = SpaceLoc(S-1) + 1
1118 : ENDIF
1119 :
1120 : ! If we have exceeded the number of delimiters in the text, then set
1121 : ! the last breakpoint at the end of the text and exit the loop.
1122 0 : IF ( S > Matches ) THEN
1123 0 : B = B + 1
1124 0 : BreakPts(B) = LEN_TRIM( Text ) + 1
1125 : EXIT
1126 : ENDIF
1127 :
1128 : ENDDO
1129 :
1130 : ! Print each line
1131 0 : DO C = 1, B-1
1132 0 : WRITE( 6, '(a)' ) Text( BreakPts(C):BreakPts(C+1)-1 )
1133 : ENDDO
1134 :
1135 0 : END SUBROUTINE WordWrapPrint
1136 : !EOC
1137 : END MODULE HCO_CharPak_Mod
|
