1** Copyright (c) 1992, NVIDIA CORPORATION.  All rights reserved.
2**
3** Licensed under the Apache License, Version 2.0 (the "License");
4** you may not use this file except in compliance with the License.
5** You may obtain a copy of the License at
6**
7**     http://www.apache.org/licenses/LICENSE-2.0
8**
9** Unless required by applicable law or agreed to in writing, software
10** distributed under the License is distributed on an "AS IS" BASIS,
11** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
12** See the License for the specific language governing permissions and
13** limitations under the License.
14
15*   KANJI - functions, entries, dummy args of type NCHARACTER.
16
17	program p
18	parameter(N=14)
19
20	ncharacter*1 a1
21	ncharacter*2 a2
22	ncharacter*3 a(2,2)
23	ncharacter*4 a4
24	ncharacter*5 a5(6)
25	common a2, a5
26
27	! declare nchar functions:
28	ncharacter nextc*1, alpha*3, char1*2, char2*2
29
30	integer expect(N), rslts(N)
31
32	data i1 / 1 /
33	data expect /	66, 67,
34     +			97, 99, 'a1a1'x, 97,
35     +			98, 99, 67, 66,
36     +			3, 4, 4,   90   /
37
38	! -------- test function nextc:
39
40	a1 = nextc(nc'A')
41	rslts(1) = ichar(a1)		!	'B'
42	rslts(2) = ichar(nextc(a1))	!	'C'
43
44	! --------- test function alpha:
45
46	a4 = alpha()
47	rslts(3) = ichar( a4(1:1) )	!	'a'
48	rslts(4) = ichar( a4(3:3) )	!	'c'
49	rslts(5) = ichar( a4(4:4) )	!	' '
50	a4 = alpha() // alpha()
51	rslts(6) = ichar( a4(4:4) )	!	'a'
52
53	! --------- test function char1 and entry char2:
54
55	a2 = char1(nc'abcdefg')
56	rslts(7) = ichar( a2(1:1) )	!	'b'
57	rslts(8) = ichar( a2(2:2) )	!	'c'
58
59	a2 = nc'BC'
60	a2 = char2(a2//a2//a2)	! 'BCBCBC'(4:5)
61	rslts(9) = ichar( a2(1:1) )	!	'C'
62	rslts(10) = ichar( a2(2:2) )	!	'B'
63
64	! ---------- test function ifunc:
65
66	rslts(11) = ifunc( NC'abc' )	!	3
67	rslts(12) = ifunc( a2 // NC'xx')!	4
68	rslts(13) = ifunc( a5(i1)(2-i1:3+i1) ) ! 4
69
70	! ---------- test function jfunc:
71
72	a(2,2) = nc'XYZ'
73	rslts(14) = jfunc(a, 2)		!	'Z'
74
75	call check(rslts, expect, N)
76	end
77
78	ncharacter function nextc(c)
79	ncharacter*1 c
80	i = ichar(c) + 1
81	nextc = nchar(i)
82	end
83
84	ncharacter*(*) function alpha
85	alpha = nc'abcdefghijklmnopqrstuvw'
86	return
87	end
88
89	function char1(c)
90	ncharacter*2 char1
91	ncharacter*(2) char2
92	ncharacter*200 c
93	char1 = c(2:3)
94	return
95
96	entry char2(c)
97	char2 = c(4:5)
98	end
99
100	function ifunc(c)
101	ncharacter*(*) c
102	ifunc = len(c)
103	end
104
105	function jfunc(c, n)
106	ncharacter c(n,n)*(*)
107	jfunc = ichar( c(2,2)(3:3) )
108	end
109