source: XMLF90/src/strings/m_strings.f90 @ 277

Last change on this file since 277 was 6, checked in by ymipsl, 14 years ago

Import des sources XMLF90

File size: 163.0 KB
Line 
1!*******************************************************************************
2! module STRINGS
3! Mart Rentmeester, Mart.Rentmeester@sci.kun.nl
4! http://nn-online.sci.kun.nl/fortran
5! Version 1.0
6!*******************************************************************************
7
8      module m_strings
9
10      private
11
12      type string
13          private
14          integer                 :: len = 0
15          integer                 :: size = 0
16
17          character, pointer      :: chars(:) => null()
18
19      end type string
20
21      character, parameter :: blank = ' '
22
23!     GENERIC PROCEDURE INTERFACE DEFINITIONS
24
25!---- LEN interface
26      interface len
27          module procedure len_s
28      end interface
29
30!---- Conversion (to CHAR) procedure interfaces
31      interface char
32          module procedure s_to_c, &! string to character
33                           s_to_slc       ! string to specified length character
34      end interface
35
36!---- ASSIGNMENT interfaces
37      interface assignment(=)
38          module procedure assign_s_to_s, &! string = string
39                           assign_s_to_c, &! character = string
40                           assign_c_to_s        ! string = character
41      end interface
42
43!---- // operator interfaces
44      interface operator(//)
45          module procedure s_concat_s, &! string // string
46                           s_concat_c, &! string // character
47                           c_concat_s     ! character // string
48      end interface
49
50!---- INSERT_IN_STRING interface
51      interface insert_in_string
52          module procedure insert_in_string_c, insert_in_string_s
53      end interface
54
55!---- PREPEND_TO_STRING interface
56      interface prepend_to_string
57          module procedure prepend_to_string_c, prepend_to_string_s
58      end interface
59
60!---- APPEND_TO_STRING interface
61      interface append_to_string
62          module procedure append_to_string_c, append_to_string_s
63      end interface
64
65!---- REPLACE_IN_STRING interface
66      interface replace_in_string
67          module procedure replace_in_string_sc_s,   replace_in_string_ss_s,   &
68                           replace_in_string_sc_sf,  replace_in_string_ss_sf,  &
69                           replace_in_string_scc,    replace_in_string_ssc,    &
70                           replace_in_string_scs,    replace_in_string_sss,    &
71                           replace_in_string_scc_f,  replace_in_string_ssc_f,  &
72                           replace_in_string_scs_f,  replace_in_string_sss_f
73      end interface
74
75
76!---- REPEAT interface
77      interface repeat
78          module procedure repeat_s
79      end interface
80
81!---- ==  .eq. comparison operator interfaces
82      interface operator(==)
83          module procedure s_eq_s, &! string == string
84                           s_eq_c, &! string == character
85                           c_eq_s         ! character == string
86      end interface
87
88!---- /=  .ne. comparison operator interfaces
89      interface operator(/=)
90          module procedure s_ne_s, &! string /= string
91                           s_ne_c, &! string /= character
92                           c_ne_s         ! character /= string
93      end interface
94
95!---- <  .lt. comparison operator interfaces
96      interface operator(<)
97          module procedure s_lt_s, &! string < string
98                           s_lt_c, &! string < character
99                           c_lt_s         ! character < string
100      end interface
101
102!---- <=  .le. comparison operator interfaces
103      interface operator(<=)
104          module procedure s_le_s, &! string <= string
105                           s_le_c, &! string <= character
106                           c_le_s         ! character <= string
107      end interface
108
109!---- >=  .ge. comparison operator interfaces
110      interface operator(>=)
111          module procedure s_ge_s, &! string >= string
112                           s_ge_c, &! string >= character
113                           c_ge_s         ! character >= string
114      end interface
115
116!---- >  .gt. comparison operator interfaces
117      interface operator(>)
118          module procedure s_gt_s, &! string > string
119                           s_gt_c, &! string > character
120                           c_gt_s         ! character > string
121      end interface
122
123!---- .aeq. comparison operator interfaces
124      interface operator(.aeq.)
125          module procedure a_eq_a, &! array == array
126                           a_eq_c, &! array == character
127                           c_eq_a         ! character == array
128      end interface
129
130!---- .ane. comparison operator interfaces
131      interface operator(.ane.)
132          module procedure a_ne_a, &! array /= array
133                           a_ne_c, &! array /= character
134                           c_ne_a         ! character /= array
135      end interface
136
137!---- .alt. comparison operator interfaces
138      interface operator(.alt.)
139          module procedure a_lt_a, &! array < array
140                           a_lt_c, &! array < character
141                           c_lt_a         ! character < array
142      end interface
143
144!---- .ale. comparison operator interfaces
145      interface operator(.ale.)
146          module procedure a_le_a, &! array <= array
147                           a_le_c, &! array <= character
148                           c_le_a         ! character <= array
149      end interface
150
151!---- .age. comparison operator interfaces
152      interface operator(.age.)
153          module procedure a_ge_a, &! array >= array
154                           a_ge_c, &! array >= character
155                           c_ge_a         ! character >= array
156      end interface
157
158!---- .agt. comparison operator interfaces
159      interface operator(.agt.)
160          module procedure a_gt_a, &! array > array
161                           a_gt_c, &! array > character
162                           c_gt_a         ! character > array
163      end interface
164
165!---- LLT comparison function interfaces
166      interface llt
167          module procedure s_llt_s, &! llt(string,string)
168                           s_llt_c, &! llt(string,character)
169                           c_llt_s        ! llt(character,string)
170      end interface
171
172!---- LLE comparison function interfaces
173      interface lle
174          module procedure s_lle_s, &! lle(string,string)
175                           s_lle_c, &! lle(string,character)
176                           c_lle_s        ! lle(character,string)
177      end interface
178
179!---- LGE comparison function interfaces
180      interface lge
181          module procedure s_lge_s, &! lge(string,string)
182                           s_lge_c, &! lge(string,character)
183                           c_lge_s        ! lge(character,string)
184      end interface
185
186!---- LGT comparison function interfaces
187      interface lgt
188          module procedure s_lgt_s, &! lgt(string,string)
189                           s_lgt_c, &! lgt(string,character)
190                           c_lgt_s        ! lgt(character,string)
191      end interface
192
193!---- ALLT comparison function interfaces
194      interface allt
195          module procedure a_allt_a, &! allt(array,array)
196                           a_allt_c, &! allt(array,character)
197                           c_allt_a        ! allt(character,array)
198      end interface
199
200!---- ALLE comparison function interfaces
201      interface alle
202          module procedure a_alle_a, &! alle(array,array)
203                           a_alle_c, &! alle(array,character)
204                           c_alle_a        ! alle(character,array)
205      end interface
206
207!---- ALGE comparison function interfaces
208      interface alge
209          module procedure a_alge_a, &! alge(array,array)
210                           a_alge_c, &! alge(array,character)
211                           c_alge_a        ! alge(character,array)
212      end interface
213
214!---- ALGT comparison function interfaces
215      interface algt
216          module procedure a_algt_a, &! algt(array,array)
217                           a_algt_c, &! algt(array,character)
218                           c_algt_a        ! algt(character,array)
219      end interface
220
221!---- INDEX procedure
222      interface index
223          module procedure index_ss, index_sc, index_cs
224      end interface
225
226!---- AINDEX procedure
227      interface aindex
228          module procedure aindex_aa, aindex_ac, aindex_ca
229      end interface
230
231!---- SCAN procedure
232      interface scan
233          module procedure scan_ss, scan_sc, scan_cs
234      end interface
235
236!---- ASCAN procedure
237      interface ascan
238          module procedure ascan_aa, ascan_ac, ascan_ca
239      end interface
240
241!---- VERIFY procedure
242      interface verify
243          module procedure verify_ss, verify_sc, verify_cs
244      end interface
245
246!---- AVERIFY procedure
247      interface averify
248          module procedure averify_aa, averify_ac, averify_ca
249      end interface
250
251!---- TRIM interface
252      interface len_trim
253          module procedure len_trim_s
254      end interface
255
256!---- LEN_TRIM interface
257      interface trim
258          module procedure trim_s
259      end interface
260
261!---- IACHAR interface
262      interface iachar
263          module procedure iachar_s
264      end interface
265
266!---- ICHAR interface
267      interface ichar
268          module procedure ichar_s
269      end interface
270
271!---- ADJUSTL interface
272      interface adjustl
273          module procedure adjustl_s
274      end interface
275
276!---- ADJUSTR interface
277      interface adjustr
278          module procedure adjustr_s
279      end interface
280
281!---- LEN_STRIP interface
282      interface len_strip
283          module procedure len_strip_c, len_strip_s
284      end interface
285
286!---- STRIP interface
287      interface strip
288          module procedure strip_c, strip_s
289      end interface
290
291!---- UPPERCASE interface
292      interface uppercase
293          module procedure uppercase_s, uppercase_c
294      end interface
295
296!---- TO_UPPERCASE interface
297      interface to_uppercase
298          module procedure to_uppercase_s, to_uppercase_c
299      end interface
300
301!---- LOWERCASE interface
302      interface lowercase
303          module procedure lowercase_s, lowercase_c
304      end interface
305
306!---- TO_LOWERCASE interface
307      interface to_lowercase
308          module procedure to_lowercase_s, to_lowercase_c
309      end interface
310
311!---- EXTRACT interface
312      interface extract
313          module procedure extract_s, extract_c
314      end interface
315
316!---- SUBSTRING interface
317      interface substring
318          module procedure extract_s, extract_c
319      end interface
320
321!---- REMOVE interface
322      interface remove
323          module procedure remove_s, remove_c
324      end interface
325
326!---- INSERT interface
327      interface insert
328          module procedure insert_ss, insert_cs, insert_sc, insert_cc
329      end interface
330
331!---- REPLACE interface
332      interface replace
333          module procedure replace_cc_s,   replace_cs_s,   &
334                           replace_sc_s,   replace_ss_s,   &
335                           replace_cc_sf,  replace_cs_sf,  &
336                           replace_sc_sf,  replace_ss_sf,  &
337                           replace_ccc,    replace_csc,    &
338                           replace_ccs,    replace_css,    &
339                           replace_scc,    replace_ssc,    &
340                           replace_scs,    replace_sss,    &
341                           replace_ccc_f,  replace_csc_f,  &
342                           replace_ccs_f,  replace_css_f,  &
343                           replace_scc_f,  replace_ssc_f,  &
344                           replace_scs_f,  replace_sss_f
345      end interface
346
347!---- SORT interface
348      interface sort
349          module procedure sort_c, sort_s
350      end interface
351
352!---- LSORT interface
353      interface lsort
354          module procedure lsort_c, lsort_s
355      end interface
356
357!---- RANK interface
358      interface rank
359          module procedure rank_c, rank_s
360      end interface
361
362!---- LRANK interface
363      interface lrank
364          module procedure lrank_c, lrank_s
365      end interface
366
367
368
369!---- Publically accessible entities
370      public :: string
371      public :: assignment(=),unstring
372      public :: insert,replace,remove,extract,substring
373      public :: repeat,index,scan,verify
374      public :: operator(//)
375      public :: operator(==),operator(/=)
376      public :: operator(<),operator(<=)
377      public :: operator(>),operator(>=)
378      public :: llt,lle,lge,lgt
379      public :: char,len,len_trim,trim,iachar,ichar,adjustl,adjustr
380      public :: lowercase,to_lowercase,uppercase,to_uppercase
381      public :: strip,len_strip
382      public :: sort,rank,lsort,lrank
383
384      public :: resize_string,string_size,swap_strings
385      public :: trim_string,strip_string
386      public :: adjustl_string,adjustr_string
387      public :: insert_in_string,remove_from_string
388      public :: prepend_to_string,append_to_string
389      public :: replace_in_string
390
391
392
393
394      contains
395
396!*******************************************************************************
397!     LEN
398!*******************************************************************************
399
400      elemental function len_s(s)
401
402      implicit none
403      type(string), intent(in)  :: s
404      integer                   :: len_s
405
406
407      len_s = s%len
408
409      end function len_s
410
411!*******************************************************************************
412!     STRING_SIZE
413!*******************************************************************************
414
415      elemental function string_size(s)
416
417      implicit none
418      type(string), intent(in)  :: s
419      integer                   :: string_size
420
421
422      string_size = s%size
423
424      end function string_size
425
426!*******************************************************************************
427!     CHAR
428!*******************************************************************************
429!     Returns the characters of string as an automatically sized character
430
431      pure function s_to_c(s)
432
433      implicit none
434      type(string),intent(in)   :: s
435      character(len(s))         :: s_to_c
436
437
438      s_to_c = transfer(s%chars(1:len(s)),s_to_c)
439
440      end function s_to_c
441
442!*******************************************************************************
443!     Returns the character of fixed length, length, containing the characters
444!     of string either padded with blanks or truncated on the right to fit
445
446      pure function s_to_slc(s,length)
447
448      implicit none
449      type(string),intent(in)  :: s
450      integer, intent(in)      :: length
451      character(length)        :: s_to_slc
452      integer                  :: i,lc
453
454
455      lc = min(len(s),length)
456      s_to_slc(1:lc) = transfer(s%chars(1:lc),s_to_slc)
457
458!     Result longer than string: padding needed
459      if (lc < length) s_to_slc(lc+1:length) = blank
460
461      end function s_to_slc
462
463!*******************************************************************************
464! Assign a string value to a string variable overriding default assignement.
465! Reallocates string variable to size of string value and copies characters.
466
467      elemental subroutine assign_s_to_s(var,expr)
468
469      implicit none
470      type(string), intent(out)  :: var
471      type(string), intent(in)   :: expr
472
473
474
475      if (associated(var%chars,expr%chars)) then
476!         Identity assignment: nothing to be done
477          continue
478      else
479          if (associated(var%chars)) deallocate(var%chars)
480
481          var%size = expr%size
482          var%len = expr%len
483!AG
484          if (associated(expr%chars)) then
485             allocate(var%chars(1:var%size))
486             var%chars(1:var%len) = expr%chars(1:var%len)
487          endif
488      endif
489
490
491      end subroutine assign_s_to_s
492
493!*******************************************************************************
494! Assign a string value to a character variable.
495! If the string is longer than the character truncate the string on the right.
496! If the string is shorter the character is blank padded on the right.
497
498      elemental subroutine assign_s_to_c(var,expr)
499
500      implicit none
501      character(*), intent(out)  :: var
502      type(string), intent(in)   :: expr
503      integer                    :: i,lc,ls
504
505
506      lc = len(var);
507      ls = min(len(expr),lc)
508
509      var(1:ls) = transfer(expr%chars(1:ls),var(1:ls))
510
511      do i=ls+1,lc
512          var(i:i) = blank
513      enddo
514
515      end subroutine assign_s_to_c
516
517!*******************************************************************************
518!     Assign a character value to a string variable.
519!     Disassociates the string variable from its current value, allocates new
520!     space to hold the characters and copies them from the character value
521!     into this space.
522
523      elemental subroutine assign_c_to_s(var,expr)
524
525      implicit none
526      type(string), intent(out)  :: var
527      character(*), intent(in)   :: expr
528      integer                    :: i,lc
529
530
531
532      if (associated(var%chars)) deallocate(var%chars)
533
534
535      lc = len(expr)
536      var%len = lc
537      var%size = lc
538      allocate(var%chars(1:lc))
539!!AG: NAG compiler uses temporaries here:
540      var%chars(:) = (/ (expr(i:i), i=1,lc) /)
541
542      endsubroutine assign_c_to_s
543
544!*******************************************************************************
545!     RESIZE_STRING procedure
546!*******************************************************************************
547
548!*** return code
549!*** n < 0  --> deallocate?
550
551!     pure subroutine resize_string(s,newsize,status)
552      pure subroutine resize_string(s,newsize)
553
554      implicit none
555      type(string), intent(inout)     :: s
556      integer, intent(in)             :: newsize
557!     integer, intent(out), optional  :: status
558
559      character, pointer              :: c(:)
560
561      integer                         :: i
562
563
564      if (newsize <= 0) return
565
566
567      if (associated(s%chars)) then
568
569          i = min(newsize,s%len)
570          allocate(c(i))
571          c(:) = s%chars(1:i)
572          deallocate(s%chars)
573
574          s%chars => c
575
576          s%len = i
577          s%size = newsize
578      else
579          s%size = newsize
580          s%len = 0
581          allocate(s%chars(s%size))
582      endif
583
584      end subroutine resize_string
585
586!*******************************************************************************
587!     SWAP_STRINGS
588!*******************************************************************************
589      subroutine swap_strings(s1,s2)
590
591
592      implicit none
593      type(string), intent(inout)  :: s1,s2
594      integer                      :: l,s
595      character, pointer           :: c(:)
596
597
598      l = s1%len
599      s = s1%size
600      c => s1%chars
601      s1%len = s2%len
602      s1%size = s2%size
603      s1%chars => s2%chars
604      s2%len = l
605      s2%size = s
606      s2%chars => c
607
608      end subroutine swap_strings
609
610!*******************************************************************************
611!     TRIM_STRINGSIZE
612!*******************************************************************************
613
614      subroutine trim_stringsize(s)
615
616      implicit none
617      type(string), intent(inout)  :: s
618
619
620      call resize_string(s,len(s))
621
622      end subroutine trim_stringsize
623
624!*******************************************************************************
625!     TRIM_STRING
626!*******************************************************************************
627
628      subroutine trim_string(s)
629
630      implicit none
631      type(string), intent(inout)  :: s
632
633
634      s%len = len_trim(s)
635
636      end subroutine trim_string
637
638!*******************************************************************************
639!    STRIP
640!*******************************************************************************
641
642     pure subroutine strip_string(s)
643
644     implicit none
645     type(string), intent(inout)  :: s
646     integer                      :: i,i1,i2
647
648
649     do i1=1,len(s)
650         if (s%chars(i1) /= blank) exit
651     enddo
652     do i2=len(s),1,-1
653         if (s%chars(i2) /= blank) exit
654     enddo
655     do i=i1,i2
656         s%chars(i-i1+1) = s%chars(i)
657     enddo
658     s%len = i2 - i1 + 1
659
660     end subroutine strip_string
661
662!*******************************************************************************
663!     ADJUSTL_STRING
664!*******************************************************************************
665! Returns as a character variable the string adjusted to the left,
666! removing leading blanks and inserting trailing blanks.
667
668      pure subroutine adjustl_string(s)
669
670      implicit none
671      type(string), intent(inout)  :: s
672      integer                      :: i,j
673
674
675      do i=1,len(s)
676          if (s%chars(i) /= blank) exit
677      enddo
678      do j=i,len(s)
679          s%chars(j-i:j-i) = s%chars(j)
680      enddo
681      s%chars(j+1:) = blank
682
683      end subroutine adjustl_string
684
685!*******************************************************************************
686!     ADJUSTR_STRING
687!*******************************************************************************
688! Returns as a character variable the string adjusted to the right,
689! removing trailing blanks and inserting leading blanks.
690
691      pure subroutine adjustr_string(s)
692
693      implicit none
694      type(string), intent(inout)  :: s
695      integer                      :: i,j,l,lt
696
697
698      l = len(s)
699      lt = len_trim(s)
700
701      i = l - lt
702
703      do j=1,lt
704          s%chars(j+i:j+i) = s%chars(j)
705      enddo
706      s%chars(1:i) = blank
707
708
709      end subroutine adjustr_string
710
711!*******************************************************************************
712!     PREPEND_TO_STRING
713!*******************************************************************************
714
715      pure subroutine prepend_to_string_s(s1,s2)
716
717      implicit none
718      type(string), intent(inout)  :: s1
719      type(string), intent(in)     :: s2
720      integer                      :: i,ls1,ls2
721
722      character, pointer           :: ss(:)
723
724
725      ls1 = len(s1)
726      ls2 = len(s2)
727      if (ls2 == 0) return
728      if (ls1+ls2 > string_size(s1)) then
729          allocate(ss(ls1+ls2))
730          do i=1,ls2
731              ss(i) = s2%chars(i)
732          enddo
733          do i=1,ls1
734              ss(ls2+i) = s1%chars(i)
735          enddo
736          deallocate(s1%chars)
737
738          s1%chars => ss
739
740          s1%len = ls1 + ls2
741          s1%size = s1%len
742      else
743          do i=ls1,1,-1
744              s1%chars(ls2+i) = s1%chars(i)
745          enddo
746          do i=1,ls2
747              s1%chars(i) = s2%chars(i)
748          enddo
749          s1%len = ls1 + ls2
750      endif
751
752      end subroutine prepend_to_string_s
753
754!*******************************************************************************
755
756      pure subroutine prepend_to_string_c(s,c)
757
758      implicit none
759      type(string), intent(inout)  :: s
760      character(*), intent(in)     :: c
761      integer                      :: i,ls,lc
762
763      character, pointer           :: ss(:)
764
765
766
767      ls = len(s)
768      lc = len(c)
769      if (lc == 0) return
770      if (ls+lc > string_size(s)) then
771          allocate(ss(ls+lc))
772          do i=1,lc
773              ss(i) = c(i:i)
774          enddo
775          do i=1,ls
776              ss(lc+i) = s%chars(i)
777          enddo
778          deallocate(s%chars)
779
780          s%chars => ss
781
782          s%len = ls + lc
783          s%size = s%len
784      else
785          do i=ls,1,-1
786              s%chars(lc+i) = s%chars(i)
787          enddo
788          do i=1,lc
789              s%chars(i) = c(i:i)
790          enddo
791          s%len = ls + lc
792      endif
793
794      end subroutine prepend_to_string_c
795
796!*******************************************************************************
797!     APPEND_TO_STRING
798!*******************************************************************************
799
800      pure subroutine append_to_string_s(s1,s2)
801
802      implicit none
803      type(string), intent(inout)  :: s1
804      type(string), intent(in)     :: s2
805      integer                      :: i,ls1,ls2
806
807      character, pointer           :: ss(:)
808
809
810      ls1 = len(s1)
811      ls2 = len(s2)
812      if (ls2 == 0) return
813      if (ls1+ls2 > string_size(s1)) then
814          allocate(ss(ls1+ls2))
815          do i=1,ls1
816              ss(i) = s1%chars(i)
817          enddo
818          do i=ls1+1,ls1+ls2
819              ss(i) = s2%chars(i-ls1)
820          enddo
821          deallocate(s1%chars)
822
823          s1%chars => ss
824
825          s1%len = ls1 + ls2
826          s1%size = s1%len
827      else
828          do i=ls1+1,ls1+ls2
829              s1%chars(i) = s2%chars(i-ls1)
830          enddo
831          s1%len = ls1 + ls2
832      endif
833
834      end subroutine append_to_string_s
835
836!*******************************************************************************
837
838      pure subroutine append_to_string_c(s,c)
839
840      implicit none
841      type(string), intent(inout)  :: s
842      character(*), intent(in)     :: c
843      integer                      :: i,ls,lc
844
845      character, pointer           :: ss(:)
846
847
848
849      ls = len(s)
850      lc = len(c)
851      if (lc == 0) return
852      if (ls+lc > string_size(s)) then
853          allocate(ss(ls+lc))
854          do i=1,ls
855              ss(i) = s%chars(i)
856          enddo
857          do i=ls+1,ls+lc
858              ss(i) = c(i-ls:i-ls)
859          enddo
860          deallocate(s%chars)
861
862          s%chars => ss
863
864          s%len = ls + lc
865          s%size = s%len
866      else
867          do i=ls+1,ls+lc
868              s%chars(i) = c(i-ls:i-ls)
869          enddo
870          s%len = ls + lc
871      endif
872
873      end subroutine append_to_string_c
874
875!*******************************************************************************
876!     INSERT_IN_STRING
877!*******************************************************************************
878
879      pure subroutine insert_in_string_s(s1,start,s2)
880
881      implicit none
882      type(string), intent(inout)  :: s1
883      type(string), intent(in)     :: s2
884      integer, intent(in)          :: start
885      integer                      :: i,ip,is,ls1,ls2
886
887      character, pointer           :: ss(:)
888
889
890      ls1 = len(s1)
891      ls2 = len(s2)
892      if (ls2 == 0) return
893      if (ls1+ls2 > string_size(s1)) then
894          allocate(ss(ls1+ls2))
895          is = max(start,1)
896          ip = min(ls1+1,is)
897          do i=1,ip-1
898              ss(i) = s1%chars(i)
899          enddo
900          do i=ip,ip+ls2-1
901              ss(i) = s2%chars(i-ip+1)
902          enddo
903          do i=ip+ls2,ls1+ls2
904              ss(i) = s1%chars(i-ls2)
905          enddo
906          deallocate(s1%chars)
907
908          s1%chars => ss
909
910          s1%len = ls1 + ls2
911          s1%size = s1%len
912      else
913          is = max(start,1)
914          ip = min(ls1+1,is)
915          do i=ls1+ls2,ip+ls2,-1
916              s1%chars(i) = s1%chars(i-ls2)
917          enddo
918          do i=ip,ip+ls2-1
919              s1%chars(i) = s2%chars(i-ip+1)
920          enddo
921          s1%len = ls1 + ls2
922      endif
923
924      end subroutine insert_in_string_s
925
926!*******************************************************************************
927
928      pure subroutine insert_in_string_c(s,start,c)
929
930      implicit none
931      type(string), intent(inout)  :: s
932      character(*), intent(in)     :: c
933      integer, intent(in)          :: start
934      integer                      :: i,ip,is,ls,lc
935
936      character, pointer           :: ss(:)
937
938
939
940      ls = len(s)
941      lc = len(c)
942      if (lc == 0) return
943      if (ls+lc > string_size(s)) then
944          allocate(ss(ls+lc))
945          is = max(start,1)
946          ip = min(ls+1,is)
947          do i=1,ip-1
948              ss(i) = s%chars(i)
949          enddo
950          do i=ip,ip+lc-1
951              ss(i) = c(i-ip+1:i-ip+1)
952          enddo
953          do i=ip+lc,ls+lc
954              ss(i) = s%chars(i-lc)
955          enddo
956          deallocate(s%chars)
957
958          s%chars => ss
959
960          s%len = ls + lc
961          s%size = s%len
962      else
963          is = max(start,1)
964          ip = min(ls+1,is)
965          do i=ls+lc,ip+lc,-1
966              s%chars(i) = s%chars(i-lc)
967          enddo
968          do i=ip,ip+lc-1
969              s%chars(i) = c(i-ip+1:i-ip+1)
970          enddo
971          s%len = ls + lc
972      endif
973
974      end subroutine insert_in_string_c
975
976!*******************************************************************************
977!     REPLACE_IN_STRING
978!*******************************************************************************
979!     pure subroutine replace_in_string_ss_s(s,start,ss)
980!
981!     implicit none
982!     type(string), intent(inout)  :: s
983!     type(string), intent(in)     :: ss
984!     integer, intent(in)          :: start
985!
986!
987!     call replace_in_string_sc_s(s,start,char(ss))
988!
989!     end subroutine replace_in_string_ss_s
990!*******************************************************************************
991
992!*******************************************************************************
993
994      pure subroutine replace_in_string_ss_s(s,start,ss)
995
996      implicit none
997      type(string), intent(inout)  :: s
998      type(string), intent(in)     :: ss
999      integer, intent(in)          :: start
1000      integer                      :: i,ip,is,lr,lss,ls
1001      character, pointer           :: rs(:)
1002      logical                      :: new
1003
1004
1005      lr = lr_ss_s(s,start,ss)
1006      lss = len(ss)
1007      ls = len(s)
1008      is = max(start,1)
1009      ip = min(ls+1,is)
1010
1011      new = lr > string_size(s)
1012
1013      if (new) then
1014          allocate(rs(lr))
1015      else
1016          rs => s%chars
1017      endif
1018
1019      do i=lr,ip+lss,-1
1020          rs(i) = s%chars(i)
1021      enddo
1022      do i=lss,1,-1
1023          rs(ip-1+i) = ss%chars(i)
1024      enddo
1025      if (new) then
1026          do i=1,ip-1
1027              rs(i) = s%chars(i)
1028          enddo
1029      endif
1030
1031      if (new) then
1032          deallocate(s%chars)
1033          s%chars => rs
1034          s%size = lr
1035      else
1036          nullify(rs)
1037      endif
1038      s%len = lr
1039
1040      end subroutine replace_in_string_ss_s
1041
1042!*******************************************************************************
1043!     pure subroutine replace_in_string_ss_sf(s,start,finish,ss)
1044!
1045!     implicit none
1046!     type(string), intent(inout)  :: s
1047!     type(string), intent(in)     :: ss
1048!     integer, intent(in)          :: start,finish
1049!
1050!
1051!     call replace_in_string_sc_sf(s,start,finish,char(ss))
1052!
1053!     end subroutine replace_in_string_ss_sf
1054!*******************************************************************************
1055
1056!*******************************************************************************
1057
1058      pure subroutine replace_in_string_ss_sf(s,start,finish,ss)
1059
1060      implicit none
1061      type(string), intent(inout)  :: s
1062      type(string), intent(in)     :: ss
1063      integer, intent(in)          :: start,finish
1064      integer                      :: i,if,ip,is,lr,ls,lss
1065      character, pointer           :: rs(:)
1066      logical                      :: new
1067
1068
1069      lr = lr_ss_sf(s,start,finish,ss)
1070      lss = len(ss)
1071      ls = len(s)
1072      is = max(start,1)
1073      ip = min(ls+1,is)
1074      if = max(ip-1,min(finish,ls))
1075
1076      new = lr > string_size(s)
1077
1078      if (new) then
1079          allocate(rs(lr))
1080      else
1081          rs => s%chars
1082      endif
1083
1084      do i=1,lr-ip-lss+1
1085          rs(i+ip+lss-1) = s%chars(if+i)
1086      enddo
1087      do i=lss,1,-1
1088          rs(i+ip-1) = ss%chars(i)
1089      enddo
1090      if (new) then
1091          do i=1,ip-1
1092              rs(i) = s%chars(i)
1093          enddo
1094      endif
1095
1096      if (new) then
1097          deallocate(s%chars)
1098          s%chars => rs
1099          s%size = lr
1100      else
1101          nullify(rs)
1102      endif
1103      s%len = lr
1104
1105      end subroutine replace_in_string_ss_sf
1106
1107!*******************************************************************************
1108
1109!*******************************************************************************
1110
1111      pure subroutine replace_in_string_sc_s(s,start,c)
1112
1113      implicit none
1114      type(string), intent(inout)  :: s
1115      character(*), intent(in)     :: c
1116      integer, intent(in)          :: start
1117      integer                      :: i,ip,is,lc,lr,ls
1118      character, pointer           :: rs(:)
1119      logical                      :: new
1120
1121
1122      lr = lr_sc_s(s,start,c)
1123      lc = len(c)
1124      ls = len(s)
1125      is = max(start,1)
1126      ip = min(ls+1,is)
1127
1128      new = lr > string_size(s)
1129
1130      if (new) then
1131          allocate(rs(lr))
1132      else
1133          rs => s%chars
1134      endif
1135
1136      do i=lr,ip+lc,-1
1137          rs(i) = s%chars(i)
1138      enddo
1139      do i=lc,1,-1
1140          rs(ip-1+i) = c(i:i)
1141      enddo
1142      if (new) then
1143          do i=1,ip-1
1144              rs(i) = s%chars(i)
1145          enddo
1146      endif
1147
1148      if (new) then
1149          deallocate(s%chars)
1150          s%chars => rs
1151          s%size = lr
1152      else
1153          nullify(rs)
1154      endif
1155      s%len = lr
1156
1157      end subroutine replace_in_string_sc_s
1158
1159!*******************************************************************************
1160
1161!*******************************************************************************
1162
1163      pure subroutine replace_in_string_sc_sf(s,start,finish,c)
1164
1165      implicit none
1166      type(string), intent(inout)  :: s
1167      character(*), intent(in)     :: c
1168      integer, intent(in)          :: start,finish
1169      integer                      :: i,if,ip,is,lc,lr,ls
1170      character, pointer           :: rs(:)
1171      logical                      :: new
1172
1173
1174      lr = lr_sc_sf(s,start,finish,c)
1175      lc = len(c)
1176      ls = len(s)
1177      is = max(start,1)
1178      ip = min(ls+1,is)
1179      if = max(ip-1,min(finish,ls))
1180
1181      new = lr > string_size(s)
1182
1183      if (new) then
1184          allocate(rs(lr))
1185      else
1186          rs => s%chars
1187      endif
1188
1189      do i=1,lr-ip-lc+1
1190          rs(i+ip+lc-1) = s%chars(if+i)
1191      enddo
1192      do i=lc,1,-1
1193          rs(i+ip-1) = c(i:i)
1194      enddo
1195      if (new) then
1196          do i=1,ip-1
1197              rs(i) = s%chars(i)
1198          enddo
1199      endif
1200
1201      if (new) then
1202          deallocate(s%chars)
1203          s%chars => rs
1204          s%size = lr
1205      else
1206          nullify(rs)
1207      endif
1208      s%len = lr
1209
1210      end subroutine replace_in_string_sc_sf
1211
1212!*******************************************************************************
1213!*******************************************************************************
1214!*******************************************************************************
1215
1216      pure subroutine replace_in_string_scc(s,target,ss)
1217
1218      implicit none
1219      type(string), intent(inout)  :: s
1220      character(*), intent(in)     :: target,ss
1221
1222
1223      call x_replace_in_string_scc(s,target,ss,'first')
1224
1225
1226      end subroutine replace_in_string_scc
1227
1228!*******************************************************************************
1229
1230      pure subroutine replace_in_string_scc_f(s,target,ss,action)
1231
1232      implicit none
1233      type(string), intent(inout)  :: s
1234      character(*), intent(in)     :: target,ss,action
1235
1236
1237      call x_replace_in_string_scc(s,target,ss,action)
1238
1239      end subroutine replace_in_string_scc_f
1240
1241!*******************************************************************************
1242
1243      pure subroutine x_replace_in_string_scc(s,target,ss,action)
1244
1245      implicit none
1246      type(string), intent(inout)  :: s
1247      character(*), intent(in)     :: target,ss,action
1248      logical                      :: every,back
1249      integer                      :: lr,ls,lt,lss
1250      integer                      :: i,i1,i2,k1,k2,m1,m2
1251
1252      character, pointer           :: rs(:)
1253
1254
1255
1256      lr = lr_scc(s,target,ss,action)
1257      ls = len(s)
1258      lt = len(target)
1259      lss = len(ss)
1260
1261      if (lt == 0) then
1262          if (ls == 0) then
1263              do i=1,lss
1264                  s%chars(i) = ss(i:i)
1265              enddo
1266              s%len = lss
1267          endif
1268          return
1269      endif
1270
1271      select case(uppercase(action))
1272      case('FIRST')
1273          back = .false.
1274          every = .false.
1275      case('LAST')
1276          back = .true.
1277          every = .false.
1278      case('ALL')
1279          back = .false.
1280          every = .true.
1281      case default
1282          back = .false.
1283          every = .false.
1284      end select
1285
1286      allocate(rs(lr))
1287
1288      if (back) then
1289!         Backwards search
1290
1291!         k2 points to the absolute position one before the target in string
1292          k2 = ls
1293          m2 = lr
1294          do
1295!             find the next occurrence of target
1296              i1 = aindex(s%chars(:k2),target,back)
1297              if (i1 == 0) then
1298!                 fill up to the end
1299                  rs(:m2) = s%chars(:k2)
1300                  exit
1301              endif
1302!             i1 points to the absolute position of the first
1303!             letter of target in string
1304!             i2 points to the absolute position of the last
1305!             letter of target in string
1306              i2 = i1 + lt - 1
1307
1308!             copy the unaffected text string chunk after it
1309!             k1 points to the absolute position one after target in string
1310              k1 = i2 + 1
1311              m1 = m2 + k1 - k2
1312              rs(m1:m2) = s%chars(k1:k2)
1313              m2 = m1 - 1
1314              m1 = m2 - lss + 1
1315!             copy the replacement substring for target
1316              do i=1,lss
1317                  rs(m1+i-1) = ss(i:i)
1318              enddo
1319
1320!             k2 points to the absolute position one before the target in string
1321              k2 = i1 - 1
1322              m2 = m1 - 1
1323              if (.not.every) then
1324                  rs(:m2) = s%chars(:k2)
1325                  exit
1326              endif
1327          enddo
1328      else
1329!         Forward search
1330
1331!         k1 points to the absolute position one after target in string
1332          k1 = 1
1333          m1 = 1
1334          do
1335!             find the next occurrence of target
1336              i1 = aindex(s%chars(k1:),target)
1337              if (i1 == 0) then
1338!                 fill up to the end
1339                  rs(m1:lr) = s%chars(k1:ls)
1340                  exit
1341              endif
1342!             i1 points to the absolute position of the first
1343!             letter of target in string
1344              i1 = k1 + (i1 - 1)
1345!             i2 points to the absolute position of the last
1346!             letter of target in string
1347              i2 = i1 + lt - 1
1348
1349!             copy the unaffected text string chunk before it
1350!             k2 points to the absolute position one before the target in string
1351              k2 = i1 - 1
1352              m2 = m1 + k2 - k1
1353              rs(m1:m2) = s%chars(k1:k2)
1354              m1 = m2 + 1
1355              m2 = m1 + lss - 1
1356!             copy the replacement substring for target
1357              do i=1,lss
1358                  rs(m1+i-1) = ss(i:i)
1359              enddo
1360
1361!             k1 points to the absolute position one after target in string
1362              k1 = i2 + 1
1363              m1 = m2 + 1
1364              if (.not.every) then
1365                  rs(m1:lr) = s%chars(k1:ls)
1366                  exit
1367              endif
1368          enddo
1369      endif
1370
1371
1372      if (associated(s%chars)) deallocate(s%chars)
1373      s%chars => rs
1374
1375      s%len = lr
1376      s%size = size(s%chars)
1377
1378      end subroutine x_replace_in_string_scc
1379
1380!*******************************************************************************
1381
1382      pure subroutine replace_in_string_ssc(s,target,ss)
1383
1384      implicit none
1385      type(string), intent(inout)  :: s
1386      type(string), intent(in)     :: target
1387      character(*), intent(in)     :: ss
1388
1389
1390      call x_replace_in_string_scc(s,char(target),ss,'first')
1391
1392      end subroutine replace_in_string_ssc
1393
1394!*******************************************************************************
1395
1396      pure subroutine replace_in_string_ssc_f(s,target,ss,action)
1397
1398      implicit none
1399      type(string), intent(inout)  :: s
1400      type(string), intent(in)     :: target
1401      character(*), intent(in)     :: ss,action
1402
1403
1404      call x_replace_in_string_scc(s,char(target),ss,action)
1405
1406      end subroutine replace_in_string_ssc_f
1407
1408!*******************************************************************************
1409
1410      pure subroutine replace_in_string_scs(s,target,ss)
1411
1412      implicit none
1413      type(string), intent(inout)  :: s
1414      type(string), intent(in)     :: ss
1415      character(*), intent(in)     :: target
1416
1417
1418      call x_replace_in_string_scc(s,target,char(ss),'first')
1419
1420      end subroutine replace_in_string_scs
1421
1422!*******************************************************************************
1423
1424      pure subroutine replace_in_string_scs_f(s,target,ss,action)
1425
1426      implicit none
1427      type(string), intent(inout)  :: s
1428      type(string), intent(in)     :: ss
1429      character(*), intent(in)     :: target,action
1430
1431
1432      call x_replace_in_string_scc(s,target,char(ss),action)
1433
1434      end subroutine replace_in_string_scs_f
1435
1436!*******************************************************************************
1437
1438      pure subroutine replace_in_string_sss(s,target,ss)
1439
1440      implicit none
1441      type(string), intent(inout)  :: s
1442      type(string), intent(in)     :: ss,target
1443
1444
1445      call x_replace_in_string_scc(s,char(target),char(ss),'first')
1446
1447      end subroutine replace_in_string_sss
1448
1449!*******************************************************************************
1450
1451      pure subroutine replace_in_string_sss_f(s,target,ss,action)
1452
1453      implicit none
1454      type(string), intent(inout)  :: s
1455      type(string), intent(in)     :: ss,target
1456      character(*), intent(in)     :: action
1457
1458
1459      call x_replace_in_string_scc(s,char(target),char(ss),action)
1460
1461      end subroutine replace_in_string_sss_f
1462
1463!*******************************************************************************
1464!     REMOVE_FROM_STRING
1465!*******************************************************************************
1466
1467      pure subroutine remove_from_string(s,start,finish)
1468
1469      implicit none
1470      type(string), intent(inout)                      :: s
1471      integer, intent(in)                              :: start,finish
1472      integer                                          :: i,if,is,le,ls
1473
1474
1475      is = max(1,start)
1476      ls = len(s)
1477      if = min(ls,finish)
1478      if (if < is) return
1479
1480      le = if - is + 1            ! = len_extract
1481      do i=if+1,ls
1482          s%chars(i-le) = s%chars(i)
1483      enddo
1484      s%len = s%len - le
1485
1486      end subroutine remove_from_string
1487
1488!*******************************************************************************
1489!     UNSTRING procedure
1490!*******************************************************************************
1491!     Deallocate the chars in the string to avoid leaking of memory
1492!     Use this in functions and subroutines on locally declared variables
1493!     of type string after their use. (I.e. garbage collecting).
1494
1495      elemental subroutine unstring(s)
1496
1497      implicit none
1498      type(string), intent(inout)  :: s
1499
1500
1501
1502      if (associated(s%chars)) deallocate(s%chars)
1503      nullify(s%chars)
1504
1505      s%size = 0
1506      s%len = 0
1507
1508      end subroutine unstring
1509
1510!*******************************************************************************
1511!     //
1512!*******************************************************************************
1513!     string // string
1514
1515      pure function s_concat_s(s1,s2)
1516
1517      implicit none
1518      type(string), intent(in)    :: s1,s2
1519      character(len(s1)+len(s2))  :: s_concat_s
1520      integer                     :: l1,l2
1521
1522
1523      l1 = len(s1)
1524      l2 = len(s2)
1525      s_concat_s(1:l1) = s1
1526      s_concat_s(1+l1:l1+l2) = s2
1527
1528      end function s_concat_s
1529
1530!*******************************************************************************
1531!     string // character
1532
1533      pure function s_concat_c(s,c)
1534
1535      implicit none
1536      type(string), intent(in)  :: s
1537      character(*), intent(in)  :: c
1538      character(len(s)+len(c))  :: s_concat_c
1539      integer                   :: ls,lc
1540
1541
1542      ls = len(s)
1543      lc = len(c)
1544      s_concat_c(1:ls) = s
1545      s_concat_c(1+ls:ls+lc) = c
1546
1547      end function s_concat_c
1548
1549!*******************************************************************************
1550!     character // string
1551
1552      pure function c_concat_s(c,s)
1553
1554      implicit none
1555      character(*), intent(in)  :: c
1556      type(string), intent(in)  :: s
1557      character(len(s)+len(c))  :: c_concat_s
1558      integer                   :: lc,ls
1559
1560
1561      lc = len(c)
1562      ls = len(s)
1563      c_concat_s(1:lc) = c
1564      c_concat_s(1+lc:lc+ls) = s
1565
1566      end function c_concat_s
1567
1568!*******************************************************************************
1569!     REPEAT
1570!*******************************************************************************
1571
1572      function repeat_s(s,ncopies)
1573
1574      implicit none
1575      type(string), intent(in)   :: s
1576      integer, intent(in)        :: ncopies
1577      character(ncopies*len(s))  :: repeat_s
1578
1579
1580      if (ncopies < 0) stop 'Negative ncopies requested in REPEAT'
1581      repeat_s = repeat(char(s),ncopies)
1582
1583      end function repeat_s
1584
1585!*******************************************************************************
1586!     LEN_TRIM
1587!*******************************************************************************
1588
1589      elemental function len_trim_s(s)
1590
1591      implicit none
1592      type(string), intent(in)  :: s
1593      integer                   :: len_trim_s
1594
1595      if (len(s) == 0) then
1596        len_trim_s = 0
1597        return
1598      endif
1599      do len_trim_s = len(s),1,-1
1600          if (s%chars(len_trim_s) /= blank) return
1601      end do
1602
1603      end function len_trim_s
1604
1605!*******************************************************************************
1606!     TRIM
1607!*******************************************************************************
1608
1609      pure function trim_s(s)
1610
1611      implicit none
1612      type(string), intent(in)  :: s
1613      character(len_trim(s))    :: trim_s
1614      integer                   :: i
1615
1616
1617      do i=1,len(trim_s)
1618          trim_s(i:i) = s%chars(i)
1619      enddo
1620
1621      end function trim_s
1622
1623!*******************************************************************************
1624!     IACHAR
1625!*******************************************************************************
1626! Returns the position of the character string in the ISO 646 collating
1627! sequence. String must be of length one, otherwise result is as for
1628! intrinsic iachar.
1629
1630      elemental function iachar_s(s)
1631
1632      implicit none
1633      type(string), intent(in) :: s
1634      integer                  :: iachar_s
1635
1636
1637      iachar_s = iachar(char(s))
1638
1639      end function iachar_s
1640
1641!*******************************************************************************
1642!     ICHAR
1643!*******************************************************************************
1644! Returns the position of character from string in the processor collating
1645! sequence. String must be of length one, otherwise it will behave as the
1646! intrinsic ichar with the equivalent character string.
1647
1648      elemental function ichar_s(s)
1649
1650      implicit none
1651      type(string), intent(in) ::  s
1652      integer                  ::  ichar_s
1653
1654
1655      ichar_s = ichar(char(s))
1656
1657      end function ichar_s
1658
1659!*******************************************************************************
1660!     ADJUSTL
1661!*******************************************************************************
1662! Returns as a character variable the string adjusted to the left,
1663! removing leading blanks and inserting trailing blanks.
1664
1665      pure function adjustl_s(s)
1666
1667      implicit none
1668      type(string), intent(in)  :: s
1669      character(len(s))         :: adjustl_s
1670
1671
1672      adjustl_s = adjustl(char(s))
1673
1674      end function adjustl_s
1675
1676!*******************************************************************************
1677!     ADJUSTR
1678!*******************************************************************************
1679! Returns as a character variable the string adjusted to the right,
1680! removing trailing blanks and inserting leading blanks.
1681
1682      pure function adjustr_s(s)
1683
1684      implicit none
1685      type(string), intent(in)  :: s
1686      character(len(s))         :: adjustr_s
1687
1688
1689      adjustr_s = adjustr(char(s))
1690
1691      end function adjustr_s
1692
1693!*******************************************************************************
1694!    LEN_STRIP
1695!*******************************************************************************
1696
1697     elemental function len_strip_s(s)
1698
1699     implicit none
1700     type(string), intent(in) :: s
1701     integer                  :: len_strip_s
1702     integer                  :: i1,i2
1703
1704
1705     do i1=1,len(s)
1706         if (s%chars(i1) /= blank) exit
1707     enddo
1708     do i2=len(s),1,-1
1709         if (s%chars(i2) /= blank) exit
1710     enddo
1711     len_strip_s = max(0,i2-i1+1)
1712
1713     end function len_strip_s
1714
1715!*******************************************************************************
1716!    STRIP
1717!*******************************************************************************
1718
1719     pure function strip_s(s)
1720
1721     implicit none
1722     type(string), intent(in)  :: s
1723     character(len_strip(s))   :: strip_s
1724     integer                   :: i,j
1725
1726
1727     do i=1,len(s)
1728         if (s%chars(i) /= blank) exit
1729     enddo
1730     do j=1,len(strip_s)
1731         strip_s(j:j) = s%chars(i+j-1)
1732     enddo
1733
1734     end function strip_s
1735
1736!*******************************************************************************
1737
1738     elemental function len_strip_c(c)
1739
1740     implicit none
1741     character(*), intent(in) :: c
1742     integer                  :: len_strip_c
1743     integer                  :: i1,i2
1744
1745
1746     do i1=1,len(c)
1747         if (c(i1:i1) /= blank) exit
1748     enddo
1749     i2 = len_trim(c)
1750     len_strip_c = max(0,i2-i1+1)
1751
1752     end function len_strip_c
1753
1754!*******************************************************************************
1755
1756     pure function strip_c(c)
1757
1758     implicit none
1759     character(*), intent(in)  :: c
1760     character(len_strip(c))   :: strip_c
1761     integer                   :: i
1762
1763
1764     do i=1,len(c)
1765         if (c(i:i) /= blank) exit
1766     enddo
1767     strip_c(1:) = c(i:)
1768
1769     end function strip_c
1770
1771!*******************************************************************************
1772!     EXTRACT
1773!*******************************************************************************
1774      elemental FUNCTION len_extract_s(s,start,finish)
1775
1776      implicit none
1777      type(string), intent(in)  :: s
1778      integer, intent(in)       :: start,finish
1779      integer                   :: len_extract_s
1780      integer                   :: is,if
1781
1782
1783      is = max(1,start)
1784      if = min(len(s),finish)
1785      if (if < is) then
1786          len_extract_s = 0
1787      else
1788          len_extract_s = max(0,if-is) + 1
1789      endif
1790
1791      end function len_extract_s
1792
1793!*****************************************************
1794      pure function extract_s(s,start,finish)
1795
1796      implicit none
1797      type(string), intent(in)                  :: s
1798      integer, intent(in)                       :: start,finish
1799      character(len_extract_s(s,start,finish))  :: extract_s
1800      integer                                   :: i,is,if
1801
1802
1803      is = max(1,start)
1804      if = min(len(s),finish)
1805      if (if < is) then
1806          extract_s = ''
1807      else
1808          do i=1,max(0,if-is+1)
1809              extract_s(i:i) = s%chars(is+i-1)
1810          enddo
1811      endif
1812
1813      end function extract_s
1814
1815!*******************************************************************************
1816
1817!      elemental FUNCTION len_extract_s(s,start,finish)
1818
1819!      implicit none
1820!      type(string), intent(in)  :: s
1821!      integer, intent(in)       :: start,finish
1822!      integer                   :: len_extract_s
1823!      integer                   :: is,if
1824
1825
1826!      is = max(1,start)
1827!      if = min(len(s),finish)
1828!      if (if < is) then
1829!          len_extract_s = 0
1830!      else
1831!          len_extract_s = max(0,if-is) + 1
1832!      endif
1833
1834!      end function len_extract_s
1835
1836!*******************************************************************************
1837
1838      elemental function len_extract_c(c,start,finish)
1839
1840      implicit none
1841      character(*), intent(in)  :: c
1842      integer, intent(in)       :: start,finish
1843      integer                   :: len_extract_c
1844      integer                   :: is,if
1845
1846
1847      is = max(1,start)
1848      if = min(len(c),finish)
1849      if (if < is) then
1850          len_extract_c = 0
1851      else
1852          len_extract_c = max(0,if-is) + 1
1853      endif
1854
1855      end function len_extract_c
1856
1857!*******************************************************************************
1858
1859      pure function extract_c(c,start,finish)
1860
1861      implicit none
1862      character(*), intent(in)                  :: c
1863      integer, intent(in)                       :: start,finish
1864      character(len_extract_c(c,start,finish))  :: extract_c
1865      integer                                   :: is,if
1866
1867
1868      is = max(1,start)
1869      if = min(len(c),finish)
1870      if (if < is) then
1871          extract_c = ''
1872      else
1873          extract_c(1:if-is+1) = c(is:if)
1874      endif
1875
1876      end function extract_c
1877
1878!*******************************************************************************
1879
1880!      elemental function len_extract_c(c,start,finish)
1881
1882!      implicit none
1883!      character(*), intent(in)  :: c
1884!      integer, intent(in)       :: start,finish
1885!      integer                   :: len_extract_c
1886!      integer                   :: is,if
1887
1888
1889!      is = max(1,start)
1890!      if = min(len(c),finish)
1891!      if (if < is) then
1892!          len_extract_c = 0
1893!      else
1894!          len_extract_c = max(0,if-is) + 1
1895!      endif
1896
1897!      end function len_extract_c
1898
1899!*******************************************************************************
1900!     INSERT
1901!*******************************************************************************
1902
1903      pure function insert_ss(s1,start,s2)
1904
1905      implicit none
1906      type(string), intent(in)    :: s1,s2
1907      integer, intent(in)         :: start
1908      character(len(s1)+len(s2))  :: insert_ss
1909      integer                     :: i,ip,is,ls1,ls2
1910
1911
1912      ls1 = len(s1)
1913      ls2 = len(s2)
1914      is = max(start,1)
1915      ip = min(ls1+1,is)
1916      do i=1,ip-1
1917          insert_ss(i:i) = s1%chars(i)
1918      enddo
1919      do i=ip,ip+ls2-1
1920          insert_ss(i:i) = s2%chars(i-ip+1)
1921      enddo
1922      do i=ip+ls2,ls1+ls2
1923          insert_ss(i:i) = s1%chars(i-ls2)
1924      enddo
1925
1926      end function insert_ss
1927
1928!*******************************************************************************
1929
1930      pure function insert_sc(s1,start,c2)
1931
1932      implicit none
1933      type(string), intent(in)    :: s1
1934      character(*), intent(in)    :: c2
1935      integer, intent(in)         :: start
1936      character(len(s1)+len(c2))  :: insert_sc
1937      integer                     :: i,ip,is,ls1,ls2
1938
1939
1940      ls1 = len(s1)
1941      ls2 = len(c2)
1942      is = max(start,1)
1943      ip = min(ls1+1,is)
1944      do i=1,ip-1
1945          insert_sc(i:i) = s1%chars(i)
1946      enddo
1947      insert_sc(ip:ip+ls2-1) = c2
1948      do i=ip+ls2,ls1+ls2
1949          insert_sc(i:i) = s1%chars(i-ls2)
1950      enddo
1951
1952      end function insert_sc
1953
1954!*******************************************************************************
1955
1956      pure function insert_cs(c1,start,s2)
1957
1958      implicit none
1959      character(*), intent(in)    :: c1
1960      type(string), intent(in)    :: s2
1961      integer, intent(in)         :: start
1962      character(len(c1)+len(s2))  :: insert_cs
1963      integer                     :: i,ip,is,ls1,ls2
1964
1965
1966      ls1 = len(c1)
1967      ls2 = len(s2)
1968      is = max(start,1)
1969      ip = min(ls1+1,is)
1970      insert_cs(1:ip-1) = c1(1:ip-1)
1971      do i=ip,ip+ls2-1
1972          insert_cs(i:i) = s2%chars(i-ip+1)
1973      enddo
1974      insert_cs(ip+ls2:ls1+ls2) = c1(ip:ls1)
1975
1976      end function insert_cs
1977
1978!*******************************************************************************
1979
1980      pure function insert_cc(c1,start,c2)
1981
1982      implicit none
1983      character(*), intent(in)    :: c1,c2
1984      integer, intent(in)         :: start
1985      character(len(c1)+len(c2))  :: insert_cc
1986      integer                     :: ip,is,ls1,ls2
1987
1988
1989      ls1 = len(c1)
1990      ls2 = len(c2)
1991      is = max(start,1)
1992      ip = min(ls1+1,is)
1993      insert_cc(1:ip-1) = c1(1:ip-1)
1994      insert_cc(ip:ip+ls2-1) = c2
1995      insert_cc(ip+ls2:ls1+ls2) = c1(ip:ls1)
1996
1997      end function insert_cc
1998
1999!*******************************************************************************
2000!     REMOVE
2001!*******************************************************************************
2002
2003      pure function remove_c(c,start,finish)
2004
2005      implicit none
2006      character(*), intent(in)                         :: c
2007      integer, intent(in)                              :: start,finish
2008      character(len(c)-len_extract_c(c,start,finish))  :: remove_c
2009      integer                                          :: if,is,ls
2010
2011
2012      is = max(1,start)
2013      ls = len(c)
2014      if = min(ls,finish)
2015      if (if < is) then
2016          remove_c = c
2017      else
2018          remove_c = c(1:is-1) // c(if+1:)
2019      endif
2020
2021      end function remove_c
2022
2023!*******************************************************************************
2024
2025      pure function remove_s(s,start,finish)
2026
2027      implicit none
2028      type(string), intent(in)                         :: s
2029      integer, intent(in)                              :: start,finish
2030      character(len(s)-len_extract_s(s,start,finish))  :: remove_s
2031      integer                                          :: i,if,is,le,ls
2032
2033
2034      is = max(1,start)
2035      ls = len(s)
2036      if = min(ls,finish)
2037      if (if < is) then
2038           remove_s = s
2039      else
2040          le = if - is + 1
2041          do i=1,is-1
2042              remove_s(i:i) = s%chars(i)
2043          enddo
2044          do i=if+1,ls
2045              remove_s(i-le:i-le) = s%chars(i)
2046          enddo
2047      endif
2048
2049      end function remove_s
2050
2051!*******************************************************************************
2052!     REPLACE
2053!*******************************************************************************
2054
2055      pure function lr_cc_s(s,start,ss) result(l)
2056
2057      implicit none
2058      character(*), intent(in)  :: s,ss
2059      integer, intent(in)       :: start
2060      integer                   :: l
2061      integer                   :: ip,is,ls,lss
2062
2063
2064      l = max(len(s),min(len(s)+1,max(start,1)+len(ss)-1))
2065
2066      end function lr_cc_s
2067
2068!*******************************************************************************
2069!  Calculate the result string by the following actions:
2070!  Insert the characters from substring SS into string STR beginning
2071!  at position START replacing the following LEN(SUBSTRING) characters of
2072!  the string and enlarging string if necessary. If START is greater than
2073!  LEN(STRING) substring is simply appended to string by concatenation.
2074!  If START is less than 1, substring replaces characters in string
2075!  starting at 1
2076
2077      function replace_cc_s(s,start,ss) result(r)
2078
2079      implicit none
2080      character(*), intent(in)        :: s,ss
2081      integer, intent(in)             :: start
2082      character(lr_cc_s(s,start,ss))  :: r
2083      integer                         :: ip,is,l,lss,ls
2084
2085
2086      lss = len(ss)
2087      ls = len(s)
2088      is = max(start,1)
2089      ip = min(ls+1,is)
2090      l = len(r)
2091
2092      r(1:ip-1) = s(1:ip-1)
2093      r(ip:ip+lss-1) = ss
2094      r(ip+lss:l) = s(ip+lss:ls)
2095
2096      end function replace_cc_s
2097
2098!*******************************************************************************
2099
2100      pure function lr_cc_sf(s,start,finish,ss) result(l)
2101
2102      implicit none
2103      character(*), intent(in)  :: s,ss
2104      integer, intent(in)       :: start,finish
2105      integer                   :: l
2106      integer                   :: if,ip,is,ls,lss
2107
2108
2109      lss = len(ss)
2110      ls = len(s)
2111      is = max(start,1)
2112      ip = min(ls+1,is)
2113      if = max(ip-1,min(finish,ls))
2114      l = lss + ls - if+ip-1
2115
2116      end function lr_cc_sf
2117
2118!*******************************************************************************
2119!  Calculates the result string by the following actions:
2120!  Insert the substring SS into string STR beginning at position
2121!  START replacing the following FINISH-START+1 characters of the string
2122!  and enlarging or shrinking the string if necessary.
2123!  If start is greater than LEN(STRING) substring is simply appended to
2124!  string by concatenation. If START is less than 1, START = 1 is used.
2125!  If FINISH is greater than LEN(STRING), FINISH = LEN(STRING) is used.
2126!  If FINISH is less than START, substring is inserted before START.
2127
2128      function replace_cc_sf(s,start,finish,ss) result(r)
2129
2130      implicit none
2131      character(*), intent(in)                :: s,ss
2132      integer, intent(in)                     :: start,finish
2133      character(lr_cc_sf(s,start,finish,ss))  :: r
2134      integer                                 :: i,if,ip,is,l,ls,lss
2135
2136
2137      lss = len(ss)
2138      ls = len(s)
2139      is = max(start,1)
2140      ip = min(ls+1,is)
2141      if = max(ip-1,min(finish,ls))
2142      l = len(r)
2143
2144      r(1:ip-1) = s(1:ip-1)
2145      do i=1,lss
2146          r(i+ip-1:i+ip-1) = ss(i:i)
2147      enddo
2148      do i=1,l-ip-lss+1
2149          r(i+ip+lss-1:i+ip+lss-1) = s(if+i:if+i)
2150      enddo
2151
2152      end function replace_cc_sf
2153
2154!*******************************************************************************
2155
2156      pure function lr_cs_s(s,start,ss) result(l)
2157
2158      implicit none
2159      character(*), intent(in)  :: s
2160      type(string), intent(in)  :: ss
2161      integer, intent(in)       :: start
2162      integer                   :: l
2163      integer                   :: ip,is,ls,lss
2164
2165
2166      l = max(len(s),min(len(s)+1,max(start,1)+len(ss)-1))
2167
2168      end function lr_cs_s
2169
2170!*******************************************************************************
2171!  Calculate the result string by the following actions:
2172!  Insert the characters from substring SS into string STR beginning
2173!  at position START replacing the following LEN(SUBSTRING) characters of
2174!  the string and enlarging string if necessary. If START is greater than
2175!  LEN(STRING) substring is simply appended to string by concatenation.
2176!  If START is less than 1, substring replaces characters in string
2177!  starting at 1
2178
2179      function replace_cs_s(s,start,ss) result(r)
2180
2181      implicit none
2182      character(*), intent(in)        :: s
2183      type(string), intent(in)        :: ss
2184      integer, intent(in)             :: start
2185      character(lr_cs_s(s,start,ss))  :: r
2186      integer                         :: i,ip,is,l,lss,ls
2187
2188
2189      lss = len(ss)
2190      ls = len(s)
2191      is = max(start,1)
2192      ip = min(ls+1,is)
2193      l = len(r)
2194
2195      r(1:ip-1) = s(1:ip-1)
2196      r(ip:ip+lss-1) = transfer(ss%chars(1:lss),r(1:lss))
2197      r(ip+lss:l) = s(ip+lss:ls)
2198
2199      end function replace_cs_s
2200
2201!*******************************************************************************
2202
2203      pure function lr_cs_sf(s,start,finish,ss) result(l)
2204
2205      implicit none
2206      character(*), intent(in)  :: s
2207      type(string), intent(in)  :: ss
2208      integer, intent(in)       :: start,finish
2209      integer                   :: l
2210      integer                   :: if,ip,is,ls,lss
2211
2212
2213      lss = len(ss)
2214      ls = len(s)
2215      is = max(start,1)
2216      ip = min(ls+1,is)
2217      if = max(ip-1,min(finish,ls))
2218      l = lss + ls - if+ip-1
2219
2220      end function lr_cs_sf
2221
2222!*******************************************************************************
2223!  Calculates the result string by the following actions:
2224!  Insert the substring SS into string STR beginning at position
2225!  START replacing the following FINISH-START+1 characters of the string
2226!  and enlarging or shrinking the string if necessary.
2227!  If start is greater than LEN(STRING) substring is simply appended to
2228!  string by concatenation. If START is less than 1, START = 1 is used.
2229!  If FINISH is greater than LEN(STRING), FINISH = LEN(STRING) is used.
2230!  If FINISH is less than START, substring is inserted before START.
2231
2232      function replace_cs_sf(s,start,finish,ss) result(r)
2233
2234      implicit none
2235      character(*), intent(in)                :: s
2236      type(string), intent(in)                :: ss
2237      integer, intent(in)                     :: start,finish
2238      character(lr_cs_sf(s,start,finish,ss))  :: r
2239      integer                                 :: i,if,ip,is,l,ls,lss
2240
2241
2242      lss = len(ss)
2243      ls = len(s)
2244      is = max(start,1)
2245      ip = min(ls+1,is)
2246      if = max(ip-1,min(finish,ls))
2247      l = len(r)
2248
2249      r(1:ip-1) = s(1:ip-1)
2250
2251      r(i+ip:i+ip+lss-1) = transfer(ss%chars(1:lss),r(1:lss))
2252
2253      do i=1,lss
2254          r(i+ip-1:i+ip-1) = ss%chars(i)
2255      enddo
2256
2257      do i=1,l-ip-lss+1
2258          r(i+ip+lss-1:i+ip+lss-1) = s(if+i:if+i)
2259      enddo
2260
2261      end function replace_cs_sf
2262
2263!*******************************************************************************
2264
2265      pure function lr_sc_s(s,start,ss) result(l)
2266
2267      implicit none
2268      type(string), intent(in)  :: s
2269      character(*), intent(in)  :: ss
2270      integer, intent(in)       :: start
2271      integer                   :: l
2272      integer                   :: ip,is,ls,lss
2273
2274
2275      l = max(len(s),min(len(s)+1,max(start,1)+len(ss)-1))
2276
2277      end function lr_sc_s
2278
2279!*******************************************************************************
2280!  Calculate the result string by the following actions:
2281!  Insert the characters from substring SS into string STR beginning
2282!  at position START replacing the following LEN(SUBSTRING) characters of
2283!  the string and enlarging string if necessary. If START is greater than
2284!  LEN(STRING) substring is simply appended to string by concatenation.
2285!  If START is less than 1, substring replaces characters in string
2286!  starting at 1
2287
2288      function replace_sc_s(s,start,ss) result(r)
2289
2290      implicit none
2291      type(string), intent(in)        :: s
2292      character(*), intent(in)        :: ss
2293      integer, intent(in)             :: start
2294      character(lr_sc_s(s,start,ss))  :: r
2295      integer                         :: i,ip,is,l,lss,ls
2296
2297
2298      lss = len(ss)
2299      ls = len(s)
2300      is = max(start,1)
2301      ip = min(ls+1,is)
2302      l = len(r)
2303
2304      do i=1,ip-1
2305          r(i:i) = s%chars(i)
2306      enddo
2307
2308      do i=1,lss
2309          r(i+ip-1:i+ip-1) = ss(i:i)
2310      enddo
2311
2312      do i=ip+lss,l
2313          r(i:i) = s%chars(i)
2314      enddo
2315
2316      end function replace_sc_s
2317
2318!*******************************************************************************
2319
2320      pure function lr_sc_sf(s,start,finish,ss) result(l)
2321
2322      implicit none
2323      type(string), intent(in)  :: s
2324      character(*), intent(in)  :: ss
2325      integer, intent(in)       :: start,finish
2326      integer                   :: l
2327      integer                   :: if,ip,is,ls,lss
2328
2329
2330      lss = len(ss)
2331      ls = len(s)
2332      is = max(start,1)
2333      ip = min(ls+1,is)
2334      if = max(ip-1,min(finish,ls))
2335      l = lss + ls - if+ip-1
2336
2337      end function lr_sc_sf
2338
2339!*******************************************************************************
2340!  Calculates the result string by the following actions:
2341!  Insert the substring SS into string STR beginning at position
2342!  START replacing the following FINISH-START+1 characters of the string
2343!  and enlarging or shrinking the string if necessary.
2344!  If start is greater than LEN(STRING) substring is simply appended to
2345!  string by concatenation. If START is less than 1, START = 1 is used.
2346!  If FINISH is greater than LEN(STRING), FINISH = LEN(STRING) is used.
2347!  If FINISH is less than START, substring is inserted before START.
2348
2349      function replace_sc_sf(s,start,finish,ss) result(r)
2350
2351      implicit none
2352      type(string), intent(in)                :: s
2353      character(*), intent(in)                :: ss
2354      integer, intent(in)                     :: start,finish
2355      character(lr_sc_sf(s,start,finish,ss))  :: r
2356      integer                                 :: i,if,ip,is,l,ls,lss
2357
2358
2359      lss = len(ss)
2360      ls = len(s)
2361      is = max(start,1)
2362      ip = min(ls+1,is)
2363      if = max(ip-1,min(finish,ls))
2364      l = len(r)
2365
2366      do i=1,ip-1
2367          r(i:i) = s%chars(i)
2368      enddo
2369
2370      r(ip:ip+lss-1) = ss
2371
2372      do i=1,l-ip-lss+1
2373          r(i+ip+lss-1:i+ip+lss-1) = s%chars(if+i)
2374      enddo
2375
2376      end function replace_sc_sf
2377
2378!*******************************************************************************
2379
2380      pure function lr_ss_s(s,start,ss) result(l)
2381
2382      implicit none
2383      type(string), intent(in)  :: s,ss
2384      integer, intent(in)       :: start
2385      integer                   :: l
2386      integer                   :: ip,is,ls,lss
2387
2388
2389      l = max(len(s),min(len(s)+1,max(start,1)+len(ss)-1))
2390
2391      end function lr_ss_s
2392
2393!*******************************************************************************
2394!  Calculate the result string by the following actions:
2395!  Insert the characters from substring SS into string STR beginning
2396!  at position START replacing the following LEN(SUBSTRING) characters of
2397!  the string and enlarging string if necessary. If START is greater than
2398!  LEN(STRING) substring is simply appended to string by concatenation.
2399!  If START is less than 1, substring replaces characters in string
2400!  starting at 1
2401
2402      function replace_ss_s(s,start,ss) result(r)
2403
2404      implicit none
2405      type(string), intent(in)        :: s,ss
2406      integer, intent(in)             :: start
2407      character(lr_ss_s(s,start,ss))  :: r
2408      integer                         :: i,ip,is,l,lss,ls
2409
2410
2411      lss = len(ss)
2412      ls = len(s)
2413      is = max(start,1)
2414      ip = min(ls+1,is)
2415      l = len(r)
2416
2417      do i=1,ip-1
2418          r(i:i) = s%chars(i)
2419      enddo
2420
2421      do i=1,lss
2422          r(ip-1+i:ip-1+i) = ss%chars(i)
2423      enddo
2424
2425      do i=ip+lss,l
2426          r(i:i) = s%chars(i)
2427      enddo
2428
2429      end function replace_ss_s
2430
2431!*******************************************************************************
2432
2433      pure function lr_ss_sf(s,start,finish,ss) result(l)
2434
2435      implicit none
2436      type(string), intent(in)  :: s,ss
2437      integer, intent(in)       :: start,finish
2438      integer                   :: l
2439      integer                   :: if,ip,is,ls,lss
2440
2441
2442      lss = len(ss)
2443      ls = len(s)
2444      is = max(start,1)
2445      ip = min(ls+1,is)
2446      if = max(ip-1,min(finish,ls))
2447      l = lss + ls - if+ip-1
2448
2449      end function lr_ss_sf
2450
2451!*******************************************************************************
2452!  Calculates the result string by the following actions:
2453!  Insert the substring SS into string STR beginning at position
2454!  START replacing the following FINISH-START+1 characters of the string
2455!  and enlarging or shrinking the string if necessary.
2456!  If start is greater than LEN(STRING) substring is simply appended to
2457!  string by concatenation. If START is less than 1, START = 1 is used.
2458!  If FINISH is greater than LEN(STRING), FINISH = LEN(STRING) is used.
2459!  If FINISH is less than START, substring is inserted before START.
2460
2461      function replace_ss_sf(s,start,finish,ss) result(r)
2462
2463      implicit none
2464      type(string), intent(in)                :: s,ss
2465      integer, intent(in)                     :: start,finish
2466      character(lr_ss_sf(s,start,finish,ss))  :: r
2467      integer                                 :: i,if,ip,is,l,ls,lss
2468
2469
2470      lss = len(ss)
2471      ls = len(s)
2472      is = max(start,1)
2473      ip = min(ls+1,is)
2474      if = max(ip-1,min(finish,ls))
2475      l = len(r)
2476
2477      do i=1,ip-1
2478          r(i:i) = s%chars(i)
2479      enddo
2480
2481      do i=1,lss
2482          r(i+ip-1:i+ip-1) = ss%chars(i)
2483      enddo
2484
2485      do i=1,l-ip-lss+1
2486          r(i+ip+lss-1:i+ip+lss-1) = s%chars(if+i)
2487      enddo
2488
2489      end function replace_ss_sf
2490
2491!*******************************************************************************
2492
2493      pure function lr_ccc(s,target,ss,action) result(l)
2494
2495      implicit none
2496      character(*), intent(in)       :: s,target,ss,action
2497      integer                        :: l
2498      logical                        :: every,back
2499      integer                        :: ls,lt,lss,ipos,nr
2500
2501
2502      ls = len(s)
2503      lt = len(target)
2504      lss = len(ss)
2505
2506      if (lt == 0) then
2507          if (ls == 0) then
2508              l = lss
2509          else
2510              l = ls
2511          endif
2512          return
2513      endif
2514
2515      if (lt == lss) then
2516          l = ls
2517          return
2518      endif
2519
2520      select case(uppercase(action))
2521      case('FIRST')
2522          back = .false.
2523          every = .false.
2524      case('LAST')
2525          back = .true.
2526          every = .false.
2527      case('ALL')
2528          back = .false.
2529          every = .true.
2530      case default
2531          back = .false.
2532          every = .false.
2533      end select
2534
2535      nr = 0
2536      if (back) then
2537          ipos = ls
2538          do while (ipos > 0)
2539              ipos = index(s(:ipos),target,back)
2540              if (ipos == 0) exit
2541              nr = nr + 1
2542              if (.not. every) exit
2543              ipos = ipos - 1
2544          enddo
2545      else
2546          ipos = 1
2547          do while (ipos <= ls-lt+1)
2548              l = index(s(ipos:),target)
2549              if (l == 0) exit
2550              nr = nr + 1
2551              if (.not. every) exit
2552              ipos = ipos + l + 1
2553              ipos = ipos + 1
2554          enddo
2555      endif
2556      l = ls + nr*(lss-lt)
2557
2558      end function lr_ccc
2559
2560!*******************************************************************************
2561
2562      function replace_ccc(s,target,ss) result(r)
2563
2564      implicit none
2565      character(*), intent(in)                :: s,target,ss
2566      character(lr_ccc(s,target,ss,'first'))  :: r
2567
2568
2569      call x_replace_ccc(s,target,ss,'first',r)
2570
2571      end function replace_ccc
2572
2573!*******************************************************************************
2574
2575      function replace_ccc_f(s,target,ss,action) result(r)
2576
2577      implicit none
2578      character(*), intent(in)               :: s,target,ss,action
2579      character(lr_ccc(s,target,ss,action))  :: r
2580
2581
2582      call x_replace_ccc(s,target,ss,action,r)
2583
2584      end function replace_ccc_f
2585
2586!*******************************************************************************
2587!  Calculate the result string by the following actions:
2588!  Search for occurences of TARGET in string S, and replaces these with
2589!  substring SS.  If BACK present with value true search is backward otherwise
2590!  search is done forward.  If EVERY present with value true all accurences
2591!  of TARGET in S are replaced, otherwise only the first found is
2592!  replaced.  If TARGET is not found the result is the same as S.
2593
2594      subroutine x_replace_ccc(s,target,ss,action,r)
2595
2596      implicit none
2597      character(*), intent(in)               :: s,target,ss,action
2598      character(*), intent(inout)            :: r
2599      logical                                :: every,back
2600      integer                                :: lr,ls,lt,lss
2601      integer                                :: i1,i2,k1,k2,m1,m2
2602
2603
2604      lr = len(r)
2605      ls = len(s)
2606      lt = len(target)
2607      lss = len(ss)
2608
2609      if (lt == 0) then
2610          if (ls == 0) then
2611              r = ss
2612          else
2613              r = s
2614          endif
2615          return
2616      endif
2617
2618      select case(uppercase(action))
2619      case('FIRST')
2620          back = .false.
2621          every = .false.
2622      case('LAST')
2623          back = .true.
2624          every = .false.
2625      case('ALL')
2626          back = .false.
2627          every = .true.
2628      case default
2629          back = .false.
2630          every = .false.
2631      end select
2632
2633      if (back) then
2634          k2 = ls
2635          m2 = lr
2636          do
2637              i1 = index(s(:k2),target,back)
2638              if (i1 == 0) then
2639                  r(:m2) = s(:k2)
2640                  return
2641              endif
2642              i2 = i1 + lt - 1
2643              k1 = i2 + 1
2644              m1 = m2 + k1 - k2
2645              r(m1:m2) = s(k1:k2)
2646              m2 = m1 - 1
2647              m1 = m2 - lss + 1
2648              r(m1:m2) = ss
2649              k2 = i1 - 1
2650              m2 = m1 - 1
2651              if (.not. every) then
2652                  r(:m2) = s(:k2)
2653                  return
2654              endif
2655          enddo
2656      else
2657          k1 = 1
2658          m1 = 1
2659          do
2660              i1 = index(s(k1:),target)
2661              if (i1 == 0) then
2662                  r(m1:) = s(k1:)
2663                  return
2664              endif
2665              i1 = k1 + (i1 - 1)
2666              i2 = i1 + lt - 1
2667              k2 = i1 - 1
2668              m2 = m1 + k2 - k1
2669              r(m1:m2) = s(k1:k2)
2670              m1 = m2 + 1
2671              m2 = m1 + lss - 1
2672              r(m1:m2) = ss
2673              k1 = i2 + 1
2674              m1 = m2 + 1
2675              if (.not. every) then
2676                  r(m1:) = s(k1:)
2677                  return
2678              endif
2679          enddo
2680      endif
2681
2682      end subroutine x_replace_ccc
2683
2684!*******************************************************************************
2685
2686      function replace_csc(s,target,ss) result(r)
2687
2688      implicit none
2689      character(*), intent(in)                      :: s,ss
2690      type(string), intent(in)                      :: target
2691      character(lr_ccc(s,char(target),ss,'first'))  :: r
2692
2693
2694      call x_replace_ccc(s,char(target),ss,'first',r)
2695
2696      end function replace_csc
2697
2698!*******************************************************************************
2699
2700      function replace_csc_f(s,target,ss,action) result(r)
2701
2702      implicit none
2703      character(*), intent(in)                     :: s,ss,action
2704      type(string), intent(in)                     :: target
2705      character(lr_ccc(s,char(target),ss,action))  :: r
2706
2707
2708      call x_replace_ccc(s,char(target),ss,action,r)
2709
2710      end function replace_csc_f
2711
2712!*******************************************************************************
2713!*******************************************************************************
2714
2715      function replace_ccs(s,target,ss) result(r)
2716
2717      implicit none
2718      character(*), intent(in)                      :: s,target
2719      type(string), intent(in)                      :: ss
2720      character(lr_ccc(s,target,char(ss),'first'))  :: r
2721
2722
2723      call x_replace_ccc(s,target,char(ss),'first',r)
2724
2725      end function replace_ccs
2726
2727!*******************************************************************************
2728
2729      function replace_ccs_f(s,target,ss,action) result(r)
2730
2731      implicit none
2732      character(*), intent(in)                     :: s,target,action
2733      type(string), intent(in)                     :: ss
2734      character(lr_ccc(s,target,char(ss),action))  :: r
2735
2736
2737      call x_replace_ccc(s,target,char(ss),action,r)
2738
2739      end function replace_ccs_f
2740
2741!*******************************************************************************
2742!*******************************************************************************
2743
2744      function replace_css(s,target,ss) result(r)
2745
2746      implicit none
2747      character(*), intent(in)                            :: s
2748      type(string), intent(in)                            :: ss,target
2749      character(lr_ccc(s,char(target),char(ss),'first'))  :: r
2750
2751
2752      call x_replace_ccc(s,char(target),char(ss),'first',r)
2753
2754      end function replace_css
2755
2756!*******************************************************************************
2757
2758      function replace_css_f(s,target,ss,action) result(r)
2759
2760      implicit none
2761      character(*), intent(in)                           :: s,action
2762      type(string), intent(in)                           :: ss,target
2763      character(lr_ccc(s,char(target),char(ss),action))  :: r
2764
2765
2766      call x_replace_ccc(s,char(target),char(ss),action,r)
2767
2768      end function replace_css_f
2769
2770!*******************************************************************************
2771!*******************************************************************************
2772      pure function lr_scc(s,target,ss,action) result(l)
2773
2774      implicit none
2775      type(string), intent(in)       :: s
2776      character(*), intent(in)       :: target,ss,action
2777      integer                        :: l
2778      logical                        :: every,back
2779      integer                        :: ls,lt,lss,ipos,nr
2780
2781
2782      ls = len(s)
2783      lt = len(target)
2784      lss = len(ss)
2785
2786      if (lt == 0) then
2787          if (ls == 0) then
2788              l = lss
2789          else
2790              l = ls
2791          endif
2792          return
2793      endif
2794      if (lt == lss) then
2795          l = ls
2796          return
2797      endif
2798
2799      select case(uppercase(action))
2800      case('FIRST')
2801          back = .false.
2802          every = .false.
2803      case('LAST')
2804          back = .true.
2805          every = .false.
2806      case('ALL')
2807          back = .false.
2808          every = .true.
2809      case default
2810          back = .false.
2811          every = .false.
2812      end select
2813
2814      nr = 0
2815      if (back) then
2816          ipos = ls
2817          do while (ipos > 0)
2818              ipos = aindex(s%chars(:ipos),target,back)
2819              if (ipos == 0) exit
2820              nr = nr + 1
2821              if (.not. every) exit
2822              ipos = ipos - 1
2823          enddo
2824
2825      else
2826          ipos = 1
2827          do while (ipos <= ls-lt+1)
2828              l = aindex(s%chars(ipos:),target)
2829              if (l == 0) exit
2830              nr = nr + 1
2831              if (.not. every) exit
2832              ipos = ipos + l + 1
2833          enddo
2834      endif
2835      l = ls + nr*(lss-lt)
2836
2837      end function lr_scc
2838
2839!*******************************************************************************
2840
2841      function replace_scc(s,target,ss) result(r)
2842
2843      implicit none
2844      type(string), intent(in)                :: s
2845      character(*), intent(in)                :: target,ss
2846      character(lr_scc(s,target,ss,'first'))  :: r
2847
2848
2849      call x_replace_scc(s,target,ss,'first',r)
2850
2851
2852      end function replace_scc
2853
2854!*******************************************************************************
2855
2856      function replace_scc_f(s,target,ss,action) result(r)
2857
2858      implicit none
2859      type(string), intent(in)               :: s
2860      character(*), intent(in)               :: target,ss,action
2861      character(lr_scc(s,target,ss,action))  :: r
2862
2863
2864      call x_replace_scc(s,target,ss,action,r)
2865
2866      end function replace_scc_f
2867
2868!*******************************************************************************
2869!  Calculate the result string by the following actions:
2870!  Search for occurences of TARGET in string S, and replaces these with
2871!  substring SS.  If BACK present with value true search is backward otherwise
2872!  search is done forward.  If EVERY present with value true all accurences
2873!  of TARGET in S are replaced, otherwise only the first found is
2874!  replaced.  If TARGET is not found the result is the same as S.
2875
2876      subroutine x_replace_scc(s,target,ss,action,r)
2877
2878      implicit none
2879      type(string), intent(in)               :: s
2880      character(*), intent(in)               :: target,ss,action
2881      character(*), intent(inout)            :: r
2882      logical                                :: every,back
2883      integer                                :: lr,ls,lt,lss
2884      integer                                :: i1,i2,k1,k2,m1,m2
2885
2886
2887      lr = len(r)
2888      ls = len(s)
2889      lt = len(target)
2890      lss = len(ss)
2891
2892      if (lt == 0) then
2893          if (ls == 0) then
2894              r = ss
2895          else
2896              r = s
2897          endif
2898          return
2899      endif
2900
2901      select case(uppercase(action))
2902      case('FIRST')
2903          back = .false.
2904          every = .false.
2905      case('LAST')
2906          back = .true.
2907          every = .false.
2908      case('ALL')
2909          back = .false.
2910          every = .true.
2911      case default
2912          back = .false.
2913          every = .false.
2914      end select
2915
2916      if (back) then
2917          k2 = ls
2918          m2 = lr
2919          do
2920              i1 = aindex(s%chars(:k2),target,back)
2921              if (i1 == 0) then
2922                  r(:m2) = transfer(s%chars(:k2),r(:m2))
2923                  return
2924              endif
2925              i2 = i1 + lt - 1
2926              k1 = i2 + 1
2927              m1 = m2 + k1 - k2
2928              r(m1:m2) = transfer(s%chars(k1:k2),r(m1:m2))
2929              m2 = m1 - 1
2930              m1 = m2 - lss + 1
2931              r(m1:m2) = ss
2932              k2 = i1 - 1
2933              m2 = m1 - 1
2934              if (.not.every) then
2935                  r(:m2) = transfer(s%chars(:k2),r(:m2))
2936                  return
2937              endif
2938          enddo
2939      else
2940          k1 = 1
2941          m1 = 1
2942          do
2943              i1 = aindex(s%chars(k1:),target)
2944              if (i1 == 0) then
2945                  r(m1:) = transfer(s%chars(k1:),r(m1:))
2946                  return
2947              endif
2948              i1 = k1 + (i1 - 1)
2949              i2 = i1 + lt - 1
2950              k2 = i1 - 1
2951              m2 = m1 + k2 - k1
2952              r(m1:m2) = transfer(s%chars(k1:k2),r(m1:m2))
2953              m1 = m2 + 1
2954              m2 = m1 + lss - 1
2955              r(m1:m2) = ss
2956              k1 = i2 + 1
2957              m1 = m2 + 1
2958              if (.not.every) then
2959                  r(m1:) = transfer(s%chars(k1:),r(m1:))
2960                  return
2961              endif
2962          enddo
2963      endif
2964
2965      end subroutine x_replace_scc
2966
2967!*******************************************************************************
2968
2969      function replace_ssc(s,target,ss) result(r)
2970
2971      implicit none
2972      type(string), intent(in)                      :: s,target
2973      character(*), intent(in)                      :: ss
2974      character(lr_scc(s,char(target),ss,'first'))  :: r
2975
2976
2977      call x_replace_scc(s,char(target),ss,'first',r)
2978
2979
2980      end function replace_ssc
2981
2982!*******************************************************************************
2983
2984      function replace_ssc_f(s,target,ss,action) result(r)
2985
2986      implicit none
2987      type(string), intent(in)                     :: s,target
2988      character(*), intent(in)                     :: ss,action
2989      character(lr_scc(s,char(target),ss,action))  :: r
2990
2991
2992      call x_replace_scc(s,char(target),ss,action,r)
2993
2994      end function replace_ssc_f
2995
2996!*******************************************************************************
2997
2998      function replace_scs(s,target,ss) result(r)
2999
3000      implicit none
3001      type(string), intent(in)                      :: s,ss
3002      character(*), intent(in)                      :: target
3003      character(lr_scc(s,target,char(ss),'first'))  :: r
3004
3005
3006      call x_replace_scc(s,target,char(ss),'first',r)
3007
3008      end function replace_scs
3009
3010!*******************************************************************************
3011
3012      function replace_scs_f(s,target,ss,action) result(r)
3013
3014      implicit none
3015      type(string), intent(in)                     :: s,ss
3016      character(*), intent(in)                     :: target,action
3017      character(lr_scc(s,target,char(ss),action))  :: r
3018
3019
3020      call x_replace_scc(s,target,char(ss),action,r)
3021
3022      end function replace_scs_f
3023
3024!*******************************************************************************
3025
3026      function replace_sss(s,target,ss) result(r)
3027
3028      implicit none
3029      type(string), intent(in)                            :: s,ss,target
3030      character(lr_scc(s,char(target),char(ss),'first'))  :: r
3031
3032
3033      call x_replace_scc(s,char(target),char(ss),'first',r)
3034
3035      end function replace_sss
3036
3037!*******************************************************************************
3038
3039      function replace_sss_f(s,target,ss,action) result(r)
3040
3041      implicit none
3042      type(string), intent(in)                           :: s,ss,target
3043      character(*), intent(in)                           :: action
3044      character(lr_scc(s,char(target),char(ss),action))  :: r
3045
3046
3047      call x_replace_scc(s,char(target),char(ss),action,r)
3048
3049      end function replace_sss_f
3050
3051!*******************************************************************************
3052!     SORT, LSORT
3053!*******************************************************************************
3054!*******************************************************************************
3055! Sorts A into ascending order, from A(1) to A(N).
3056! Reference: Richard C. Singleton, Algorithm 347, SORT.
3057! Comm. ACM 3, 321 (March 1969).
3058! Algorithm is Copyright 1969 Association of Computing Machinery,
3059!*******************************************************************************
3060
3061      subroutine sort_c(a)
3062
3063      implicit none
3064      character(*), intent(inout)  :: a(:)
3065      character(len(a))            :: t,s
3066      integer                      :: p,i,j,k,l,m
3067      integer                      :: is(0:63)
3068
3069
3070      m = 0
3071      i = 1
3072      j = size(a)
3073
3074    5 continue
3075      if (i >= j) goto 70
3076
3077   10 continue
3078      p = (i + j)/2
3079      t = a(p)
3080      if (a(i) > t) then
3081          a(p) = a(i)
3082          a(i) = t
3083          t = a(p)
3084      endif
3085      if (a(j) < t) then
3086          a(p) = a(j)
3087          a(j) = t
3088          t = a(p)
3089          if (a(i) > t) then
3090              a(p) = a(i)
3091              a(i) = t
3092              t = a(p)
3093          endif
3094      endif
3095
3096      k = i
3097      l = j
3098      do
3099          do
3100              l = l - 1
3101              if (a(l) <= t) exit
3102          enddo
3103          s = a(l)
3104          do
3105              k = k + 1
3106              if (a(k) >= t) exit
3107          enddo
3108          if (k > l) exit
3109          a(l) = a(k)
3110          a(k) = s
3111      enddo
3112
3113      if (l-i > j-k) then
3114          is(m) = i
3115          m = m + 1
3116          is(m) = l
3117          m = m + 1
3118          i = k
3119      else
3120          is(m) = k
3121          m = m + 1
3122          is(m) = j
3123          m = m + 1
3124          j = l
3125      endif
3126      goto 80
3127
3128   70 continue
3129      if (m == 0) return
3130      m = m - 1
3131      j = is(m)
3132      m = m - 1
3133      i = is(m)
3134
3135   80 continue
3136      if (j-i >= 11) goto 10
3137      if (i == 1) goto 5
3138      i = i - 1
3139
3140      do
3141          i = i + 1
3142          if (i == j) goto 70
3143          t = a(i+1)
3144          if (a(i) <= t) cycle
3145          k = i
3146          do
3147              a(k+1) = a(k)
3148              k = k - 1
3149              if (t >= a(k)) exit
3150          enddo
3151          a(k+1) = t
3152      enddo
3153
3154      end subroutine sort_c
3155
3156!*******************************************************************************
3157! Sorts A into ascending order, from A(1) to A(N).
3158! Reference: Richard C. Singleton, Algorithm 347, SORT.
3159! Comm. ACM 3, 321 (March 1969).
3160! Algorithm is Copyright 1969 Association of Computing Machinery,
3161!*******************************************************************************
3162
3163      subroutine sort_s(a)
3164
3165      implicit none
3166      type(string), intent(inout)  :: a(:)
3167      type(string)                 :: s,t
3168      integer                      :: p,i,j,k,l,m
3169      integer                      :: is(0:63)
3170
3171
3172      m = 0
3173      i = 1
3174      j = size(a)
3175
3176    5 continue
3177      if (i >= j) goto 70
3178
3179   10 continue
3180      p = (i + j)/2
3181      call pstring(t,a(p))
3182      if (a(i) > t) then
3183          call pstring(a(p),a(i))
3184          call pstring(a(i),t)
3185          call pstring(t,a(p))
3186      endif
3187      if (a(j) < t) then
3188          call pstring(a(p),a(j))
3189          call pstring(a(j),t)
3190          call pstring(t,a(p))
3191          if (a(i) > t) then
3192              call pstring(a(p),a(i))
3193              call pstring(a(i),t)
3194              call pstring(t,a(p))
3195          endif
3196      endif
3197
3198      k = i
3199      l = j
3200      do
3201          do
3202              l = l - 1
3203              if (a(l) <= t) exit
3204          enddo
3205          call pstring(s,a(l))
3206          do
3207              k = k + 1
3208              if (a(k) >= t) exit
3209          enddo
3210          if (k > l) exit
3211          call pstring(a(l),a(k))
3212          call pstring(a(k),s)
3213      enddo
3214
3215      if (l-i > j-k) then
3216          is(m) = i
3217          m = m + 1
3218          is(m) = l
3219          m = m + 1
3220          i = k
3221      else
3222          is(m) = k
3223          m = m + 1
3224          is(m) = j
3225          m = m + 1
3226          j = l
3227      endif
3228      goto 80
3229
3230   70 continue
3231      if (m == 0) return
3232      m = m - 1
3233      j = is(m)
3234      m = m - 1
3235      i = is(m)
3236
3237   80 continue
3238      if (j-i >= 11) goto 10
3239      if (i == 1) goto 5
3240      i = i - 1
3241
3242      do
3243          i = i + 1
3244          if (i == j) goto 70
3245          call pstring(t,a(i+1))
3246          if (a(i) <= t) cycle
3247          k = i
3248          do
3249              call pstring(a(k+1),a(k))
3250              k = k - 1
3251              if (t >= a(k)) exit
3252          enddo
3253          call pstring(a(k+1),t)
3254      enddo
3255
3256      contains
3257
3258!-------------------------------------------------------------------------------
3259      subroutine pstring(p,t)
3260
3261      implicit none
3262      type(string), intent(inout)  :: p
3263      type(string), intent(in)     :: t
3264
3265
3266      p%len = t%len
3267      p%size = t%size
3268      p%chars => t%chars
3269
3270
3271      end subroutine pstring
3272!-------------------------------------------------------------------------------
3273
3274      end subroutine sort_s
3275
3276!*******************************************************************************
3277! Sorts A into ascending order, from A(1) to A(N).
3278! Reference: Richard C. Singleton, Algorithm 347, SORT.
3279! Comm. ACM 3, 321 (March 1969).
3280! Algorithm is Copyright 1969 Association of Computing Machinery,
3281! reproduced with permission.
3282!*******************************************************************************
3283
3284      subroutine lsort_c(a)
3285
3286      implicit none
3287      character(*), intent(inout)  :: a(:)
3288      character(len(a))            :: t,s
3289      integer                      :: p,i,j,k,l,m
3290      integer                      :: is(0:63)
3291
3292
3293      m = 0
3294      i = 1
3295      j = size(a)
3296
3297    5 continue
3298      if (i >= j) goto 70
3299
3300   10 continue
3301      p = (i + j)/2
3302      t = a(p)
3303      if (lgt(a(i),t)) then
3304          a(p) = a(i)
3305          a(i) = t
3306          t = a(p)
3307      endif
3308      if (llt(a(j),t)) then
3309          a(p) = a(j)
3310          a(j) = t
3311          t = a(p)
3312          if (lgt(a(i),t)) then
3313              a(p) = a(i)
3314              a(i) = t
3315              t = a(p)
3316          endif
3317      endif
3318
3319      k = i
3320      l = j
3321      do
3322          do
3323              l = l - 1
3324              if (lle(a(l),t)) exit
3325          enddo
3326          s = a(l)
3327          do
3328              k = k + 1
3329              if (lge(a(k),t)) exit
3330          enddo
3331          if (k > l) exit
3332          a(l) = a(k)
3333          a(k) = s
3334      enddo
3335
3336      if (l-i > j-k) then
3337          is(m) = i
3338          m = m + 1
3339          is(m) = l
3340          m = m + 1
3341          i = k
3342      else
3343          is(m) = k
3344          m = m + 1
3345          is(m) = j
3346          m = m + 1
3347          j = l
3348      endif
3349      goto 80
3350
3351   70 continue
3352      if (m == 0) return
3353      m = m - 1
3354      j = is(m)
3355      m = m - 1
3356      i = is(m)
3357
3358   80 continue
3359      if (j-i >= 11) goto 10
3360      if (i == 1) goto 5
3361      i = i - 1
3362
3363      do
3364          i = i + 1
3365          if (i == j) goto 70
3366          t = a(i+1)
3367          if (lle(a(i),t)) cycle
3368          k = i
3369          do
3370              a(k+1) = a(k)
3371              k = k - 1
3372              if (lge(t,a(k))) exit
3373          enddo
3374          a(k+1) = t
3375      enddo
3376
3377      end subroutine lsort_c
3378
3379!*******************************************************************************
3380! Sorts A into ascending order, from A(1) to A(N).
3381! Reference: Richard C. Singleton, Algorithm 347, SORT.
3382! Comm. ACM 3, 321 (March 1969).
3383! Algorithm is Copyright 1969 Association of Computing Machinery,
3384!*******************************************************************************
3385
3386      subroutine lsort_s(a)
3387
3388      implicit none
3389      type(string), intent(inout)  :: a(:)
3390      type(string)                 :: s,t
3391      integer                      :: p,i,j,k,l,m
3392      integer                      :: is(0:63)
3393
3394
3395      m = 0
3396      i = 1
3397      j = size(a)
3398
3399    5 continue
3400      if (i >= j) goto 70
3401
3402   10 continue
3403      p = (i + j)/2
3404      call pstring(t,a(p))
3405      if (lgt(a(i),t)) then
3406          call pstring(a(p),a(i))
3407          call pstring(a(i),t)
3408          call pstring(t,a(p))
3409      endif
3410      if (llt(a(j),t)) then
3411          call pstring(a(p),a(j))
3412          call pstring(a(j),t)
3413          call pstring(t,a(p))
3414          if (lgt(a(i),t)) then
3415              call pstring(a(p),a(i))
3416              call pstring(a(i),t)
3417              call pstring(t,a(p))
3418          endif
3419      endif
3420
3421      k = i
3422      l = j
3423      do
3424          do
3425              l = l - 1
3426              if (lle(a(l),t)) exit
3427          enddo
3428          call pstring(s,a(l))
3429          do
3430              k = k + 1
3431              if (lge(a(k),t)) exit
3432          enddo
3433          if (k > l) exit
3434          call pstring(a(l),a(k))
3435          call pstring(a(k),s)
3436      enddo
3437
3438      if (l-i > j-k) then
3439          is(m) = i
3440          m = m + 1
3441          is(m) = l
3442          m = m + 1
3443          i = k
3444      else
3445          is(m) = k
3446          m = m + 1
3447          is(m) = j
3448          m = m + 1
3449          j = l
3450      endif
3451      goto 80
3452
3453   70 continue
3454      if (m == 0) return
3455      m = m - 1
3456      j = is(m)
3457      m = m - 1
3458      i = is(m)
3459
3460   80 continue
3461      if (j-i >= 11) goto 10
3462      if (i == 1) goto 5
3463      i = i - 1
3464
3465      do
3466          i = i + 1
3467          if (i == j) goto 70
3468          call pstring(t,a(i+1))
3469          if (lle(a(i),t)) cycle
3470          k = i
3471          do
3472              call pstring(a(k+1),a(k))
3473              k = k - 1
3474              if (lge(t,a(k))) exit
3475          enddo
3476          call pstring(a(k+1),t)
3477      enddo
3478
3479      contains
3480
3481!-------------------------------------------------------------------------------
3482      subroutine pstring(p,t)
3483
3484      implicit none
3485      type(string), intent(inout)  :: p
3486      type(string), intent(in)     :: t
3487
3488
3489      p%len = t%len
3490      p%size = t%size
3491      p%chars => t%chars
3492
3493
3494      end subroutine pstring
3495!-------------------------------------------------------------------------------
3496
3497      end subroutine lsort_s
3498
3499!*******************************************************************************
3500!     RANK, LRANK
3501!*******************************************************************************
3502!*******************************************************************************
3503! Sorts A into ascending order, from A(1) to A(N).
3504! Reference: Richard C. Singleton, Algorithm 347, SORT.
3505! Comm. ACM 3, 321 (March 1969).
3506! Algorithm is Copyright 1969 Association of Computing Machinery,
3507! reproduced with permission.
3508!*******************************************************************************
3509
3510      subroutine rank_c(a,r)
3511
3512      implicit none
3513      character(*), intent(in)  :: a(:)
3514      integer, intent(out)      :: r(size(a))
3515      character(len(a))         :: t
3516      integer                   :: i,j,k,l,m,n,p,rs,rt
3517      integer                   :: is(0:63)
3518
3519
3520      n = size(a)
3521      r(:) = (/ (i, i=1,n) /)
3522      m = 0
3523      i = 1
3524      j = n
3525
3526    5 continue
3527      if (i >= j) goto 70
3528
3529   10 continue
3530      p = (j+i)/2
3531      rt = r(p)
3532      t = a(rt)
3533      if (a(r(i)) > t) then
3534          r(p) = r(i)
3535          r(i) = rt
3536          rt = r(p)
3537          t = a(rt)
3538      endif
3539      if (a(r(j)) < t) then
3540          r(p) = r(j)
3541          r(j) = rt
3542          rt = r(p)
3543          t = a(rt)
3544          if (a(r(i)) > t) then
3545              r(p) = r(i)
3546              r(i) = rt
3547              rt = r(p)
3548              t = a(rt)
3549          endif
3550      endif
3551
3552      k = i
3553      l = j
3554      do
3555          do
3556              l = l - 1
3557              if (a(r(l)) <= t) exit
3558          enddo
3559          rs = r(l)
3560          do
3561              k = k + 1
3562              if (a(r(k)) >= t) exit
3563          enddo
3564          if (k > l) exit
3565          r(l) = r(k)
3566          r(k) = rs
3567      enddo
3568
3569      if (l-i > j-k) then
3570          is(m) = i
3571          m = m + 1
3572          is(m) = l
3573          m = m + 1
3574          i = k
3575      else
3576          is(m) = k
3577          m = m + 1
3578          is(m) = j
3579          m = m + 1
3580          j = l
3581      endif
3582      goto 80
3583
3584   70 continue
3585      if (m == 0) return
3586      m = m - 1
3587      j = is(m)
3588      m = m - 1
3589      i = is(m)
3590
3591   80 continue
3592      if (j-i >= 11) goto 10
3593      if (i == 1) goto 5
3594      i = i - 1
3595
3596      do
3597          i = i + 1
3598          if (i == j) goto 70
3599          rt = r(i+1)
3600          t = a(rt)
3601          if (a(r(i)) <= t) cycle
3602          k = i
3603          do
3604              r(k+1) = r(k)
3605              k = k - 1
3606              if (t >= a(r(k))) exit
3607          enddo
3608          r(k+1) = rt
3609      enddo
3610
3611      end subroutine rank_c
3612
3613!*******************************************************************************
3614! Sorts A into ascending order, from A(1) to A(N).
3615! Reference: Richard C. Singleton, Algorithm 347, SORT.
3616! Comm. ACM 3, 321 (March 1969).
3617! Algorithm is Copyright 1969 Association of Computing Machinery,
3618!*******************************************************************************
3619
3620      subroutine rank_s(a,r)
3621
3622      implicit none
3623      type(string), intent(in)  :: a(:)
3624      integer, intent(out)      :: r(size(a))
3625      type(string)              :: t
3626      integer                   :: i,j,k,l,m,n,p,rs,rt
3627      integer                   :: is(0:63)
3628
3629
3630      n = size(a)
3631      r(:) = (/ (i, i=1,n) /)
3632      m = 0
3633      i = 1
3634      j = n
3635
3636    5 continue
3637      if (i >= j) goto 70
3638
3639   10 continue
3640      p = (j+i)/2
3641      rt = r(p)
3642      call pstring(t,a(rt))
3643      if (a(r(i)) > t) then
3644          r(p) = r(i)
3645          r(i) = rt
3646          rt = r(p)
3647          call pstring(t,a(rt))
3648      endif
3649      if (a(r(j)) < t) then
3650          r(p) = r(j)
3651          r(j) = rt
3652          rt = r(p)
3653          call pstring(t,a(rt))
3654          if (a(r(i)) > t) then
3655              r(p) = r(i)
3656              r(i) = rt
3657              rt = r(p)
3658              call pstring(t,a(rt))
3659          endif
3660      endif
3661
3662      k = i
3663      l = j
3664      do
3665          do
3666              l = l - 1
3667              if (a(r(l)) <= t) exit
3668          enddo
3669          rs = r(l)
3670          do
3671              k = k + 1
3672              if (a(r(k)) >= t) exit
3673          enddo
3674          if (k > l) exit
3675          r(l) = r(k)
3676          r(k) = rs
3677      enddo
3678
3679      if (l-i > j-k) then
3680          is(m) = i
3681          m = m + 1
3682          is(m) = l
3683          m = m + 1
3684          i = k
3685      else
3686          is(m) = k
3687          m = m + 1
3688          is(m) = j
3689          m = m + 1
3690          j = l
3691      endif
3692      goto 80
3693
3694   70 continue
3695      if (m == 0) return
3696      m = m - 1
3697      j = is(m)
3698      m = m - 1
3699      i = is(m)
3700
3701   80 continue
3702      if (j-i >= 11) goto 10
3703      if (i == 1) goto 5
3704      i = i - 1
3705
3706      do
3707          i = i + 1
3708          if (i == j) goto 70
3709          rt = r(i+1)
3710          call pstring(t,a(rt))
3711          if (a(r(i)) <= t) cycle
3712          k = i
3713          do
3714              r(k+1) = r(k)
3715              k = k - 1
3716              if (t >= a(r(k))) exit
3717          enddo
3718          r(k+1) = rt
3719      enddo
3720
3721      contains
3722
3723!-------------------------------------------------------------------------------
3724      subroutine pstring(p,t)
3725
3726      implicit none
3727      type(string), intent(inout)  :: p
3728      type(string), intent(in)     :: t
3729
3730
3731      p%len = t%len
3732      p%size = t%size
3733      p%chars => t%chars
3734
3735
3736      end subroutine pstring
3737!-------------------------------------------------------------------------------
3738
3739      end subroutine rank_s
3740
3741!*******************************************************************************
3742! Sorts A into ascending order, from A(1) to A(N).
3743! Reference: Richard C. Singleton, Algorithm 347, SORT.
3744! Comm. ACM 3, 321 (March 1969).
3745! Algorithm is Copyright 1969 Association of Computing Machinery,
3746!*******************************************************************************
3747
3748      subroutine lrank_c(a,r)
3749
3750      implicit none
3751      character(*), intent(in)  :: a(:)
3752      integer, intent(out)      :: r(size(a))
3753      character(len(a))         :: t
3754      integer                   :: i,j,k,l,m,n,p,rs,rt
3755      integer                   :: is(0:63)
3756
3757
3758      n = size(a)
3759      r(:) = (/ (i, i=1,n) /)
3760      m = 0
3761      i = 1
3762      j = n
3763
3764    5 continue
3765      if (i >= j) goto 70
3766
3767   10 continue
3768      p = (j+i)/2
3769      rt = r(p)
3770      t = a(rt)
3771      if (lgt(a(r(i)),t)) then
3772          r(p) = r(i)
3773          r(i) = rt
3774          rt = r(p)
3775          t = a(rt)
3776      endif
3777      if (llt(a(r(j)),t)) then
3778          r(p) = r(j)
3779          r(j) = rt
3780          rt = r(p)
3781          t = a(rt)
3782          if (llt(a(r(i)),t)) then
3783              r(p) = r(i)
3784              r(i) = rt
3785              rt = r(p)
3786              t = a(rt)
3787          endif
3788      endif
3789
3790      k = i
3791      l = j
3792      do
3793          do
3794              l = l - 1
3795              if (lle(a(r(l)),t)) exit
3796          enddo
3797          rs = r(l)
3798          do
3799              k = k + 1
3800              if (lge(a(r(k)),t)) exit
3801          enddo
3802          if (k > l) exit
3803          r(l) = r(k)
3804          r(k) = rs
3805      enddo
3806
3807      if (l-i > j-k) then
3808          is(m) = i
3809          m = m + 1
3810          is(m) = l
3811          m = m + 1
3812          i = k
3813      else
3814          is(m) = k
3815          m = m + 1
3816          is(m) = j
3817          m = m + 1
3818          j = l
3819      endif
3820      goto 80
3821
3822   70 continue
3823      if (m == 0) return
3824      m = m - 1
3825      j = is(m)
3826      m = m - 1
3827      i = is(m)
3828
3829   80 continue
3830      if (j-i >= 11) goto 10
3831      if (i == 1) goto 5
3832      i = i - 1
3833
3834      do
3835          i = i + 1
3836          if (i == j) goto 70
3837          rt = r(i+1)
3838          t = a(rt)
3839          if (lle(a(r(i)),t)) cycle
3840          k = i
3841          do
3842              r(k+1) = r(k)
3843              k = k - 1
3844              if (lge(t,a(r(k)))) exit
3845          enddo
3846          r(k+1) = rt
3847      enddo
3848
3849      end subroutine lrank_c
3850
3851!*******************************************************************************
3852! Sorts A into ascending order, from A(1) to A(N).
3853! Reference: Richard C. Singleton, Algorithm 347, SORT.
3854! Comm. ACM 3, 321 (March 1969).
3855! Algorithm is Copyright 1969 Association of Computing Machinery,
3856!*******************************************************************************
3857
3858      subroutine lrank_s(a,r)
3859
3860      implicit none
3861      type(string), intent(in)  :: a(:)
3862      integer, intent(out)      :: r(size(a))
3863      type(string)              :: t
3864      integer                   :: i,j,k,l,m,n,p,rs,rt
3865      integer                   :: is(0:63)
3866
3867
3868      n = size(a)
3869      r(:) = (/ (i, i=1,n) /)
3870      m = 0
3871      i = 1
3872      j = n
3873
3874    5 continue
3875      if (i >= j) goto 70
3876
3877   10 continue
3878      p = (j+i)/2
3879      rt = r(p)
3880      call pstring(t,a(rt))
3881      if (lgt(a(r(i)),t)) then
3882          r(p) = r(i)
3883          r(i) = rt
3884          rt = r(p)
3885          call pstring(t,a(rt))
3886      endif
3887      if (llt(a(r(j)),t)) then
3888          r(p) = r(j)
3889          r(j) = rt
3890          rt = r(p)
3891          call pstring(t,a(rt))
3892          if (lgt(a(r(i)),t)) then
3893              r(p) = r(i)
3894              r(i) = rt
3895              rt = r(p)
3896              call pstring(t,a(rt))
3897          endif
3898      endif
3899
3900      k = i
3901      l = j
3902      do
3903          do
3904              l = l - 1
3905              if (lle(a(r(l)),t)) exit
3906          enddo
3907          rs = r(l)
3908          do
3909              k = k + 1
3910              if (lge(a(r(k)),t)) exit
3911          enddo
3912          if (k > l) exit
3913          r(l) = r(k)
3914          r(k) = rs
3915      enddo
3916
3917      if (l-i > j-k) then
3918          is(m) = i
3919          m = m + 1
3920          is(m) = l
3921          m = m + 1
3922          i = k
3923      else
3924          is(m) = k
3925          m = m + 1
3926          is(m) = j
3927          m = m + 1
3928          j = l
3929      endif
3930      goto 80
3931
3932   70 continue
3933      if (m == 0) return
3934      m = m - 1
3935      j = is(m)
3936      m = m - 1
3937      i = is(m)
3938
3939   80 continue
3940      if (j-i >= 11) goto 10
3941      if (i == 1) goto 5
3942      i = i - 1
3943
3944      do
3945          i = i + 1
3946          if (i == j) goto 70
3947          rt = r(i+1)
3948          call pstring(t,a(rt))
3949          if (lle(a(r(i)),t)) cycle
3950          k = i
3951          do
3952              r(k+1) = r(k)
3953              k = k - 1
3954              if (lge(t,a(r(k)))) exit
3955          enddo
3956          r(k+1) = rt
3957      enddo
3958
3959      contains
3960
3961!-------------------------------------------------------------------------------
3962      subroutine pstring(p,t)
3963
3964      implicit none
3965      type(string), intent(inout)  :: p
3966      type(string), intent(in)     :: t
3967
3968
3969      p%len = t%len
3970      p%size = t%size
3971      p%chars => t%chars
3972
3973
3974      end subroutine pstring
3975!-------------------------------------------------------------------------------
3976
3977      end subroutine lrank_s
3978
3979!*******************************************************************************
3980!     COMPARE, LCOMPARE, ACOMPARE, ALCOMPARE
3981!*******************************************************************************
3982!*******************************************************************************
3983
3984      elemental function compare_ss(s1,s2) result(css)
3985
3986      implicit none
3987      type(string), intent(in)  :: s1,s2
3988      character(2)              :: css
3989      integer                   :: i,l1,l2
3990
3991
3992      l1 = len(s1)
3993      l2 = len(s2)
3994      do i=1,min(l1,l2)
3995          if (s1%chars(i) < s2%chars(i)) then
3996              css = 'LT'
3997              return
3998          elseif (s1%chars(i) > s2%chars(i)) then
3999              css = 'GT'
4000              return
4001          endif
4002      enddo
4003      if (l1 < l2) then
4004          do i=l1+1,l2
4005              if (blank < s2%chars(i)) then
4006                  css = 'LT'
4007                  return
4008              elseif (blank > s2%chars(i)) then
4009                  css = 'GT'
4010                  return
4011              endif
4012          enddo
4013      elseif (l1 > l2) then
4014          do i=l2+1,l1
4015              if (s1%chars(i) < blank) then
4016                  css = 'LT'
4017                  return
4018              elseif (s1%chars(i) > blank) then
4019                  css = 'GT'
4020                  return
4021              endif
4022          enddo
4023      endif
4024      css = 'EQ'
4025
4026      end function compare_ss
4027
4028!*******************************************************************************
4029
4030      elemental function compare_cs(c,s) result(css)
4031
4032      implicit none
4033      character(*), intent(in)  :: c
4034      type(string), intent(in)  :: s
4035      character(2)              :: css
4036      integer                   :: i,lc,ls
4037
4038
4039      lc = len(c)
4040      ls = len(s)
4041      do i=1,min(lc,ls)
4042          if (c(i:i) < s%chars(i)) then
4043              css = 'LT'
4044              return
4045          elseif (c(i:i) > s%chars(i)) then
4046              css = 'GT'
4047              return
4048          endif
4049      enddo
4050      if (lc < ls) then
4051          do i=lc+1,ls
4052              if (blank < s%chars(i)) then
4053                  css = 'LT'
4054                  return
4055              elseif (blank > s%chars(i)) then
4056                  css = 'GT'
4057                  return
4058              endif
4059          enddo
4060      elseif (lc > ls) then
4061          do i=ls+1,lc
4062              if (c(i:i) < blank) then
4063                  css = 'LT'
4064                  return
4065              elseif (c(i:i) > blank) then
4066                  css = 'GT'
4067                  return
4068              endif
4069          enddo
4070      endif
4071      css = 'EQ'
4072
4073      end function compare_cs
4074
4075!*******************************************************************************
4076!     ==
4077!*******************************************************************************
4078! string == string
4079
4080      elemental function s_eq_s(s1,s2)
4081
4082      implicit none
4083      type(string), intent(in)  :: s1,s2
4084      logical                   :: s_eq_s
4085      integer                   :: l1,l2
4086
4087
4088      l1 = len(s1)
4089      l2 = len(s2)
4090      if (l1 > l2) then
4091          s_eq_s = all(s1%chars(1:l2) == s2%chars) .and.  &
4092                   all(s1%chars(l2+1:l1) == blank)
4093      elseif (l1 < l2) then
4094          s_eq_s = all(s1%chars == s2%chars(1:l1)) .and.  &
4095                   all(blank == s2%chars(l1+1:l2))
4096      else
4097          s_eq_s = all(s1%chars == s2%chars)
4098      endif
4099
4100      end function s_eq_s
4101
4102!*******************************************************************************
4103! string == character
4104
4105      elemental function s_eq_c(s,c)
4106
4107      implicit none
4108      type(string), intent(in)  :: s
4109      character(*), intent(in)  :: c
4110      logical                   :: s_eq_c
4111      integer                   :: i,ls,lc
4112
4113
4114      ls = len(s)
4115      lc = len(c)
4116      do i=1,min(ls,lc)
4117          if (s%chars(i) /= c(i:i)) then
4118              s_eq_c = .false.
4119              return
4120          endif
4121      enddo
4122      if ((ls > lc) .and. any(s%chars(lc+1:ls) /= blank)) then
4123          s_eq_c = .false.
4124      elseif ((ls < lc) .and. (blank /= c(ls+1:lc))) then
4125          s_eq_c = .false.
4126      else
4127          s_eq_c = .true.
4128      endif
4129
4130      end function s_eq_c
4131
4132!*******************************************************************************
4133! character == string
4134
4135      elemental function c_eq_s(c,s)
4136
4137      implicit none
4138      character(*), intent(in)  :: c
4139      type(string), intent(in)  :: s
4140      logical                   :: c_eq_s
4141      integer                   :: i,lc,ls
4142
4143
4144      lc = len(c)
4145      ls = len(s)
4146      do i=1,min(lc,ls)
4147          if (c(i:i) /= s%chars(i)) then
4148              c_eq_s = .false.
4149              return
4150          endif
4151      enddo
4152      if ((lc > ls) .and. (c(ls+1:lc) /= blank)) then
4153          c_eq_s = .false.
4154      elseif ((lc < ls) .and. any(blank /= s%chars(lc+1:ls) ) )then
4155          c_eq_s = .false.
4156      else
4157          c_eq_s = .true.
4158      endif
4159
4160      end function c_eq_s
4161
4162!*******************************************************************************
4163!     /=
4164!*******************************************************************************
4165! string /= string
4166
4167      elemental function s_ne_s(s1,s2)
4168
4169      implicit none
4170      type(string), intent(in)  :: s1,s2
4171      logical                   :: s_ne_s
4172      integer                   :: l1,l2
4173
4174
4175      l1 = len(s1)
4176      l2 = len(s2)
4177      if (l1 > l2) then
4178          s_ne_s = any(s1%chars(1:l2) /= s2%chars) .or.  &
4179                   any(s1%chars(l2+1:l1) /= blank)
4180      elseif (l1 < l2) then
4181          s_ne_s = any(s1%chars /= s2%chars(1:l1)) .or. &
4182                   any(blank /= s2%chars(l1+1:l2))
4183      else
4184          s_ne_s = any(s1%chars /= s2%chars)
4185      endif
4186
4187      end function s_ne_s
4188
4189!*******************************************************************************
4190! string /= character
4191
4192      elemental function s_ne_c(s,c)
4193
4194      implicit none
4195      type(string), intent(in)  :: s
4196      character(*), intent(in)  :: c
4197      logical                   :: s_ne_c
4198      integer                   :: i,ls,lc
4199
4200
4201      ls = len(s)
4202      lc = len(c)
4203      do i=1,min(ls,lc)
4204          if (s%chars(i) /= c(i:i) )then
4205              s_ne_c = .true.
4206              return
4207          endif
4208      enddo
4209      if ((ls > lc) .and. any(s%chars(ls+1:lc) /= blank)) then
4210          s_ne_c = .true.
4211      elseif ((ls < lc) .and. blank /= c(ls+1:lc)) then
4212          s_ne_c = .true.
4213      else
4214          s_ne_c = .false.
4215      endif
4216
4217      end function s_ne_c
4218
4219!*******************************************************************************
4220! character /= string
4221
4222      elemental function c_ne_s(c,s)
4223
4224      implicit none
4225      character(*), intent(in)  :: c
4226      type(string), intent(in)  :: s
4227      logical                   :: c_ne_s
4228      integer                   :: i,lc,ls
4229
4230
4231      lc = len(c)
4232      ls = len(s)
4233      do i=1,min(lc,ls)
4234          if (c(i:i) /= s%chars(i)) then
4235              c_ne_s = .true.
4236              return
4237          endif
4238      enddo
4239      if ((lc > ls) .and. c(ls+1:lc) /= blank) then
4240          c_ne_s = .true.
4241      elseif ((lc < ls) .and. any(blank /= s%chars(lc+1:ls))) then
4242          c_ne_s = .true.
4243      else
4244          c_ne_s = .false.
4245      endif
4246
4247      end function c_ne_s
4248
4249!*******************************************************************************
4250!     < operators
4251!*******************************************************************************
4252! string < string
4253
4254      elemental function s_lt_s(s1,s2)
4255
4256      implicit none
4257      type(string), intent(in)  :: s1,s2
4258      logical                   :: s_lt_s
4259
4260
4261      s_lt_s = compare_ss(s1,s2) == 'LT'
4262
4263      end function s_lt_s
4264
4265!*******************************************************************************
4266! string < character
4267
4268      elemental function s_lt_c(s,c)
4269
4270      implicit none
4271      type(string), intent(in)  :: s
4272      character(*), intent(in)  :: c
4273      logical                   :: s_lt_c
4274
4275
4276      s_lt_c = compare_cs(c,s) == 'GT'
4277
4278      end function s_lt_c
4279
4280!*******************************************************************************
4281! character < string
4282
4283      elemental function c_lt_s(c,s)
4284
4285      implicit none
4286      character(*), intent(in)  :: c
4287      type(string), intent(in)  :: s
4288      logical                   :: c_lt_s
4289
4290
4291      c_lt_s = compare_cs(c,s) == 'LT'
4292
4293      end function c_lt_s
4294
4295!*******************************************************************************
4296!     <=  operators
4297!*******************************************************************************
4298! string <= string
4299
4300      elemental function s_le_s(s1,s2)
4301
4302      implicit none
4303      type(string), intent(in)  :: s1,s2
4304      logical                   :: s_le_s
4305
4306
4307      s_le_s = compare_ss(s1,s2) /= 'GT'
4308
4309      end function s_le_s
4310
4311!*******************************************************************************
4312! string <= character
4313
4314      elemental function s_le_c(s,c)
4315
4316      implicit none
4317      type(string), intent(in)  :: s
4318      character(*), intent(in)  :: c
4319      logical                   :: s_le_c
4320
4321
4322      s_le_c = compare_cs(c,s) /= 'LT'
4323
4324      end function s_le_c
4325
4326!*******************************************************************************
4327! character <= string
4328
4329      elemental function c_le_s(c,s)
4330
4331      implicit none
4332      character(*), intent(in)  :: c
4333      type(string), intent(in)  :: s
4334      logical                   :: c_le_s
4335
4336
4337      c_le_s = compare_cs(c,s) /= 'GT'
4338
4339      end function c_le_s
4340
4341!*******************************************************************************
4342!     >=  operators
4343!*******************************************************************************
4344! string >= string
4345
4346      elemental function s_ge_s(s1,s2)
4347
4348      implicit none
4349      type(string), intent(in) :: s1,s2
4350      logical                  :: s_ge_s
4351
4352
4353      s_ge_s = compare_ss(s1,s2) /= 'LT'
4354
4355      end function s_ge_s
4356
4357!*******************************************************************************
4358! string >= character
4359
4360      elemental function s_ge_c(s,c)
4361
4362      implicit none
4363      type(string), intent(in)  :: s
4364      character(*), intent(in)  :: c
4365      logical                   :: s_ge_c
4366
4367
4368      s_ge_c = compare_cs(c,s) /= 'GT'
4369
4370      end function s_ge_c
4371
4372!*******************************************************************************
4373! character >= string
4374
4375      elemental function c_ge_s(c,s)
4376
4377      implicit none
4378      character(*), intent(in)  :: c
4379      type(string), intent(in)  :: s
4380      logical                   :: c_ge_s
4381
4382
4383      c_ge_s = compare_cs(c,s) /= 'LT'
4384
4385      end function c_ge_s
4386
4387!*******************************************************************************
4388!     >  operators
4389!*******************************************************************************
4390! string > string
4391
4392      elemental function s_gt_s(s1,s2)
4393
4394      implicit none
4395      type(string), intent(in) :: s1,s2
4396      logical                  :: s_gt_s
4397
4398
4399      s_gt_s = compare_ss(s1,s2) == 'GT'
4400
4401      end function s_gt_s
4402
4403!*******************************************************************************
4404! string > character
4405
4406      elemental function s_gt_c(s,c)
4407
4408      implicit none
4409      type(string), intent(in)  :: s
4410      character(*), intent(in)  :: c
4411      logical                   :: s_gt_c
4412
4413
4414      s_gt_c = compare_cs(c,s) == 'LT'
4415
4416      end function s_gt_c
4417
4418!*******************************************************************************
4419! character > string
4420
4421      elemental function c_gt_s(c,s)
4422
4423      implicit none
4424      character(*), intent(in)  :: c
4425      type(string), intent(in)  :: s
4426      logical                   :: c_gt_s
4427
4428
4429      c_gt_s = compare_cs(c,s) == 'GT'
4430
4431      end function c_gt_s
4432
4433!*******************************************************************************
4434
4435      elemental function lcompare_ss(s1,s2) result(css)
4436
4437      implicit none
4438      type(string), intent(in)  :: s1,s2
4439      character(2)              :: css
4440      integer                   :: i,l1,l2
4441
4442
4443      l1 = len(s1)
4444      l2 = len(s2)
4445      do i=1,min(l1,l2)
4446          if (llt(s1%chars(i),s2%chars(i))) then
4447              css = 'LT'
4448              return
4449          elseif (lgt(s1%chars(i),s2%chars(i))) then
4450              css = 'GT'
4451              return
4452          endif
4453      enddo
4454      if (l1 < l2) then
4455          do i=l1+1,l2
4456              if (llt(blank,s2%chars(i))) then
4457                  css = 'LT'
4458                  return
4459              elseif (lgt(blank,s2%chars(i))) then
4460                  css = 'GT'
4461                  return
4462              endif
4463          enddo
4464      elseif (l1 > l2) then
4465          do i=l2+1,l1
4466              if (llt(s1%chars(i),blank)) then
4467                  css = 'LT'
4468                  return
4469              elseif (lgt(s1%chars(i),blank)) then
4470                  css = 'GT'
4471                  return
4472              endif
4473          enddo
4474      endif
4475      css = 'EQ'
4476
4477      end function lcompare_ss
4478
4479!*******************************************************************************
4480
4481      elemental function lcompare_cs(c,s) result(css)
4482
4483      implicit none
4484      character(*), intent(in)  :: c
4485      type(string), intent(in)  :: s
4486      character(2)              :: css
4487      integer                   :: i,lc,ls
4488
4489
4490      lc = len(c)
4491      ls = len(s)
4492      do i=1,min(lc,ls)
4493          if (llt(c(i:i),s%chars(i))) then
4494              css = 'LT'
4495              return
4496          elseif (lgt(c(i:i),s%chars(i))) then
4497              css = 'GT'
4498              return
4499          endif
4500      enddo
4501      if (lc < ls) then
4502          do i=lc+1,ls
4503              if (llt(blank,s%chars(i))) then
4504                  css = 'LT'
4505                  return
4506              elseif (lgt(blank,s%chars(i))) then
4507                  css = 'GT'
4508                  return
4509              endif
4510          enddo
4511      elseif (lc > ls) then
4512          do i=ls+1,lc
4513              if (llt(c(i:i),blank)) then
4514                  css = 'LT'
4515                  return
4516              elseif (lgt(c(i:i),blank)) then
4517                  css = 'GT'
4518                  return
4519              endif
4520          enddo
4521      endif
4522      css = 'EQ'
4523
4524      end function lcompare_cs
4525
4526!*******************************************************************************
4527!     LLT function
4528!*******************************************************************************
4529!     llt(string,string)
4530
4531      elemental function s_llt_s(s1,s2)
4532
4533      implicit none
4534      type(string), intent(in)  :: s1,s2
4535      logical                   :: s_llt_s
4536
4537      s_llt_s = (lcompare_ss(s1,s2) == 'LT')
4538
4539      end function s_llt_s
4540
4541!*******************************************************************************
4542!     llt(string,character)
4543
4544      elemental function s_llt_c(s1,c2)
4545
4546      implicit none
4547      type(string), intent(in)  :: s1
4548      character(*), intent(in)  :: c2
4549      logical                   :: s_llt_c
4550
4551      s_llt_c = (lcompare_cs(c2,s1) == 'GT')
4552
4553      end function s_llt_c
4554
4555!*******************************************************************************
4556!     llt(character,string)
4557
4558      elemental function c_llt_s(c1,s2)
4559
4560      implicit none
4561      type(string), intent(in)  :: s2
4562      character(*), intent(in)  :: c1
4563      logical                   :: c_llt_s
4564
4565      c_llt_s = (lcompare_cs(c1,s2) == 'LT')
4566
4567      end function c_llt_s
4568
4569!*******************************************************************************
4570!     LGT function
4571!*******************************************************************************
4572!     lgt(string,string)
4573
4574      elemental function s_lgt_s(s1,s2)
4575
4576      implicit none
4577      type(string), intent(in)  :: s1,s2
4578      logical                   :: s_lgt_s
4579
4580      s_lgt_s = (lcompare_ss(s1,s2) == 'GT')
4581
4582      end function s_lgt_s
4583
4584!*******************************************************************************
4585!     lgt(string,character)
4586
4587      elemental function s_lgt_c(s1,c2)
4588
4589      implicit none
4590      type(string), intent(in)  :: s1
4591      character(*), intent(in)  :: c2
4592      logical                   :: s_lgt_c
4593
4594      s_lgt_c = (lcompare_cs(c2,s1) == 'LT')
4595
4596      end function s_lgt_c
4597
4598!*******************************************************************************
4599!     lgt(character,string)
4600
4601      elemental function c_lgt_s(c1,s2)
4602
4603      implicit none
4604      type(string), intent(in)  :: s2
4605      character(*), intent(in)  :: c1
4606      logical                   :: c_lgt_s
4607
4608      c_lgt_s = (lcompare_cs(c1,s2) == 'GT')
4609
4610      end function c_lgt_s
4611
4612!*******************************************************************************
4613!     LGE function
4614!*******************************************************************************
4615!     lge(string,string)
4616
4617      elemental function s_lge_s(s1,s2)
4618
4619      implicit none
4620      type(string), intent(in)  :: s1,s2
4621      logical                   :: s_lge_s
4622
4623      s_lge_s = (lcompare_ss(s1,s2) /= 'LT')
4624
4625      end function s_lge_s
4626
4627!*******************************************************************************
4628!     lge(string,character)
4629
4630      elemental function s_lge_c(s1,c2)
4631
4632      implicit none
4633      type(string), intent(in)  :: s1
4634      character(*), intent(in)  :: c2
4635      logical                   :: s_lge_c
4636
4637      s_lge_c = (lcompare_cs(c2,s1) /= 'GT')
4638
4639      end function s_lge_c
4640
4641!*******************************************************************************
4642!     lge(character,string)
4643
4644      elemental function c_lge_s(c1,s2)
4645
4646      implicit none
4647      type(string), intent(in)  :: s2
4648      character(*), intent(in)  :: c1
4649      logical                   :: c_lge_s
4650
4651      c_lge_s = (lcompare_cs(c1,s2) /= 'LT')
4652
4653      end function c_lge_s
4654
4655!*******************************************************************************
4656!     LLE function
4657!*******************************************************************************
4658!     lle(string,string)
4659
4660      elemental function s_lle_s(s1,s2)
4661
4662      implicit none
4663      type(string), intent(in)  :: s1,s2
4664      logical                   :: s_lle_s
4665
4666      s_lle_s = (lcompare_ss(s1,s2) /= 'GT')
4667
4668      end function s_lle_s
4669
4670!*******************************************************************************
4671!     lle(string,character)
4672
4673      elemental function s_lle_c(s1,c2)
4674
4675      implicit none
4676      type(string), intent(in)  :: s1
4677      character(*), intent(in)  :: c2
4678      logical                   :: s_lle_c
4679
4680      s_lle_c = (lcompare_cs(c2,s1) /= 'LT')
4681
4682      end function s_lle_c
4683
4684!*******************************************************************************
4685!     lle(character,string)
4686
4687      elemental function c_lle_s(c1,s2)
4688
4689      implicit none
4690      type(string), intent(in)  :: s2
4691      character(*), intent(in)  :: c1
4692      logical                   :: c_lle_s
4693
4694      c_lle_s = (lcompare_cs(c1,s2) /= 'GT')
4695
4696      end function c_lle_s
4697
4698!*******************************************************************************
4699
4700      pure function acompare_aa(a1,a2) result(caa)
4701
4702      implicit none
4703      character, intent(in)  :: a1(:),a2(:)
4704      character(2)           :: caa
4705      integer                :: i,l1,l2
4706
4707
4708      l1 = size(a1)
4709      l2 = size(a2)
4710      do i=1,min(l1,l2)
4711          if (a1(i) < a2(i)) then
4712              caa = 'LT'
4713              return
4714          elseif (a1(i) > a2(i)) then
4715              caa = 'GT'
4716              return
4717          endif
4718      enddo
4719      if (l1 < l2) then
4720          do i=l1+1,l2
4721              if (blank < a2(i)) then
4722                  caa = 'LT'
4723                  return
4724              elseif (blank > a2(i)) then
4725                  caa = 'GT'
4726                  return
4727              endif
4728          enddo
4729      elseif (l1 > l2) then
4730          do i=l2+1,l1
4731              if (a1(i) < blank) then
4732                  caa = 'LT'
4733                  return
4734              elseif (a1(i) > blank) then
4735                  caa = 'GT'
4736                  return
4737              endif
4738          enddo
4739      endif
4740      caa = 'EQ'
4741
4742      end function acompare_aa
4743
4744!*******************************************************************************
4745
4746      pure function acompare_ca(c,a) result(cca)
4747
4748      implicit none
4749      character(*), intent(in)  :: c
4750      character, intent(in)     :: a(:)
4751      character(2)              :: cca
4752      integer                   :: i,lc,la
4753
4754
4755      lc = len(c)
4756      la = size(a)
4757      do i=1,min(lc,la)
4758          if (c(i:i) < a(i)) then
4759              cca = 'LT'
4760              return
4761          elseif (c(i:i) > a(i)) then
4762              cca = 'GT'
4763              return
4764          endif
4765      enddo
4766      if (lc < la) then
4767          do i=lc+1,la
4768              if (blank < a(i)) then
4769                  cca = 'LT'
4770                  return
4771              elseif (blank > a(i)) then
4772                  cca = 'GT'
4773                  return
4774              endif
4775          enddo
4776      elseif (lc > la) then
4777          do i=la+1,lc
4778              if (c(i:i) < blank) then
4779                  cca = 'LT'
4780                  return
4781              elseif (c(i:i) > blank) then
4782                  cca = 'GT'
4783                  return
4784              endif
4785          enddo
4786      endif
4787      cca = 'EQ'
4788
4789      end function acompare_ca
4790
4791!*******************************************************************************
4792!     ==
4793!*******************************************************************************
4794! array == array
4795
4796      pure function a_eq_a(a1,a2)
4797
4798      implicit none
4799      character, intent(in)  :: a1(:),a2(:)
4800      logical                :: a_eq_a
4801      integer                :: l1,l2
4802
4803
4804      l1 = size(a1)
4805      l2 = size(a2)
4806      if (l1 > l2) then
4807          a_eq_a = all(a1(1:l2) == a2) .and.  &
4808                   all(a1(l2+1:l1) == blank)
4809      elseif (l1 < l2) then
4810          a_eq_a = all(a1 == a2(1:l1)) .and.  &
4811                   all(blank == a2(l1+1:l2))
4812      else
4813          a_eq_a = all(a1 == a2)
4814      endif
4815
4816      end function a_eq_a
4817
4818!*******************************************************************************
4819! array == character
4820
4821      pure function a_eq_c(a,c)
4822
4823      implicit none
4824      character, intent(in)     :: a(:)
4825      character(*), intent(in)  :: c
4826      logical                   :: a_eq_c
4827      integer                   :: i,la,lc
4828
4829
4830      la = len(a)
4831      lc = len(c)
4832      do i=1,min(la,lc)
4833          if (a(i) /= c(i:i)) then
4834              a_eq_c = .false.
4835              return
4836          endif
4837      enddo
4838      if ((la > lc) .and. any(a(lc+1:la) /= blank)) then
4839          a_eq_c = .false.
4840      elseif ((la < lc) .and. (blank /= c(la+1:lc))) then
4841          a_eq_c = .false.
4842      else
4843          a_eq_c = .true.
4844      endif
4845
4846      end function a_eq_c
4847
4848!*******************************************************************************
4849! character == array
4850
4851      pure function c_eq_a(c,a)
4852
4853      implicit none
4854      character(*), intent(in)  :: c
4855      character, intent(in)     :: a(:)
4856      logical                   :: c_eq_a
4857
4858
4859      c_eq_a = a_eq_c(a,c)
4860
4861      end function c_eq_a
4862
4863!*******************************************************************************
4864!     /=
4865!*******************************************************************************
4866! array /= array
4867
4868      pure function a_ne_a(a1,a2)
4869
4870      implicit none
4871      character, intent(in)  :: a1(:),a2(:)
4872      logical                :: a_ne_a
4873      integer                :: l1,l2
4874
4875
4876      l1 = size(a1)
4877      l2 = size(a2)
4878      if (l1 > l2) then
4879          a_ne_a = any(a1(1:l2) /= a2) .or.  &
4880                   any(a1(l2+1:l1) /= blank)
4881      elseif (l1 < l2) then
4882          a_ne_a = any(a1 /= a2(1:l1)) .or. &
4883                   any(blank /= a2(l1+1:l2))
4884      else
4885          a_ne_a = any(a1 /= a2)
4886      endif
4887
4888      end function a_ne_a
4889
4890!*******************************************************************************
4891! array /= character
4892
4893      pure function a_ne_c(a,c)
4894
4895      implicit none
4896      character, intent(in)     :: a(:)
4897      character(*), intent(in)  :: c
4898      logical                   :: a_ne_c
4899      integer                   :: i,la,lc
4900
4901
4902      la = size(a)
4903      lc = len(c)
4904      do i=1,min(la,lc)
4905          if (a(i) /= c(i:i) )then
4906              a_ne_c = .true.
4907              return
4908          endif
4909      enddo
4910      if ((la > lc) .and. any(a(la+1:lc) /= blank)) then
4911          a_ne_c = .true.
4912      elseif ((la < lc) .and. blank /= c(la+1:lc)) then
4913          a_ne_c = .true.
4914      else
4915          a_ne_c = .false.
4916      endif
4917
4918      end function a_ne_c
4919
4920!*******************************************************************************
4921! character /= array
4922
4923      pure function c_ne_a(c,a)
4924
4925      implicit none
4926      character(*), intent(in)  :: c
4927      character, intent(in)     :: a(:)
4928      logical                   :: c_ne_a
4929
4930
4931      c_ne_a = acompare_ca(c,a) /= 'EQ'
4932
4933      end function c_ne_a
4934
4935!*******************************************************************************
4936!     < operators
4937!*******************************************************************************
4938! array < array
4939
4940      pure function a_lt_a(a1,a2)
4941
4942      implicit none
4943      character, intent(in)  :: a1(:),a2(:)
4944      logical                :: a_lt_a
4945
4946
4947      a_lt_a = acompare_aa(a1,a2) == 'LT'
4948
4949      end function a_lt_a
4950
4951!*******************************************************************************
4952! array < character
4953
4954      pure function a_lt_c(a,c)
4955
4956      implicit none
4957      character, intent(in)     :: a(:)
4958      character(*), intent(in)  :: c
4959      logical                   :: a_lt_c
4960
4961
4962      a_lt_c = acompare_ca(c,a) == 'GT'
4963
4964      end function a_lt_c
4965
4966!*******************************************************************************
4967! character < array
4968
4969      pure function c_lt_a(c,a)
4970
4971      implicit none
4972      character(*), intent(in)  :: c
4973      character, intent(in)     :: a(:)
4974      logical                   :: c_lt_a
4975
4976
4977      c_lt_a = acompare_ca(c,a) == 'LT'
4978
4979      end function c_lt_a
4980
4981!*******************************************************************************
4982!     <=  operators
4983!*******************************************************************************
4984! array <= array
4985
4986      pure function a_le_a(a1,a2)
4987
4988      implicit none
4989      character, intent(in)  :: a1(:),a2(:)
4990      logical                :: a_le_a
4991
4992
4993      a_le_a = acompare_aa(a1,a2) /= 'GT'
4994
4995      end function a_le_a
4996
4997!*******************************************************************************
4998! array <= character
4999
5000      pure function a_le_c(a,c)
5001
5002      implicit none
5003      character, intent(in)     :: a(:)
5004      character(*), intent(in)  :: c
5005      logical                   :: a_le_c
5006
5007
5008      a_le_c = acompare_ca(c,a) /= 'LT'
5009
5010      end function a_le_c
5011
5012!*******************************************************************************
5013! character <= array
5014
5015      pure function c_le_a(c,a)
5016
5017      implicit none
5018      character(*), intent(in)  :: c
5019      character, intent(in)     :: a(:)
5020      logical                   :: c_le_a
5021
5022
5023      c_le_a = acompare_ca(c,a) /= 'GT'
5024
5025      end function c_le_a
5026
5027!*******************************************************************************
5028!     >=  operators
5029!*******************************************************************************
5030! array >= array
5031
5032      pure function a_ge_a(a1,a2)
5033
5034      implicit none
5035      character, intent(in)  :: a1(:),a2(:)
5036      logical                :: a_ge_a
5037
5038
5039      a_ge_a = acompare_aa(a1,a2) /= 'LT'
5040
5041      end function a_ge_a
5042
5043!*******************************************************************************
5044! array >= character
5045
5046      pure function a_ge_c(a,c)
5047
5048      implicit none
5049      character, intent(in)     :: a(:)
5050      character(*), intent(in)  :: c
5051      logical                   :: a_ge_c
5052
5053
5054      a_ge_c = acompare_ca(c,a) /= 'GT'
5055
5056      end function a_ge_c
5057
5058!*******************************************************************************
5059! character >= array
5060
5061      pure function c_ge_a(c,a)
5062
5063      implicit none
5064      character(*), intent(in)  :: c
5065      character, intent(in)     :: a(:)
5066      logical                   :: c_ge_a
5067
5068
5069      c_ge_a = acompare_ca(c,a) /= 'LT'
5070
5071      end function c_ge_a
5072
5073!*******************************************************************************
5074!     >  operators
5075!*******************************************************************************
5076! array > array
5077
5078      pure function a_gt_a(a1,a2)
5079
5080      implicit none
5081      character, intent(in)  :: a1(:),a2(:)
5082      logical                :: a_gt_a
5083
5084
5085      a_gt_a = acompare_aa(a1,a2) == 'GT'
5086
5087      end function a_gt_a
5088
5089!*******************************************************************************
5090! array > character
5091
5092      pure function a_gt_c(a,c)
5093
5094      implicit none
5095      character, intent(in)     :: a(:)
5096      character(*), intent(in)  :: c
5097      logical                   :: a_gt_c
5098
5099
5100      a_gt_c = acompare_ca(c,a) == 'LT'
5101
5102      end function a_gt_c
5103
5104!*******************************************************************************
5105! character > array
5106
5107      pure function c_gt_a(c,a)
5108
5109      implicit none
5110      character(*), intent(in)  :: c
5111      character, intent(in)     :: a(:)
5112      logical                   :: c_gt_a
5113
5114
5115      c_gt_a = acompare_ca(c,a) == 'GT'
5116
5117      end function c_gt_a
5118
5119!*******************************************************************************
5120
5121      pure function alcompare_aa(a1,a2) result(caa)
5122
5123      implicit none
5124      character, intent(in)  :: a1(:),a2(:)
5125      character(2)           :: caa
5126      integer                :: i,l1,l2
5127
5128
5129      l1 = size(a1)
5130      l2 = size(a2)
5131      do i=1,min(l1,l2)
5132          if (llt(a1(i),a2(i))) then
5133              caa = 'LT'
5134              return
5135          elseif (lgt(a1(i),a2(i))) then
5136              caa = 'GT'
5137              return
5138          endif
5139      enddo
5140      if (l1 < l2) then
5141          do i=l1+1,l2
5142              if (llt(blank,a2(i))) then
5143                  caa = 'LT'
5144                  return
5145              elseif (lgt(blank,a2(i))) then
5146                  caa = 'GT'
5147                  return
5148              endif
5149          enddo
5150      elseif (l1 > l2) then
5151          do i=l2+1,l1
5152              if (llt(a1(i),blank)) then
5153                  caa = 'LT'
5154                  return
5155              elseif (lgt(a1(i),blank)) then
5156                  caa = 'GT'
5157                  return
5158              endif
5159          enddo
5160      endif
5161      caa = 'EQ'
5162
5163      end function alcompare_aa
5164
5165!*******************************************************************************
5166
5167      pure function alcompare_ca(c,a) result(cca)
5168
5169      implicit none
5170      character(*), intent(in)  :: c
5171      character, intent(in)     :: a(:)
5172      character(2)              :: cca
5173      integer                   :: i,lc,la
5174
5175
5176      lc = len(c)
5177      la = size(a)
5178      do i=1,min(lc,la)
5179          if (llt(c(i:i),a(i))) then
5180              cca = 'LT'
5181              return
5182          elseif (lgt(c(i:i),a(i))) then
5183              cca = 'GT'
5184              return
5185          endif
5186      enddo
5187      if (lc < la) then
5188          do i=lc+1,la
5189              if (llt(blank,a(i))) then
5190                  cca = 'LT'
5191                  return
5192              elseif (lgt(blank,a(i))) then
5193                  cca = 'GT'
5194                  return
5195              endif
5196          enddo
5197      elseif (lc > la) then
5198          do i=la+1,lc
5199              if (llt(c(i:i),blank)) then
5200                  cca = 'LT'
5201                  return
5202              elseif (lgt(c(i:i),blank)) then
5203                  cca = 'GT'
5204                  return
5205              endif
5206          enddo
5207      endif
5208      cca = 'EQ'
5209
5210      end function alcompare_ca
5211
5212!*******************************************************************************
5213!     LLT operators
5214!*******************************************************************************
5215! array < array
5216
5217      pure function a_allt_a(a1,a2)
5218
5219      implicit none
5220      character, intent(in)  :: a1(:),a2(:)
5221      logical                :: a_allt_a
5222
5223
5224      a_allt_a = alcompare_aa(a1,a2) == 'LT'
5225
5226      end function a_allt_a
5227
5228!*******************************************************************************
5229! array < character
5230
5231      pure function a_allt_c(a1,c2)
5232
5233      implicit none
5234      character, intent(in)     :: a1(:)
5235      character(*), intent(in)  :: c2
5236      logical                   :: a_allt_c
5237
5238
5239      a_allt_c = alcompare_ca(c2,a1) == 'GT'
5240
5241      end function a_allt_c
5242
5243!*******************************************************************************
5244! character < array
5245
5246      pure function c_allt_a(c1,a2)
5247
5248      implicit none
5249      character(*), intent(in)  :: c1
5250      character, intent(in)     :: a2(:)
5251      logical                   :: c_allt_a
5252
5253
5254      c_allt_a = alcompare_ca(c1,a2) == 'LT'
5255
5256      end function c_allt_a
5257
5258!*******************************************************************************
5259!     LLE  operators
5260!*******************************************************************************
5261! array <= array
5262
5263      pure function a_alle_a(a1,a2)
5264
5265      implicit none
5266      character, intent(in)  :: a1(:),a2(:)
5267      logical                :: a_alle_a
5268
5269
5270      a_alle_a = alcompare_aa(a1,a2) /= 'GT'
5271
5272      end function a_alle_a
5273
5274!*******************************************************************************
5275! array <= character
5276
5277      pure function a_alle_c(a1,c2)
5278
5279      implicit none
5280      character, intent(in)     :: a1(:)
5281      character(*), intent(in)  :: c2
5282      logical                   :: a_alle_c
5283
5284
5285      a_alle_c = alcompare_ca(c2,a1) /= 'LT'
5286
5287      end function a_alle_c
5288
5289!*******************************************************************************
5290! character <= array
5291
5292      pure function c_alle_a(c1,a2)
5293
5294      implicit none
5295      character(*), intent(in)  :: c1
5296      character, intent(in)     :: a2(:)
5297      logical                   :: c_alle_a
5298
5299
5300      c_alle_a = alcompare_ca(c1,a2) /= 'GT'
5301
5302      end function c_alle_a
5303
5304!*******************************************************************************
5305!     LGE  operators
5306!*******************************************************************************
5307! array >= array
5308
5309      pure function a_alge_a(a1,a2)
5310
5311      implicit none
5312      character, intent(in)  :: a1(:),a2(:)
5313      logical                :: a_alge_a
5314
5315
5316      a_alge_a = alcompare_aa(a1,a2) /= 'LT'
5317
5318      end function a_alge_a
5319
5320!*******************************************************************************
5321! array >= character
5322
5323      pure function a_alge_c(a1,c2)
5324
5325      implicit none
5326      character, intent(in)     :: a1(:)
5327      character(*), intent(in)  :: c2
5328      logical                   :: a_alge_c
5329
5330
5331      a_alge_c = alcompare_ca(c2,a1) /= 'GT'
5332
5333      end function a_alge_c
5334
5335!*******************************************************************************
5336! character >= array
5337
5338      pure function c_alge_a(c1,a2)
5339
5340      implicit none
5341      character(*), intent(in)  :: c1
5342      character, intent(in)     :: a2(:)
5343      logical                   :: c_alge_a
5344
5345
5346      c_alge_a = alcompare_ca(c1,a2) /= 'LT'
5347
5348      end function c_alge_a
5349
5350!*******************************************************************************
5351!     LGT  operators
5352!*******************************************************************************
5353! array > array
5354
5355      pure function a_algt_a(a1,a2)
5356
5357      implicit none
5358      character, intent(in)  :: a1(:),a2(:)
5359      logical                :: a_algt_a
5360
5361
5362      a_algt_a = alcompare_aa(a1,a2) == 'GT'
5363
5364      end function a_algt_a
5365
5366!*******************************************************************************
5367! array > character
5368
5369      pure function a_algt_c(a1,c2)
5370
5371      implicit none
5372      character, intent(in)     :: a1(:)
5373      character(*), intent(in)  :: c2
5374      logical                   :: a_algt_c
5375
5376
5377      a_algt_c = alcompare_ca(c2,a1) == 'LT'
5378
5379      end function a_algt_c
5380
5381!*******************************************************************************
5382! character > array
5383
5384      pure function c_algt_a(c1,a2)
5385
5386      implicit none
5387      character(*), intent(in)  :: c1
5388      character, intent(in)     :: a2(:)
5389      logical                   :: c_algt_a
5390
5391
5392      c_algt_a = alcompare_ca(c1,a2) == 'GT'
5393
5394      end function c_algt_a
5395
5396!*******************************************************************************
5397!     INDEX
5398!*******************************************************************************
5399
5400      elemental function