Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

	PROGRAM CHFUN

C COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1983, 1985
C ALL RIGHTS RESERVED.
C 
C THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
C ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH LICENSE AND WITH THE
C INCLUSION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE OR ANY  OTHER
C COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
C OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF THE  SOFTWARE  IS  HEREBY
C TRANSFERRED.
C 
C THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT  NOTICE
C AND  SHOULD  NOT  BE  CONSTRUED  AS A COMMITMENT BY DIGITAL EQUIPMENT
C CORPORATION.
C 
C DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY  OF  ITS
C SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.

C	Feb-82
C	CDM

C	Tests character functions (reg and statement fucntions).

	IMPLICIT CHARACTER*11 (C)
	CHARACTER CHAR1*6,CHAR3*9,CHAR4*4,CHAR5(3)*8
	CHARACTER CHAR7*8
	CHARACTER CH1*7,CH3*4,CH7*5,CH10*15,CH11*8
	CHARACTER CHAR10*20,CHAR11*6,CHAR12(3)*3,CHAR13*8

	COMMON //CHAR11,CHAR12

C	Character statement function definitions

C	Should truncate off 'B'
	CH1(CHAR1)=CHAR1//'AB'
C	Implicity *11
	CH2(CHAR2,I,J,CHAR3,K,L)=CHAR2(I:J) // CHAR3(K:L)
C	No args
	CH3()=CHAR4
	CH7()=CHAR10(3:4)//'LCG'

C-100-	Statement functions

	IF (CH1('xyzzy A') .NE. 'xyzzy A') TYPE 100, CHAR7
100	FORMAT(' ?Error 100. CHAR1='A6', should = ''xyzzy A''')

C-200-	SF con't

	CHAR5(2)='SOME DAY OVER'

	CHAR5(1)=CH2(CHAR5(2),2,4,'ABCDEF',4,6)

	IF (CHAR5(1) .NE. 'OMEDEF') TYPE 200,CHAR5(1)
200	FORMAT(' ?Error 200. CHAR5(1)='A8', should = ''OMEDEF''')

C-300-	Last SF
C	Throw in concatenation, no args wanted & substring
C	Use of a non-passed variable

	CHAR6='XXXXXXXXXXX'
	CHAR4='ABCD'
	CHAR6(3:9)=CH3(1)//'XYZ'

	IF (CHAR6.NE.'XXABCDXYZXX') TYPE 300,CHAR6
300	FORMAT(' ?Error 300. CHAR6='A11', should = ''XXABCXYZXX''')

C-400-	Character functions
C	Simple expressions passed, numeric & non numeric args

	CHAR10='DECSYSTEMxxCONTINUED'

	I=2; J=10

	CHAR10=CH10(CH7(),CHAR10,I,J)
	IF (CHAR10 .NE. 'CSLCGKTYECSYSTE') TYPE 400,CHAR10
400	FORMAT(' ?Error 400. CHAR10='A20', should =',
	1 '''CSLCGKTYECSYSTE''')

C-500-	No args.  Values passed by common blocks.

501	CHAR11='ABCDEF'
	CHAR12(1)='GHI'
	CHAR12(2)='JKL'

	IF ('HIAB' .NE. CH11()) TYPE 500,CH11()
500	FORMAT(' ?Error 500. CH11()='A8', should = ''HIAB''')

	STOP 'End of character functions'
	END

C-CH11-
	CHARACTER*8 FUNCTION CH11()

C	args passed by blank common

	COMMON //CH1,CH2
	CHARACTER*2 CH1(3),CH2*6

	IF (CH1(1) .EQ. 'BLAH') THEN
		CH11='BAD'
	ELSE
		CH11=CH2(2:3)//CH1(1)
	ENDIF

	END

C-CH10-
	CHARACTER*15 FUNCTION CH10(CHAR1,CHAR2,N1,N2)

C	Called by label 400

	CHARACTER CHAR1*5,CHAR2*10,CHAR3*8
	CHAR3=CHAR1 // 'KTY'
	CH10=CHAR3//CHAR2(N1:N2)
	RETURN
	END