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
|
SUBROUTINE UPCASE (BYTE,N)
C
C THIS ROUTINE CHANGES ALL LOWER CASE CHARACTERS INTO UPPER CASE.
C IT ALSO CONVERTS BCD INPUT CODE TO EBCDIC FOR IBM MACHINE
C
LOGICAL FLAG
INTEGER TAB(20), FFFLAG
CHARACTER*1 BYTE(1), BK1, LA, LZ, IL,
1 IC, IP, LC(256)
CHARACTER*56 KC(5)
COMMON /MACHIN/ MACHX
COMMON /UPCASX/ FLAG, ID, IA, IZ
COMMON /XECHOX/ FFFLAG
EQUIVALENCE (KC(1),LC(1))
C
C TAB = UPPER CASE 'A' TO LOWER CASE 'a' SPAN
C
DATA TAB / +32, -64, +32, +3968, +32, +32, +32, +32 ,
1 +32, +32, +32, +32, +32, +32, +32, +32 ,
2 +32, +32, +32, +32 /
DATA BK1, LA, LZ, IL, IC /
1 ' ', 'A', 'Z', '(', ',' /
DATA IP / '%' /
C
C TAB IS DECIMAL VALUE BETWEEN UPPER CASE 'A' AND LOWER CASE 'a'
C TAB IS POSITIVE IF LOWER CASE 'a' COMES AFTER UPPER CASE 'A' IN
C MACHINE ASCII CHARACTER SET; OTHERWISE TAB IS NEGATIVE.
C
C THE FOLLOWING KC TABLE MUST BE PUNCHED IN EBCDIC CODE (FOR IBM
C ONLY) ======= ===========
C
DATA KC /
1 ' ',
2 ' .)(+ + $*) -/ ,(% ',
3 ' =''''= ABCDEFGHI JKLMNOPQR STUVWX',
4 'YZ ABCDEFGHI JKLMNOPQR ',
5 ' STUVWXYZ 0123456789 WRITTEN BY G.CHAN/UNISYS'/
C
IF (MACHX .EQ. 2) GO TO 30
IF (FLAG) GO TO 10
FLAG =.TRUE.
ID = TAB(MACHX)
IA = ICHAR(LA) + ID
IZ = ICHAR(LZ) + ID
C
10 DO 20 I = 1,N
IF (BYTE(I) .EQ. BK1) GO TO 20
J = ICHAR(BYTE(I))
IF (J.LT.IA .OR. J.GT.IZ) GO TO 20
BYTE(I) = CHAR(J-ID)
20 CONTINUE
RETURN
C
C IBM MACHINE ONLY, WHICH USES EBCDIC CODE
C
30 DO 40 I = 1,N
J = ICHAR(BYTE(I))
40 BYTE(I) = LC(J+1)
C
C THE % SIGN MAY BE CHANGED TO ( IN BCD-EBCDIC CONVERSION,
C CHANGE IT BACK TO %
C
IF (FFFLAG.NE.1234 .OR. N.LT.5) RETURN
DO 50 I = 5,N
IF (BYTE(I).EQ.IL .AND. BYTE(I+1).EQ.IL .AND. (BYTE(I-1).EQ.IC
1 .OR. BYTE(I-1).EQ.BK1)) BYTE(I) = IP
50 CONTINUE
RETURN
END
|
