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