1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
*DECK LCMCAR
SUBROUTINE LCMCAR(TEXT,LACTIO,NITMA)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Transform a character variable into integer vector back and forth.
* This routine is portable and based on the *ascii* collating sequence,
* equivalence between: text=' ' <=> nitma=0, is imposed.
*
*Copyright:
* Copyright (C) 1999 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): R. Roy
*
*Parameters: input
* TEXT character variable.
* LACT logical conversion flag: .true. character to integer;
* .false. integer to character.
* NITMA integer (32 bits) vector.
*
*Limitations:
* it is assumed that: 0 <= ichar() <= 255,
* otherwise a character would not stand in one byte.
*
*Internal parameters:
* ALPHAB limited alphabet used for variable names (character*96).
* TASCII table to convert ichar() values into *ascii* codes.
* IASCII inversion of tascii().
* IBASE1 integral basis defined as maximum value of ichar()+1;
* to optimize calculations, it is a power of 2 (128 or 256).
*
*-----------------------------------------------------------------------
*
IMPLICIT NONE
CHARACTER TEXT*(*)
LOGICAL LACTIO
CHARACTER ALPHAB*96
INTEGER NITMA(*)
INTEGER IBASE1,IBASE2,TASCII(0:255),IASCII(0:127)
INTEGER I0,I1,I2,I3,J01,J23,K,LMAX,L1,NBDIM,IBDIM
INTEGER IWRITE
PARAMETER ( IWRITE= 6 )
SAVE IBASE1,IBASE2,TASCII,IASCII
DATA IBASE1/0/
*
IF(IBASE1.EQ.0) THEN
* PREPARE TABLES TASCII() AND IASCII() AND SET INTEGERS IBASE1
* + IBASE2 FOR CHARACTER/INTEGER CONVERSIONS.
* 0 1 2 3
* 0123456789012345678901234567890123456789
ALPHAB=' !..$%&.()*+,-./0123456789:;<=>?.ABCDEF'//
> 'GHIJKLMNOPQRSTUVWXYZ...._.abcdefghijklmn'//
> 'opqrstuvwxyz.....'
*
LMAX= 0
DO 30 K=0,95
L1= ICHAR(ALPHAB(K+1:K+1))
LMAX= MAX(LMAX,L1)
TASCII(L1)= K
IASCII(K)= L1
30 CONTINUE
IF( LMAX.LT.128 )THEN
IBASE1= 128
ELSE
IBASE1= 256
ENDIF
IBASE2= IBASE1*IBASE1
ENDIF
*
NBDIM= LEN(TEXT)
IF( MOD(NBDIM,4).NE.0 )THEN
WRITE(IWRITE,*) 'LCMCAR: LEN(TEXT)=',NBDIM,' NOT / BY 4'
CALL XABORT('LCMCAR: INVALID CHARACTER <-> INTEGER CONVERSION')
ELSE
NBDIM= NBDIM/4
ENDIF
IF( LACTIO )THEN
*
* CONVERT EACH CHARACTER*4 TO INTEGER
DO 10 IBDIM= 1, NBDIM
I0= TASCII(ICHAR(TEXT(IBDIM*4-3:IBDIM*4-3)))
I1= TASCII(ICHAR(TEXT(IBDIM*4-2:IBDIM*4-2)))
I2= TASCII(ICHAR(TEXT(IBDIM*4-1:IBDIM*4-1)))
I3= TASCII(ICHAR(TEXT(IBDIM*4 :IBDIM*4 )))
NITMA(IBDIM)= (I0+IBASE1*I1) + IBASE2*(I2+IBASE1*I3)
10 CONTINUE
ELSE
*
* CONVERT INTEGER TO CHARACTER*4
DO 20 IBDIM= 1, NBDIM
J23= NITMA(IBDIM)/IBASE2
I3 = J23/IBASE1
I2 = J23-IBASE1*I3
J01= NITMA(IBDIM)-J23*IBASE2
I1 = J01/IBASE1
I0 = J01-IBASE1*I1
TEXT(IBDIM*4-3:IBDIM*4-3)= CHAR(IASCII(I0))
TEXT(IBDIM*4-2:IBDIM*4-2)= CHAR(IASCII(I1))
TEXT(IBDIM*4-1:IBDIM*4-1)= CHAR(IASCII(I2))
TEXT(IBDIM*4 :IBDIM*4 )= CHAR(IASCII(I3))
20 CONTINUE
ENDIF
RETURN
END
|
