« back to all changes in this revision
Viewing changes to Src/fdict/src/iso_var_str.f90
- browse files at revision 645
- compare with another revision
- download diff
- download tarball
- view history from revision 645
- Committer: Rafi Ullah
- Date: 2017-08-30 14:09:10 UTC
- mfrom: (611.1.19 trunk)
- Revision ID: rraffiu@gmail.com-20170830140910-bhu0osuh4d59wn8e
Merged with trunk-630
- files added:
- README_CHESS
- Tests/CheSS
- Tests/lua_si111
- Tests/si001-diags
- Tests/si001-ldos
- files removed:
- Examples/TranSiesta
- Examples/TranSiesta/Elec
- Examples/TranSiesta/Elec/OUT
- Examples/TranSiesta/Scat
- Examples/TranSiesta/Scat/OUT
- Examples/TranSiesta/Scat/OUT_TBT
- Util/Denchar/Src/fdf
- Util/Helpers/fdf
- files renamed:
- Tests/h2o_lua/ => Tests/lua_h2o/
- Tests/h2o_lua/h2o.fdf => Tests/lua_h2o/lua_h2o.fdf
- Tests/h2o_lua/h2o.pseudos => Tests/lua_h2o/lua_h2o.pseudos
- Util/COOP/sys_local.f90 => Util/COOP/local_sys.f90
- Util/Optical/input.f => Util/Optical/optical_input.f
- Util/STM/ol-stm/Src/readwaves.f => Util/STM/ol-stm/Src/m_wfsx.f
- files modified:
- Docs/CHANGES.tddft02
added
removed
Src/fdict/src/iso_var_str.f90
1
MODULE ISO_VAR_STR
2
3
! Written by J.L.Schonfelder
4
! Incorporating suggestions by members of the committee ISO/IEC JTC1/SC22/WG5
5
6
! Version produced (3-Nov-1998)
7
! Updated to exploit facilities included in Fortran 95
8
9
!-----------------------------------------------------------------------------!
10
! This module defines the interface and one possible implementation for a !
11
! dynamic length character string facility in Fortran 95. The Fortran 95 !
12
! language is defined by the standard ISO/IEC 1539-1 : 1997. !
13
! The publicly accessible interface defined by this module is conformant !
14
! with the auxilliary standard, ISO/IEC 1539-2 : 1999. !
15
! The detailed implementation may be considered as an informal definition of !
16
! the required semantics, and may also be used as a guide to the production !
17
! of a portable implementation. !
18
! N.B. Although every care has been taken to produce valid Fortran code in !
19
! construction of this module no guarantee is given or implied that this !
20
! code will work correctly without error on any specific processor, nor !
21
! is this implementation intended to be in any way optimal either in use !
22
! of storage or CPU cycles. !
23
!-----------------------------------------------------------------------------!
24
25
PRIVATE
26
27
!-----------------------------------------------------------------------------!
28
! By default all entities declared or defined in this module are private to !
29
! the module. Only those entities declared explicitly as being public are !
30
! accessible to programs using the module. In particular, the procedures and !
31
! operators defined herein are made accessible via their generic identifiers !
32
! only; their specific names are private. !
33
!-----------------------------------------------------------------------------!
34
35
TYPE VAR_STR
36
PRIVATE
37
CHARACTER,DIMENSION(:),POINTER :: chars => NULL()
38
ENDTYPE VAR_STR
39
40
!-----------------------------------------------------------------------------!
41
! The representation chosen for this definition of the module is of a string !
42
! type consisting of a single component that is a pointer to a rank one array !
43
! of characters. !
44
! Note: this Module is defined only for characters of default kind. A similar !
45
! module could be defined for non-default characters if these are supported !
46
! on a processor by adding a KIND parameter to the component in the type !
47
! definition, and to all delarations of objects of CHARACTER type. !
48
!-----------------------------------------------------------------------------!
49
50
CHARACTER,PARAMETER :: blank = " "
51
52
!----- GENERIC PROCEDURE INTERFACE DEFINITIONS -------------------------------!
53
54
!----- LEN interface ---------------------------------------------------------!
55
INTERFACE LEN
56
MODULE PROCEDURE len_s ! length of string
57
ENDINTERFACE
58
59
!----- Conversion procedure interfaces ---------------------------------------!
60
INTERFACE VARSTR
61
MODULE PROCEDURE c_to_s ! character to string
62
ENDINTERFACE
63
64
INTERFACE CHAR
65
MODULE PROCEDURE s_to_c, & ! string to character
66
s_to_fix_c ! string to specified length character
67
ENDINTERFACE
68
69
!----- ASSIGNMENT interfaces -------------------------------------------------!
70
INTERFACE ASSIGNMENT(=)
71
MODULE PROCEDURE s_ass_s, & ! string = string
72
c_ass_s, & ! character = string
73
s_ass_c ! string = character
74
ENDINTERFACE
75
76
!----- Concatenation operator interfaces -------------------------------------!
77
INTERFACE OPERATOR(//)
78
MODULE PROCEDURE s_concat_s, & ! string//string
79
s_concat_c, & ! string//character
80
c_concat_s ! character//string
81
ENDINTERFACE
82
83
!----- Repeated Concatenation interface --------------------------------------!
84
INTERFACE REPEAT
85
MODULE PROCEDURE repeat_s
86
ENDINTERFACE
87
88
!------ Equality comparison operator interfaces-------------------------------!
89
INTERFACE OPERATOR(==)
90
MODULE PROCEDURE s_eq_s, & ! string==string
91
s_eq_c, & ! string==character
92
c_eq_s ! character==string
93
ENDINTERFACE
94
95
!----- not-equality comparison operator interfaces ---------------------------!
96
INTERFACE OPERATOR(/=)
97
MODULE PROCEDURE s_ne_s, & ! string/=string
98
s_ne_c, & ! string/=character
99
c_ne_s ! character/=string
100
ENDINTERFACE
101
102
!----- less-than comparison operator interfaces ------------------------------!
103
INTERFACE OPERATOR(<)
104
MODULE PROCEDURE s_lt_s, & ! string<string
105
s_lt_c, & ! string<character
106
c_lt_s ! character<string
107
ENDINTERFACE
108
109
!----- less-than-or-equal comparison operator interfaces ---------------------!
110
INTERFACE OPERATOR(<=)
111
MODULE PROCEDURE s_le_s, & ! string<=string
112
s_le_c, & ! string<=character
113
c_le_s ! character<=string
114
ENDINTERFACE
115
116
!----- greater-than-or-equal comparison operator interfaces ------------------!
117
INTERFACE OPERATOR(>=)
118
MODULE PROCEDURE s_ge_s, & ! string>=string
119
s_ge_c, & ! string>=character
120
c_ge_s ! character>=string
121
ENDINTERFACE
122
123
!----- greater-than comparison operator interfaces ---------------------------!
124
INTERFACE OPERATOR(>)
125
MODULE PROCEDURE s_gt_s, & ! string>string
126
s_gt_c, & ! string>character
127
c_gt_s ! character>string
128
ENDINTERFACE
129
130
!----- LLT procedure interfaces ----------------------------------------------!
131
INTERFACE LLT
132
MODULE PROCEDURE s_llt_s, & ! LLT(string,string)
133
s_llt_c, & ! LLT(string,character)
134
c_llt_s ! LLT(character,string)
135
ENDINTERFACE
136
137
!----- LLE procedure interfaces ----------------------------------------------!
138
INTERFACE LLE
139
MODULE PROCEDURE s_lle_s, & ! LLE(string,string)
140
s_lle_c, & ! LLE(string,character)
141
c_lle_s ! LLE(character,string)
142
ENDINTERFACE
143
144
!----- LGE procedure interfaces ----------------------------------------------!
145
INTERFACE LGE
146
MODULE PROCEDURE s_lge_s, & ! LGE(string,string)
147
s_lge_c, & ! LGE(string,character)
148
c_lge_s ! LGE(character,string)
149
ENDINTERFACE
150
151
!----- LGT procedure interfaces ----------------------------------------------!
152
INTERFACE LGT
153
MODULE PROCEDURE s_lgt_s, & ! LGT(string,string)
154
s_lgt_c, & ! LGT(string,character)
155
c_lgt_s ! LGT(character,string)
156
ENDINTERFACE
157
158
!----- Input procedure interfaces --------------------------------------------!
159
INTERFACE GET
160
MODULE PROCEDURE get_d_eor, & ! default unit, EoR termination
161
get_u_eor, & ! specified unit, EoR termination
162
get_d_tset_s, & ! default unit, string set termination
163
get_u_tset_s, & ! specified unit, string set termination
164
get_d_tset_c, & ! default unit, char set termination
165
get_u_tset_c ! specified unit, char set termination
166
ENDINTERFACE
167
168
!----- Output procedure interfaces -------------------------------------------!
169
INTERFACE PUT
170
MODULE PROCEDURE put_d_s, & ! string to default unit
171
put_u_s, & ! string to specified unit
172
put_d_c, & ! char to default unit
173
put_u_c ! char to specified unit
174
ENDINTERFACE
175
176
INTERFACE PUT_LINE
177
MODULE PROCEDURE putline_d_s, & ! string to default unit
178
putline_u_s, & ! string to specified unit
179
putline_d_c, & ! char to default unit
180
putline_u_c ! char to specified unit
181
ENDINTERFACE
182
183
!----- Insert procedure interfaces -------------------------------------------!
184
INTERFACE INSERT
185
MODULE PROCEDURE insert_ss, & ! string in string
186
insert_sc, & ! char in string
187
insert_cs, & ! string in char
188
insert_cc ! char in char
189
ENDINTERFACE
190
191
!----- Replace procedure interfaces ------------------------------------------!
192
INTERFACE REPLACE
193
MODULE PROCEDURE replace_ss, & ! string by string, at specified
194
replace_sc, & ! string by char , starting
195
replace_cs, & ! char by string , point
196
replace_cc, & ! char by char
197
replace_ss_sf,& ! string by string, between
198
replace_sc_sf,& ! string by char , specified
199
replace_cs_sf,& ! char by string , starting and
200
replace_cc_sf,& ! char by char , finishing points
201
replace_sss, & ! in string replace string by string
202
replace_ssc, & ! in string replace string by char
203
replace_scs, & ! in string replace char by string
204
replace_scc, & ! in string replace char by char
205
replace_css, & ! in char replace string by string
206
replace_csc, & ! in char replace string by char
207
replace_ccs, & ! in char replace char by string
208
replace_ccc ! in char replace char by char
209
ENDINTERFACE
210
211
!----- Remove procedure interface --------------------------------------------!
212
!INTERFACE REMOVE
213
! MODULE PROCEDURE remove_s, & ! characters from string, between start
214
! remove_c ! characters from char , and finish
215
!ENDINTERFACE
216
217
!----- Extract procedure interface -------------------------------------------!
218
INTERFACE EXTRACT
219
MODULE PROCEDURE extract_s, & ! from string extract string, between start
220
extract_c ! from char extract string, and finish
221
ENDINTERFACE
222
223
!----- Split procedure interface ---------------------------------------------!
224
INTERFACE SPLIT
225
MODULE PROCEDURE split_s, & ! split string at first occurance of
226
split_c ! character in set
227
ENDINTERFACE
228
229
!----- Index procedure interfaces --------------------------------------------!
230
INTERFACE INDEX
231
MODULE PROCEDURE index_ss, index_sc, index_cs
232
ENDINTERFACE
233
234
!----- Scan procedure interfaces ---------------------------------------------!
235
INTERFACE SCAN
236
MODULE PROCEDURE scan_ss, scan_sc, scan_cs
237
ENDINTERFACE
238
239
!----- Verify procedure interfaces -------------------------------------------!
240
INTERFACE VERIFY
241
MODULE PROCEDURE verify_ss, verify_sc, verify_cs
242
ENDINTERFACE
243
244
!----- Interfaces for remaining intrinsic function overloads -----------------!
245
INTERFACE LEN_TRIM
246
MODULE PROCEDURE len_trim_s
247
ENDINTERFACE
248
249
INTERFACE TRIM
250
MODULE PROCEDURE trim_s
251
ENDINTERFACE
252
253
INTERFACE IACHAR
254
MODULE PROCEDURE iachar_s
255
ENDINTERFACE
256
257
INTERFACE ICHAR
258
MODULE PROCEDURE ichar_s
259
ENDINTERFACE
260
261
INTERFACE ADJUSTL
262
MODULE PROCEDURE adjustl_s
263
ENDINTERFACE
264
265
INTERFACE ADJUSTR
266
MODULE PROCEDURE adjustr_s
267
ENDINTERFACE
268
269
!----- specification of publically accessible entities -----------------------!
270
PUBLIC :: VAR_STR,VARSTR,CHAR,LEN,GET,PUT,PUT_LINE,INSERT,REPLACE, &
271
SPLIT,REPEAT,EXTRACT,INDEX,SCAN,VERIFY,LLT,LLE,LGE,LGT, &
272
ASSIGNMENT(=),OPERATOR(//),OPERATOR(==),OPERATOR(/=),OPERATOR(<), &
273
OPERATOR(<=),OPERATOR(>=),OPERATOR(>),LEN_TRIM,TRIM,IACHAR,ICHAR, &
274
ADJUSTL,ADJUSTR
275
276
!PUBLIC :: REMOVE
277
278
CONTAINS
279
280
!----- LEN Procedure ---------------------------------------------------------!
281
ELEMENTAL FUNCTION len_s(string) ! generic LEN
282
type(VAR_STR),INTENT(IN) :: string
283
INTEGER :: len_s
284
! returns the length of the string argument or zero if there is no current
285
! string value
286
IF(.NOT.ASSOCIATED(string%chars))THEN
287
len_s = 0
288
ELSE
289
len_s = SIZE(string%chars)
290
ENDIF
291
ENDFUNCTION len_s
292
293
!----- Conversion Procedures ------------------------------------------------!
294
ELEMENTAL FUNCTION c_to_s(chr) ! generic VAR_STR
295
type(VAR_STR) :: c_to_s
296
CHARACTER(LEN=*),INTENT(IN) :: chr
297
! returns the string consisting of the characters char
298
INTEGER :: lc
299
lc=LEN(chr)
300
ALLOCATE(c_to_s%chars(1:lc))
301
DO i=1,lc
302
c_to_s%chars(i) = chr(i:i)
303
ENDDO
304
ENDFUNCTION c_to_s
305
306
PURE FUNCTION s_to_c(string) ! generic CHAR
307
type(VAR_STR),INTENT(IN) :: string
308
CHARACTER(LEN=SIZE(string%chars)) :: s_to_c
309
! returns the characters of string as an automatically sized character
310
INTEGER :: lc
311
lc=SIZE(string%chars)
312
DO i=1,lc
313
s_to_c(i:i) = string%chars(i)
314
ENDDO
315
ENDFUNCTION s_to_c
316
317
PURE FUNCTION s_to_fix_c(string,length) ! generic CHAR
318
type(VAR_STR),INTENT(IN) :: string
319
INTEGER,INTENT(IN) :: length
320
CHARACTER(LEN=length) :: s_to_fix_c
321
! returns the character of fixed length, length, containing the characters
322
! of string either padded with blanks or truncated on the right to fit
323
INTEGER :: lc
324
lc=MIN(SIZE(string%chars),length)
325
DO i=1,lc
326
s_to_fix_c(i:i) = string%chars(i)
327
ENDDO
328
IF(lc < length)THEN ! result longer than string padding needed
329
s_to_fix_c(lc+1:length) = blank
330
ENDIF
331
ENDFUNCTION s_to_fix_c
332
333
!----- ASSIGNMENT Procedures -------------------------------------------------!
334
ELEMENTAL SUBROUTINE s_ass_s(var,expr)
335
type(VAR_STR),INTENT(INOUT) :: var
336
type(VAR_STR),INTENT(IN) :: expr
337
! assign a string value to a string variable overriding default assignement
338
! reallocates string variable to size of string value and copies characters
339
if(LEN(expr) == 0)THEN
340
var = ""
341
RETURN
342
ENDIF
343
IF(ASSOCIATED(var%chars,expr%chars))THEN
344
CONTINUE ! identity assignment do nothing
345
ELSEIF(ASSOCIATED(var%chars))THEN
346
DEALLOCATE(var%chars)
347
ALLOCATE(var%chars(1:SIZE(expr%chars)))
348
var%chars = expr%chars
349
ELSE
350
ALLOCATE(var%chars(1:SIZE(expr%chars)))
351
var%chars = expr%chars
352
ENDIF
353
ENDSUBROUTINE s_ass_s
354
355
ELEMENTAL SUBROUTINE c_ass_s(var,expr)
356
CHARACTER(LEN=*),INTENT(OUT) :: var
357
type(VAR_STR),INTENT(IN) :: expr
358
! assign a string value to a character variable
359
! if the string is longer than the character truncate the string on the right
360
! if the string is shorter the character is blank padded on the right
361
INTEGER :: lc,ls
362
lc = LEN(var); ls = MIN(LEN(expr),lc)
363
DO i = 1,ls
364
var(i:i) = expr%chars(i)
365
ENDDO
366
DO i = ls+1,lc
367
var(i:i) = blank
368
ENDDO
369
ENDSUBROUTINE c_ass_s
370
371
ELEMENTAL SUBROUTINE s_ass_c(var,expr)
372
type(VAR_STR),INTENT(INOUT) :: var
373
CHARACTER(LEN=*),INTENT(IN) :: expr
374
! assign a character value to a string variable
375
! disassociates the string variable from its current value, allocates new
376
! space to hold the characters and copies them from the character value
377
! into this space.
378
INTEGER :: lc
379
lc = LEN(expr)
380
IF(ASSOCIATED(var%chars))DEALLOCATE(var%chars)
381
IF(lc == 0)RETURN
382
ALLOCATE(var%chars(1:lc))
383
DO i = 1,lc
384
var%chars(i) = expr(i:i)
385
ENDDO
386
ENDSUBROUTINE s_ass_c
387
388
!----- Concatenation operator procedures ------------------------------------!
389
ELEMENTAL FUNCTION s_concat_s(string_a,string_b) ! string//string
390
type(VAR_STR),INTENT(IN) :: string_a,string_b
391
type(VAR_STR) :: s_concat_s
392
INTEGER :: la,lb
393
la = LEN(string_a); lb = LEN(string_b)
394
ALLOCATE(s_concat_s%chars(1:la+lb))
395
s_concat_s%chars(1:la) = string_a%chars
396
s_concat_s%chars(1+la:la+lb) = string_b%chars
397
ENDFUNCTION s_concat_s
398
399
ELEMENTAL FUNCTION s_concat_c(string_a,string_b) ! string//character
400
type(VAR_STR),INTENT(IN) :: string_a
401
CHARACTER(LEN=*),INTENT(IN) :: string_b
402
type(VAR_STR) :: s_concat_c
403
INTEGER :: la,lb
404
la = LEN(string_a); lb = LEN(string_b)
405
ALLOCATE(s_concat_c%chars(1:la+lb))
406
s_concat_c%chars(1:la) = string_a%chars
407
DO i = 1,lb
408
s_concat_c%chars(la+i) = string_b(i:i)
409
ENDDO
410
ENDFUNCTION s_concat_c
411
412
ELEMENTAL FUNCTION c_concat_s(string_a,string_b) ! character//string
413
CHARACTER(LEN=*),INTENT(IN) :: string_a
414
type(VAR_STR),INTENT(IN) :: string_b
415
type(VAR_STR) :: c_concat_s
416
INTEGER :: la,lb
417
la = LEN(string_a); lb = LEN(string_b)
418
ALLOCATE(c_concat_s%chars(1:la+lb))
419
DO i = 1,la
420
c_concat_s%chars(i) = string_a(i:i)
421
ENDDO
422
c_concat_s%chars(1+la:la+lb) = string_b%chars
423
ENDFUNCTION c_concat_s
424
425
!----- Reapeated concatenation procedures -----------------------------------!
426
ELEMENTAL FUNCTION repeat_s(string,ncopies)
427
type(VAR_STR),INTENT(IN) :: string
428
INTEGER,INTENT(IN) :: ncopies
429
type(VAR_STR) :: repeat_s
430
! Returns a string produced by the concatenation of ncopies of the
431
! argument string
432
INTEGER :: lr,ls
433
IF (ncopies <= 0) THEN
434
ALLOCATE(repeat_s%chars(1:0)) ! return a zero length string
435
RETURN
436
ENDIF
437
ls = LEN(string); lr = ls*ncopies
438
ALLOCATE(repeat_s%chars(1:lr))
439
DO i = 1,ncopies
440
repeat_s%chars(1+(i-1)*ls:i*ls) = string%chars
441
ENDDO
442
ENDFUNCTION repeat_s
443
444
!------ Equality comparison operators ----------------------------------------!
445
ELEMENTAL FUNCTION s_eq_s(string_a,string_b) ! string==string
446
type(VAR_STR),INTENT(IN) :: string_a,string_b
447
LOGICAL :: s_eq_s
448
INTEGER :: la,lb
449
la = LEN(string_a); lb = LEN(string_b)
450
IF (la > lb) THEN
451
s_eq_s = ALL(string_a%chars(1:lb) == string_b%chars) .AND. &
452
ALL(string_a%chars(lb+1:la) == blank)
453
ELSEIF (la < lb) THEN
454
s_eq_s = ALL(string_a%chars == string_b%chars(1:la)) .AND. &
455
ALL(blank == string_b%chars(la+1:lb))
456
ELSE
457
s_eq_s = ALL(string_a%chars == string_b%chars)
458
ENDIF
459
ENDFUNCTION s_eq_s
460
461
ELEMENTAL FUNCTION s_eq_c(string_a,string_b) ! string==character
462
type(VAR_STR),INTENT(IN) :: string_a
463
CHARACTER(LEN=*),INTENT(IN) :: string_b
464
LOGICAL :: s_eq_c
465
INTEGER :: la,lb,ls
466
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
467
DO i = 1,ls
468
IF( string_a%chars(i) /= string_b(i:i) )THEN
469
s_eq_c = .FALSE.; RETURN
470
ENDIF
471
ENDDO
472
IF( la > lb .AND. ANY( string_a%chars(lb+1:la) /= blank ) )THEN
473
s_eq_c = .FALSE.; RETURN
474
ELSEIF( la < lb .AND. blank /= string_b(la+1:lb) )THEN
475
s_eq_c = .FALSE.; RETURN
476
ENDIF
477
s_eq_c = .TRUE.
478
ENDFUNCTION s_eq_c
479
480
ELEMENTAL FUNCTION c_eq_s(string_a,string_b) ! character==string
481
CHARACTER(LEN=*),INTENT(IN) :: string_a
482
type(VAR_STR),INTENT(IN) :: string_b
483
LOGICAL :: c_eq_s
484
INTEGER :: la,lb,ls
485
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
486
DO i = 1,ls
487
IF( string_a(i:i) /= string_b%chars(i) )THEN
488
c_eq_s = .FALSE.; RETURN
489
ENDIF
490
ENDDO
491
IF( la > lb .AND. string_a(lb+1:la) /= blank )THEN
492
c_eq_s = .FALSE.; RETURN
493
ELSEIF( la < lb .AND. ANY( blank /= string_b%chars(la+1:lb) ) )THEN
494
c_eq_s = .FALSE.; RETURN
495
ENDIF
496
c_eq_s = .TRUE.
497
ENDFUNCTION c_eq_s
498
499
!------ Non-equality operators -----------------------------------------------!
500
ELEMENTAL FUNCTION s_ne_s(string_a,string_b) ! string/=string
501
type(VAR_STR),INTENT(IN) :: string_a,string_b
502
LOGICAL :: s_ne_s
503
INTEGER :: la,lb
504
la = LEN(string_a); lb = LEN(string_b)
505
IF (la > lb) THEN
506
s_ne_s = ANY(string_a%chars(1:lb) /= string_b%chars) .OR. &
507
ANY(string_a%chars(lb+1:la) /= blank)
508
ELSEIF (la < lb) THEN
509
s_ne_s = ANY(string_a%chars /= string_b%chars(1:la)) .OR. &
510
ANY(blank /= string_b%chars(la+1:lb))
511
ELSE
512
s_ne_s = ANY(string_a%chars /= string_b%chars)
513
ENDIF
514
ENDFUNCTION s_ne_s
515
516
ELEMENTAL FUNCTION s_ne_c(string_a,string_b) ! string/=character
517
type(VAR_STR),INTENT(IN) :: string_a
518
CHARACTER(LEN=*),INTENT(IN) :: string_b
519
LOGICAL :: s_ne_c
520
INTEGER :: la,lb,ls
521
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
522
DO i = 1,ls
523
IF( string_a%chars(i) /= string_b(i:i) )THEN
524
s_ne_c = .TRUE.; RETURN
525
ENDIF
526
ENDDO
527
IF( la > lb .AND. ANY( string_a%chars(lb+1:la) /= blank ) )THEN
528
s_ne_c = .TRUE.; RETURN
529
ELSEIF( la < lb .AND. blank /= string_b(la+1:lb) )THEN
530
s_ne_c = .TRUE.; RETURN
531
ENDIF
532
s_ne_c = .FALSE.
533
ENDFUNCTION s_ne_c
534
535
ELEMENTAL FUNCTION c_ne_s(string_a,string_b) ! character/=string
536
CHARACTER(LEN=*),INTENT(IN) :: string_a
537
type(VAR_STR),INTENT(IN) :: string_b
538
LOGICAL :: c_ne_s
539
INTEGER :: la,lb,ls
540
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
541
DO i = 1,ls
542
IF( string_a(i:i) /= string_b%chars(i) )THEN
543
c_ne_s = .TRUE.; RETURN
544
ENDIF
545
ENDDO
546
IF( la > lb .AND. string_a(lb+1:la) /= blank )THEN
547
c_ne_s = .TRUE.; RETURN
548
ELSEIF( la < lb .AND. ANY( blank /= string_b%chars(la+1:lb) ) )THEN
549
c_ne_s = .TRUE.; RETURN
550
ENDIF
551
c_ne_s = .FALSE.
552
ENDFUNCTION c_ne_s
553
554
!------ Less-than operators --------------------------------------------------!
555
ELEMENTAL FUNCTION s_lt_s(string_a,string_b) ! string<string
556
type(VAR_STR),INTENT(IN) :: string_a,string_b
557
LOGICAL :: s_lt_s
558
INTEGER :: ls,la,lb
559
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
560
DO i = 1,ls
561
IF( string_a%chars(i) < string_b%chars(i) )THEN
562
s_lt_s = .TRUE.; RETURN
563
ELSEIF( string_a%chars(i) > string_b%chars(i) )THEN
564
s_lt_s = .FALSE.; RETURN
565
ENDIF
566
ENDDO
567
IF( la < lb )THEN
568
DO i = la+1,lb
569
IF( blank < string_b%chars(i) )THEN
570
s_lt_s = .TRUE.; RETURN
571
ELSEIF( blank > string_b%chars(i) )THEN
572
s_lt_s = .FALSE.; RETURN
573
ENDIF
574
ENDDO
575
ELSEIF( la > lb )THEN
576
DO i = lb+1,la
577
IF( string_a%chars(i) < blank )THEN
578
s_lt_s = .TRUE.; RETURN
579
ELSEIF( string_a%chars(i) > blank )THEN
580
s_lt_s = .FALSE.; RETURN
581
ENDIF
582
ENDDO
583
ENDIF
584
s_lt_s = .FALSE.
585
ENDFUNCTION s_lt_s
586
587
ELEMENTAL FUNCTION s_lt_c(string_a,string_b) ! string<character
588
type(VAR_STR),INTENT(IN) :: string_a
589
CHARACTER(LEN=*),INTENT(IN) :: string_b
590
LOGICAL :: s_lt_c
591
INTEGER :: ls,la,lb
592
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
593
DO i = 1,ls
594
IF( string_a%chars(i) < string_b(i:i) )THEN
595
s_lt_c = .TRUE.; RETURN
596
ELSEIF( string_a%chars(i) > string_b(i:i) )THEN
597
s_lt_c = .FALSE.; RETURN
598
ENDIF
599
ENDDO
600
IF( la < lb )THEN
601
IF( blank < string_b(la+1:lb) )THEN
602
s_lt_c = .TRUE.; RETURN
603
ELSEIF( blank > string_b(la+1:lb) )THEN
604
s_lt_c = .FALSE.; RETURN
605
ENDIF
606
ELSEIF( la > lb )THEN
607
DO i = lb+1,la
608
IF( string_a%chars(i) < blank )THEN
609
s_lt_c = .TRUE.; RETURN
610
ELSEIF( string_a%chars(i) > blank )THEN
611
s_lt_c = .FALSE.; RETURN
612
ENDIF
613
ENDDO
614
ENDIF
615
s_lt_c = .FALSE.
616
ENDFUNCTION s_lt_c
617
618
ELEMENTAL FUNCTION c_lt_s(string_a,string_b) ! character<string
619
CHARACTER(LEN=*),INTENT(IN) :: string_a
620
type(VAR_STR),INTENT(IN) :: string_b
621
LOGICAL :: c_lt_s
622
INTEGER :: ls,la,lb
623
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
624
DO i = 1,ls
625
IF( string_a(i:i) < string_b%chars(i) )THEN
626
c_lt_s = .TRUE.; RETURN
627
ELSEIF( string_a(i:i) > string_b%chars(i) )THEN
628
c_lt_s = .FALSE.; RETURN
629
ENDIF
630
ENDDO
631
IF( la < lb )THEN
632
DO i = la+1,lb
633
IF( blank < string_b%chars(i) )THEN
634
c_lt_s = .TRUE.; RETURN
635
ELSEIF( blank > string_b%chars(i) )THEN
636
c_lt_s = .FALSE.; RETURN
637
ENDIF
638
ENDDO
639
ELSEIF( la > lb )THEN
640
IF( string_a(lb+1:la) < blank )THEN
641
c_lt_s = .TRUE.; RETURN
642
ELSEIF( string_a(lb+1:la) > blank )THEN
643
c_lt_s = .FALSE.; RETURN
644
ENDIF
645
ENDIF
646
c_lt_s = .FALSE.
647
ENDFUNCTION c_lt_s
648
649
!------ Less-than-or-equal-to operators --------------------------------------!
650
ELEMENTAL FUNCTION s_le_s(string_a,string_b) ! string<=string
651
type(VAR_STR),INTENT(IN) :: string_a,string_b
652
LOGICAL :: s_le_s
653
INTEGER :: ls,la,lb
654
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
655
DO i = 1,ls
656
IF( string_a%chars(i) < string_b%chars(i) )THEN
657
s_le_s = .TRUE.; RETURN
658
ELSEIF( string_a%chars(i) > string_b%chars(i) )THEN
659
s_le_s = .FALSE.; RETURN
660
ENDIF
661
ENDDO
662
IF( la < lb )THEN
663
DO i = la+1,lb
664
IF( blank < string_b%chars(i) )THEN
665
s_le_s = .TRUE.; RETURN
666
ELSEIF( blank > string_b%chars(i) )THEN
667
s_le_s = .FALSE.; RETURN
668
ENDIF
669
ENDDO
670
ELSEIF( la > lb )THEN
671
DO i = lb+1,la
672
IF( string_a%chars(i) < blank )THEN
673
s_le_s = .TRUE.; RETURN
674
ELSEIF( string_a%chars(i) > blank )THEN
675
s_le_s = .FALSE.; RETURN
676
ENDIF
677
ENDDO
678
ENDIF
679
s_le_s = .TRUE.
680
ENDFUNCTION s_le_s
681
682
ELEMENTAL FUNCTION s_le_c(string_a,string_b) ! string<=character
683
type(VAR_STR),INTENT(IN) :: string_a
684
CHARACTER(LEN=*),INTENT(IN) :: string_b
685
LOGICAL :: s_le_c
686
INTEGER :: ls,la,lb
687
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
688
DO i = 1,ls
689
IF( string_a%chars(i) < string_b(i:i) )THEN
690
s_le_c = .TRUE.; RETURN
691
ELSEIF( string_a%chars(i) > string_b(i:i) )THEN
692
s_le_c = .FALSE.; RETURN
693
ENDIF
694
ENDDO
695
IF( la < lb )THEN
696
IF( blank < string_b(la+1:lb) )THEN
697
s_le_c = .TRUE.; RETURN
698
ELSEIF( blank > string_b(la+1:lb) )THEN
699
s_le_c = .FALSE.; RETURN
700
ENDIF
701
ELSEIF( la > lb )THEN
702
DO i = lb+1,la
703
IF( string_a%chars(i) < blank )THEN
704
s_le_c = .TRUE.; RETURN
705
ELSEIF( string_a%chars(i) > blank )THEN
706
s_le_c = .FALSE.; RETURN
707
ENDIF
708
ENDDO
709
ENDIF
710
s_le_c = .TRUE.
711
ENDFUNCTION s_le_c
712
713
ELEMENTAL FUNCTION c_le_s(string_a,string_b) ! character<=string
714
CHARACTER(LEN=*),INTENT(IN) :: string_a
715
type(VAR_STR),INTENT(IN) :: string_b
716
LOGICAL :: c_le_s
717
INTEGER :: ls,la,lb
718
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
719
DO i = 1,ls
720
IF( string_a(i:i) < string_b%chars(i) )THEN
721
c_le_s = .TRUE.; RETURN
722
ELSEIF( string_a(i:i) > string_b%chars(i) )THEN
723
c_le_s = .FALSE.; RETURN
724
ENDIF
725
ENDDO
726
IF( la < lb )THEN
727
DO i = la+1,lb
728
IF( blank < string_b%chars(i) )THEN
729
c_le_s = .TRUE.; RETURN
730
ELSEIF( blank > string_b%chars(i) )THEN
731
c_le_s = .FALSE.; RETURN
732
ENDIF
733
ENDDO
734
ELSEIF( la > lb )THEN
735
IF( string_a(lb+1:la) < blank )THEN
736
c_le_s = .TRUE.; RETURN
737
ELSEIF( string_a(lb+1:la) > blank )THEN
738
c_le_s = .FALSE.; RETURN
739
ENDIF
740
ENDIF
741
c_le_s = .TRUE.
742
ENDFUNCTION c_le_s
743
744
!------ Greater-than-or-equal-to operators -----------------------------------!
745
ELEMENTAL FUNCTION s_ge_s(string_a,string_b) ! string>=string
746
type(VAR_STR),INTENT(IN) :: string_a,string_b
747
LOGICAL :: s_ge_s
748
INTEGER :: ls,la,lb
749
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
750
DO i = 1,ls
751
IF( string_a%chars(i) > string_b%chars(i) )THEN
752
s_ge_s = .TRUE.; RETURN
753
ELSEIF( string_a%chars(i) < string_b%chars(i) )THEN
754
s_ge_s = .FALSE.; RETURN
755
ENDIF
756
ENDDO
757
IF( la < lb )THEN
758
DO i = la+1,lb
759
IF( blank > string_b%chars(i) )THEN
760
s_ge_s = .TRUE.; RETURN
761
ELSEIF( blank < string_b%chars(i) )THEN
762
s_ge_s = .FALSE.; RETURN
763
ENDIF
764
ENDDO
765
ELSEIF( la > lb )THEN
766
DO i = lb+1,la
767
IF( string_a%chars(i) > blank )THEN
768
s_ge_s = .TRUE.; RETURN
769
ELSEIF( string_a%chars(i) < blank )THEN
770
s_ge_s = .FALSE.; RETURN
771
ENDIF
772
ENDDO
773
ENDIF
774
s_ge_s = .TRUE.
775
ENDFUNCTION s_ge_s
776
777
ELEMENTAL FUNCTION s_ge_c(string_a,string_b) ! string>=character
778
type(VAR_STR),INTENT(IN) :: string_a
779
CHARACTER(LEN=*),INTENT(IN) :: string_b
780
LOGICAL :: s_ge_c
781
INTEGER :: ls,la,lb
782
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
783
DO i = 1,ls
784
IF( string_a%chars(i) > string_b(i:i) )THEN
785
s_ge_c = .TRUE.; RETURN
786
ELSEIF( string_a%chars(i) < string_b(i:i) )THEN
787
s_ge_c = .FALSE.; RETURN
788
ENDIF
789
ENDDO
790
IF( la < lb )THEN
791
IF( blank > string_b(la+1:lb) )THEN
792
s_ge_c = .TRUE.; RETURN
793
ELSEIF( blank < string_b(la+1:lb) )THEN
794
s_ge_c = .FALSE.; RETURN
795
ENDIF
796
ELSEIF( la > lb )THEN
797
DO i = lb+1,la
798
IF( string_a%chars(i) > blank )THEN
799
s_ge_c = .TRUE.; RETURN
800
ELSEIF( string_a%chars(i) < blank )THEN
801
s_ge_c = .FALSE.; RETURN
802
ENDIF
803
ENDDO
804
ENDIF
805
s_ge_c = .TRUE.
806
ENDFUNCTION s_ge_c
807
808
ELEMENTAL FUNCTION c_ge_s(string_a,string_b) ! character>=string
809
CHARACTER(LEN=*),INTENT(IN) :: string_a
810
type(VAR_STR),INTENT(IN) :: string_b
811
LOGICAL :: c_ge_s
812
INTEGER :: ls,la,lb
813
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
814
DO i = 1,ls
815
IF( string_a(i:i) > string_b%chars(i) )THEN
816
c_ge_s = .TRUE.; RETURN
817
ELSEIF( string_a(i:i) < string_b%chars(i) )THEN
818
c_ge_s = .FALSE.; RETURN
819
ENDIF
820
ENDDO
821
IF( la < lb )THEN
822
DO i = la+1,lb
823
IF( blank > string_b%chars(i) )THEN
824
c_ge_s = .TRUE.; RETURN
825
ELSEIF( blank < string_b%chars(i) )THEN
826
c_ge_s = .FALSE.; RETURN
827
ENDIF
828
ENDDO
829
ELSEIF( la > lb )THEN
830
IF( string_a(lb+1:la) > blank )THEN
831
c_ge_s = .TRUE.; RETURN
832
ELSEIF( string_a(lb+1:la) < blank )THEN
833
c_ge_s = .FALSE.; RETURN
834
ENDIF
835
ENDIF
836
c_ge_s = .TRUE.
837
ENDFUNCTION c_ge_s
838
839
!------ Greater-than operators -----------------------------------------------!
840
ELEMENTAL FUNCTION s_gt_s(string_a,string_b) ! string>string
841
type(VAR_STR),INTENT(IN) :: string_a,string_b
842
LOGICAL :: s_gt_s
843
INTEGER :: ls,la,lb
844
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
845
DO i = 1,ls
846
IF( string_a%chars(i) > string_b%chars(i) )THEN
847
s_gt_s = .TRUE.; RETURN
848
ELSEIF( string_a%chars(i) < string_b%chars(i) )THEN
849
s_gt_s = .FALSE.; RETURN
850
ENDIF
851
ENDDO
852
IF( la < lb )THEN
853
DO i = la+1,lb
854
IF( blank > string_b%chars(i) )THEN
855
s_gt_s = .TRUE.; RETURN
856
ELSEIF( blank < string_b%chars(i) )THEN
857
s_gt_s = .FALSE.; RETURN
858
ENDIF
859
ENDDO
860
ELSEIF( la > lb )THEN
861
DO i = lb+1,la
862
IF( string_a%chars(i) > blank )THEN
863
s_gt_s = .TRUE.; RETURN
864
ELSEIF( string_a%chars(i) < blank )THEN
865
s_gt_s = .FALSE.; RETURN
866
ENDIF
867
ENDDO
868
ENDIF
869
s_gt_s = .FALSE.
870
ENDFUNCTION s_gt_s
871
872
ELEMENTAL FUNCTION s_gt_c(string_a,string_b) ! string>character
873
type(VAR_STR),INTENT(IN) :: string_a
874
CHARACTER(LEN=*),INTENT(IN) :: string_b
875
LOGICAL :: s_gt_c
876
INTEGER :: ls,la,lb
877
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
878
DO i = 1,ls
879
IF( string_a%chars(i) > string_b(i:i) )THEN
880
s_gt_c = .TRUE.; RETURN
881
ELSEIF( string_a%chars(i) < string_b(i:i) )THEN
882
s_gt_c = .FALSE.; RETURN
883
ENDIF
884
ENDDO
885
IF( la < lb )THEN
886
IF( blank > string_b(la+1:lb) )THEN
887
s_gt_c = .TRUE.; RETURN
888
ELSEIF( blank < string_b(la+1:lb) )THEN
889
s_gt_c = .FALSE.; RETURN
890
ENDIF
891
ELSEIF( la > lb )THEN
892
DO i = lb+1,la
893
IF( string_a%chars(i) > blank )THEN
894
s_gt_c = .TRUE.; RETURN
895
ELSEIF( string_a%chars(i) < blank )THEN
896
s_gt_c = .FALSE.; RETURN
897
ENDIF
898
ENDDO
899
ENDIF
900
s_gt_c = .FALSE.
901
ENDFUNCTION s_gt_c
902
903
ELEMENTAL FUNCTION c_gt_s(string_a,string_b) ! character>string
904
CHARACTER(LEN=*),INTENT(IN) :: string_a
905
type(VAR_STR),INTENT(IN) :: string_b
906
LOGICAL :: c_gt_s
907
INTEGER :: ls,la,lb
908
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
909
DO i = 1,ls
910
IF( string_a(i:i) > string_b%chars(i) )THEN
911
c_gt_s = .TRUE.; RETURN
912
ELSEIF( string_a(i:i) < string_b%chars(i) )THEN
913
c_gt_s = .FALSE.; RETURN
914
ENDIF
915
ENDDO
916
IF( la < lb )THEN
917
DO i = la+1,lb
918
IF( blank > string_b%chars(i) )THEN
919
c_gt_s = .TRUE.; RETURN
920
ELSEIF( blank < string_b%chars(i) )THEN
921
c_gt_s = .FALSE.; RETURN
922
ENDIF
923
ENDDO
924
ELSEIF( la > lb )THEN
925
IF( string_a(lb+1:la) > blank )THEN
926
c_gt_s = .TRUE.; RETURN
927
ELSEIF( string_a(lb+1:la) < blank )THEN
928
c_gt_s = .FALSE.; RETURN
929
ENDIF
930
ENDIF
931
c_gt_s = .FALSE.
932
ENDFUNCTION c_gt_s
933
934
!----- LLT procedures -------------------------------------------------------!
935
ELEMENTAL FUNCTION s_llt_s(string_a,string_b) ! string_a<string_b ISO-646 ordering
936
type(VAR_STR),INTENT(IN) :: string_a,string_b
937
LOGICAL :: s_llt_s
938
! Returns TRUE if string_a preceeds string_b in the ISO 646 collating
939
! sequence. Otherwise the result is FALSE. The result is FALSE if both
940
! string_a and string_b are zero length.
941
INTEGER :: ls,la,lb
942
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
943
DO i = 1,ls
944
IF( LLT(string_a%chars(i),string_b%chars(i)) )THEN
945
s_llt_s = .TRUE.; RETURN
946
ELSEIF( LGT(string_a%chars(i),string_b%chars(i)) )THEN
947
s_llt_s = .FALSE.; RETURN
948
ENDIF
949
ENDDO
950
IF( la < lb )THEN
951
DO i = la+1,lb
952
IF( LLT(blank,string_b%chars(i)) )THEN
953
s_llt_s = .TRUE.; RETURN
954
ELSEIF( LGT(blank,string_b%chars(i)) )THEN
955
s_llt_s = .FALSE.; RETURN
956
ENDIF
957
ENDDO
958
ELSEIF( la > lb )THEN
959
DO i = lb+1,la
960
IF( LLT(string_a%chars(i),blank) )THEN
961
s_llt_s = .TRUE.; RETURN
962
ELSEIF( LGT(string_a%chars(i),blank) )THEN
963
s_llt_s = .FALSE.; RETURN
964
ENDIF
965
ENDDO
966
ENDIF
967
s_llt_s = .FALSE.
968
ENDFUNCTION s_llt_s
969
970
ELEMENTAL FUNCTION s_llt_c(string_a,string_b) ! string_a<string_b ISO-646 ordering
971
type(VAR_STR),INTENT(IN) :: string_a
972
CHARACTER(LEN=*),INTENT(IN) :: string_b
973
LOGICAL :: s_llt_c
974
INTEGER :: ls,la,lb
975
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
976
DO i = 1,ls
977
IF( LLT(string_a%chars(i),string_b(i:i)) )THEN
978
s_llt_c = .TRUE.; RETURN
979
ELSEIF( LGT(string_a%chars(i),string_b(i:i)) )THEN
980
s_llt_c = .FALSE.; RETURN
981
ENDIF
982
ENDDO
983
IF( la < lb )THEN
984
IF( LLT(blank,string_b(la+1:lb)) )THEN
985
s_llt_c = .TRUE.; RETURN
986
ELSEIF( LGT(blank,string_b(la+1:lb)) )THEN
987
s_llt_c = .FALSE.; RETURN
988
ENDIF
989
ELSEIF( la > lb )THEN
990
DO i = lb+1,la
991
IF( LLT(string_a%chars(i),blank) )THEN
992
s_llt_c = .TRUE.; RETURN
993
ELSEIF( LGT(string_a%chars(i),blank) )THEN
994
s_llt_c = .FALSE.; RETURN
995
ENDIF
996
ENDDO
997
ENDIF
998
s_llt_c = .FALSE.
999
ENDFUNCTION s_llt_c
1000
1001
ELEMENTAL FUNCTION c_llt_s(string_a,string_b) ! string_a,string_b ISO-646 ordering
1002
CHARACTER(LEN=*),INTENT(IN) :: string_a
1003
type(VAR_STR),INTENT(IN) :: string_b
1004
LOGICAL :: c_llt_s
1005
INTEGER :: ls,la,lb
1006
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
1007
DO i = 1,ls
1008
IF( LLT(string_a(i:i),string_b%chars(i)) )THEN
1009
c_llt_s = .TRUE.; RETURN
1010
ELSEIF( LGT(string_a(i:i),string_b%chars(i)) )THEN
1011
c_llt_s = .FALSE.; RETURN
1012
ENDIF
1013
ENDDO
1014
IF( la < lb )THEN
1015
DO i = la+1,lb
1016
IF( LLT(blank,string_b%chars(i)) )THEN
1017
c_llt_s = .TRUE.; RETURN
1018
ELSEIF( LGT(blank,string_b%chars(i)) )THEN
1019
c_llt_s = .FALSE.; RETURN
1020
ENDIF
1021
ENDDO
1022
ELSEIF( la > lb )THEN
1023
IF( LLT(string_a(lb+1:la),blank) )THEN
1024
c_llt_s = .TRUE.; RETURN
1025
ELSEIF( LGT(string_a(lb+1:la),blank) )THEN
1026
c_llt_s = .FALSE.; RETURN
1027
ENDIF
1028
ENDIF
1029
c_llt_s = .FALSE.
1030
ENDFUNCTION c_llt_s
1031
1032
!----- LLE procedures -------------------------------------------------------!
1033
ELEMENTAL FUNCTION s_lle_s(string_a,string_b) ! string_a<=string_b ISO-646 ordering
1034
type(VAR_STR),INTENT(IN) :: string_a,string_b
1035
LOGICAL :: s_lle_s
1036
! Returns TRUE if strings are equal or if string_a preceeds string_b in the
1037
! ISO 646 collating sequence. Otherwise the result is FALSE.
1038
INTEGER :: ls,la,lb
1039
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
1040
DO i = 1,ls
1041
IF( LLT(string_a%chars(i),string_b%chars(i)) )THEN
1042
s_lle_s = .TRUE.; RETURN
1043
ELSEIF( LGT(string_a%chars(i),string_b%chars(i)) )THEN
1044
s_lle_s = .FALSE.; RETURN
1045
ENDIF
1046
ENDDO
1047
IF( la < lb )THEN
1048
DO i = la+1,lb
1049
IF( LLT(blank,string_b%chars(i)) )THEN
1050
s_lle_s = .TRUE.; RETURN
1051
ELSEIF( LGT(blank,string_b%chars(i)) )THEN
1052
s_lle_s = .FALSE.; RETURN
1053
ENDIF
1054
ENDDO
1055
ELSEIF( la > lb )THEN
1056
DO i = lb+1,la
1057
IF( LLT(string_a%chars(i),blank) )THEN
1058
s_lle_s = .TRUE.; RETURN
1059
ELSEIF( LGT(string_a%chars(i),blank) )THEN
1060
s_lle_s = .FALSE.; RETURN
1061
ENDIF
1062
ENDDO
1063
ENDIF
1064
s_lle_s = .TRUE.
1065
ENDFUNCTION s_lle_s
1066
1067
ELEMENTAL FUNCTION s_lle_c(string_a,string_b) ! strung_a<=string_b ISO-646 ordering
1068
type(VAR_STR),INTENT(IN) :: string_a
1069
CHARACTER(LEN=*),INTENT(IN) :: string_b
1070
LOGICAL :: s_lle_c
1071
INTEGER :: ls,la,lb
1072
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
1073
DO i = 1,ls
1074
IF( LLT(string_a%chars(i),string_b(i:i)) )THEN
1075
s_lle_c = .TRUE.; RETURN
1076
ELSEIF( LGT(string_a%chars(i),string_b(i:i)) )THEN
1077
s_lle_c = .FALSE.; RETURN
1078
ENDIF
1079
ENDDO
1080
IF( la < lb )THEN
1081
IF( LLT(blank,string_b(la+1:lb)) )THEN
1082
s_lle_c = .TRUE.; RETURN
1083
ELSEIF( LGT(blank,string_b(la+1:lb)) )THEN
1084
s_lle_c = .FALSE.; RETURN
1085
ENDIF
1086
ELSEIF( la > lb )THEN
1087
DO i = lb+1,la
1088
IF( LLT(string_a%chars(i),blank) )THEN
1089
s_lle_c = .TRUE.; RETURN
1090
ELSEIF( LGT(string_a%chars(i),blank) )THEN
1091
s_lle_c = .FALSE.; RETURN
1092
ENDIF
1093
ENDDO
1094
ENDIF
1095
s_lle_c = .TRUE.
1096
ENDFUNCTION s_lle_c
1097
1098
ELEMENTAL FUNCTION c_lle_s(string_a,string_b) ! string_a<=string_b ISO-646 ordering
1099
CHARACTER(LEN=*),INTENT(IN) :: string_a
1100
type(VAR_STR),INTENT(IN) :: string_b
1101
LOGICAL :: c_lle_s
1102
INTEGER :: ls,la,lb
1103
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
1104
DO i = 1,ls
1105
IF( LLT(string_a(i:i),string_b%chars(i)) )THEN
1106
c_lle_s = .TRUE.; RETURN
1107
ELSEIF( LGT(string_a(i:i),string_b%chars(i)) )THEN
1108
c_lle_s = .FALSE.; RETURN
1109
ENDIF
1110
ENDDO
1111
IF( la < lb )THEN
1112
DO i = la+1,lb
1113
IF( LLT(blank,string_b%chars(i)) )THEN
1114
c_lle_s = .TRUE.; RETURN
1115
ELSEIF( LGT(blank,string_b%chars(i)) )THEN
1116
c_lle_s = .FALSE.; RETURN
1117
ENDIF
1118
ENDDO
1119
ELSEIF( la > lb )THEN
1120
IF( LLT(string_a(lb+1:la),blank) )THEN
1121
c_lle_s = .TRUE.; RETURN
1122
ELSEIF( LGT(string_a(lb+1:la),blank) )THEN
1123
c_lle_s = .FALSE.; RETURN
1124
ENDIF
1125
ENDIF
1126
c_lle_s = .TRUE.
1127
ENDFUNCTION c_lle_s
1128
1129
!----- LGE procedures -------------------------------------------------------!
1130
ELEMENTAL FUNCTION s_lge_s(string_a,string_b) ! string_a>=string_b ISO-646 ordering
1131
type(VAR_STR),INTENT(IN) :: string_a,string_b
1132
LOGICAL :: s_lge_s
1133
! Returns TRUE if strings are equal or if string_a follows string_b in the
1134
! ISO 646 collating sequence. Otherwise the result is FALSE.
1135
INTEGER :: ls,la,lb
1136
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
1137
DO i = 1,ls
1138
IF( LGT(string_a%chars(i),string_b%chars(i)) )THEN
1139
s_lge_s = .TRUE.; RETURN
1140
ELSEIF( LLT(string_a%chars(i),string_b%chars(i)) )THEN
1141
s_lge_s = .FALSE.; RETURN
1142
ENDIF
1143
ENDDO
1144
IF( la < lb )THEN
1145
DO i = la+1,lb
1146
IF( LGT(blank,string_b%chars(i)) )THEN
1147
s_lge_s = .TRUE.; RETURN
1148
ELSEIF( LLT(blank,string_b%chars(i)) )THEN
1149
s_lge_s = .FALSE.; RETURN
1150
ENDIF
1151
ENDDO
1152
ELSEIF( la > lb )THEN
1153
DO i = lb+1,la
1154
IF( LGT(string_a%chars(i),blank) )THEN
1155
s_lge_s = .TRUE.; RETURN
1156
ELSEIF( LLT(string_a%chars(i),blank) )THEN
1157
s_lge_s = .FALSE.; RETURN
1158
ENDIF
1159
ENDDO
1160
ENDIF
1161
s_lge_s = .TRUE.
1162
ENDFUNCTION s_lge_s
1163
1164
ELEMENTAL FUNCTION s_lge_c(string_a,string_b) ! string_a>=string_b ISO-646 ordering
1165
type(VAR_STR),INTENT(IN) :: string_a
1166
CHARACTER(LEN=*),INTENT(IN) :: string_b
1167
LOGICAL :: s_lge_c
1168
INTEGER :: ls,la,lb
1169
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
1170
DO i = 1,ls
1171
IF( LGT(string_a%chars(i),string_b(i:i)) )THEN
1172
s_lge_c = .TRUE.; RETURN
1173
ELSEIF( LLT(string_a%chars(i),string_b(i:i)) )THEN
1174
s_lge_c = .FALSE.; RETURN
1175
ENDIF
1176
ENDDO
1177
IF( la < lb )THEN
1178
IF( LGT(blank,string_b(la+1:lb)) )THEN
1179
s_lge_c = .TRUE.; RETURN
1180
ELSEIF( LLT(blank,string_b(la+1:lb)) )THEN
1181
s_lge_c = .FALSE.; RETURN
1182
ENDIF
1183
ELSEIF( la > lb )THEN
1184
DO i = lb+1,la
1185
IF( LGT(string_a%chars(i),blank) )THEN
1186
s_lge_c = .TRUE.; RETURN
1187
ELSEIF( LLT(string_a%chars(i),blank) )THEN
1188
s_lge_c = .FALSE.; RETURN
1189
ENDIF
1190
ENDDO
1191
ENDIF
1192
s_lge_c = .TRUE.
1193
ENDFUNCTION s_lge_c
1194
1195
ELEMENTAL FUNCTION c_lge_s(string_a,string_b) ! string_a>=string_b ISO-646 ordering
1196
CHARACTER(LEN=*),INTENT(IN) :: string_a
1197
type(VAR_STR),INTENT(IN) :: string_b
1198
LOGICAL :: c_lge_s
1199
INTEGER :: ls,la,lb
1200
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
1201
DO i = 1,ls
1202
IF( LGT(string_a(i:i),string_b%chars(i)) )THEN
1203
c_lge_s = .TRUE.; RETURN
1204
ELSEIF( LLT(string_a(i:i),string_b%chars(i)) )THEN
1205
c_lge_s = .FALSE.; RETURN
1206
ENDIF
1207
ENDDO
1208
IF( la < lb )THEN
1209
DO i = la+1,lb
1210
IF( LGT(blank,string_b%chars(i)) )THEN
1211
c_lge_s = .TRUE.; RETURN
1212
ELSEIF( LLT(blank,string_b%chars(i)) )THEN
1213
c_lge_s = .FALSE.; RETURN
1214
ENDIF
1215
ENDDO
1216
ELSEIF( la > lb )THEN
1217
IF( LGT(string_a(lb+1:la),blank) )THEN
1218
c_lge_s = .TRUE.; RETURN
1219
ELSEIF( LLT(string_a(lb+1:la),blank) )THEN
1220
c_lge_s = .FALSE.; RETURN
1221
ENDIF
1222
ENDIF
1223
c_lge_s = .TRUE.
1224
ENDFUNCTION c_lge_s
1225
1226
!----- LGT procedures -------------------------------------------------------!
1227
ELEMENTAL FUNCTION s_lgt_s(string_a,string_b) ! string_a>string_b ISO-646 ordering
1228
type(VAR_STR),INTENT(IN) :: string_a,string_b
1229
LOGICAL :: s_lgt_s
1230
! Returns TRUE if string_a follows string_b in the ISO 646 collating sequence.
1231
! Otherwise the result is FALSE. The result is FALSE if both string_a and
1232
! string_b are zero length.
1233
INTEGER :: ls,la,lb
1234
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
1235
DO i = 1,ls
1236
IF( LGT(string_a%chars(i),string_b%chars(i)) )THEN
1237
s_lgt_s = .TRUE.; RETURN
1238
ELSEIF( LLT(string_a%chars(i),string_b%chars(i)) )THEN
1239
s_lgt_s = .FALSE.; RETURN
1240
ENDIF
1241
ENDDO
1242
IF( la < lb )THEN
1243
DO i = la+1,lb
1244
IF( LGT(blank,string_b%chars(i)) )THEN
1245
s_lgt_s = .TRUE.; RETURN
1246
ELSEIF( LLT(blank,string_b%chars(i)) )THEN
1247
s_lgt_s = .FALSE.; RETURN
1248
ENDIF
1249
ENDDO
1250
ELSEIF( la > lb )THEN
1251
DO i = lb+1,la
1252
IF( LGT(string_a%chars(i),blank) )THEN
1253
s_lgt_s = .TRUE.; RETURN
1254
ELSEIF( LLT(string_a%chars(i),blank) )THEN
1255
s_lgt_s = .FALSE.; RETURN
1256
ENDIF
1257
ENDDO
1258
ENDIF
1259
s_lgt_s = .FALSE.
1260
ENDFUNCTION s_lgt_s
1261
1262
ELEMENTAL FUNCTION s_lgt_c(string_a,string_b) ! string_a>string_b ISO-646 ordering
1263
type(VAR_STR),INTENT(IN) :: string_a
1264
CHARACTER(LEN=*),INTENT(IN) :: string_b
1265
LOGICAL :: s_lgt_c
1266
INTEGER :: ls,la,lb
1267
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
1268
DO i = 1,ls
1269
IF( LGT(string_a%chars(i),string_b(i:i)) )THEN
1270
s_lgt_c = .TRUE.; RETURN
1271
ELSEIF( LLT(string_a%chars(i),string_b(i:i)) )THEN
1272
s_lgt_c = .FALSE.; RETURN
1273
ENDIF
1274
ENDDO
1275
IF( la < lb )THEN
1276
IF( LGT(blank,string_b(la+1:lb)) )THEN
1277
s_lgt_c = .TRUE.; RETURN
1278
ELSEIF( LLT(blank,string_b(la+1:lb)) )THEN
1279
s_lgt_c = .FALSE.; RETURN
1280
ENDIF
1281
ELSEIF( la > lb )THEN
1282
DO i = lb+1,la
1283
IF( LGT(string_a%chars(i),blank) )THEN
1284
s_lgt_c = .TRUE.; RETURN
1285
ELSEIF( LLT(string_a%chars(i),blank) )THEN
1286
s_lgt_c = .FALSE.; RETURN
1287
ENDIF
1288
ENDDO
1289
ENDIF
1290
s_lgt_c = .FALSE.
1291
ENDFUNCTION s_lgt_c
1292
1293
ELEMENTAL FUNCTION c_lgt_s(string_a,string_b) ! string_a>string_b ISO-646 ordering
1294
CHARACTER(LEN=*),INTENT(IN) :: string_a
1295
type(VAR_STR),INTENT(IN) :: string_b
1296
LOGICAL :: c_lgt_s
1297
INTEGER :: ls,la,lb
1298
la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb)
1299
DO i = 1,ls
1300
IF( LGT(string_a(i:i),string_b%chars(i)) )THEN
1301
c_lgt_s = .TRUE.; RETURN
1302
ELSEIF( LLT(string_a(i:i),string_b%chars(i)) )THEN
1303
c_lgt_s = .FALSE.; RETURN
1304
ENDIF
1305
ENDDO
1306
IF( la < lb )THEN
1307
DO i = la+1,lb
1308
IF( LGT(blank,string_b%chars(i)) )THEN
1309
c_lgt_s = .TRUE.; RETURN
1310
ELSEIF( LLT(blank,string_b%chars(i)) )THEN
1311
c_lgt_s = .FALSE.; RETURN
1312
ENDIF
1313
ENDDO
1314
ELSEIF( la > lb )THEN
1315
IF( LGT(string_a(lb+1:la),blank) )THEN
1316
c_lgt_s = .TRUE.; RETURN
1317
ELSEIF( LLT(string_a(lb+1:la),blank) )THEN
1318
c_lgt_s = .FALSE.; RETURN
1319
ENDIF
1320
ENDIF
1321
c_lgt_s = .FALSE.
1322
ENDFUNCTION c_lgt_s
1323
1324
1325
!----- Input string procedure -----------------------------------------------!
1326
SUBROUTINE get_d_eor(string,maxlen,iostat)
1327
type(VAR_STR),INTENT(OUT) :: string
1328
! the string variable to be filled with
1329
! characters read from the
1330
! file connected to the default unit
1331
INTEGER,INTENT(IN),OPTIONAL :: maxlen
1332
! if present indicates the maximum
1333
! number of characters that will be
1334
! read from the file
1335
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1336
! if present used to return the status
1337
! of the data transfer
1338
! if absent errors cause termination
1339
! reads string from the default unit starting at next character in the file
1340
! and terminating at the end of record or after maxlen characters.
1341
CHARACTER(LEN=80) :: buffer
1342
INTEGER :: ist,nch,toread,nb
1343
IF(PRESENT(maxlen))THEN
1344
toread=maxlen
1345
ELSE
1346
toread=HUGE(1)
1347
ENDIF
1348
string = "" ! clears return string N.B. will also deallocate string via the
1349
! assignment operation
1350
DO ! repeatedly read buffer and add to string until EoR
1351
! or maxlen reached
1352
IF(toread <= 0)EXIT
1353
nb=MIN(80,toread)
1354
READ(*,FMT='(A)',ADVANCE='NO',EOR=9999,SIZE=nch,IOSTAT=ist) buffer(1:nb)
1355
IF( ist /= 0 )THEN
1356
IF(PRESENT(iostat)) THEN
1357
iostat=ist
1358
RETURN
1359
ELSE
1360
WRITE(*,*) " Error No.",ist, &
1361
" during READ_STRING of varying string on default unit"
1362
STOP
1363
ENDIF
1364
ENDIF
1365
string = string //buffer(1:nb)
1366
toread = toread - nb
1367
ENDDO
1368
IF(PRESENT(iostat)) iostat = 0
1369
RETURN
1370
9999 string = string //buffer(1:nch)
1371
IF(PRESENT(iostat)) iostat = ist
1372
ENDSUBROUTINE get_d_eor
1373
1374
SUBROUTINE get_u_eor(unit,string,maxlen,iostat)
1375
INTEGER,INTENT(IN) :: unit
1376
! identifies the input unit which must be
1377
! connected for sequential formatted read
1378
type(VAR_STR),INTENT(OUT) :: string
1379
! the string variable to be filled with
1380
! characters read from the
1381
! file connected to the unit
1382
INTEGER,INTENT(IN),OPTIONAL :: maxlen
1383
! if present indicates the maximum
1384
! number of characters that will be
1385
! read from the file
1386
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1387
! if present used to return the status
1388
! of the data transfer
1389
! if absent errors cause termination
1390
! reads string from unit starting at next character in the file and
1391
! terminating at the end of record or after maxlen characters.
1392
CHARACTER(LEN=80) :: buffer
1393
INTEGER :: ist,nch,toread,nb
1394
IF(PRESENT(maxlen))THEN
1395
toread=maxlen
1396
ELSE
1397
toread=HUGE(1)
1398
ENDIF
1399
string="" ! clears return string N.B. will also deallocate string via the
1400
! assignment operation
1401
DO ! repeatedly read buffer and add to string until EoR
1402
! or maxlen reached
1403
IF(toread <= 0)EXIT
1404
nb=MIN(80,toread)
1405
READ(unit,FMT='(A)',ADVANCE='NO',EOR=9999,SIZE=nch,IOSTAT=ist) buffer(1:nb)
1406
IF( ist /= 0 )THEN
1407
IF(PRESENT(iostat)) THEN
1408
iostat=ist
1409
RETURN
1410
ELSE
1411
WRITE(*,*) " Error No.",ist, &
1412
" during READ_STRING of varying string on UNIT ",unit
1413
STOP
1414
ENDIF
1415
ENDIF
1416
string = string //buffer(1:nb)
1417
toread = toread - nb
1418
ENDDO
1419
IF(PRESENT(iostat)) iostat = 0
1420
RETURN
1421
9999 string = string //buffer(1:nch)
1422
IF(PRESENT(iostat)) iostat = ist
1423
ENDSUBROUTINE get_u_eor
1424
1425
SUBROUTINE get_d_tset_s(string,set,separator,maxlen,iostat)
1426
type(VAR_STR),INTENT(OUT) :: string
1427
! the string variable to be filled with
1428
! characters read from the
1429
! file connected to the default unit
1430
type(VAR_STR),INTENT(IN) :: set
1431
! the set of characters which if found in
1432
! the input terminate the read
1433
type(VAR_STR),INTENT(OUT),OPTIONAL :: separator
1434
! the actual separator character from set
1435
! found as the input string terminator
1436
! returned as zero length if termination
1437
! by maxlen or EOR
1438
INTEGER,INTENT(IN),OPTIONAL :: maxlen
1439
! if present indicates the maximum
1440
! number of characters that will be
1441
! read from the file
1442
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1443
! if present used to return the status
1444
! of the data transfer
1445
! if absent errors cause termination
1446
! reads string from the default unit starting at next character in the file and
1447
! terminating at the end of record, occurance of a character in set,
1448
! or after reading maxlen characters.
1449
CHARACTER :: buffer ! characters must be read one at a time to detect
1450
! first terminator character in set
1451
INTEGER :: ist,toread,lenset
1452
lenset = LEN(set)
1453
IF(PRESENT(maxlen))THEN
1454
toread=maxlen
1455
ELSE
1456
toread=HUGE(1)
1457
ENDIF
1458
string = "" ! clears return string N.B. will also deallocate string via the
1459
! assignment operation
1460
IF(PRESENT(separator)) separator="" ! clear the separator
1461
readchar:DO ! repeatedly read buffer and add to string
1462
IF(toread <= 0)EXIT readchar ! maxlen reached
1463
READ(*,FMT='(A)',ADVANCE='NO',EOR=9999,IOSTAT=ist) buffer
1464
IF( ist /= 0 )THEN
1465
IF(PRESENT(iostat)) THEN
1466
iostat=ist
1467
RETURN
1468
ELSE
1469
WRITE(*,*) " Error No.",ist, &
1470
" during GET of varying string on default unit"
1471
STOP
1472
ENDIF
1473
ENDIF
1474
! check for occurance of set character in buffer
1475
DO j = 1,lenset
1476
IF(buffer == set%chars(j))THEN
1477
IF(PRESENT(separator)) separator=buffer
1478
EXIT readchar ! separator terminator found
1479
ENDIF
1480
ENDDO
1481
string = string//buffer
1482
toread = toread - 1
1483
ENDDO readchar
1484
IF(PRESENT(iostat)) iostat = 0
1485
RETURN
1486
9999 CONTINUE ! EOR terminator read
1487
IF(PRESENT(iostat)) iostat = ist
1488
ENDSUBROUTINE get_d_tset_s
1489
1490
SUBROUTINE get_u_tset_s(unit,string,set,separator,maxlen,iostat)
1491
INTEGER,INTENT(IN) :: unit
1492
! identifies the input unit which must be
1493
! connected for sequential formatted read
1494
type(VAR_STR),INTENT(OUT) :: string
1495
! the string variable to be filled with
1496
! characters read from the
1497
! file connected to the unit
1498
type(VAR_STR),INTENT(IN) :: set
1499
! the set of characters which if found in
1500
! the input terminate the read
1501
type(VAR_STR),INTENT(OUT),OPTIONAL :: separator
1502
! the actual separator character from set
1503
! found as the input string terminator
1504
! returned as zero length if termination
1505
! by maxlen or EOR
1506
INTEGER,INTENT(IN),OPTIONAL :: maxlen
1507
! if present indicates the maximum
1508
! number of characters that will be
1509
! read from the file
1510
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1511
! if present used to return the status
1512
! of the data transfer
1513
! if absent errors cause termination
1514
! reads string from unit starting at next character in the file and
1515
! terminating at the end of record, occurance of a character in set,
1516
! or after reading maxlen characters.
1517
CHARACTER :: buffer ! characters must be read one at a time to detect
1518
! first terminator character in set
1519
INTEGER :: ist,toread,lenset
1520
lenset = LEN(set)
1521
IF(PRESENT(maxlen))THEN
1522
toread=maxlen
1523
ELSE
1524
toread=HUGE(1)
1525
ENDIF
1526
string = "" ! clears return string N.B. will also deallocate string via the
1527
! assignment operation
1528
IF(PRESENT(separator)) separator="" ! clear the separator
1529
readchar:DO ! repeatedly read buffer and add to string
1530
IF(toread <= 0)EXIT readchar ! maxlen reached
1531
READ(unit,FMT='(A)',ADVANCE='NO',EOR=9999,IOSTAT=ist) buffer
1532
IF( ist /= 0 )THEN
1533
IF(PRESENT(iostat)) THEN
1534
iostat=ist
1535
RETURN
1536
ELSE
1537
WRITE(*,*) " Error No.",ist, &
1538
" during GET of varying string on unit ",unit
1539
STOP
1540
ENDIF
1541
ENDIF
1542
! check for occurance of set character in buffer
1543
DO j = 1,lenset
1544
IF(buffer == set%chars(j))THEN
1545
IF(PRESENT(separator)) separator=buffer
1546
EXIT readchar ! separator terminator found
1547
ENDIF
1548
ENDDO
1549
string = string//buffer
1550
toread = toread - 1
1551
ENDDO readchar
1552
IF(PRESENT(iostat)) iostat = 0
1553
RETURN
1554
9999 CONTINUE ! EOR terminator found
1555
IF(PRESENT(iostat)) iostat = ist
1556
ENDSUBROUTINE get_u_tset_s
1557
1558
SUBROUTINE get_d_tset_c(string,set,separator,maxlen,iostat)
1559
type(VAR_STR),INTENT(OUT) :: string
1560
! the string variable to be filled with
1561
! characters read from the
1562
! file connected to the default unit
1563
CHARACTER(LEN=*),INTENT(IN) :: set
1564
! the set of characters which if found in
1565
! the input terminate the read
1566
type(VAR_STR),INTENT(OUT),OPTIONAL :: separator
1567
! the actual separator character from set
1568
! found as the input string terminator
1569
! returned as zero length if termination
1570
! by maxlen or EOR
1571
INTEGER,INTENT(IN),OPTIONAL :: maxlen
1572
! if present indicates the maximum
1573
! number of characters that will be
1574
! read from the file
1575
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1576
! if present used to return the status
1577
! of the data transfer
1578
! if absent errors cause termination
1579
! reads string from the default unit starting at next character in the file and
1580
! terminating at the end of record, occurance of a character in set,
1581
! or after reading maxlen characters.
1582
CHARACTER :: buffer ! characters must be read one at a time to detect
1583
! first terminator character in set
1584
INTEGER :: ist,toread,lenset
1585
lenset = LEN(set)
1586
IF(PRESENT(maxlen))THEN
1587
toread=maxlen
1588
ELSE
1589
toread=HUGE(1)
1590
ENDIF
1591
string = "" ! clears return string N.B. will also deallocate string via the
1592
! assignment operation
1593
IF(PRESENT(separator)) separator="" ! clear separator
1594
readchar:DO ! repeatedly read buffer and add to string
1595
IF(toread <= 0)EXIT readchar ! maxlen reached
1596
READ(*,FMT='(A)',ADVANCE='NO',EOR=9999,IOSTAT=ist) buffer
1597
IF( ist /= 0 )THEN
1598
IF(PRESENT(iostat)) THEN
1599
iostat=ist
1600
RETURN
1601
ELSE
1602
WRITE(*,*) " Error No.",ist, &
1603
" during GET of varying string on default unit"
1604
STOP
1605
ENDIF
1606
ENDIF
1607
! check for occurance of set character in buffer
1608
DO j = 1,lenset
1609
IF(buffer == set(j:j))THEN
1610
IF(PRESENT(separator)) separator=buffer
1611
EXIT readchar
1612
ENDIF
1613
ENDDO
1614
string = string//buffer
1615
toread = toread - 1
1616
ENDDO readchar
1617
IF(PRESENT(iostat)) iostat = 0
1618
RETURN
1619
9999 CONTINUE ! EOR terminator read
1620
IF(PRESENT(iostat)) iostat = ist
1621
ENDSUBROUTINE get_d_tset_c
1622
1623
SUBROUTINE get_u_tset_c(unit,string,set,separator,maxlen,iostat)
1624
INTEGER,INTENT(IN) :: unit
1625
! identifies the input unit which must be
1626
! connected for sequential formatted read
1627
type(VAR_STR),INTENT(OUT) :: string
1628
! the string variable to be filled with
1629
! characters read from the
1630
! file connected to the unit
1631
CHARACTER(LEN=*),INTENT(IN) :: set
1632
! the set of characters which if found in
1633
! the input terminate the read
1634
type(VAR_STR),INTENT(OUT),OPTIONAL :: separator
1635
! the actual separator character from set
1636
! found as the input string terminator
1637
! returned as zero length if termination
1638
! by maxlen or EOR
1639
INTEGER,INTENT(IN),OPTIONAL :: maxlen
1640
! if present indicates the maximum
1641
! number of characters that will be
1642
! read from the file
1643
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1644
! if present used to return the status
1645
! of the data transfer
1646
! if absent errors cause termination
1647
! reads string from unit starting at next character in the file and
1648
! terminating at the end of record, occurance of a character in set,
1649
! or after reading maxlen characters.
1650
CHARACTER :: buffer ! characters must be read one at a time to detect
1651
! first terminator character in set
1652
INTEGER :: ist,toread,lenset
1653
lenset = LEN(set)
1654
IF(PRESENT(maxlen))THEN
1655
toread=maxlen
1656
ELSE
1657
toread=HUGE(1)
1658
ENDIF
1659
string = "" ! clears return string N.B. will also deallocate string via the
1660
! assignment operation
1661
IF(PRESENT(separator)) separator="" ! clear separator
1662
readchar:DO ! repeatedly read buffer and add to string
1663
IF(toread <= 0)EXIT readchar ! maxlen reached
1664
READ(unit,FMT='(A)',ADVANCE='NO',EOR=9999,IOSTAT=ist) buffer
1665
IF( ist /= 0 )THEN
1666
IF(PRESENT(iostat)) THEN
1667
iostat=ist
1668
RETURN
1669
ELSE
1670
WRITE(*,*) " Error No.",ist, &
1671
" during GET of varying string on unit ",unit
1672
STOP
1673
ENDIF
1674
ENDIF
1675
! check for occurance of set character in buffer
1676
DO j = 1,lenset
1677
IF(buffer == set(j:j))THEN
1678
IF(PRESENT(separator)) separator=buffer
1679
EXIT readchar ! separator terminator found
1680
ENDIF
1681
ENDDO
1682
string = string//buffer
1683
toread = toread - 1
1684
ENDDO readchar
1685
IF(PRESENT(iostat)) iostat = 0
1686
RETURN
1687
9999 CONTINUE ! EOR terminator read
1688
IF(PRESENT(iostat)) iostat = ist
1689
ENDSUBROUTINE get_u_tset_c
1690
1691
!----- Output string procedures ----------------------------------------------!
1692
SUBROUTINE put_d_s(string,iostat)
1693
type(VAR_STR),INTENT(IN) :: string
1694
! the string variable to be appended to
1695
! the current record or to the start of
1696
! the next record if there is no
1697
! current record
1698
! uses the default unit
1699
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1700
! if present used to return the status
1701
! of the data transfer
1702
! if absent errors cause termination
1703
INTEGER :: ist
1704
WRITE(*,FMT='(A)',ADVANCE='NO',IOSTAT=ist) CHAR(string)
1705
IF( ist /= 0 )THEN
1706
IF(PRESENT(iostat))THEN
1707
iostat = ist
1708
RETURN
1709
ELSE
1710
WRITE(*,*) " Error No.",ist, &
1711
" during PUT of varying string on default unit"
1712
STOP
1713
ENDIF
1714
ENDIF
1715
IF(PRESENT(iostat)) iostat=0
1716
ENDSUBROUTINE put_d_s
1717
1718
SUBROUTINE put_u_s(unit,string,iostat)
1719
INTEGER,INTENT(IN) :: unit
1720
! identifies the output unit which must
1721
! be connected for sequential formatted
1722
! write
1723
type(VAR_STR),INTENT(IN) :: string
1724
! the string variable to be appended to
1725
! the current record or to the start of
1726
! the next record if there is no
1727
! current record
1728
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1729
! if present used to return the status
1730
! of the data transfer
1731
! if absent errors cause termination
1732
INTEGER :: ist
1733
WRITE(unit,FMT='(A)',ADVANCE='NO',IOSTAT=ist) CHAR(string)
1734
IF( ist /= 0 )THEN
1735
IF(PRESENT(iostat))THEN
1736
iostat = ist
1737
RETURN
1738
ELSE
1739
WRITE(*,*) " Error No.",ist, &
1740
" during PUT of varying string on UNIT ",unit
1741
STOP
1742
ENDIF
1743
ENDIF
1744
IF(PRESENT(iostat)) iostat=0
1745
ENDSUBROUTINE put_u_s
1746
1747
SUBROUTINE put_d_c(string,iostat)
1748
CHARACTER(LEN=*),INTENT(IN) :: string
1749
! the character variable to be appended to
1750
! the current record or to the start of
1751
! the next record if there is no
1752
! current record
1753
! uses the default unit
1754
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1755
! if present used to return the status
1756
! of the data transfer
1757
! if absent errors cause termination
1758
INTEGER :: ist
1759
WRITE(*,FMT='(A)',ADVANCE='NO',IOSTAT=ist) string
1760
IF( ist /= 0 )THEN
1761
IF(PRESENT(iostat))THEN
1762
iostat = ist
1763
RETURN
1764
ELSE
1765
WRITE(*,*) " Error No.",ist, &
1766
" during PUT of character on default unit"
1767
STOP
1768
ENDIF
1769
ENDIF
1770
IF(PRESENT(iostat)) iostat=0
1771
ENDSUBROUTINE put_d_c
1772
1773
SUBROUTINE put_u_c(unit,string,iostat)
1774
INTEGER,INTENT(IN) :: unit
1775
! identifies the output unit which must
1776
! be connected for sequential formatted
1777
! write
1778
CHARACTER(LEN=*),INTENT(IN) :: string
1779
! the character variable to be appended to
1780
! the current record or to the start of
1781
! the next record if there is no
1782
! current record
1783
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1784
! if present used to return the status
1785
! of the data transfer
1786
! if absent errors cause termination
1787
INTEGER :: ist
1788
WRITE(unit,FMT='(A)',ADVANCE='NO',IOSTAT=ist) string
1789
IF( ist /= 0 )THEN
1790
IF(PRESENT(iostat))THEN
1791
iostat = ist
1792
RETURN
1793
ELSE
1794
WRITE(*,*) " Error No.",ist," during PUT of character on UNIT ",unit
1795
STOP
1796
ENDIF
1797
ENDIF
1798
IF(PRESENT(iostat)) iostat=0
1799
ENDSUBROUTINE put_u_c
1800
1801
SUBROUTINE putline_d_s(string,iostat)
1802
type(VAR_STR),INTENT(IN) :: string
1803
! the string variable to be appended to
1804
! the current record or to the start of
1805
! the next record if there is no
1806
! current record
1807
! uses the default unit
1808
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1809
! if present used to return the status
1810
! of the data transfer
1811
! if absent errors cause termination
1812
! appends the string to the current record and then ends the record
1813
! leaves the file positioned after the record just completed which then
1814
! becomes the previous and last record in the file.
1815
INTEGER :: ist
1816
WRITE(*,FMT='(A,/)',ADVANCE='NO',IOSTAT=ist) CHAR(string)
1817
IF( ist /= 0 )THEN
1818
IF(PRESENT(iostat))THEN
1819
iostat = ist; RETURN
1820
ELSE
1821
WRITE(*,*) " Error No.",ist, &
1822
" during PUT_LINE of varying string on default unit"
1823
STOP
1824
ENDIF
1825
ENDIF
1826
IF(PRESENT(iostat)) iostat=0
1827
ENDSUBROUTINE putline_d_s
1828
1829
SUBROUTINE putline_u_s(unit,string,iostat)
1830
INTEGER,INTENT(IN) :: unit
1831
! identifies the output unit which must
1832
! be connected for sequential formatted
1833
! write
1834
type(VAR_STR),INTENT(IN) :: string
1835
! the string variable to be appended to
1836
! the current record or to the start of
1837
! the next record if there is no
1838
! current record
1839
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1840
! if present used to return the status
1841
! of the data transfer
1842
! if absent errors cause termination
1843
! appends the string to the current record and then ends the record
1844
! leaves the file positioned after the record just completed which then
1845
! becomes the previous and last record in the file.
1846
INTEGER :: ist
1847
WRITE(unit,FMT='(A,/)',ADVANCE='NO',IOSTAT=ist) CHAR(string)
1848
IF( ist /= 0 )THEN
1849
IF(PRESENT(iostat))THEN
1850
iostat = ist; RETURN
1851
ELSE
1852
WRITE(*,*) " Error No.",ist, &
1853
" during PUT_LINE of varying string on UNIT",unit
1854
STOP
1855
ENDIF
1856
ENDIF
1857
IF(PRESENT(iostat)) iostat=0
1858
ENDSUBROUTINE putline_u_s
1859
1860
SUBROUTINE putline_d_c(string,iostat)
1861
CHARACTER(LEN=*),INTENT(IN) :: string
1862
! the character variable to be appended to
1863
! the current record or to the start of
1864
! the next record if there is no
1865
! current record
1866
! uses the default unit
1867
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1868
! if present used to return the status
1869
! of the data transfer
1870
! if absent errors cause termination
1871
! appends the string to the current record and then ends the record
1872
! leaves the file positioned after the record just completed which then
1873
! becomes the previous and last record in the file.
1874
INTEGER :: ist
1875
WRITE(*,FMT='(A,/)',ADVANCE='NO',IOSTAT=ist) string
1876
IF(PRESENT(iostat))THEN
1877
iostat = ist
1878
RETURN
1879
ELSEIF( ist /= 0 )THEN
1880
WRITE(*,*) " Error No.",ist, &
1881
" during PUT_LINE of character on default unit"
1882
STOP
1883
ENDIF
1884
ENDSUBROUTINE putline_d_c
1885
1886
SUBROUTINE putline_u_c(unit,string,iostat)
1887
INTEGER,INTENT(IN) :: unit
1888
! identifies the output unit which must
1889
! be connected for sequential formatted
1890
! write
1891
CHARACTER(LEN=*),INTENT(IN) :: string
1892
! the character variable to be appended to
1893
! the current record or to the start of
1894
! the next record if there is no
1895
! current record
1896
INTEGER,INTENT(OUT),OPTIONAL :: iostat
1897
! if present used to return the status
1898
! of the data transfer
1899
! if absent errors cause termination
1900
! appends the string to the current record and then ends the record
1901
! leaves the file positioned after the record just completed which then
1902
! becomes the previous and last record in the file.
1903
INTEGER :: ist
1904
WRITE(unit,FMT='(A,/)',ADVANCE='NO',IOSTAT=ist) string
1905
IF(PRESENT(iostat))THEN
1906
iostat = ist
1907
RETURN
1908
ELSEIF( ist /= 0 )THEN
1909
WRITE(*,*) " Error No.",ist, &
1910
" during WRITE_LINE of character on UNIT",unit
1911
STOP
1912
ENDIF
1913
ENDSUBROUTINE putline_u_c
1914
1915
!----- Insert procedures ----------------------------------------------------!
1916
ELEMENTAL FUNCTION insert_ss(string,start,substring)
1917
type(VAR_STR) :: insert_ss
1918
type(VAR_STR),INTENT(IN) :: string
1919
INTEGER,INTENT(IN) :: start
1920
type(VAR_STR),INTENT(IN) :: substring
1921
! calculates result string by inserting the substring into string
1922
! beginning at position start pushing the remainder of the string
1923
! to the right and enlarging it accordingly,
1924
! if start is greater than LEN(string) the substring is simply appended
1925
! to string by concatenation. if start is less than 1
1926
! substring is inserted before string, ie. start is treated as if it were 1
1927
CHARACTER,POINTER,DIMENSION(:) :: work
1928
INTEGER :: ip,is,lsub,ls
1929
lsub = LEN(substring); ls = LEN(string)
1930
is = MAX(start,1)
1931
ip = MIN(ls+1,is)
1932
ALLOCATE(work(1:lsub+ls))
1933
work(1:ip-1) = string%chars(1:ip-1)
1934
work(ip:ip+lsub-1) =substring%chars
1935
work(ip+lsub:lsub+ls) = string%chars(ip:ls)
1936
insert_ss%chars => work
1937
ENDFUNCTION insert_ss
1938
1939
ELEMENTAL FUNCTION insert_sc(string,start,substring)
1940
type(VAR_STR) :: insert_sc
1941
type(VAR_STR),INTENT(IN) :: string
1942
INTEGER,INTENT(IN) :: start
1943
CHARACTER(LEN=*),INTENT(IN) :: substring
1944
! calculates result string by inserting the substring into string
1945
! beginning at position start pushing the remainder of the string
1946
! to the right and enlarging it accordingly,
1947
! if start is greater than LEN(string) the substring is simply appended
1948
! to string by concatenation. if start is less than 1
1949
! substring is inserted before string, ie. start is treated as if it were 1
1950
CHARACTER,POINTER,DIMENSION(:) :: work
1951
INTEGER :: ip,is,lsub,ls
1952
lsub = LEN(substring); ls = LEN(string)
1953
is = MAX(start,1)
1954
ip = MIN(ls+1,is)
1955
ALLOCATE(work(1:lsub+ls))
1956
work(1:ip-1) = string%chars(1:ip-1)
1957
DO i = 1,lsub
1958
work(ip-1+i) = substring(i:i)
1959
ENDDO
1960
work(ip+lsub:lsub+ls) = string%chars(ip:ls)
1961
insert_sc%chars => work
1962
ENDFUNCTION insert_sc
1963
1964
ELEMENTAL FUNCTION insert_cs(string,start,substring)
1965
type(VAR_STR) :: insert_cs
1966
CHARACTER(LEN=*),INTENT(IN) :: string
1967
INTEGER,INTENT(IN) :: start
1968
type(VAR_STR),INTENT(IN) :: substring
1969
! calculates result string by inserting the substring into string
1970
! beginning at position start pushing the remainder of the string
1971
! to the right and enlarging it accordingly,
1972
! if start is greater than LEN(string) the substring is simply appended
1973
! to string by concatenation. if start is less than 1
1974
! substring is inserted before string, ie. start is treated as if it were 1
1975
CHARACTER,POINTER,DIMENSION(:) :: work
1976
INTEGER :: ip,is,lsub,ls
1977
lsub = LEN(substring); ls = LEN(string)
1978
is = MAX(start,1)
1979
ip = MIN(ls+1,is)
1980
ALLOCATE(work(1:lsub+ls))
1981
DO i=1,ip-1
1982
work(i) = string(i:i)
1983
ENDDO
1984
work(ip:ip+lsub-1) =substring%chars
1985
DO i=ip,ls
1986
work(i+lsub) = string(i:i)
1987
ENDDO
1988
insert_cs%chars => work
1989
ENDFUNCTION insert_cs
1990
1991
ELEMENTAL FUNCTION insert_cc(string,start,substring)
1992
type(VAR_STR) :: insert_cc
1993
CHARACTER(LEN=*),INTENT(IN) :: string
1994
INTEGER,INTENT(IN) :: start
1995
CHARACTER(LEN=*),INTENT(IN) :: substring
1996
! calculates result string by inserting the substring into string
1997
! beginning at position start pushing the remainder of the string
1998
! to the right and enlarging it accordingly,
1999
! if start is greater than LEN(string) the substring is simply appended
2000
! to string by concatenation. if start is less than 1
2001
! substring is inserted before string, ie. start is treated as if it were 1
2002
CHARACTER,POINTER,DIMENSION(:) :: work
2003
INTEGER :: ip,is,lsub,ls
2004
lsub = LEN(substring); ls = LEN(string)
2005
is = MAX(start,1)
2006
ip = MIN(ls+1,is)
2007
ALLOCATE(work(1:lsub+ls))
2008
DO i=1,ip-1
2009
work(i) = string(i:i)
2010
ENDDO
2011
DO i = 1,lsub
2012
work(ip-1+i) = substring(i:i)
2013
ENDDO
2014
DO i=ip,ls
2015
work(i+lsub) = string(i:i)
2016
ENDDO
2017
insert_cc%chars => work
2018
ENDFUNCTION insert_cc
2019
2020
!----- Replace procedures ---------------------------------------------------!
2021
ELEMENTAL FUNCTION replace_ss(string,start,substring)
2022
type(VAR_STR) :: replace_ss
2023
type(VAR_STR),INTENT(IN) :: string
2024
INTEGER,INTENT(IN) :: start
2025
type(VAR_STR),INTENT(IN) :: substring
2026
! calculates the result string by the following actions:
2027
! inserts the substring into string beginning at position
2028
! start replacing the following LEN(substring) characters of the string
2029
! and enlarging string if necessary. if start is greater than LEN(string)
2030
! substring is simply appended to string by concatenation. If start is less
2031
! than 1, substring replaces characters in string starting at 1
2032
CHARACTER,POINTER,DIMENSION(:) :: work
2033
INTEGER :: ip,is,nw,lsub,ls
2034
lsub = LEN(substring); ls = LEN(string)
2035
is = MAX(start,1)
2036
ip = MIN(ls+1,is)
2037
nw = MAX(ls,ip+lsub-1)
2038
ALLOCATE(work(1:nw))
2039
work(1:ip-1) = string%chars(1:ip-1)
2040
work(ip:ip+lsub-1) = substring%chars
2041
work(ip+lsub:nw) = string%chars(ip+lsub:ls)
2042
replace_ss%chars => work
2043
ENDFUNCTION replace_ss
2044
2045
ELEMENTAL FUNCTION replace_ss_sf(string,start,finish,substring)
2046
type(VAR_STR) :: replace_ss_sf
2047
type(VAR_STR),INTENT(IN) :: string
2048
INTEGER,INTENT(IN) :: start,finish
2049
type(VAR_STR),INTENT(IN) :: substring
2050
! calculates the result string by the following actions:
2051
! inserts the substring into string beginning at position
2052
! start replacing the following finish-start+1 characters of the string
2053
! and enlarging or shrinking the string if necessary.
2054
! If start is greater than LEN(string) substring is simply appended to string
2055
! by concatenation. If start is less than 1, start = 1 is used
2056
! If finish is greater than LEN(string), finish = LEN(string) is used
2057
! If finish is less than start, substring is inserted before start
2058
CHARACTER,POINTER,DIMENSION(:) :: work
2059
INTEGER :: ip,is,if,nw,lsub,ls
2060
lsub = LEN(substring); ls = LEN(string)
2061
is = MAX(start,1)
2062
ip = MIN(ls+1,is)
2063
if = MAX(ip-1,MIN(finish,ls))
2064
nw = lsub + ls - if+ip-1
2065
ALLOCATE(work(1:nw))
2066
work(1:ip-1) = string%chars(1:ip-1)
2067
work(ip:ip+lsub-1) = substring%chars
2068
work(ip+lsub:nw) = string%chars(if+1:ls)
2069
replace_ss_sf%chars => work
2070
ENDFUNCTION replace_ss_sf
2071
2072
ELEMENTAL FUNCTION replace_sc(string,start,substring)
2073
type(VAR_STR) :: replace_sc
2074
type(VAR_STR),INTENT(IN) :: string
2075
INTEGER,INTENT(IN) :: start
2076
CHARACTER(LEN=*),INTENT(IN) :: substring
2077
! calculates the result string by the following actions:
2078
! inserts the characters from substring into string beginning at position
2079
! start replacing the following LEN(substring) characters of the string
2080
! and enlarging string if necessary. If start is greater than LEN(string)
2081
! substring is simply appended to string by concatenation. If start is less
2082
! than 1, substring replaces characters in string starting at 1
2083
CHARACTER,POINTER,DIMENSION(:) :: work
2084
INTEGER :: ip,is,nw,lsub,ls
2085
lsub = LEN(substring); ls = LEN(string)
2086
is = MAX(start,1)
2087
ip = MIN(ls+1,is)
2088
nw = MAX(ls,ip+lsub-1)
2089
ALLOCATE(work(1:nw))
2090
work(1:ip-1) = string%chars(1:ip-1)
2091
DO i = 1,lsub
2092
work(ip-1+i) = substring(i:i)
2093
ENDDO
2094
work(ip+lsub:nw) = string%chars(ip+lsub:ls)
2095
replace_sc%chars => work
2096
ENDFUNCTION replace_sc
2097
2098
ELEMENTAL FUNCTION replace_sc_sf(string,start,finish,substring)
2099
type(VAR_STR) :: replace_sc_sf
2100
type(VAR_STR),INTENT(IN) :: string
2101
INTEGER,INTENT(IN) :: start,finish
2102
CHARACTER(LEN=*),INTENT(IN) :: substring
2103
! calculates the result string by the following actions:
2104
! inserts the substring into string beginning at position
2105
! start replacing the following finish-start+1 characters of the string
2106
! and enlarging or shrinking the string if necessary.
2107
! If start is greater than LEN(string) substring is simply appended to string
2108
! by concatenation. If start is less than 1, start = 1 is used
2109
! If finish is greater than LEN(string), finish = LEN(string) is used
2110
! If finish is less than start, substring is inserted before start
2111
CHARACTER,POINTER,DIMENSION(:) :: work
2112
INTEGER :: ip,is,if,nw,lsub,ls
2113
lsub = LEN(substring); ls = LEN(string)
2114
is = MAX(start,1)
2115
ip = MIN(ls+1,is)
2116
if = MAX(ip-1,MIN(finish,ls))
2117
nw = lsub + ls - if+ip-1
2118
ALLOCATE(work(1:nw))
2119
work(1:ip-1) = string%chars(1:ip-1)
2120
DO i = 1,lsub
2121
work(ip-1+i) = substring(i:i)
2122
ENDDO
2123
work(ip+lsub:nw) = string%chars(if+1:ls)
2124
replace_sc_sf%chars => work
2125
ENDFUNCTION replace_sc_sf
2126
2127
ELEMENTAL FUNCTION replace_cs(string,start,substring)
2128
type(VAR_STR) :: replace_cs
2129
CHARACTER(LEN=*),INTENT(IN) :: string
2130
INTEGER,INTENT(IN) :: start
2131
type(VAR_STR),INTENT(IN) :: substring
2132
! calculates the result string by the following actions:
2133
! inserts the substring into string beginning at position
2134
! start replacing the following LEN(substring) characters of the string
2135
! and enlarging string if necessary. if start is greater than LEN(string)
2136
! substring is simply appended to string by concatenation. If start is less
2137
! than 1, substring replaces characters in string starting at 1
2138
CHARACTER,POINTER,DIMENSION(:) :: work
2139
INTEGER :: ip,is,nw,lsub,ls
2140
lsub = LEN(substring); ls = LEN(string)
2141
is = MAX(start,1)
2142
ip = MIN(ls+1,is)
2143
nw = MAX(ls,ip+lsub-1)
2144
ALLOCATE(work(1:nw))
2145
DO i=1,ip-1
2146
work(i) = string(i:i)
2147
ENDDO
2148
work(ip:ip+lsub-1) = substring%chars
2149
DO i=ip+lsub,nw
2150
work(i) = string(i:i)
2151
ENDDO
2152
replace_cs%chars => work
2153
ENDFUNCTION replace_cs
2154
2155
ELEMENTAL FUNCTION replace_cs_sf(string,start,finish,substring)
2156
type(VAR_STR) :: replace_cs_sf
2157
CHARACTER(LEN=*),INTENT(IN) :: string
2158
INTEGER,INTENT(IN) :: start,finish
2159
type(VAR_STR),INTENT(IN) :: substring
2160
! calculates the result string by the following actions:
2161
! inserts the substring into string beginning at position
2162
! start replacing the following finish-start+1 characters of the string
2163
! and enlarging or shrinking the string if necessary.
2164
! If start is greater than LEN(string) substring is simply appended to string
2165
! by concatenation. If start is less than 1, start = 1 is used
2166
! If finish is greater than LEN(string), finish = LEN(string) is used
2167
! If finish is less than start, substring is inserted before start
2168
CHARACTER,POINTER,DIMENSION(:) :: work
2169
INTEGER :: ip,is,if,nw,lsub,ls
2170
lsub = LEN(substring); ls = LEN(string)
2171
is = MAX(start,1)
2172
ip = MIN(ls+1,is)
2173
if = MAX(ip-1,MIN(finish,ls))
2174
nw = lsub + ls - if+ip-1
2175
ALLOCATE(work(1:nw))
2176
DO i=1,ip-1
2177
work(i) = string(i:i)
2178
ENDDO
2179
work(ip:ip+lsub-1) = substring%chars
2180
DO i=1,nw-ip-lsub+1
2181
work(i+ip+lsub-1) = string(if+i:if+i)
2182
ENDDO
2183
replace_cs_sf%chars => work
2184
ENDFUNCTION replace_cs_sf
2185
2186
ELEMENTAL FUNCTION replace_cc(string,start,substring)
2187
type(VAR_STR) :: replace_cc
2188
CHARACTER(LEN=*),INTENT(IN) :: string
2189
INTEGER,INTENT(IN) :: start
2190
CHARACTER(LEN=*),INTENT(IN) :: substring
2191
! calculates the result string by the following actions:
2192
! inserts the characters from substring into string beginning at position
2193
! start replacing the following LEN(substring) characters of the string
2194
! and enlarging string if necessary. If start is greater than LEN(string)
2195
! substring is simply appended to string by concatenation. If start is less
2196
! than 1, substring replaces characters in string starting at 1
2197
CHARACTER,POINTER,DIMENSION(:) :: work
2198
INTEGER :: ip,is,nw,lsub,ls
2199
lsub = LEN(substring); ls = LEN(string)
2200
is = MAX(start,1)
2201
ip = MIN(ls+1,is)
2202
nw = MAX(ls,ip+lsub-1)
2203
ALLOCATE(work(1:nw))
2204
DO i=1,ip-1
2205
work(i) = string(i:i)
2206
ENDDO
2207
DO i=1,lsub
2208
work(ip-1+i) = substring(i:i)
2209
ENDDO
2210
DO i=ip+lsub,nw
2211
work(i) = string(i:i)
2212
ENDDO
2213
replace_cc%chars => work
2214
ENDFUNCTION replace_cc
2215
2216
ELEMENTAL FUNCTION replace_cc_sf(string,start,finish,substring)
2217
type(VAR_STR) :: replace_cc_sf
2218
CHARACTER(LEN=*),INTENT(IN) :: string
2219
INTEGER,INTENT(IN) :: start,finish
2220
CHARACTER(LEN=*),INTENT(IN) :: substring
2221
! calculates the result string by the following actions:
2222
! inserts the substring into string beginning at position
2223
! start replacing the following finish-start+1 characters of the string
2224
! and enlarging or shrinking the string if necessary.
2225
! If start is greater than LEN(string) substring is simply appended to string
2226
! by concatenation. If start is less than 1, start = 1 is used
2227
! If finish is greater than LEN(string), finish = LEN(string) is used
2228
! If finish is less than start, substring is inserted before start
2229
CHARACTER,POINTER,DIMENSION(:) :: work
2230
INTEGER :: ip,is,if,nw,lsub,ls
2231
lsub = LEN(substring); ls = LEN(string)
2232
is = MAX(start,1)
2233
ip = MIN(ls+1,is)
2234
if = MAX(ip-1,MIN(finish,ls))
2235
nw = lsub + ls - if+ip-1
2236
ALLOCATE(work(1:nw))
2237
DO i=1,ip-1
2238
work(i) = string(i:i)
2239
ENDDO
2240
DO i=1,lsub
2241
work(i+ip-1) = substring(i:i)
2242
ENDDO
2243
DO i=1,nw-ip-lsub+1
2244
work(i+ip+lsub-1) = string(if+i:if+i)
2245
ENDDO
2246
replace_cc_sf%chars => work
2247
ENDFUNCTION replace_cc_sf
2248
2249
ELEMENTAL FUNCTION replace_sss(string,target,substring,every,back)
2250
type(VAR_STR) :: replace_sss
2251
type(VAR_STR),INTENT(IN) :: string,target,substring
2252
LOGICAL,INTENT(IN),OPTIONAL :: every,back
2253
! calculates the result string by the following actions:
2254
! searches for occurences of target in string, and replaces these with
2255
! substring. if back present with value true search is backward otherwise
2256
! search is done forward. if every present with value true all occurences
2257
! of target in string are replaced, otherwise only the first found is
2258
! replaced. if target is not found the result is the same as string.
2259
LOGICAL :: dir_switch, rep_search
2260
CHARACTER,DIMENSION(:),POINTER :: work,temp
2261
INTEGER :: ls,lt,lsub,ipos,ipow
2262
ls = LEN(string); lt = LEN(target); lsub = LEN(substring)
2263
IF(lt==0)THEN
2264
IF(ls==0)THEN
2265
ALLOCATE(replace_sss%chars(1:lsub))
2266
replace_sss%chars = substring%chars
2267
RETURN
2268
ELSE
2269
ALLOCATE(replace_sss%chars(1:ls))
2270
replace_sss%chars = string%chars
2271
RETURN
2272
ENDIF
2273
ENDIF
2274
ALLOCATE(work(1:ls)); work = string%chars
2275
IF( PRESENT(back) )THEN
2276
dir_switch = back
2277
ELSE
2278
dir_switch = .FALSE.
2279
ENDIF
2280
IF( PRESENT(every) )THEN
2281
rep_search = every
2282
ELSE
2283
rep_search = .FALSE.
2284
ENDIF
2285
IF( dir_switch )THEN ! backwards search
2286
ipos = ls-lt+1
2287
DO
2288
IF( ipos < 1 )EXIT ! search past start of string
2289
! test for occurance of target in string at this position
2290
IF( ALL(string%chars(ipos:ipos+lt-1) == target%chars) )THEN
2291
! match found allocate space for string with this occurance of
2292
! target replaced by substring
2293
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2294
! copy work into temp replacing this occurance of target by
2295
! substring
2296
temp(1:ipos-1) = work(1:ipos-1)
2297
temp(ipos:ipos+lsub-1) = substring%chars
2298
temp(ipos+lsub:) = work(ipos+lt:)
2299
work => temp ! make new version of work point at the temp space
2300
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2301
! move search and replacement positions over the effected positions
2302
ipos = ipos-lt+1
2303
ENDIF
2304
ipos=ipos-1
2305
ENDDO
2306
ELSE ! forward search
2307
ipos = 1; ipow = 1
2308
DO
2309
IF( ipos > ls-lt+1 )EXIT ! search past end of string
2310
! test for occurance of target in string at this position
2311
IF( ALL(string%chars(ipos:ipos+lt-1) == target%chars) )THEN
2312
! match found allocate space for string with this occurance of
2313
! target replaced by substring
2314
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2315
! copy work into temp replacing this occurance of target by
2316
! substring
2317
temp(1:ipow-1) = work(1:ipow-1)
2318
temp(ipow:ipow+lsub-1) = substring%chars
2319
temp(ipow+lsub:) = work(ipow+lt:)
2320
work => temp ! make new version of work point at the temp space
2321
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2322
! move search and replacement positions over the effected positions
2323
ipos = ipos+lt-1; ipow = ipow+lsub-1
2324
ENDIF
2325
ipos=ipos+1; ipow=ipow+1
2326
ENDDO
2327
ENDIF
2328
replace_sss%chars => work
2329
ENDFUNCTION replace_sss
2330
2331
ELEMENTAL FUNCTION replace_ssc(string,target,substring,every,back)
2332
type(VAR_STR) :: replace_ssc
2333
type(VAR_STR),INTENT(IN) :: string,target
2334
CHARACTER(LEN=*),INTENT(IN) :: substring
2335
LOGICAL,INTENT(IN),OPTIONAL :: every,back
2336
! calculates the result string by the following actions:
2337
! searches for occurences of target in string, and replaces these with
2338
! substring. if back present with value true search is backward otherwise
2339
! search is done forward. if every present with value true all occurences
2340
! of target in string are replaced, otherwise only the first found is
2341
! replaced. if target is not found the result is the same as string.
2342
LOGICAL :: dir_switch, rep_search
2343
CHARACTER,DIMENSION(:),POINTER :: work,temp
2344
INTEGER :: ls,lt,lsub,ipos,ipow
2345
ls = LEN(string); lt = LEN(target); lsub = LEN(substring)
2346
IF(lt==0)THEN
2347
IF(ls==0)THEN
2348
ALLOCATE(replace_ssc%chars(1:lsub))
2349
DO i=1,lsub
2350
replace_ssc%chars(i) = substring(i:i)
2351
ENDDO
2352
RETURN
2353
ELSE
2354
ALLOCATE(replace_ssc%chars(1:ls))
2355
replace_ssc%chars = string%chars
2356
RETURN
2357
ENDIF
2358
ENDIF
2359
ALLOCATE(work(1:ls)); work = string%chars
2360
IF( PRESENT(back) )THEN
2361
dir_switch = back
2362
ELSE
2363
dir_switch = .FALSE.
2364
ENDIF
2365
IF( PRESENT(every) )THEN
2366
rep_search = every
2367
ELSE
2368
rep_search = .FALSE.
2369
ENDIF
2370
IF( dir_switch )THEN ! backwards search
2371
ipos = ls-lt+1
2372
DO
2373
IF( ipos < 1 )EXIT ! search past start of string
2374
! test for occurance of target in string at this position
2375
IF( ALL(string%chars(ipos:ipos+lt-1) == target%chars) )THEN
2376
! match found allocate space for string with this occurance of
2377
! target replaced by substring
2378
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2379
! copy work into temp replacing this occurance of target by
2380
! substring
2381
temp(1:ipos-1) = work(1:ipos-1)
2382
DO i=1,lsub
2383
temp(i+ipos-1) = substring(i:i)
2384
ENDDO
2385
temp(ipos+lsub:) = work(ipos+lt:)
2386
work => temp ! make new version of work point at the temp space
2387
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2388
! move search and replacement positions over the effected positions
2389
ipos = ipos-lt+1
2390
ENDIF
2391
ipos=ipos-1
2392
ENDDO
2393
ELSE ! forward search
2394
ipos = 1; ipow = 1
2395
DO
2396
IF( ipos > ls-lt+1 )EXIT ! search past end of string
2397
! test for occurance of target in string at this position
2398
IF( ALL(string%chars(ipos:ipos+lt-1) == target%chars) )THEN
2399
! match found allocate space for string with this occurance of
2400
! target replaced by substring
2401
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2402
! copy work into temp replacing this occurance of target by
2403
! substring
2404
temp(1:ipow-1) = work(1:ipow-1)
2405
DO i=1,lsub
2406
temp(i+ipow-1) = substring(i:i)
2407
ENDDO
2408
temp(ipow+lsub:) = work(ipow+lt:)
2409
work => temp ! make new version of work point at the temp space
2410
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2411
! move search and replacement positions over the effected positions
2412
ipos = ipos+lt-1; ipow = ipow+lsub-1
2413
ENDIF
2414
ipos=ipos+1; ipow=ipow+1
2415
ENDDO
2416
ENDIF
2417
replace_ssc%chars => work
2418
ENDFUNCTION replace_ssc
2419
2420
ELEMENTAL FUNCTION replace_scs(string,target,substring,every,back)
2421
type(VAR_STR) :: replace_scs
2422
type(VAR_STR),INTENT(IN) :: string,substring
2423
CHARACTER(LEN=*),INTENT(IN) :: target
2424
LOGICAL,INTENT(IN),OPTIONAL :: every,back
2425
! calculates the result string by the following actions:
2426
! searches for occurences of target in string, and replaces these with
2427
! substring. if back present with value true search is backward otherwise
2428
! search is done forward. if every present with value true all accurences
2429
! of target in string are replaced, otherwise only the first found is
2430
! replaced. if target is not found the result is the same as string.
2431
LOGICAL :: dir_switch, rep_search
2432
CHARACTER,DIMENSION(:),POINTER :: work,temp,tget
2433
INTEGER :: ls,lt,lsub,ipos,ipow
2434
ls = LEN(string); lt = LEN(target); lsub = LEN(substring)
2435
IF(lt==0)THEN
2436
IF(ls==0)THEN
2437
ALLOCATE(replace_scs%chars(1:lsub))
2438
replace_scs%chars = substring%chars
2439
RETURN
2440
ELSE
2441
ALLOCATE(replace_scs%chars(1:ls))
2442
replace_scs%chars = string%chars
2443
RETURN
2444
ENDIF
2445
ENDIF
2446
ALLOCATE(work(1:ls)); work = string%chars
2447
ALLOCATE(tget(1:lt))
2448
DO i=1,lt
2449
tget(i) = target(i:i)
2450
ENDDO
2451
IF( PRESENT(back) )THEN
2452
dir_switch = back
2453
ELSE
2454
dir_switch = .FALSE.
2455
ENDIF
2456
IF( PRESENT(every) )THEN
2457
rep_search = every
2458
ELSE
2459
rep_search = .FALSE.
2460
ENDIF
2461
IF( dir_switch )THEN ! backwards search
2462
ipos = ls-lt+1
2463
DO
2464
IF( ipos < 1 )EXIT ! search past start of string
2465
! test for occurance of target in string at this position
2466
IF( ALL(string%chars(ipos:ipos+lt-1) == tget) )THEN
2467
! match found allocate space for string with this occurance of
2468
! target replaced by substring
2469
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2470
! copy work into temp replacing this occurance of target by
2471
! substring
2472
temp(1:ipos-1) = work(1:ipos-1)
2473
temp(ipos:ipos+lsub-1) = substring%chars
2474
temp(ipos+lsub:) = work(ipos+lt:)
2475
work => temp ! make new version of work point at the temp space
2476
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2477
! move search and replacement positions over the effected positions
2478
ipos = ipos-lt+1
2479
ENDIF
2480
ipos=ipos-1
2481
ENDDO
2482
ELSE ! forward search
2483
ipos = 1; ipow = 1
2484
DO
2485
IF( ipos > ls-lt+1 )EXIT ! search past end of string
2486
! test for occurance of target in string at this position
2487
IF( ALL(string%chars(ipos:ipos+lt-1) == tget) )THEN
2488
! match found allocate space for string with this occurance of
2489
! target replaced by substring
2490
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2491
! copy work into temp replacing this occurance of target by
2492
! substring
2493
temp(1:ipow-1) = work(1:ipow-1)
2494
temp(ipow:ipow+lsub-1) = substring%chars
2495
temp(ipow+lsub:) = work(ipow+lt:)
2496
work => temp ! make new version of work point at the temp space
2497
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2498
! move search and replacement positions over the effected positions
2499
ipos = ipos+lt-1; ipow = ipow+lsub-1
2500
ENDIF
2501
ipos=ipos+1; ipow=ipow+1
2502
ENDDO
2503
ENDIF
2504
replace_scs%chars => work
2505
ENDFUNCTION replace_scs
2506
2507
ELEMENTAL FUNCTION replace_scc(string,target,substring,every,back)
2508
type(VAR_STR) :: replace_scc
2509
type(VAR_STR),INTENT(IN) :: string
2510
CHARACTER(LEN=*),INTENT(IN) :: target,substring
2511
LOGICAL,INTENT(IN),OPTIONAL :: every,back
2512
! calculates the result string by the following actions:
2513
! searches for occurences of target in string, and replaces these with
2514
! substring. if back present with value true search is backward otherwise
2515
! search is done forward. if every present with value true all accurences
2516
! of target in string are replaced, otherwise only the first found is
2517
! replaced. if target is not found the result is the same as string.
2518
LOGICAL :: dir_switch, rep_search
2519
CHARACTER,DIMENSION(:),POINTER :: work,temp,tget
2520
INTEGER :: ls,lt,lsub,ipos,ipow
2521
ls = LEN(string); lt = LEN(target); lsub = LEN(substring)
2522
IF(lt==0)THEN
2523
IF(ls==0)THEN
2524
ALLOCATE(replace_scc%chars(1:lsub))
2525
DO i=1,lsub
2526
replace_scc%chars(i) = substring(i:i)
2527
ENDDO
2528
RETURN
2529
ELSE
2530
ALLOCATE(replace_scc%chars(1:ls))
2531
replace_scc%chars = string%chars
2532
RETURN
2533
ENDIF
2534
ENDIF
2535
ALLOCATE(work(1:ls)); work = string%chars
2536
ALLOCATE(tget(1:lt))
2537
DO i=1,lt
2538
tget(i) = target(i:i)
2539
ENDDO
2540
IF( PRESENT(back) )THEN
2541
dir_switch = back
2542
ELSE
2543
dir_switch = .FALSE.
2544
ENDIF
2545
IF( PRESENT(every) )THEN
2546
rep_search = every
2547
ELSE
2548
rep_search = .FALSE.
2549
ENDIF
2550
IF( dir_switch )THEN ! backwards search
2551
ipos = ls-lt+1
2552
DO
2553
IF( ipos < 1 )EXIT ! search past start of string
2554
! test for occurance of target in string at this position
2555
IF( ALL(string%chars(ipos:ipos+lt-1) == tget) )THEN
2556
! match found allocate space for string with this occurance of
2557
! target replaced by substring
2558
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2559
! copy work into temp replacing this occurance of target by
2560
! substring
2561
temp(1:ipos-1) = work(1:ipos-1)
2562
DO i=1,lsub
2563
temp(i+ipos-1) = substring(i:i)
2564
ENDDO
2565
temp(ipos+lsub:) = work(ipos+lt:)
2566
work => temp ! make new version of work point at the temp space
2567
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2568
! move search and replacement positions over the effected positions
2569
ipos = ipos-lt+1
2570
ENDIF
2571
ipos=ipos-1
2572
ENDDO
2573
ELSE ! forward search
2574
ipos = 1; ipow = 1
2575
DO
2576
IF( ipos > ls-lt+1 )EXIT ! search past end of string
2577
! test for occurance of target in string at this position
2578
IF( ALL(string%chars(ipos:ipos+lt-1) == tget) )THEN
2579
! match found allocate space for string with this occurance of
2580
! target replaced by substring
2581
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2582
! copy work into temp replacing this occurance of target by
2583
! substring
2584
temp(1:ipow-1) = work(1:ipow-1)
2585
DO i=1,lsub
2586
temp(i+ipow-1) = substring(i:i)
2587
ENDDO
2588
temp(ipow+lsub:) = work(ipow+lt:)
2589
work => temp ! make new version of work point at the temp space
2590
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2591
! move search and replacement positions over the effected positions
2592
ipos = ipos+lt-1; ipow = ipow+lsub-1
2593
ENDIF
2594
ipos=ipos+1; ipow=ipow+1
2595
ENDDO
2596
ENDIF
2597
replace_scc%chars => work
2598
ENDFUNCTION replace_scc
2599
2600
ELEMENTAL FUNCTION replace_css(string,target,substring,every,back)
2601
type(VAR_STR) :: replace_css
2602
CHARACTER(LEN=*),INTENT(IN) :: string
2603
type(VAR_STR),INTENT(IN) :: target,substring
2604
LOGICAL,INTENT(IN),OPTIONAL :: every,back
2605
! calculates the result string by the following actions:
2606
! searches for occurences of target in string, and replaces these with
2607
! substring. if back present with value true search is backward otherwise
2608
! search is done forward. if every present with value true all accurences
2609
! of target in string are replaced, otherwise only the first found is
2610
! replaced. if target is not found the result is the same as string.
2611
LOGICAL :: dir_switch, rep_search
2612
CHARACTER,DIMENSION(:),POINTER :: work,temp,str
2613
INTEGER :: ls,lt,lsub,ipos,ipow
2614
ls = LEN(string); lt = LEN(target); lsub = LEN(substring)
2615
IF(lt==0)THEN
2616
IF(ls==0)THEN
2617
ALLOCATE(replace_css%chars(1:lsub))
2618
replace_css%chars = substring%chars
2619
RETURN
2620
ELSE
2621
ALLOCATE(replace_css%chars(1:ls))
2622
DO i=1,ls
2623
replace_css%chars(i) = string(i:i)
2624
ENDDO
2625
RETURN
2626
ENDIF
2627
ENDIF
2628
ALLOCATE(work(1:ls)); ALLOCATE(str(1:ls))
2629
DO i=1,ls
2630
str(i) = string(i:i)
2631
ENDDO
2632
work = str
2633
IF( PRESENT(back) )THEN
2634
dir_switch = back
2635
ELSE
2636
dir_switch = .FALSE.
2637
ENDIF
2638
IF( PRESENT(every) )THEN
2639
rep_search = every
2640
ELSE
2641
rep_search = .FALSE.
2642
ENDIF
2643
IF( dir_switch )THEN ! backwards search
2644
ipos = ls-lt+1
2645
DO
2646
IF( ipos < 1 )EXIT ! search past start of string
2647
! test for occurance of target in string at this position
2648
IF( ALL(str(ipos:ipos+lt-1) == target%chars) )THEN
2649
! match found allocate space for string with this occurance of
2650
! target replaced by substring
2651
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2652
! copy work into temp replacing this occurance of target by
2653
! substring
2654
temp(1:ipos-1) = work(1:ipos-1)
2655
temp(ipos:ipos+lsub-1) = substring%chars
2656
temp(ipos+lsub:) = work(ipos+lt:)
2657
work => temp ! make new version of work point at the temp space
2658
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2659
! move search and replacement positions over the effected positions
2660
ipos = ipos-lt+1
2661
ENDIF
2662
ipos=ipos-1
2663
ENDDO
2664
ELSE ! forward search
2665
ipos = 1; ipow = 1
2666
DO
2667
IF( ipos > ls-lt+1 )EXIT ! search past end of string
2668
! test for occurance of target in string at this position
2669
IF( ALL(str(ipos:ipos+lt-1) == target%chars) )THEN
2670
! match found allocate space for string with this occurance of
2671
! target replaced by substring
2672
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2673
! copy work into temp replacing this occurance of target by
2674
! substring
2675
temp(1:ipow-1) = work(1:ipow-1)
2676
temp(ipow:ipow+lsub-1) = substring%chars
2677
temp(ipow+lsub:) = work(ipow+lt:)
2678
work => temp ! make new version of work point at the temp space
2679
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2680
! move search and replacement positions over the effected positions
2681
ipos = ipos+lt-1; ipow = ipow+lsub-1
2682
ENDIF
2683
ipos=ipos+1; ipow=ipow+1
2684
ENDDO
2685
ENDIF
2686
replace_css%chars => work
2687
ENDFUNCTION replace_css
2688
2689
ELEMENTAL FUNCTION replace_csc(string,target,substring,every,back)
2690
type(VAR_STR) :: replace_csc
2691
type(VAR_STR),INTENT(IN) :: target
2692
CHARACTER(LEN=*),INTENT(IN) :: string,substring
2693
LOGICAL,INTENT(IN),OPTIONAL :: every,back
2694
! calculates the result string by the following actions:
2695
! searches for occurences of target in string, and replaces these with
2696
! substring. if back present with value true search is backward otherwise
2697
! search is done forward. if every present with value true all accurences
2698
! of target in string are replaced, otherwise only the first found is
2699
! replaced. if target is not found the result is the same as string.
2700
LOGICAL :: dir_switch, rep_search
2701
CHARACTER,DIMENSION(:),POINTER :: work,temp,str
2702
INTEGER :: ls,lt,lsub,ipos,ipow
2703
ls = LEN(string); lt = LEN(target); lsub = LEN(substring)
2704
IF(lt==0)THEN
2705
IF(ls==0)THEN
2706
ALLOCATE(replace_csc%chars(1:lsub))
2707
DO i=1,lsub
2708
replace_csc%chars(i) = substring(i:i)
2709
ENDDO
2710
RETURN
2711
ELSE
2712
ALLOCATE(replace_csc%chars(1:ls))
2713
DO i=1,ls
2714
replace_csc%chars(i) = string(i:i)
2715
ENDDO
2716
RETURN
2717
ENDIF
2718
ENDIF
2719
ALLOCATE(work(1:ls)); ALLOCATE(str(1:ls))
2720
DO i=1,ls
2721
str(i) = string(i:i)
2722
ENDDO
2723
work = str
2724
IF( PRESENT(back) )THEN
2725
dir_switch = back
2726
ELSE
2727
dir_switch = .FALSE.
2728
ENDIF
2729
IF( PRESENT(every) )THEN
2730
rep_search = every
2731
ELSE
2732
rep_search = .FALSE.
2733
ENDIF
2734
IF( dir_switch )THEN ! backwards search
2735
ipos = ls-lt+1
2736
DO
2737
IF( ipos < 1 )EXIT ! search past start of string
2738
! test for occurance of target in string at this position
2739
IF( ALL(str(ipos:ipos+lt-1) == target%chars) )THEN
2740
! match found allocate space for string with this occurance of
2741
! target replaced by substring
2742
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2743
! copy work into temp replacing this occurance of target by
2744
! substring
2745
temp(1:ipos-1) = work(1:ipos-1)
2746
DO i=1,lsub
2747
temp(i+ipos-1) = substring(i:i)
2748
ENDDO
2749
temp(ipos+lsub:) = work(ipos+lt:)
2750
work => temp ! make new version of work point at the temp space
2751
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2752
! move search and replacement positions over the effected positions
2753
ipos = ipos-lt+1
2754
ENDIF
2755
ipos=ipos-1
2756
ENDDO
2757
ELSE ! forward search
2758
ipos = 1; ipow = 1
2759
DO
2760
IF( ipos > ls-lt+1 )EXIT ! search past end of string
2761
! test for occurance of target in string at this position
2762
IF( ALL(str(ipos:ipos+lt-1) == target%chars) )THEN
2763
! match found allocate space for string with this occurance of
2764
! target replaced by substring
2765
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2766
! copy work into temp replacing this occurance of target by
2767
! substring
2768
temp(1:ipow-1) = work(1:ipow-1)
2769
DO i=1,lsub
2770
temp(i+ipow-1) = substring(i:i)
2771
ENDDO
2772
temp(ipow+lsub:) = work(ipow+lt:)
2773
work => temp ! make new version of work point at the temp space
2774
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2775
! move search and replacement positions over the effected positions
2776
ipos = ipos+lt-1; ipow = ipow+lsub-1
2777
ENDIF
2778
ipos=ipos+1; ipow=ipow+1
2779
ENDDO
2780
ENDIF
2781
replace_csc%chars => work
2782
ENDFUNCTION replace_csc
2783
2784
ELEMENTAL FUNCTION replace_ccs(string,target,substring,every,back)
2785
type(VAR_STR) :: replace_ccs
2786
type(VAR_STR),INTENT(IN) :: substring
2787
CHARACTER(LEN=*),INTENT(IN) :: string,target
2788
LOGICAL,INTENT(IN),OPTIONAL :: every,back
2789
! calculates the result string by the following actions:
2790
! searches for occurences of target in string, and replaces these with
2791
! substring. if back present with value true search is backward otherwise
2792
! search is done forward. if every present with value true all accurences
2793
! of target in string are replaced, otherwise only the first found is
2794
! replaced. if target is not found the result is the same as string.
2795
LOGICAL :: dir_switch, rep_search
2796
CHARACTER,DIMENSION(:),POINTER :: work,temp
2797
INTEGER :: ls,lt,lsub,ipos,ipow
2798
ls = LEN(string); lt = LEN(target); lsub = LEN(substring)
2799
IF(lt==0)THEN
2800
IF(ls==0)THEN
2801
ALLOCATE(replace_ccs%chars(1:lsub))
2802
replace_ccs%chars = substring%chars
2803
RETURN
2804
ELSE
2805
ALLOCATE(replace_ccs%chars(1:ls))
2806
DO i=1,ls
2807
replace_ccs%chars(i) = string(i:i)
2808
ENDDO
2809
RETURN
2810
ENDIF
2811
ENDIF
2812
ALLOCATE(work(1:ls))
2813
DO i=1,ls
2814
work(i) = string(i:i)
2815
ENDDO
2816
IF( PRESENT(back) )THEN
2817
dir_switch = back
2818
ELSE
2819
dir_switch = .FALSE.
2820
ENDIF
2821
IF( PRESENT(every) )THEN
2822
rep_search = every
2823
ELSE
2824
rep_search = .FALSE.
2825
ENDIF
2826
IF( dir_switch )THEN ! backwards search
2827
ipos = ls-lt+1
2828
DO
2829
IF( ipos < 1 )EXIT ! search past start of string
2830
! test for occurance of target in string at this position
2831
IF( string(ipos:ipos+lt-1) == target )THEN
2832
! match found allocate space for string with this occurance of
2833
! target replaced by substring
2834
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2835
! copy work into temp replacing this occurance of target by
2836
! substring
2837
temp(1:ipos-1) = work(1:ipos-1)
2838
temp(ipos:ipos+lsub-1) = substring%chars
2839
temp(ipos+lsub:) = work(ipos+lt:)
2840
work => temp ! make new version of work point at the temp space
2841
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2842
! move search and replacement positions over the effected positions
2843
ipos = ipos-lt+1
2844
ENDIF
2845
ipos=ipos-1
2846
ENDDO
2847
ELSE ! forward search
2848
ipos = 1; ipow = 1
2849
DO
2850
IF( ipos > ls-lt+1 )EXIT ! search past end of string
2851
! test for occurance of target in string at this position
2852
IF( string(ipos:ipos+lt-1) == target )THEN
2853
! match found allocate space for string with this occurance of
2854
! target replaced by substring
2855
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2856
! copy work into temp replacing this occurance of target by
2857
! substring
2858
temp(1:ipow-1) = work(1:ipow-1)
2859
temp(ipow:ipow+lsub-1) = substring%chars
2860
temp(ipow+lsub:) = work(ipow+lt:)
2861
work => temp ! make new version of work point at the temp space
2862
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2863
! move search and replacement positions over the effected positions
2864
ipos = ipos+lt-1; ipow = ipow+lsub-1
2865
ENDIF
2866
ipos=ipos+1; ipow=ipow+1
2867
ENDDO
2868
ENDIF
2869
replace_ccs%chars => work
2870
ENDFUNCTION replace_ccs
2871
2872
ELEMENTAL FUNCTION replace_ccc(string,target,substring,every,back)
2873
type(VAR_STR) :: replace_ccc
2874
CHARACTER(LEN=*),INTENT(IN) :: string,target,substring
2875
LOGICAL,INTENT(IN),OPTIONAL :: every,back
2876
! calculates the result string by the following actions:
2877
! searches for occurences of target in string, and replaces these with
2878
! substring. if back present with value true search is backward otherwise
2879
! search is done forward. if every present with value true all accurences
2880
! of target in string are replaced, otherwise only the first found is
2881
! replaced. if target is not found the result is the same as string.
2882
LOGICAL :: dir_switch, rep_search
2883
CHARACTER,DIMENSION(:),POINTER :: work,temp
2884
INTEGER :: ls,lt,lsub,ipos,ipow
2885
ls = LEN(string); lt = LEN(target); lsub = LEN(substring)
2886
IF(lt==0)THEN
2887
IF(ls==0)THEN
2888
ALLOCATE(replace_ccc%chars(1:lsub))
2889
DO i=1,lsub
2890
replace_ccc%chars(i) = substring(i:i)
2891
ENDDO
2892
RETURN
2893
ELSE
2894
ALLOCATE(replace_ccc%chars(1:ls))
2895
DO i=1,ls
2896
replace_ccc%chars(i) = string(i:i)
2897
ENDDO
2898
RETURN
2899
ENDIF
2900
ENDIF
2901
ALLOCATE(work(1:ls))
2902
DO i=1,ls
2903
work(i) = string(i:i)
2904
ENDDO
2905
IF( PRESENT(back) )THEN
2906
dir_switch = back
2907
ELSE
2908
dir_switch = .FALSE.
2909
ENDIF
2910
IF( PRESENT(every) )THEN
2911
rep_search = every
2912
ELSE
2913
rep_search = .FALSE.
2914
ENDIF
2915
IF( dir_switch )THEN ! backwards search
2916
ipos = ls-lt+1
2917
DO
2918
IF( ipos < 1 )EXIT ! search past start of string
2919
! test for occurance of target in string at this position
2920
IF( string(ipos:ipos+lt-1) == target )THEN
2921
! match found allocate space for string with this occurance of
2922
! target replaced by substring
2923
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2924
! copy work into temp replacing this occurance of target by
2925
! substring
2926
temp(1:ipos-1) = work(1:ipos-1)
2927
DO i=1,lsub
2928
temp(i+ipos-1) = substring(i:i)
2929
ENDDO
2930
temp(ipos+lsub:) = work(ipos+lt:)
2931
work => temp ! make new version of work point at the temp space
2932
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2933
! move search and replacement positions over the effected positions
2934
ipos = ipos-lt+1
2935
ENDIF
2936
ipos=ipos-1
2937
ENDDO
2938
ELSE ! forward search
2939
ipos = 1; ipow = 1
2940
DO
2941
IF( ipos > ls-lt+1 )EXIT ! search past end of string
2942
! test for occurance of target in string at this position
2943
IF( string(ipos:ipos+lt-1) == target )THEN
2944
! match found allocate space for string with this occurance of
2945
! target replaced by substring
2946
ALLOCATE(temp(1:SIZE(work)+lsub-lt))
2947
! copy work into temp replacing this occurance of target by
2948
! substring
2949
temp(1:ipow-1) = work(1:ipow-1)
2950
DO i=1,lsub
2951
temp(i+ipow-1) = substring(i:i)
2952
ENDDO
2953
temp(ipow+lsub:) = work(ipow+lt:)
2954
work => temp ! make new version of work point at the temp space
2955
IF(.NOT.rep_search)EXIT ! exit if only first replacement wanted
2956
! move search and replacement positions over the effected positions
2957
ipos = ipos+lt-1; ipow = ipow+lsub-1
2958
ENDIF
2959
ipos=ipos+1; ipow=ipow+1
2960
ENDDO
2961
ENDIF
2962
replace_ccc%chars => work
2963
ENDFUNCTION replace_ccc
2964
2965
!----- Remove procedures ----------------------------------------------------!
2966
ELEMENTAL FUNCTION remove_s(string,start,finish)
2967
type(VAR_STR) :: remove_s
2968
type(VAR_STR),INTENT(IN) :: string
2969
INTEGER,INTENT(IN),OPTIONAL :: start
2970
INTEGER,INTENT(IN),OPTIONAL :: finish
2971
! returns as result the string produced by the actions
2972
! removes the characters between start and finish from string reducing it in
2973
! size by MAX(0,ABS(finish-start+1))
2974
! if start < 1 or is missing then assumes start=1
2975
! if finish > LEN(string) or is missing then assumes finish=LEN(string)
2976
CHARACTER,DIMENSION(:),POINTER :: arg_str
2977
INTEGER :: is,if,ls
2978
ls = LEN(string)
2979
IF (PRESENT(start)) THEN
2980
is = MAX(1,start)
2981
ELSE
2982
is = 1
2983
ENDIF
2984
IF (PRESENT(finish)) THEN
2985
if = MIN(ls,finish)
2986
ELSE
2987
if = ls
2988
ENDIF
2989
IF( if < is ) THEN ! zero characters to be removed, string is unchanged
2990
ALLOCATE(arg_str(1:ls))
2991
arg_str = string%chars
2992
ELSE
2993
ALLOCATE(arg_str(1:ls-if+is-1) )
2994
arg_str(1:is-1) = string%chars(1:is-1)
2995
arg_str(is:) = string%chars(if+1:)
2996
ENDIF
2997
remove_s%chars => arg_str
2998
ENDFUNCTION remove_s
2999
3000
ELEMENTAL FUNCTION remove_c(string,start,finish)
3001
type(VAR_STR) :: remove_c
3002
CHARACTER(LEN=*),INTENT(IN) :: string
3003
INTEGER,INTENT(IN),OPTIONAL :: start
3004
INTEGER,INTENT(IN),OPTIONAL :: finish
3005
! returns as result the string produced by the actions
3006
! removes the characters between start and finish from string reducing it in
3007
! size by MAX(0,ABS(finish-start+1))
3008
! if start < 1 or is missing then assumes start=1
3009
! if finish > LEN(string) or is missing then assumes finish=LEN(string)
3010
CHARACTER,DIMENSION(:),POINTER :: arg_str
3011
INTEGER :: is,if,ls
3012
ls = LEN(string)
3013
IF (PRESENT(start)) THEN
3014
is = MAX(1,start)
3015
ELSE
3016
is = 1
3017
ENDIF
3018
IF (PRESENT(finish)) THEN
3019
if = MIN(ls,finish)
3020
ELSE
3021
if = ls
3022
ENDIF
3023
IF( if < is ) THEN ! zero characters to be removed, string is unchanged
3024
ALLOCATE(arg_str(1:ls))
3025
DO i=1,ls
3026
arg_str(i) = string(i:i)
3027
ENDDO
3028
ELSE
3029
ALLOCATE(arg_str(1:ls-if+is-1) )
3030
DO i=1,is-1
3031
arg_str(i) = string(i:i)
3032
ENDDO
3033
DO i=is,ls-if+is-1
3034
arg_str(i) = string(i-is+if+1:i-is+if+1)
3035
ENDDO
3036
ENDIF
3037
remove_c%chars => arg_str
3038
ENDFUNCTION remove_c
3039
3040
!----- Extract procedures ---------------------------------------------------!
3041
ELEMENTAL FUNCTION extract_s(string,start,finish)
3042
type(VAR_STR),INTENT(IN) :: string
3043
INTEGER,INTENT(IN),OPTIONAL :: start
3044
INTEGER,INTENT(IN),OPTIONAL :: finish
3045
type(VAR_STR) :: extract_s
3046
! extracts the characters between start and finish from string and
3047
! delivers these as the result of the function, string is unchanged
3048
! if start < 1 or is missing then it is treated as 1
3049
! if finish > LEN(string) or is missing then it is treated as LEN(string)
3050
INTEGER :: is,if
3051
IF (PRESENT(start)) THEN
3052
is = MAX(1,start)
3053
ELSE
3054
is = 1
3055
ENDIF
3056
IF (PRESENT(finish)) THEN
3057
if = MIN(LEN(string),finish)
3058
ELSE
3059
if = LEN(string)
3060
ENDIF
3061
ALLOCATE(extract_s%chars(1:if-is+1))
3062
extract_s%chars = string%chars(is:if)
3063
ENDFUNCTION extract_s
3064
3065
ELEMENTAL FUNCTION extract_c(string,start,finish)
3066
CHARACTER(LEN=*),INTENT(IN) :: string
3067
INTEGER,INTENT(IN),OPTIONAL :: start
3068
INTEGER,INTENT(IN),OPTIONAL :: finish
3069
type(VAR_STR) :: extract_c
3070
! extracts the characters between start and finish from character string and
3071
! delivers these as the result of the function, string is unchanged
3072
! if start < 1 or is missing then it is treated as 1
3073
! if finish > LEN(string) or is missing then it is treated as LEN(string)
3074
INTEGER :: is,if
3075
IF (PRESENT(start)) THEN
3076
is = MAX(1,start)
3077
ELSE
3078
is = 1
3079
ENDIF
3080
IF (PRESENT(finish)) THEN
3081
if = MIN(LEN(string),finish)
3082
ELSE
3083
if = LEN(string)
3084
ENDIF
3085
ALLOCATE(extract_c%chars(1:if-is+1))
3086
DO i=is,if
3087
extract_c%chars(i-is+1) = string(i:i)
3088
ENDDO
3089
ENDFUNCTION extract_c
3090
3091
!----- Split procedures ------------------------------------------------------!
3092
ELEMENTAL SUBROUTINE split_s(string,word,set,separator,back)
3093
type(VAR_STR),INTENT(INOUT) :: string
3094
type(VAR_STR),INTENT(OUT) :: word
3095
type(VAR_STR),INTENT(IN) :: set
3096
type(VAR_STR),INTENT(OUT),OPTIONAL :: separator
3097
LOGICAL,INTENT(IN),OPTIONAL :: back
3098
! splits the input string at the first(last) character in set
3099
! returns the leading(trailing) substring in word and the trailing(leading)
3100
! substring in string. The search is done in the forward or backward
3101
! direction depending on back. If separator is present, the actual separator
3102
! character found is returned in separator.
3103
! If no character in set is found string and separator are returned as
3104
! zero length and the whole input string is returned in word.
3105
LOGICAL :: dir_switch
3106
INTEGER :: ls,tpos
3107
CHARACTER,ALLOCATABLE :: wst(:) ! working copy of string
3108
ls = LEN(string)
3109
ALLOCATE(wst(ls))
3110
wst=string%chars
3111
IF( PRESENT(back) )THEN
3112
dir_switch = back
3113
ELSE
3114
dir_switch = .FALSE.
3115
ENDIF
3116
IF(dir_switch)THEN ! backwards search
3117
DO tpos = ls,1,-1
3118
IF(ANY(wst(tpos) == set%chars))EXIT
3119
ENDDO
3120
IF(ASSOCIATED(word%chars))DEALLOCATE(word%chars)
3121
ALLOCATE(word%chars(ls-tpos))
3122
word%chars = wst(tpos+1:ls)
3123
IF(PRESENT(separator))THEN
3124
IF(tpos==0)THEN
3125
separator = ""
3126
ELSE
3127
separator = wst(tpos)
3128
ENDIF
3129
ENDIF
3130
DEALLOCATE(string%chars)
3131
ALLOCATE(string%chars(tpos-1))
3132
string%chars = wst(1:tpos-1)
3133
ELSE ! forwards search
3134
DO tpos =1,ls
3135
IF(ANY(wst(tpos) == set%chars))EXIT
3136
ENDDO
3137
IF(ASSOCIATED(word%chars))DEALLOCATE(word%chars)
3138
ALLOCATE(word%chars(tpos-1))
3139
word%chars = wst(1:tpos-1)
3140
IF(PRESENT(separator))THEN
3141
IF(tpos==ls+1)THEN
3142
separator = ""
3143
ELSE
3144
separator = wst(tpos)
3145
ENDIF
3146
ENDIF
3147
DEALLOCATE(string%chars)
3148
ALLOCATE(string%chars(ls-tpos))
3149
string%chars = wst(tpos+1:ls)
3150
ENDIF
3151
ENDSUBROUTINE split_s
3152
3153
ELEMENTAL SUBROUTINE split_c(string,word,set,separator,back)
3154
type(VAR_STR),INTENT(INOUT) :: string
3155
type(VAR_STR),INTENT(OUT) :: word
3156
CHARACTER(LEN=*),INTENT(IN) :: set
3157
type(VAR_STR),INTENT(OUT),OPTIONAL :: separator
3158
LOGICAL,INTENT(IN),OPTIONAL :: back
3159
! splits the input string at the first(last) character in set
3160
! returns the leading(trailing) substring in word and the trailing(leading)
3161
! substring in string. The search is done in the forward or backward
3162
! direction depending on back. If separator is present, the actual separator
3163
! character found is returned in separator.
3164
! If no character in set is found string and separator are returned as
3165
! zero length and the whole input string is returned in word.
3166
LOGICAL :: dir_switch
3167
INTEGER :: ls,tpos,lset
3168
CHARACTER,ALLOCATABLE :: wst(:) ! working copy of string
3169
ls = LEN(string); lset = LEN(set)
3170
ALLOCATE(wst(ls))
3171
wst=string%chars
3172
IF( PRESENT(back) )THEN
3173
dir_switch = back
3174
ELSE
3175
dir_switch = .FALSE.
3176
ENDIF
3177
IF(dir_switch)THEN ! backwards search
3178
BSEARCH:DO tpos = ls,1,-1
3179
DO i=1,lset
3180
IF(wst(tpos) == set(i:i))EXIT BSEARCH
3181
ENDDO
3182
ENDDO BSEARCH
3183
IF(ASSOCIATED(word%chars))DEALLOCATE(word%chars)
3184
ALLOCATE(word%chars(ls-tpos))
3185
word%chars = wst(tpos+1:ls)
3186
IF(PRESENT(separator))THEN
3187
IF(tpos==0)THEN
3188
separator = ""
3189
ELSE
3190
separator = wst(tpos)
3191
ENDIF
3192
ENDIF
3193
DEALLOCATE(string%chars)
3194
ALLOCATE(string%chars(tpos-1))
3195
string%chars = wst(1:tpos-1)
3196
ELSE ! forwards search
3197
FSEARCH:DO tpos =1,ls
3198
DO i=1,lset
3199
IF(wst(tpos) == set(i:i))EXIT FSEARCH
3200
ENDDO
3201
ENDDO FSEARCH
3202
IF(ASSOCIATED(word%chars))DEALLOCATE(word%chars)
3203
ALLOCATE(word%chars(tpos-1))
3204
word%chars = wst(1:tpos-1)
3205
IF(PRESENT(separator))THEN
3206
IF(tpos==ls+1)THEN
3207
separator = ""
3208
ELSE
3209
separator = wst(tpos)
3210
ENDIF
3211
ENDIF
3212
DEALLOCATE(string%chars)
3213
ALLOCATE(string%chars(ls-tpos))
3214
string%chars = wst(tpos+1:ls)
3215
ENDIF
3216
ENDSUBROUTINE split_c
3217
3218
!----- INDEX procedures ------------------------------------------------------!
3219
ELEMENTAL FUNCTION index_ss(string,substring,back)
3220
type(VAR_STR),INTENT(IN) :: string,substring
3221
LOGICAL,INTENT(IN),OPTIONAL :: back
3222
INTEGER :: index_ss
3223
! returns the starting position in string of the substring
3224
! scanning from the front or back depending on the logical argument back
3225
LOGICAL :: dir_switch
3226
INTEGER :: ls,lsub
3227
ls = LEN(string); lsub = LEN(substring)
3228
IF( PRESENT(back) )THEN
3229
dir_switch = back
3230
ELSE
3231
dir_switch = .FALSE.
3232
ENDIF
3233
IF(dir_switch)THEN ! backwards search
3234
DO i = ls-lsub+1,1,-1
3235
IF( ALL(string%chars(i:i+lsub-1) == substring%chars) )THEN
3236
index_ss = i
3237
RETURN
3238
ENDIF
3239
ENDDO
3240
index_ss = 0
3241
ELSE ! forward search
3242
DO i = 1,ls-lsub+1
3243
IF( ALL(string%chars(i:i+lsub-1) == substring%chars) )THEN
3244
index_ss = i
3245
RETURN
3246
ENDIF
3247
ENDDO
3248
index_ss = 0
3249
ENDIF
3250
ENDFUNCTION index_ss
3251
3252
ELEMENTAL FUNCTION index_sc(string,substring,back)
3253
type(VAR_STR),INTENT(IN) :: string
3254
CHARACTER(LEN=*),INTENT(IN) :: substring
3255
LOGICAL,INTENT(IN),OPTIONAL :: back
3256
INTEGER :: index_sc
3257
! returns the starting position in string of the substring
3258
! scanning from the front or back depending on the logical argument back
3259
LOGICAL :: dir_switch,matched
3260
INTEGER :: ls,lsub
3261
ls = LEN(string); lsub = LEN(substring)
3262
IF( PRESENT(back) )THEN
3263
dir_switch = back
3264
ELSE
3265
dir_switch = .FALSE.
3266
ENDIF
3267
IF (dir_switch) THEN ! backwards search
3268
DO i = ls-lsub+1,1,-1
3269
matched = .TRUE.
3270
DO j = 1,lsub
3271
IF( string%chars(i+j-1) /= substring(j:j) )THEN
3272
matched = .FALSE.
3273
EXIT
3274
ENDIF
3275
ENDDO
3276
IF( matched )THEN
3277
index_sc = i
3278
RETURN
3279
ENDIF
3280
ENDDO
3281
index_sc = 0
3282
ELSE ! forward search
3283
DO i = 1,ls-lsub+1
3284
matched = .TRUE.
3285
DO j = 1,lsub
3286
IF( string%chars(i+j-1) /= substring(j:j) )THEN
3287
matched = .FALSE.
3288
EXIT
3289
ENDIF
3290
ENDDO
3291
IF( matched )THEN
3292
index_sc = i
3293
RETURN
3294
ENDIF
3295
ENDDO
3296
index_sc = 0
3297
ENDIF
3298
ENDFUNCTION index_sc
3299
3300
ELEMENTAL FUNCTION index_cs(string,substring,back)
3301
CHARACTER(LEN=*),INTENT(IN) :: string
3302
type(VAR_STR),INTENT(IN) :: substring
3303
LOGICAL,INTENT(IN),OPTIONAL :: back
3304
INTEGER :: index_cs
3305
! returns the starting position in string of the substring
3306
! scanning from the front or back depending on the logical argument back
3307
LOGICAL :: dir_switch,matched
3308
INTEGER :: ls,lsub
3309
ls = LEN(string); lsub = LEN(substring)
3310
IF( PRESENT(back) )THEN
3311
dir_switch = back
3312
ELSE
3313
dir_switch = .FALSE.
3314
ENDIF
3315
IF(dir_switch)THEN ! backwards search
3316
DO i = ls-lsub+1,1,-1
3317
matched = .TRUE.
3318
DO j = 1,lsub
3319
IF( string(i+j-1:i+j-1) /= substring%chars(j) )THEN
3320
matched = .FALSE.
3321
EXIT
3322
ENDIF
3323
ENDDO
3324
IF( matched )THEN
3325
index_cs = i
3326
RETURN
3327
ENDIF
3328
ENDDO
3329
index_cs = 0
3330
ELSE ! forward search
3331
DO i = 1,ls-lsub+1
3332
matched = .TRUE.
3333
DO j = 1,lsub
3334
IF( string(i+j-1:i+j-1) /= substring%chars(j) )THEN
3335
matched = .FALSE.
3336
EXIT
3337
ENDIF
3338
ENDDO
3339
IF( matched )THEN
3340
index_cs = i
3341
RETURN
3342
ENDIF
3343
ENDDO
3344
index_cs = 0
3345
ENDIF
3346
ENDFUNCTION index_cs
3347
3348
!----- SCAN procedures ------------------------------------------------------!
3349
ELEMENTAL FUNCTION scan_ss(string,set,back)
3350
type(VAR_STR),INTENT(IN) :: string,set
3351
LOGICAL,INTENT(IN),OPTIONAL :: back
3352
INTEGER :: scan_ss
3353
! returns the first position in string occupied by a character from
3354
! the characters in set, scanning is forward or backwards depending on back
3355
LOGICAL :: dir_switch
3356
INTEGER :: ls
3357
ls = LEN(string)
3358
IF( PRESENT(back) )THEN
3359
dir_switch = back
3360
ELSE
3361
dir_switch = .FALSE.
3362
ENDIF
3363
IF(dir_switch)THEN ! backwards search
3364
DO i = ls,1,-1
3365
IF( ANY( set%chars == string%chars(i) ) )THEN
3366
scan_ss = i
3367
RETURN
3368
ENDIF
3369
ENDDO
3370
scan_ss = 0
3371
ELSE ! forward search
3372
DO i = 1,ls
3373
IF( ANY( set%chars == string%chars(i) ) )THEN
3374
scan_ss = i
3375
RETURN
3376
ENDIF
3377
ENDDO
3378
scan_ss = 0
3379
ENDIF
3380
ENDFUNCTION scan_ss
3381
3382
ELEMENTAL FUNCTION scan_sc(string,set,back)
3383
type(VAR_STR),INTENT(IN) :: string
3384
CHARACTER(LEN=*),INTENT(IN) :: set
3385
LOGICAL,INTENT(IN),OPTIONAL :: back
3386
INTEGER :: scan_sc
3387
! returns the first position in string occupied by a character from
3388
! the characters in set, scanning is forward or backwards depending on back
3389
LOGICAL :: dir_switch,matched
3390
INTEGER :: ls
3391
ls = LEN(string)
3392
IF( PRESENT(back) )THEN
3393
dir_switch = back
3394
ELSE
3395
dir_switch = .FALSE.
3396
ENDIF
3397
IF(dir_switch)THEN ! backwards search
3398
DO i = ls,1,-1
3399
matched = .FALSE.
3400
DO j = 1,LEN(set)
3401
IF( string%chars(i) == set(j:j) )THEN
3402
matched = .TRUE.
3403
EXIT
3404
ENDIF
3405
ENDDO
3406
IF( matched )THEN
3407
scan_sc = i
3408
RETURN
3409
ENDIF
3410
ENDDO
3411
scan_sc = 0
3412
ELSE ! forward search
3413
DO i = 1,ls
3414
matched = .FALSE.
3415
DO j = 1,LEN(set)
3416
IF( string%chars(i) == set(j:j) )THEN
3417
matched = .TRUE.
3418
EXIT
3419
ENDIF
3420
ENDDO
3421
IF( matched )THEN
3422
scan_sc = i
3423
RETURN
3424
ENDIF
3425
ENDDO
3426
scan_sc = 0
3427
ENDIF
3428
ENDFUNCTION scan_sc
3429
3430
ELEMENTAL FUNCTION scan_cs(string,set,back)
3431
CHARACTER(LEN=*),INTENT(IN) :: string
3432
type(VAR_STR),INTENT(IN) :: set
3433
LOGICAL,INTENT(IN),OPTIONAL :: back
3434
INTEGER :: scan_cs
3435
! returns the first position in character string occupied by a character from
3436
! the characters in set, scanning is forward or backwards depending on back
3437
LOGICAL :: dir_switch,matched
3438
INTEGER :: ls
3439
ls = LEN(string)
3440
IF( PRESENT(back) )THEN
3441
dir_switch = back
3442
ELSE
3443
dir_switch = .FALSE.
3444
ENDIF
3445
IF(dir_switch)THEN ! backwards search
3446
DO i = ls,1,-1
3447
matched = .FALSE.
3448
DO j = 1,LEN(set)
3449
IF( string(i:i) == set%chars(j) )THEN
3450
matched = .TRUE.
3451
EXIT
3452
ENDIF
3453
ENDDO
3454
IF( matched )THEN
3455
scan_cs = i
3456
RETURN
3457
ENDIF
3458
ENDDO
3459
scan_cs = 0
3460
ELSE ! forward search
3461
DO i = 1,ls
3462
matched = .FALSE.
3463
DO j = 1,LEN(set)
3464
IF( string(i:i) == set%chars(j) )THEN
3465
matched = .TRUE.
3466
EXIT
3467
ENDIF
3468
ENDDO
3469
IF( matched )THEN
3470
scan_cs = i
3471
RETURN
3472
ENDIF
3473
ENDDO
3474
scan_cs = 0
3475
ENDIF
3476
ENDFUNCTION scan_cs
3477
3478
!----- VERIFY procedures ----------------------------------------------------!
3479
ELEMENTAL FUNCTION verify_ss(string,set,back)
3480
type(VAR_STR),INTENT(IN) :: string,set
3481
LOGICAL,INTENT(IN),OPTIONAL :: back
3482
INTEGER :: verify_ss
3483
! returns the first position in string not occupied by a character from
3484
! the characters in set, scanning is forward or backwards depending on back
3485
LOGICAL :: dir_switch
3486
INTEGER :: ls
3487
ls = LEN(string)
3488
IF( PRESENT(back) )THEN
3489
dir_switch = back
3490
ELSE
3491
dir_switch = .FALSE.
3492
ENDIF
3493
IF(dir_switch)THEN ! backwards search
3494
DO i = ls,1,-1
3495
IF( .NOT.(ANY( set%chars == string%chars(i) )) )THEN
3496
verify_ss = i
3497
RETURN
3498
ENDIF
3499
ENDDO
3500
verify_ss = 0
3501
ELSE ! forward search
3502
DO i = 1,ls
3503
IF( .NOT.(ANY( set%chars == string%chars(i) )) )THEN
3504
verify_ss = i
3505
RETURN
3506
ENDIF
3507
ENDDO
3508
verify_ss = 0
3509
ENDIF
3510
ENDFUNCTION verify_ss
3511
3512
ELEMENTAL FUNCTION verify_sc(string,set,back)
3513
type(VAR_STR),INTENT(IN) :: string
3514
CHARACTER(LEN=*),INTENT(IN) :: set
3515
LOGICAL,INTENT(IN),OPTIONAL :: back
3516
INTEGER :: verify_sc
3517
! returns the first position in string not occupied by a character from
3518
! the characters in set, scanning is forward or backwards depending on back
3519
LOGICAL :: dir_switch
3520
INTEGER :: ls
3521
ls = LEN(string)
3522
IF( PRESENT(back) )THEN
3523
dir_switch = back
3524
ELSE
3525
dir_switch = .FALSE.
3526
ENDIF
3527
IF(dir_switch)THEN ! backwards search
3528
back_string_search:DO i = ls,1,-1
3529
DO j = 1,LEN(set)
3530
IF( string%chars(i) == set(j:j) )CYCLE back_string_search
3531
! cycle string search if string character found in set
3532
ENDDO
3533
! string character not found in set index i is result
3534
verify_sc = i
3535
RETURN
3536
ENDDO back_string_search
3537
! each string character found in set
3538
verify_sc = 0
3539
ELSE ! forward search
3540
frwd_string_search:DO i = 1,ls
3541
DO j = 1,LEN(set)
3542
IF( string%chars(i) == set(j:j) )CYCLE frwd_string_search
3543
ENDDO
3544
verify_sc = i
3545
RETURN
3546
ENDDO frwd_string_search
3547
verify_sc = 0
3548
ENDIF
3549
ENDFUNCTION verify_sc
3550
3551
ELEMENTAL FUNCTION verify_cs(string,set,back)
3552
CHARACTER(LEN=*),INTENT(IN) :: string
3553
type(VAR_STR),INTENT(IN) :: set
3554
LOGICAL,INTENT(IN),OPTIONAL :: back
3555
INTEGER :: verify_cs
3556
! returns the first position in icharacter string not occupied by a character
3557
! from the characters in set, scanning is forward or backwards depending on
3558
! back
3559
LOGICAL :: dir_switch
3560
INTEGER :: ls
3561
ls = LEN(string)
3562
IF( PRESENT(back) )THEN
3563
dir_switch = back
3564
ELSE
3565
dir_switch = .FALSE.
3566
ENDIF
3567
IF(dir_switch)THEN ! backwards search
3568
back_string_search:DO i = ls,1,-1
3569
DO j = 1,LEN(set)
3570
IF( string(i:i) == set%chars(j) )CYCLE back_string_search
3571
ENDDO
3572
verify_cs = i
3573
RETURN
3574
ENDDO back_string_search
3575
verify_cs = 0
3576
ELSE ! forward search
3577
frwd_string_search:DO i = 1,ls
3578
DO j = 1,LEN(set)
3579
IF( string(i:i) == set%chars(j) )CYCLE frwd_string_search
3580
ENDDO
3581
verify_cs = i
3582
RETURN
3583
ENDDO frwd_string_search
3584
verify_cs = 0
3585
ENDIF
3586
ENDFUNCTION verify_cs
3587
3588
!----- LEN_TRIM procedure ----------------------------------------------------!
3589
ELEMENTAL FUNCTION len_trim_s(string)
3590
type(VAR_STR),INTENT(IN) :: string
3591
INTEGER :: len_trim_s
3592
! Returns the length of the string without counting trailing blanks
3593
INTEGER :: ls
3594
ls=LEN(string)
3595
len_trim_s = 0
3596
DO i = ls,1,-1
3597
IF (string%chars(i) /= BLANK) THEN
3598
len_trim_s = i
3599
EXIT
3600
ENDIF
3601
ENDDO
3602
ENDFUNCTION len_trim_s
3603
3604
!----- TRIM procedure -------------------------------------------------------!
3605
ELEMENTAL FUNCTION trim_s(string)
3606
type(VAR_STR),INTENT(IN) :: string
3607
type(VAR_STR) :: trim_s
3608
! Returns the argument string with trailing blanks removed
3609
INTEGER :: ls,pos
3610
ls=LEN(string)
3611
pos=0
3612
DO i = ls,1,-1
3613
IF(string%chars(i) /= BLANK) THEN
3614
pos=i
3615
EXIT
3616
ENDIF
3617
ENDDO
3618
ALLOCATE(trim_s%chars(1:pos))
3619
trim_s%chars(1:pos) = string%chars(1:pos)
3620
ENDFUNCTION trim_s
3621
3622
!----- IACHAR procedure ------------------------------------------------------!
3623
ELEMENTAL FUNCTION iachar_s(string)
3624
type(VAR_STR),INTENT(IN) :: string
3625
INTEGER :: iachar_s
3626
! returns the position of the character string in the ISO 646
3627
! collating sequence.
3628
! string must be of length one, otherwise result is as for intrinsic IACHAR
3629
iachar_s = IACHAR(CHAR(string))
3630
ENDFUNCTION iachar_s
3631
3632
!----- ICHAR procedure ------------------------------------------------------!
3633
ELEMENTAL FUNCTION ichar_s(string)
3634
type(VAR_STR),INTENT(IN) :: string
3635
INTEGER :: ichar_s
3636
! returns the position of character from string in the processor collating
3637
! sequence.
3638
! string must be of length one, otherwise it will behave as the intrinsic
3639
! ICHAR with the equivalent character string
3640
ichar_s = ICHAR(CHAR(string))
3641
ENDFUNCTION ichar_s
3642
3643
!----- ADJUSTL procedure ----------------------------------------------------!
3644
ELEMENTAL FUNCTION adjustl_s(string)
3645
type(VAR_STR),INTENT(IN) :: string
3646
type(VAR_STR) :: adjustl_s
3647
! Returns the string adjusted to the left, removing leading blanks and
3648
! inserting trailing blanks
3649
INTEGER :: ls,pos
3650
ls=LEN(string)
3651
DO pos = 1,ls
3652
IF(string%chars(pos) /= blank) EXIT
3653
ENDDO
3654
! pos now holds the position of the first non-blank character
3655
! or ls+1 if all characters are blank
3656
ALLOCATE(adjustl_s%chars(1:ls))
3657
adjustl_s%chars(1:ls-pos+1) = string%chars(pos:ls)
3658
adjustl_s%chars(ls-pos+2:ls) = blank
3659
ENDFUNCTION adjustl_s
3660
3661
!----- ADJUSTR procedure ----------------------------------------------------!
3662
ELEMENTAL FUNCTION adjustr_s(string)
3663
type(VAR_STR),INTENT(IN) :: string
3664
type(VAR_STR) :: adjustr_s
3665
! Returns the string adjusted to the right, removing trailing blanks
3666
! and inserting leading blanks
3667
INTEGER :: ls,pos
3668
ls=LEN(string)
3669
DO pos = ls,1,-1
3670
IF(string%chars(pos) /= blank) EXIT
3671
ENDDO
3672
! pos now holds the position of the last non-blank character
3673
! or zero if all characters are blank
3674
ALLOCATE(adjustr_s%chars(1:ls))
3675
adjustr_s%chars(ls-pos+1:ls) = string%chars(1:pos)
3676
adjustr_s%chars(1:ls-pos) = blank
3677
ENDFUNCTION adjustr_s
3678
3679
ENDMODULE ISO_VAR_STR
Loggerhead is a web-based interface for Breezy
Version: 2.0.1