%PROCESS MARGINS(1,100), LANGLVL(SAA2); %PROCESS DEFAULT (INITFILL ('11')); /*************************************************************************/ /* */ /* ALGORITHM AS227 APPL. STATIST. (1987) VOL. 36, NO. 2, pp. 245-9. */ /* */ /* Generates all possible N-bit binary codes, and applies a users */ /* procedure for each code generated. */ /* */ /*************************************************************************/ /* Journal of the Royal Statistical Society (Series C): */ /* Applied Statistics, Vol.36, No. 2, pp. 245-249. */ /* Translated from Fortran 90 to PL/I by R. A. Vowels, 1 April 2006. */ /* Code converted using TO_F90 by Alan Miller */ /* Date: 2003-04-26 Time: 20:20:16 */ /* Translated from Algol 60. */ (SUBSCRIPTRANGE, FIXEDOVERFLOW, SIZE): t_as227 : PROCEDURE OPTIONS (MAIN, REORDER); /* A simple program to print out the combinations when n = 4. */ (SUBSCRIPTRANGE, FIXEDOVERFLOW, SIZE): gcount: PROCEDURE (n, apply, ifault) OPTIONS (REORDER); DECLARE ( n ) FIXED BINARY (31); DECLARE APPLY ENTRY (FIXED BINARY (31), FIXED BINARY (31), (*) BIT(1) ALIGNED); DECLARE ( ifault ) FIXED BINARY (31); /* Local variables */ DECLARE ( change, i, tpoint(n) ) FIXED BINARY (31); DECLARE ( STATUS(n) ) BIT(1) ALIGNED; IF n < 1 THEN DO; ifault = 1; RETURN; END; ifault = 0; /* Initialize and make first call to user's routine. */ DO i = 1 TO n; STATUS(i) = '0'B; tpoint(i) = i + 1; END; CALL apply(n, n, STATUS); /* Generate a new code. The user's routine is called twice each */ /* cycle; the first time the bit which changes is bit 1. */ L20: IF STATUS(1) THEN DO; STATUS(1) = '0'B; change = tpoint(2); END; ELSE DO; STATUS(1) = '1'B; change = 2; END; CALL apply(n, 1, STATUS); /* Check if count exhausted. */ IF change > n THEN RETURN; IF STATUS(change) THEN DO; STATUS(change) = '0'B; tpoint(change) = tpoint(change+1); END; ELSE DO; STATUS(change) = '1'B; tpoint(change) = change + 1; END; CALL apply(n, change, STATUS); GO TO L20; END gcount; (SUBSCRIPTRANGE, FIXEDOVERFLOW, SIZE): print_comb: PROCEDURE (n, change, STATUS) OPTIONS (REORDER); DECLARE ( n, change ) FIXED BINARY (31); DECLARE ( STATUS(n) ) BIT(1) ALIGNED; PUT SKIP EDIT ( STATUS )(4 B(1), SKIP); RETURN; END print_comb; DECLARE ( n STATIC INITIAL (4), ifault ) FIXED BINARY (31); CALL gcount(n, print_comb, ifault); STOP; END t_as227;