diff --git a/testmvscompilers.jcl b/testmvscompilers.jcl new file mode 100644 index 0000000..23aa3ec --- /dev/null +++ b/testmvscompilers.jcl @@ -0,0 +1,15849 @@ +//NLTLIB JOB 'S322-0C4','WFJM', +// USER=HERC01,PASSWORD=CUL8TR, +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CREDS EXEC PGM=IEBUPDTE,PARM=NEW +//SYSPRINT DD SYSOUT=A +//SYSUT2 DD DSNAME=HERC01.LTLIB, +// UNIT=3350,VOL=SER=PUB000, +// SPACE=(80,(2000,200,15)),DISP=(NEW,CATLG), +// DCB=(RECFM=FB,LRECL=80,BLKSIZE=3120) +//SYSIN DD DATA,DLM='@@' +./ ADD NAME=$$$INDEX,LEVEL=00,SOURCE=0,LIST=ALL +//******************************************************************** +//* +//* Name: HERC01.LTLIB($$$INDEX) +//* +//* Desc: Short index of PDS with MVS 3.8j language test jobs +//* +//* For full information consult GitHub project wfjm/mvs38j-langtest +//* https://github.com/wfjm/mvs38j-langtest/blob/master/README.md +//* +//* The index simply gives the relation between the 7 character +//* PDS member names and the jcl file names of the project. +//* Member names as well as file name are composed of +//* Case ID - test case identifier (hewo,sine,....) +//* Compiler ID - compiler identifier (a60,asm,....) +//* Job type - t --> test jobs +//* f --> benchmark jobs +//* p --> print benchmark jobs (for soep/soeq) +//* +//******************************************************************** +Membername Short description x +---------- ------------------------------------------------------------ +HEWO --- section --- The classical 'Hello Word' +HEWOA60 hewo_a60.jcl +HEWOASM hewo_asm.jcl +HEWOCOB hewo_cob.jcl +HEWOFOG hewo_forg.jcl +HEWOFOH hewo_forh.jcl +HEWOFOW hewo_forw.jcl +HEWOGCC hewo_gcc.jcl +HEWOJCC hewo_jcc.jcl +HEWOPAS hewo_pas.jcl +HEWOPLI hewo_pli.jcl +HEWOSIM hewo_sim.jcl +SINE --- section --- Line printer plot of sine and cosine +SINEA60 sine_a60.jcl +SINEFOG sine_forg.jcl +SINEFOH sine_forh.jcl +SINEFOW sine_forw.jcl +SINEGCC sine_gcc.jcl +SINEJCC sine_jcc.jcl +SINEPAS sine_pas.jcl +SINEPLI sine_pli.jcl +SINESIM sine_sim.jcl +SOEP --- section --- Sieve of Eratosthenes prime search (byte) +SOEPA60 soep_a60_f.jcl +SOEPA60 soep_a60_p.jcl +SOEPA60 soep_a60_t.jcl +SOEPASM soep_asm_f.jcl +SOEPASM soep_asm_p.jcl +SOEPASM soep_asm_t.jcl +SOEPGCC soep_gcc_f.jcl +SOEPGCC soep_gcc_p.jcl +SOEPGCC soep_gcc_t.jcl +SOEPJCC soep_jcc_f.jcl +SOEPJCC soep_jcc_p.jcl +SOEPJCC soep_jcc_t.jcl +SOEPFOG soep_forg_f.jcl +SOEPFOG soep_forg_p.jcl +SOEPFOG soep_forg_t.jcl +SOEPFOH soep_forh_f.jcl +SOEPFOH soep_forh_p.jcl +SOEPFOH soep_forh_t.jcl +SOEPFOW soep_forw_f.jcl +SOEPFOW soep_forw_p.jcl +SOEPFOW soep_forw_t.jcl +SOEPPAS soep_pas_f.jcl +SOEPPAS soep_pas_p.jcl +SOEPPAS soep_pas_t.jcl +SOEPPLI soep_pli_f.jcl +SOEPPLI soep_pli_p.jcl +SOEPPLI soep_pli_t.jcl +SOEPSIM soep_sim_f.jcl +SOEPSIM soep_sim_p.jcl +SOEPSIM soep_sim_t.jcl +SOEQ --- section --- Sieve of Eratosthenes prime search (bit) +SOEQASM soeq_asm_f.jcl +SOEQASM soeq_asm_p.jcl +SOEQASM soeq_asm_t.jcl +SOEQGCC soeq_gcc_f.jcl +SOEQGCC soeq_gcc_p.jcl +SOEQGCC soeq_gcc_t.jcl +SOEQJCC soeq_jcc_f.jcl +SOEQJCC soeq_jcc_p.jcl +SOEQJCC soeq_jcc_t.jcl +SOEQPAS soeq_pas_f.jcl +SOEQPAS soeq_pas_p.jcl +SOEQPAS soeq_pas_t.jcl +SOEQPLI soeq_pli_f.jcl +SOEQPLI soeq_pli_p.jcl +SOEQPLI soeq_pli_t.jcl +TOWH --- section --- Tower of Hanoi solver +TOWHA60 towh_a60_f.jcl +TOWHA60 towh_a60_t.jcl +TOWHASM towh_asm_f.jcl +TOWHASM towh_asm_t.jcl +TOWHGCC towh_gcc_f.jcl +TOWHGCC towh_gcc_t.jcl +TOWHJCC towh_jcc_f.jcl +TOWHJCC towh_jcc_t.jcl +TOWHFOG towh_forg_f.jcl +TOWHFOG towh_forg_t.jcl +TOWHFOH towh_forh_f.jcl +TOWHFOH towh_forh_t.jcl +TOWHFOW towh_forw_f.jcl +TOWHFOW towh_forw_t.jcl +TOWHPAS towh_pas_f.jcl +TOWHPAS towh_pas_t.jcl +TOWHPLI towh_pli_f.jcl +TOWHPLI towh_pli_t.jcl +TOWHSIM towh_sim_f.jcl +TOWHSIM towh_sim_t.jcl +MCPI --- section --- Monte Carlo estimate of pi +MCPIA60 mcpi_a60_f.jcl +MCPIA60 mcpi_a60_t.jcl +MCPIASM mcpi_asm_f.jcl +MCPIASM mcpi_asm_t.jcl +MCPIGCC mcpi_gcc_f.jcl +MCPIGCC mcpi_gcc_t.jcl +MCPIJCC mcpi_jcc_f.jcl +MCPIJCC mcpi_jcc_t.jcl +MCPIFOG mcpi_forg_f.jcl +MCPIFOG mcpi_forg_t.jcl +MCPIFOH mcpi_forh_f.jcl +MCPIFOH mcpi_forh_t.jcl +MCPIFOW mcpi_forw_f.jcl +MCPIFOW mcpi_forw_t.jcl +MCPIPAS mcpi_pas_f.jcl +MCPIPAS mcpi_pas_t.jcl +MCPIPLI mcpi_pli_f.jcl +MCPIPLI mcpi_pli_t.jcl +MCPISIM mcpi_sim_f.jcl +MCPISIM mcpi_sim_t.jcl +./ ADD NAME=HEWOA60,LEVEL=00,SOURCE=0,LIST=ALL +//HEWO#A60 JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(1,0),PRTY=8 +//CLG EXEC ALGOFCLG, +// PARM.ALGOL='', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='' +//ALGOL.SYSIN DD * +'BEGIN' + OUTSTRING (1,'('Hello World !')'); +'END' +/* +//GO.ALGLDD01 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=HEWOASM,LEVEL=00,SOURCE=0,LIST=ALL +//HEWO#ASM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=128K,TIME=(1,0),PRTY=8 +//CLG EXEC ASMFCLG, +// MAC1='SYS2.MACLIB', +// PARM.ASM='NODECK,LOAD', +// PARM.LKED='MAP,LIST,LET,NCAL', +// COND.LKED=(8,LE,ASM), +// PARM.GO='', +// COND.GO=((8,LE,ASM),(4,LT,LKED)) +//ASM.SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(600,100)) +//ASM.SYSUT2 DD DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSUT3 DD DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSGO DD DSN=&&OBJSET,UNIT=SYSDA,SPACE=(80,(2000,500)) +//ASM.SYSIN DD * +* 1 2 3 4 5 6 71 +*23456789*12345*789012345678901234*678901234567890123456789012345678901 + PRINT NOGEN don't show macro expansions +HEWO START 0 start main code csect at base 0 + SAVE (14,12) Save input registers + LR R12,R15 base register := entry address + USING HEWO,R12 declare base register + ST R13,SAVE+4 set back pointer in current save area + LR R2,R13 remember callers save area + LA R13,SAVE setup current save area + ST R13,8(R2) set forw pointer in callers save area +* + OPEN (SYSPRINT,OUTPUT) open SYSPRINT + LTR R15,R15 test return code + BNE ABND8 abort if open failed + PUT SYSPRINT,MSG write the message + CLOSE SYSPRINT close SYSPRINT +* + L R13,SAVE+4 get old save area back + RETURN (14,12),RC=0 return to OS +* +ABND8 ABEND 8 bail out with abend U008 +* +* File and work area definitions +* +SAVE DS 18F local save area +MSG DC CL133' Hello World !' +SYSPRINT DCB DSORG=PS,MACRF=PM,DDNAME=SYSPRINT, X + RECFM=FBA,LRECL=133,BLKSIZE=1330 + YREGS , + END HEWO define main entry point +/* +//GO.SYSUDUMP DD SYSOUT=*,OUTLIM=2000 +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=HEWOCOB,LEVEL=00,SOURCE=0,LIST=ALL +//HEWO#COB JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=2048K,TIME=(1,0),PRTY=8 +//CLG EXEC COBUCLG, +// PARM.LKED='MAP,LIST,LET' +//COB.SYSIN DD * +000100 IDENTIFICATION DIVISION. +000200 PROGRAM-ID. 'HEWO'. +000300 ENVIRONMENT DIVISION. +001000 DATA DIVISION. +100000 PROCEDURE DIVISION. +100100 00-MAIN. +100500 DISPLAY 'Hello World !'. +100600 STOP RUN. +/* +//GO.SYSIN DD * +//GO.SYSOUT DD SYSOUT=* +/* +// +./ ADD NAME=HEWOFOG,LEVEL=00,SOURCE=0,LIST=ALL +//HEWO#FOG JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTGCLG, +// PARM.FORT='', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C +C --- main program --------------------------------------------------- +C PROGRAM HEWO + WRITE(6,9000) + STOP +C +9000 FORMAT(1X,'Hello World !') +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=HEWOFOH,LEVEL=00,SOURCE=0,LIST=ALL +//HEWO#FOH JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTHCLG, +// PARM.FORT='OPT=2', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C +C --- main program --------------------------------------------------- +C PROGRAM HEWO + WRITE(6,9000) + STOP +C +9000 FORMAT(1X,'Hello World !') +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=HEWOFOW,LEVEL=00,SOURCE=0,LIST=ALL +//HEWO#FOW JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC WATFIV +//SYSIN DD * +$JOB HEWO#FOW,T=(1,0),P=100,CHECK +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C +C --- main program --------------------------------------------------- +C PROGRAM HEWO + WRITE(6,9000) + STOP +C +9000 FORMAT(1X,'Hello World !') +C + END +$ENTRY +$STOP +/* +// +./ ADD NAME=HEWOGCC,LEVEL=00,SOURCE=0,LIST=ALL +//HEWO#GCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(1,0),PRTY=8 +//CLG EXEC GCCCLG,COPTS='-O3', +// PARM.LKED='MAP,LIST' +//COMP.SYSIN DD DATA,DLM='/@' +#include + +int main () +{ + printf ("Hello World !\n"); + return 0; +} +/@ +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=HEWOJCC,LEVEL=00,SOURCE=0,LIST=ALL +//HEWO#JCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(1,0),PRTY=8 +//CLG EXEC JCCCLG, +// JOPTS='-o', +// PARM.LKED='NCAL,MAP,LIST,NORENT' +//COMPILE.SYSIN DD DATA,DLM='/@' +#include + +int main () +{ + printf ("Hello World !\n"); + return 0; +} +/@ +//GO.STDOUT DD SYSOUT=*,OUTLIM=5000 +//GO.STDERR DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=HEWOPAS,LEVEL=00,SOURCE=0,LIST=ALL +//HEWO#PAS JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(1,0),PRTY=8 +//CLG EXEC PASCLG,GOTIME=3600,GOREG=1024K, +// OPT='M+', +// GOPARM='/STACK=512k' +//COMPILE.SYSIN DD * +program hewo(input,output); +begin + writeln(' ','Hello World !'); +end. +/* +//GO.OUTPUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=HEWOPLI,LEVEL=00,SOURCE=0,LIST=ALL +//HEWO#PLI JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC PL1LFCLG, +// PARM.PL1L='LOAD,NODECK,OPT=2', +// PARM.LKED='MAP,LIST' +//PL1L.SYSLIN DD UNIT=SYSDA +//PL1L.SYSIN DD * +/* 1 2 3 4 5 6 7*/-------- +/*4567890123456789012345678901234567890123456789012345678901234567890*/-------- + HELLO: PROC OPTIONS(MAIN) REORDER; + PUT SKIP LIST('Hello World !'); + END HELLO; +/* +//LKED.SYSLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.STEPLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.SYSIN DD * +/* +// +./ ADD NAME=HEWOSIM,LEVEL=00,SOURCE=0,LIST=ALL +//HEWO#SIM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1000K,TIME=(1,0),PRTY=8 +//CLG EXEC SIMCLG, +// PARM.SIM='', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='LINECNT=64' +//SIM.SYSIN DD * +BEGIN + OutText( "Hello World !" ); + OutImage; + OutImage; +END; +/* +//GO.SYSOUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=SINEA60,LEVEL=00,SOURCE=0,LIST=ALL +//SINE#A60 JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(1,0),PRTY=8 +//CLG EXEC ALGOFCLG, +// PARM.ALGOL='', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='' +//ALGOL.SYSIN DD * +'BEGIN' +'COMMENT' +* $Id: sine_a60.a60 978 2017-12-28 21:32:18Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-27 978 1.1 use outsymbol +* 2017-09-05 946 1.0 Initial version +*; + + 'INTEGER' I,J,ISIN,ICOS; + 'REAL' X,XRAD,FSIN,FCOS; + 'INTEGER' 'ARRAY' PLOT[1:81]; + + 'COMMENT' set record lenth = 132 and page length = 64; + SYSACT(1,6,132); + SYSACT(1,8,64); + + OUTSTRING (1,'(' x sin(x) cos(x) ')'); + OUTSTRING (1,'('-1 -0.5 0')'); + OUTSTRING (1,'(' +0.5 +1')'); + SYSACT(1,14,1); + OUTSTRING (1,'(' ')'); + OUTSTRING (1,'('+-------------------.-------------------:')'); + OUTSTRING (1,'('-------------------.-------------------+')'); + SYSACT(1,14,1); + + 'FOR' I := 0 'STEP' 1 'UNTIL' 60 'DO' 'BEGIN' + X := 6.0 * I; + XRAD := X/57.2957; + FSIN := SIN(XRAD); + FCOS := COS(XRAD); + OUTINTEGER(1,6*I); + OUTREAL(1,FSIN); + OUTREAL(1,FCOS); + + 'COMMENT' printer plot symbols: 1=+ 2=. 3=: 4=* 5=# 6=blank; + 'FOR' J := 1 'STEP' 1 'UNTIL' 81 'DO' PLOT[J] := 6; + PLOT[ 1] := 1; + PLOT[21] := 2; + PLOT[41] := 3; + PLOT[61] := 2; + PLOT[81] := 1; + ISIN := ENTIER(41.5 + 40.0 * FSIN); + ICOS := ENTIER(41.5 + 40.0 * FCOS); + PLOT[ISIN] := 4; + PLOT[ICOS] := 5; + 'FOR' J := 1 'STEP' 1 'UNTIL' 81 'DO' + OUTSYMBOL (1,'('+.:*# ')',PLOT[J]); + SYSACT(1,14,1); + 'END'; + + OUTSTRING (1,'(' ')'); + OUTSTRING (1,'('+-------------------.-------------------:')'); + OUTSTRING (1,'('-------------------.-------------------+')'); + SYSACT(1,14,1); + +'END' +/* +//GO.ALGLDD01 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=SINEFOG,LEVEL=00,SOURCE=0,LIST=ALL +//SINE#FOG JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTGCLG, +// PARM.FORT='', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: sine_for.f 964 2017-11-19 08:47:46Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-08-09 934 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM SINE + INTEGER PLOT(81) + INTEGER I,J,ISIN,ICOS + REAL*4 X,XRAD,FSIN,FCOS + INTEGER CBL,CPL,CDO,CCO,CST,CHA + DATA CBL/1H /,CPL/1H+/,CDO/1H./,CCO/1H:/,CST/1H*/,CHA/1H#/ +C + WRITE(6,9000) + WRITE(6,9010) +C +C Fortran IV(1966): DO limits must all to be > 0 -- FORTRAN-G enforces this + DO 100 I=1,61 + X = 6. * (I-1) + XRAD = X/57.2957795131 + FSIN = SIN(XRAD) + FCOS = COS(XRAD) + DO 200 J=1,81 + PLOT(J) = CBL +200 CONTINUE + PLOT( 1) = CPL + PLOT(21) = CDO + PLOT(41) = CCO + PLOT(61) = CDO + PLOT(81) = CPL + ISIN = 41.5 + 40. * FSIN + ICOS = 41.5 + 40. * FCOS + PLOT(ISIN) = CST + PLOT(ICOS) = CHA + WRITE(6,9020) X,FSIN,FCOS,PLOT +100 CONTINUE + WRITE(6,9010) + STOP +C +9000 FORMAT(1X,' x sin(x) cos(x) ', + * '-1 -0.5 0', + * ' +0.5 +1') +9010 FORMAT(1X,' ', + * '+-------------------.-------------------:', + * '-------------------.-------------------:') +9020 FORMAT(1X,F6.0,1X,F8.5,1X,F8.5,3X,81A1) +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=SINEFOH,LEVEL=00,SOURCE=0,LIST=ALL +//SINE#FOH JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTHCLG, +// PARM.FORT='OPT=2', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: sine_for.f 964 2017-11-19 08:47:46Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-08-09 934 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM SINE + INTEGER PLOT(81) + INTEGER I,J,ISIN,ICOS + REAL*4 X,XRAD,FSIN,FCOS + INTEGER CBL,CPL,CDO,CCO,CST,CHA + DATA CBL/1H /,CPL/1H+/,CDO/1H./,CCO/1H:/,CST/1H*/,CHA/1H#/ +C + WRITE(6,9000) + WRITE(6,9010) +C +C Fortran IV(1966): DO limits must all to be > 0 -- FORTRAN-G enforces this + DO 100 I=1,61 + X = 6. * (I-1) + XRAD = X/57.2957795131 + FSIN = SIN(XRAD) + FCOS = COS(XRAD) + DO 200 J=1,81 + PLOT(J) = CBL +200 CONTINUE + PLOT( 1) = CPL + PLOT(21) = CDO + PLOT(41) = CCO + PLOT(61) = CDO + PLOT(81) = CPL + ISIN = 41.5 + 40. * FSIN + ICOS = 41.5 + 40. * FCOS + PLOT(ISIN) = CST + PLOT(ICOS) = CHA + WRITE(6,9020) X,FSIN,FCOS,PLOT +100 CONTINUE + WRITE(6,9010) + STOP +C +9000 FORMAT(1X,' x sin(x) cos(x) ', + * '-1 -0.5 0', + * ' +0.5 +1') +9010 FORMAT(1X,' ', + * '+-------------------.-------------------:', + * '-------------------.-------------------:') +9020 FORMAT(1X,F6.0,1X,F8.5,1X,F8.5,3X,81A1) +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=SINEFOW,LEVEL=00,SOURCE=0,LIST=ALL +//SINE#FOW JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC WATFIV +//SYSIN DD * +$JOB SINE#FOW,T=(1,0),P=100,CHECK +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: sine_for.f 964 2017-11-19 08:47:46Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-08-09 934 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM SINE + INTEGER PLOT(81) + INTEGER I,J,ISIN,ICOS + REAL*4 X,XRAD,FSIN,FCOS + INTEGER CBL,CPL,CDO,CCO,CST,CHA + DATA CBL/1H /,CPL/1H+/,CDO/1H./,CCO/1H:/,CST/1H*/,CHA/1H#/ +C + WRITE(6,9000) + WRITE(6,9010) +C +C Fortran IV(1966): DO limits must all to be > 0 -- FORTRAN-G enforces this + DO 100 I=1,61 + X = 6. * (I-1) + XRAD = X/57.2957795131 + FSIN = SIN(XRAD) + FCOS = COS(XRAD) + DO 200 J=1,81 + PLOT(J) = CBL +200 CONTINUE + PLOT( 1) = CPL + PLOT(21) = CDO + PLOT(41) = CCO + PLOT(61) = CDO + PLOT(81) = CPL + ISIN = 41.5 + 40. * FSIN + ICOS = 41.5 + 40. * FCOS + PLOT(ISIN) = CST + PLOT(ICOS) = CHA + WRITE(6,9020) X,FSIN,FCOS,PLOT +100 CONTINUE + WRITE(6,9010) + STOP +C +9000 FORMAT(1X,' x sin(x) cos(x) ', + * '-1 -0.5 0', + * ' +0.5 +1') +9010 FORMAT(1X,' ', + * '+-------------------.-------------------:', + * '-------------------.-------------------:') +9020 FORMAT(1X,F6.0,1X,F8.5,1X,F8.5,3X,81A1) +C + END +$ENTRY +$STOP +/* +// +./ ADD NAME=SINEGCC,LEVEL=00,SOURCE=0,LIST=ALL +//SINE#GCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(1,0),PRTY=8 +//CLG EXEC GCCCLG,COPTS='-O3', +// PARM.LKED='MAP,LIST' +//COMP.SYSIN DD DATA,DLM='/@' +/* $Id: sine_cc.c 964 2017-11-19 08:47:46Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-07-30 931 0.1 Initial version */ + +#include +#include + +int main () +{ + char plot[82]; + int i,j,isin,icos; + double x,xrad,fsin,fcos; + char* f1 = " x sin(x) cos(x) " + "-1 -0.5 0" + " +0.5 +1"; + char* f2 = " " + "+-------------------.-------------------:" + "-------------------.-------------------:"; + + plot[81] = 0; + printf ("%s\n",f1); + printf ("%s\n",f2); + + for (i=0; i<=60; i++) { + x = 6. * i; + xrad = x/57.2957795131; + fsin = sin(xrad); + fcos = cos(xrad); + for (j=0; j<81; j++) plot[j] = ' '; + plot[ 0] = '+'; + plot[20] = '.'; + plot[40] = ':'; + plot[60] = '.'; + plot[80] = '+'; + isin = 40.5 + 40. * fsin; + icos = 40.5 + 40. * fcos; + plot[isin] = '*'; + plot[icos] = '#'; + printf("%6.0f %8.5f %8.5f %s\n", x,fsin,fcos,plot); + } + printf ("%s\n",f2); + return 0; +} +/@ +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=SINEJCC,LEVEL=00,SOURCE=0,LIST=ALL +//SINE#JCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(1,0),PRTY=8 +//CLG EXEC JCCCLG, +// JOPTS='-o', +// PARM.LKED='NCAL,MAP,LIST,NORENT' +//COMPILE.SYSIN DD DATA,DLM='/@' +/* $Id: sine_cc.c 964 2017-11-19 08:47:46Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-07-30 931 0.1 Initial version */ + +#include +#include + +int main () +{ + char plot[82]; + int i,j,isin,icos; + double x,xrad,fsin,fcos; + char* f1 = " x sin(x) cos(x) " + "-1 -0.5 0" + " +0.5 +1"; + char* f2 = " " + "+-------------------.-------------------:" + "-------------------.-------------------:"; + + plot[81] = 0; + printf ("%s\n",f1); + printf ("%s\n",f2); + + for (i=0; i<=60; i++) { + x = 6. * i; + xrad = x/57.2957795131; + fsin = sin(xrad); + fcos = cos(xrad); + for (j=0; j<81; j++) plot[j] = ' '; + plot[ 0] = '+'; + plot[20] = '.'; + plot[40] = ':'; + plot[60] = '.'; + plot[80] = '+'; + isin = 40.5 + 40. * fsin; + icos = 40.5 + 40. * fcos; + plot[isin] = '*'; + plot[icos] = '#'; + printf("%6.0f %8.5f %8.5f %s\n", x,fsin,fcos,plot); + } + printf ("%s\n",f2); + return 0; +} +/@ +//GO.STDOUT DD SYSOUT=*,OUTLIM=5000 +//GO.STDERR DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=SINEPAS,LEVEL=00,SOURCE=0,LIST=ALL +//SINE#PAS JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(1,0),PRTY=8 +//CLG EXEC PASCLG,GOTIME=3600,GOREG=1024K, +// OPT='M+', +// GOPARM='/STACK=512k' +//COMPILE.SYSIN DD * +(* $Id: sine_pas.pas 964 2017-11-19 08:47:46Z mueller $ *) +(* +(* Copyright 2017- by Walter F.J. Mueller *) +(* +(* This program is free software; you may redistribute and/or modify *) +(* it under the terms of the GNU General Public License version 3. *) +(* See Licence.txt in distribition directory for further details. *) +(* *) +(* Revision History: *) +(* Date Rev Version Comment *) +(* 2017-09-08 949 1.0 Initial version *) + +program sine(input,output); +var + i,j,isin,icos : integer; + x,xrad,fsin,fcos : real; + plot : ARRAY[1 .. 81] of char; + +begin + + writeln(' ',' x sin(x) cos(x) ', + '-1 -0.5 0', + ' +0.5 +1'); + writeln(' ', ' ', + '+-------------------.-------------------:', + '-------------------.-------------------+'); + + for i := 0 to 60 do begin + x := 6.0 * i; + xrad := x/57.2957795131; + fsin := sin(xrad); + fcos := cos(xrad); + for j := 1 to 81 do plot[j] := ' '; + plot[ 1] := '+'; + plot[21] := '.'; + plot[41] := ':'; + plot[61] := '.'; + plot[81] := '+'; + isin := trunc(41.5 + 40.0 * fsin); + icos := trunc(41.5 + 40.0 * fcos); + plot[isin] := '*'; + plot[icos] := '#'; + write(' ',x:6:1,fsin:9:5,fcos:9:5,' '); + for j := 1 to 81 do write(plot[j]:1); + writeln(' '); + end; + writeln(' ', ' ', + '+-------------------.-------------------:', + '-------------------.-------------------+'); +end. +/* +//GO.OUTPUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=SINEPLI,LEVEL=00,SOURCE=0,LIST=ALL +//SINE#PLI JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC PL1LFCLG, +// PARM.PL1L='LOAD,NODECK,OPT=2', +// PARM.LKED='MAP,LIST' +//PL1L.SYSLIN DD UNIT=SYSDA +//PL1L.SYSIN DD * +/* 1 2 3 4 5 6 7*/-------- +/*4567890123456789012345678901234567890123456789012345678901234567890*/-------- +/* $Id: sine_pli.pli 964 2017-11-19 08:47:46Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-09-07 947 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + + SINE: PROC OPTIONS(MAIN) REORDER; + DCL (I,ISIN,ICOS) BIN FIXED(31); + DCL (X,XRAD,FSIN,FCOS) DEC FLOAT(6); + DCL PLOT CHAR(81); + + PUT SKIP EDIT(' x sin(x) cos(x) ', + '-1 -0.5 0', + ' +0.5 +1') + (A,A,A); + PUT SKIP EDIT(' ', + '+-------------------.-------------------:', + '-------------------.-------------------+') + (A,A,A); + + DO I=0 TO 60; + X = 6. * I; + XRAD = X/57.2957795131; + FSIN = SIN(XRAD); + FCOS = COS(XRAD); + PLOT = ' '; + SUBSTR(PLOT, 1,1) = '+'; + SUBSTR(PLOT,21,1) = '.'; + SUBSTR(PLOT,41,1) = ':'; + SUBSTR(PLOT,61,1) = '.'; + SUBSTR(PLOT,81,1) = '+'; + ISIN = 41.5 + 40. * FSIN; + ICOS = 41.5 + 40. * FCOS; + SUBSTR(PLOT,ISIN,1) = '*'; + SUBSTR(PLOT,ICOS,1) = '#'; + PUT SKIP EDIT (X,FSIN,FCOS,PLOT) + (F(6,0),X(1),F(8,5),X(1),F(8,5),X(3),A); + END; + + PUT SKIP EDIT(' ', + '+-------------------.-------------------:', + '-------------------.-------------------+') + (A,A,A); + + END SINE; +/* +//LKED.SYSLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.STEPLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.SYSIN DD * +/* +// +./ ADD NAME=SINESIM,LEVEL=00,SOURCE=0,LIST=ALL +//SINE#SIM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1000K,TIME=(1,0),PRTY=8 +//CLG EXEC SIMCLG, +// PARM.SIM='', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='LINECNT=64' +//SIM.SYSIN DD * +COMMENT +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-09-08 949 1.0 Initial version +*; + +BEGIN + INTEGER i,j,isin,icos; + REAL x,xrad,fsin,fcos; + CHARACTER ARRAY plot(1:81); + + OutText(" x sin(x) cos(x) "); + OutText("-1 -0.5 0"); + OutText(" +0.5 +1"); + OutImage; + OutText(" "); + OutText("+-------------------.-------------------:"); + OutText("-------------------.-------------------+"); + OutImage; + + FOR i := 0 STEP 1 UNTIL 60 DO BEGIN + x := 6.0 * i; + xrad := x/57.2957795131; + fsin := sin(xrad); + fcos := cos(xrad); + FOR j := 1 STEP 1 UNTIL 81 DO plot(j) := ' '; + plot( 1) := '+'; + plot(21) := '.'; + plot(41) := ':'; + plot(61) := '.'; + plot(81) := '+'; + isin := Entier(41.5 + 40.0 * fsin); + icos := Entier(41.5 + 40.0 * fcos); + plot(isin) := '*'; + plot(icos) := '#'; + OutFix(x,0,6); + OutFix(fsin,5,9); + OutFix(fcos,5,9); + OutText(" "); + FOR j := 1 STEP 1 UNTIL 81 DO OutChar(plot(j)); + OutImage; + END; + OutText(" "); + OutText("+-------------------.-------------------:"); + OutText("-------------------.-------------------+"); + OutImage; + OutImage; +END; +/* +//GO.SYSOUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +/* +// +./ ADD NAME=SOEPA60F,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#A60 JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC ALGOFCLG, +// PARM.ALGOL='', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='' +//ALGOL.SYSIN DD * +'BEGIN' +'COMMENT' +* $Id: soep_a60.a60 975 2017-12-25 19:22:43Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end +* 2017-12-23 972 1.1 change (n-1)/2 --> n'/'2 +* use integer '/' divide +* 2017-09-17 951 1.0 Initial version +* 2017-09-05 946 0.1 First draft +*; + + 'INTEGER' NMAX,PRNT,IMAX,NMSQRT; + 'INTEGER' I,N,IMIN; + 'INTEGER' NP,IL,NL; + + 'COMMENT' set record lenth = 132 and page length = 64; + SYSACT(1,6,132); + SYSACT(1,8,64); + + ININTEGER(0,NMAX); + ININTEGER(0,PRNT); + + 'IF' NMAX <= 10 'THEN' 'BEGIN' + OUTSTRING (1,'('nmax must be >= 10, abort')'); + 'GOTO' DONE; + 'END'; + + NMSQRT := ENTIER(SQRT(NMAX)); + IMAX := (NMAX-1)'/'2; + + 'BEGIN' + 'BOOLEAN' 'ARRAY' PRIME[0:IMAX]; + 'FOR' I := 0 'STEP' 1 'UNTIL' IMAX 'DO' PRIME[I] := 'TRUE'; + + 'FOR' N := 3 'STEP' 2 'UNTIL' NMSQRT 'DO' 'BEGIN' + 'IF' PRIME[N'/'2] 'THEN' 'BEGIN' + IMIN := (N*N) '/' 2; + 'FOR' I := IMIN 'STEP' N 'UNTIL' IMAX 'DO' PRIME[I] := 'FALSE'; + 'END'; + 'END'; + + 'IF' PRNT > 0 'THEN' 'BEGIN' + OUTSTRING (1,'('List of Primes up to ')'); + OUTINTEGER(1, NMAX); + SYSACT(1,14,1); + OUTINTEGER(1, 2); + NP := 1; + 'FOR' I := 1 'STEP' 1 'UNTIL' IMAX 'DO' 'BEGIN' + 'IF' PRIME[I] 'THEN' 'BEGIN' + OUTINTEGER(1, 1+2*I); + NP := NP + 1; + 'IF' NP = 10 'THEN' 'BEGIN' + SYSACT(1,14,1); + NP := 0; + 'END'; + 'END'; + 'END'; + 'IF' NP > 0 'THEN' SYSACT(1,14,1); + 'END'; + + IL := 4; + NL := 10; + NP := 1; + 'FOR' I := 1 'STEP' 1 'UNTIL' IMAX 'DO' 'BEGIN' + 'IF' PRIME[I] 'THEN' NP := NP+ 1; + 'IF' I = IL 'THEN' 'BEGIN' + NL := 2*IL + 2; + OUTSTRING (1,'('pi(')'); + OUTINTEGER(1, NL); + OUTSTRING (1,'('):')'); + OUTINTEGER(1, NP); + SYSACT(1,14,1); + IL := 10*(IL+1)-1; + 'END'; + 'END'; + + 'IF' NL < NMAX 'THEN' 'BEGIN' + OUTSTRING (1,'('pi(')'); + OUTINTEGER(1, NMAX); + OUTSTRING (1,'('):')'); + OUTINTEGER(1, NP); + SYSACT(1,14,1); + 'END'; + + 'END'; + + DONE: +'END' +/* +//GO.ALGLDD01 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 10000000 0 +/* +// +./ ADD NAME=SOEPA60P,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#A60 JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC ALGOFCLG, +// PARM.ALGOL='', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='' +//ALGOL.SYSIN DD * +'BEGIN' +'COMMENT' +* $Id: soep_a60.a60 975 2017-12-25 19:22:43Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end +* 2017-12-23 972 1.1 change (n-1)/2 --> n'/'2 +* use integer '/' divide +* 2017-09-17 951 1.0 Initial version +* 2017-09-05 946 0.1 First draft +*; + + 'INTEGER' NMAX,PRNT,IMAX,NMSQRT; + 'INTEGER' I,N,IMIN; + 'INTEGER' NP,IL,NL; + + 'COMMENT' set record lenth = 132 and page length = 64; + SYSACT(1,6,132); + SYSACT(1,8,64); + + ININTEGER(0,NMAX); + ININTEGER(0,PRNT); + + 'IF' NMAX <= 10 'THEN' 'BEGIN' + OUTSTRING (1,'('nmax must be >= 10, abort')'); + 'GOTO' DONE; + 'END'; + + NMSQRT := ENTIER(SQRT(NMAX)); + IMAX := (NMAX-1)'/'2; + + 'BEGIN' + 'BOOLEAN' 'ARRAY' PRIME[0:IMAX]; + 'FOR' I := 0 'STEP' 1 'UNTIL' IMAX 'DO' PRIME[I] := 'TRUE'; + + 'FOR' N := 3 'STEP' 2 'UNTIL' NMSQRT 'DO' 'BEGIN' + 'IF' PRIME[N'/'2] 'THEN' 'BEGIN' + IMIN := (N*N) '/' 2; + 'FOR' I := IMIN 'STEP' N 'UNTIL' IMAX 'DO' PRIME[I] := 'FALSE'; + 'END'; + 'END'; + + 'IF' PRNT > 0 'THEN' 'BEGIN' + OUTSTRING (1,'('List of Primes up to ')'); + OUTINTEGER(1, NMAX); + SYSACT(1,14,1); + OUTINTEGER(1, 2); + NP := 1; + 'FOR' I := 1 'STEP' 1 'UNTIL' IMAX 'DO' 'BEGIN' + 'IF' PRIME[I] 'THEN' 'BEGIN' + OUTINTEGER(1, 1+2*I); + NP := NP + 1; + 'IF' NP = 10 'THEN' 'BEGIN' + SYSACT(1,14,1); + NP := 0; + 'END'; + 'END'; + 'END'; + 'IF' NP > 0 'THEN' SYSACT(1,14,1); + 'END'; + + IL := 4; + NL := 10; + NP := 1; + 'FOR' I := 1 'STEP' 1 'UNTIL' IMAX 'DO' 'BEGIN' + 'IF' PRIME[I] 'THEN' NP := NP+ 1; + 'IF' I = IL 'THEN' 'BEGIN' + NL := 2*IL + 2; + OUTSTRING (1,'('pi(')'); + OUTINTEGER(1, NL); + OUTSTRING (1,'('):')'); + OUTINTEGER(1, NP); + SYSACT(1,14,1); + IL := 10*(IL+1)-1; + 'END'; + 'END'; + + 'IF' NL < NMAX 'THEN' 'BEGIN' + OUTSTRING (1,'('pi(')'); + OUTINTEGER(1, NMAX); + OUTSTRING (1,'('):')'); + OUTINTEGER(1, NP); + SYSACT(1,14,1); + 'END'; + + 'END'; + + DONE: +'END' +/* +//GO.ALGLDD01 DD SYSOUT=*,OUTLIM=100000 +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEPA60T,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#A60 JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(1,0),PRTY=8 +//CLG EXEC ALGOFCLG, +// PARM.ALGOL='', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='' +//ALGOL.SYSIN DD * +'BEGIN' +'COMMENT' +* $Id: soep_a60.a60 975 2017-12-25 19:22:43Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end +* 2017-12-23 972 1.1 change (n-1)/2 --> n'/'2 +* use integer '/' divide +* 2017-09-17 951 1.0 Initial version +* 2017-09-05 946 0.1 First draft +*; + + 'INTEGER' NMAX,PRNT,IMAX,NMSQRT; + 'INTEGER' I,N,IMIN; + 'INTEGER' NP,IL,NL; + + 'COMMENT' set record lenth = 132 and page length = 64; + SYSACT(1,6,132); + SYSACT(1,8,64); + + ININTEGER(0,NMAX); + ININTEGER(0,PRNT); + + 'IF' NMAX <= 10 'THEN' 'BEGIN' + OUTSTRING (1,'('nmax must be >= 10, abort')'); + 'GOTO' DONE; + 'END'; + + NMSQRT := ENTIER(SQRT(NMAX)); + IMAX := (NMAX-1)'/'2; + + 'BEGIN' + 'BOOLEAN' 'ARRAY' PRIME[0:IMAX]; + 'FOR' I := 0 'STEP' 1 'UNTIL' IMAX 'DO' PRIME[I] := 'TRUE'; + + 'FOR' N := 3 'STEP' 2 'UNTIL' NMSQRT 'DO' 'BEGIN' + 'IF' PRIME[N'/'2] 'THEN' 'BEGIN' + IMIN := (N*N) '/' 2; + 'FOR' I := IMIN 'STEP' N 'UNTIL' IMAX 'DO' PRIME[I] := 'FALSE'; + 'END'; + 'END'; + + 'IF' PRNT > 0 'THEN' 'BEGIN' + OUTSTRING (1,'('List of Primes up to ')'); + OUTINTEGER(1, NMAX); + SYSACT(1,14,1); + OUTINTEGER(1, 2); + NP := 1; + 'FOR' I := 1 'STEP' 1 'UNTIL' IMAX 'DO' 'BEGIN' + 'IF' PRIME[I] 'THEN' 'BEGIN' + OUTINTEGER(1, 1+2*I); + NP := NP + 1; + 'IF' NP = 10 'THEN' 'BEGIN' + SYSACT(1,14,1); + NP := 0; + 'END'; + 'END'; + 'END'; + 'IF' NP > 0 'THEN' SYSACT(1,14,1); + 'END'; + + IL := 4; + NL := 10; + NP := 1; + 'FOR' I := 1 'STEP' 1 'UNTIL' IMAX 'DO' 'BEGIN' + 'IF' PRIME[I] 'THEN' NP := NP+ 1; + 'IF' I = IL 'THEN' 'BEGIN' + NL := 2*IL + 2; + OUTSTRING (1,'('pi(')'); + OUTINTEGER(1, NL); + OUTSTRING (1,'('):')'); + OUTINTEGER(1, NP); + SYSACT(1,14,1); + IL := 10*(IL+1)-1; + 'END'; + 'END'; + + 'IF' NL < NMAX 'THEN' 'BEGIN' + OUTSTRING (1,'('pi(')'); + OUTINTEGER(1, NMAX); + OUTSTRING (1,'('):')'); + OUTINTEGER(1, NP); + SYSACT(1,14,1); + 'END'; + + 'END'; + + DONE: +'END' +/* +//GO.ALGLDD01 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEPASMF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#ASM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC ASMFCLG, +// MAC1='SYS2.MACLIB', +// PARM.ASM='NOLIST,NOXREF,NORLD,NODECK,LOAD', +// PARM.LKED='MAP,LIST,LET,NCAL', +// COND.LKED=(8,LE,ASM), +// PARM.GO='', +// COND.GO=((8,LE,ASM),(4,LT,LKED)) +//ASM.SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(600,100)) +//ASM.SYSUT2 DD DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSUT3 DD DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSGO DD DSN=&&OBJSET,UNIT=SYSDA,SPACE=(80,(2000,500)) +//ASM.SYSIN DD * +* 1 2 3 4 5 6 71 +*23456789*12345*789012345678901234*678901234567890123456789012345678901 +* $Id: soep_asm.asm 972 2017-12-23 20:55:41Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software; you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +* 2017-11-12 961 1.0 Initial version +* 2017-10-03 954 0.1 First draft +* + PRINT NOGEN don't show macro expansions +* +* Prime number search +* RC = 0 ok +* RC = 4 NMAX out of range +* RC = 8 unexpected SYSIN EOF +* RC = 12 open SYSIN failed +* RC = 16 open SYSPRINT failed +* +* local macros -------------------------------------------------------- +* +* +* OTXTDSC - setup text descriptor for simple output system - +* + MACRO +&LABEL OTXTDSC &TEXT +TEXT CSECT +SPTR&SYSNDX DC &TEXT +&SYSECT CSECT + DS 0F +&LABEL DC AL1(L'SPTR&SYSNDX),AL3(SPTR&SYSNDX) + MEND +* +* main preamble ------------------------------------------------------- +* +MAIN START 0 start main code csect at base 0 + SAVE (14,12) Save input registers + LR R12,R15 base register := entry address + USING MAIN,R12 declare base register + ST R13,SAVE+4 set back pointer in current save area + LR R2,R13 remember callers save area + LA R13,SAVE setup current save area + ST R13,8(R2) set forw pointer in callers save area +* +* open datasets ------------------------------------------------------- +* + OPEN (SYSPRINT,OUTPUT) open SYSPRINT + LTR R15,R15 test return code + BE OOPENOK + MVI RC+3,X'10' + B EXIT quit with RC=16 +OOPENOK OPEN (SYSIN,INPUT) open SYSIN + LTR R15,R15 test return code + BE IOPENOK + MVI RC+3,X'0C' + B EXIT quit with RC=12 +IOPENOK EQU * +* +* read input parameters, and check range ------------------------------ +* + BAL R14,IGETLINE read input line + BAL R14,IINT10 get NMAX + ST R1,NMAX + BAL R14,IINT10 get PRNT + STC R1,PRNT +* + L R1,NMAX + C R1,=F'10' is NMAX >= 10 + BL NMAXBAD if < not + C R1,=F'10000000' is NMAX <= 10000000 + BNH NMAXOK if <= yes +NMAXBAD L R1,MSGPERR + BAL R14,OTEXT print error + BAL R14,OPUTLINE write line + MVI RC+3,X'04' + B EXIT quit with RC=4 +NMAXOK EQU * +* +* setup phase --------------------------------------------------------- +* +* calculate sqrt(nmax) ----------------------------------- +* use simple bi-section method +* R4 low bound +* R5 high bound +* R7 middle (low+high)/2 +* + LA R4,1 set low bound + L R5,NMAX set high bound + LA R6,32 set iteration limit +NMSQRTLP LR R7,R4 R7:= low + AR R7,R5 R7:= (low+high) + SRA R7,1 R7:= (low+high)/2 + LR R3,R7 + MR R2,R7 (R2,R3) := R7*R7 + LTR R2,R2 more than 32 bit ? + BNE NMSQRTHI if != yes, mid too high + CL R3,NMAX mid*mid > NMAX + BH NMSQRTHI if > yes, mid too high + LR R4,R7 here mid to low: low := mid + B NMSQRTGO +NMSQRTHI LR R5,R7 here mid to high: high := mid +NMSQRTGO LR R8,R5 R8 := high + SR R8,R4 R8 := high-low + LR R1,R6 + C R8,=F'1' spread <= 1 ? + BNH NMSQRTOK if <= yes, quit + BCT R6,NMSQRTLP + ABEND 99 abort if doesn't converge +NMSQRTOK EQU * + ST R4,NMSQRT + +* allocate PRIME array ----------------------------------- + L R2,NMAX + BCTR R2,0 NMAX-1 + SRA R2,1 (NMAX-1)/2 + ST R2,IMAX + LA R5,1(R2) IMAX+1 (24 bit enough) + GETMAIN RU,LV=(5) allocate storage for PRIME + ST R1,PRIME store sieve base + LR R9,R1 R9 := PRIME base +* +* set each PRIME array byte to X'01' --------------------- + LR R4,R1 R4 := PRIME +* R5 := IMAX+1 (still) + XR R6,R6 R6 := 0 + L R7,=X'01000000' R7 := padding=1 and length=0 + MVCL R4,R6 set all PRIME bytes to 1 +* +* sieve phase --------------------------------------------------------- +* outer loop: ind R6 n +* inc R4 2 +* lim R5 sqrt(NMAX) +* inner loop: ind R3 p +* inc R6 n +* lim R7 pmax +* R0,R1,R2 temporaries +* register usage: +* R0 temporary +* R1 temporary +* R2 temporary +* R3 inner loop ind p +* R4 outer loop inc 2 +* R5 outer loop lim sqrt(NMAX) +* R6 inner loop inc n (and outer loop ind !!) +* R7 inner loop lim pmax +* R8 -- unused -- +* R9 &prime +* R10 -- unused -- +* R11 -- unused -- +* +* +* equivalent C code: +* pmax = &prime[imax]; +* for (n=3; n<=nmsqrt; n+=2) { +* if (prime[(n-1)/2] == 0) continue; +* for (p=&prime[(n*n-1)/2]; p<=pmax; p+=n) *p = 0; +* } +* + LA R6,3 outer ind: R6:=3 + LA R4,2 outer inc: R4:=2 + L R5,NMSQRT outer lim: R5:=NMSQRT + LR R7,R9 R7:=&prime + A R7,IMAX inner lim: R7:=&prime[imax] +SIEVO LR R2,R6 R2:=n + SRA R2,1 R2:=n/2 + AR R2,R9 R2:=&prime[n/2] + CLI 0(R2),X'00' test prime candidate + BE SIEVOC if = not, continue outer loop +* + LR R1,R6 R1:=n + MR R0,R6 R1:=n*n (lower half, enough) + LR R3,R1 R3:=n*n too +* + SRA R3,1 R3:=(n*n)/2 + AR R3,R9 R3:=&prime[(n*n-1)/2] +* +SIEVI MVI 0(R3),X'00' *p=0 + BXLE R3,R6,SIEVI +* +SIEVOC BXLE R6,R4,SIEVO +* +* print primes table -------------------------------------------------- +* loop: ind R3 i +* inc R4 1 +* lim R5 imax +* R2 np +* + CLI PRNT,X'00' primes to be printed ? + BE NOPRNT if = skip + L R1,MSGLIST + BAL R14,OTEXT print heading + L R1,NMAX + BAL R14,OINT10 print nmax + BAL R14,OPUTLINE write line +* + LA R1,2 + BAL R14,OINT10 print "2" (1st prime...) + LA R2,1 np=1 + LA R3,1 ind: R3:=1 + LA R4,1 inc: R4:=1 + L R5,IMAX lim: R5:=IMAX +PRTLOOP LR R6,R3 R6:=i + AR R6,R9 R6:=&primes[i] + CLI 0(R6),X'00' test whether prime + BE PRTLOOPC if = not, continue + LR R1,R3 R1:=i + SLA R1,1 R1:=2*i + LA R1,1(R1) R1:=1+2*i + BAL R14,OINT10 and print F(10) + LA R2,1(R2) np+=1 + C R2,=F'10' check wheter = 10 + BNZ PRTLOOPC if != not, continue + BAL R14,OPUTLINE write line + XR R2,R2 np=0 +PRTLOOPC EQU * + BXLE R3,R4,PRTLOOP +* + LTR R2,R2 check prime count np + BZ NOPRNT + BAL R14,OPUTLINE write line +NOPRNT EQU * +* +* print primes count -------------------------------------------------- +* loop: ind R3 i +* inc R4 1 +* lim R5 imax +* R2 np +* R7 il +* R8 nl +* + LA R2,1 np=1 + LA R7,4 il=4 + LA R8,10 nl=10 + LA R3,1 ind: R3:=1 + LA R4,1 inc: R4:=1 + L R5,IMAX lim: R5:=IMAX +TBLLOOP LR R6,R3 R6:=i + AR R6,R9 R6:=&primes[i] + CLI 0(R6),X'00' test whether prime + BE NOPRIME if = not + LA R2,1(R2) np+= 1 +NOPRIME CR R3,R7 test i != il + BNE TBLLOOPC + LR R8,R7 nl=il + SLA R8,1 nl=2*il + LA R8,2(R8) nl=2+2*il +* + L R1,MSGPI + BAL R14,OTEXT print "pi(...." + LR R1,R8 + BAL R14,OINT10 print nl + L R1,MSGPISEP + BAL R14,OTEXT print "):..." + LR R1,R2 + BAL R14,OINT10 print np + BAL R14,OPUTLINE write line +* + LR R1,R7 R1:=il + LA R1,1(R1) R1:=il+1 + M R0,=F'10' R1:=10*(il+1) + S R1,=F'1' R1:=10*(il+1)-1 + LR R7,R1 update il +* +TBLLOOPC EQU * + BXLE R3,R4,TBLLOOP +* + C R8,NMAX is nl != nmax ? + BE TBLNOTR if = not, skip extra summary +* + L R1,MSGPI + BAL R14,OTEXT print "pi(...." + L R1,NMAX + BAL R14,OINT10 print nmax + L R1,MSGPISEP + BAL R14,OTEXT print "):..." + LR R1,R2 + BAL R14,OINT10 print np + BAL R14,OPUTLINE write line +* +TBLNOTR EQU * +* +* close datasets and return to OS ------------------------------------- +* +EXIT CLOSE SYSPRINT close SYSPRINT + CLOSE SYSIN close SYSIN + L R13,SAVE+4 get old save area back + L R0,RC get return code + ST R0,16(R13) store in old save R15 + RETURN (14,12) return to OS (will setup RC) +* +* include simple output system ---------------------------------------- +* +* simple output system procedures ------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* OSKIP02 -------------------------------------------------- +* add 2 blanks +* +OSKIP02 LA R1,2 +* +* OSKIP ---------------------------------------------------- +* add blanks, count in R1 +* +OSKIP A R1,OLPTR new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OTAB ---------------------------------------------------- +* set output column, position in R1 +* +OTAB A R1,=A(OLBUF+1) new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OSFILL --------------------------------------------------- +* add " ***" pattern, total length in R1 +* +OSFILL L R15,OLPTR R15 points to edit position + MVI 0(R15),C' ' initial blank + B OSFILLN +OSFILLL MVI 0(R15),C'*' further '*' +OSFILLN LA R15,1(R15) + BCT R1,OSFILLL + ST R15,OLPTR store pointer + BR R14 +* +* OTEXT ---------------------------------------------------- +* print text, R1 hold descriptor address +* descriptor format +* DC AL1() +* DC AL2(
) +* +OTEXT ST R14,OTEXTL save R14 + LR R14,R1 + SRL R14,24 R14 now string length + L R15,OLPTR R15 points to edit position + LR R0,R15 R0 too + AR R0,R14 push pointer, add length + ST R0,OLPTR store pointer + BCTR R14,0 decrement length for EX + EX R14,OTEXTMVC copy string via EX:MVC + L R14,OTEXTL restore R14 linkage + BR R14 +* +OTEXTMVC MVC 0(1,R15),0(R1) length via EX, dst R15, src R1 +OTEXTL DS F save area for R14 (return linkage) +* +* OPUTLINE ------------------------------------------------- +* write line to SYSPRINT +* +OPUTLINE ST R14,OPUTLNEL save R14 + L R15,=A(OLBUF) + CLI 133(R15),X'00' check fence byte + BNE OPUTLNEA crash if fence blown + L R1,=A(SYSPRINT) R1 point to DCB + LR R0,R15 R1 point to buffer + PUT (1),(0) write line + L R15,=A(OLBUF) point to CC of OLBUF + MVI 0(R15),C' ' blank OLBUF(0) + MVC 1(L'OLBUF-1,R15),0(R15) propagate blank + LA R15,1(R15) point to 1st print char in OLBUF + ST R15,OLPTR reset current position pointer + LA R15,1 + AH R15,OLCNT increment line counter + STH R15,OLCNT + SH R15,OLMAX R15 := OLCNT-OLMAX + BL OPUTLNES if < no new page + XR R15,R15 R15 := 0 + SH R15,OLCNT clear line counter + L R15,=A(OLBUF) point to CC of OLBUF +* MVI 0(R15),C'1' set new page CC in OLBUF +OPUTLNES L R14,OPUTLNEL restore R14 linkage + BR R14 +* +OPUTLNEA ABEND 255 abend in case of errors +* +OPUTLNEL DS F save area for R14 (return linkage) +* +* Work area for simple output system ------------------------ +* +OLPTR DC A(OLBUF+1) current output line position +OLCNT DC H'0' line counter +OLMAX DC H'60' lines per page +OCVD DS D buffer for CVD (8 byte, DW aligned) +* +ODTEMP DS D double buffer for conversions +ODNZERO DC X'4E000000',X'00000000' denormalized double zero +ODNONE DC X'4E000000',X'00000001' denormalized double one +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSPRINT DCB DSORG=PS,MACRF=PM,DDNAME=SYSPRINT, X + RECFM=FBA,LRECL=133,BLKSIZE=0 +OLBUF DC CL133' ',X'00' output line buffer and fence byte +* +MAIN CSECT +* +* OINT10 --------------------------------------------------- +* print integer, like PL/I F(10) or C %10d format +* very fast, for non-negative numbers only ! +* +OINT10 CL R1,=F'999999999' too large ? + BH OINT10F if > yes, do OSFILL + CVD R1,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEI10L,R15),OEI10 setup pattern + ED 0(OEI10L,R15),OCVD+3 and edit + LA R15,OEI10L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OINT10F LA R1,10 + B OSFILL +* +OEI10 DC C' ',7X'20',X'21',X'20' pat: bddddddd(d +OEI10L EQU *-OEI10 +* include simple input system ----------------------------------------- +* +* simple input system procedures -------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* IGETLINE ------------------------------------------------- +* read line from SYSIN +* EOF handling: +* - IEOFOK holds the 'EOF OK' flag +* - if EOF seen and IEOFOK = X'00', program ends with RC=8 +* - if EOF seen and IEOFOK != X'00', program ends with RC=0 +* +IGETLINE ST R14,IGETLNEL save R14 + L R1,=A(SYSIN) + L R0,=A(ILBUF) + GET (1),(0) read line + L R0,=A(ILBUF) + ST R0,ILPTR set input ptr to begin of line + L R14,IGETLNEL restore R14 linkage + BR R14 +* +IGETLNEL DS F save area for R14 (return linkage) +* +* IEOFHDL -------------------------------------------------- +* +IEOFHDL BALR R12,R0 where are we ? + LA R15,*-MAIN offset from MAIN to here + SR R12,R15 base reg now points to MAIN + LA R14,EXIT + CLI IEOFOK,X'00' is EOF ok ? + BNER R14 if != yes, jump to EXIT + MVI RC+3,X'08' otherwise set RC=8 + BR R14 and jump to EXIT +* +* Work area for simple output system ------------------------ +* +ILPTR DC A(ILBUF) current input line position +IEOFOK DS X'00' EOF ok flag +ICVB DS D buffer for CVB (8 byte, DW aligned) +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSIN DCB DSORG=PS,MACRF=GM,DDNAME=SYSIN,EODAD=IEOFHDL X + RECFM=FB,LRECL=80,BLKSIZE=0 +ILBUF DC CL80' ' input line buffer +MAIN CSECT +* +* IINT10 --------------------------------------------------- +* read integer, like PL/I F(10) or C %10d format +* +IINT10 L R15,ILPTR get input pointer + PACK ICVB(8),0(10,R15) pack next 10 char + CVB R1,ICVB and convert + LA R15,10(R15) push pointer by 10 char + ST R15,ILPTR and update + BR R14 +* +* Work area definitions ----------------------------------------------- +* +SAVE DS 18F local save area +RC DC F'0' return code +NMAX DC F'10000000' highest prime to search for +NMSQRT DS F sqrt(NMAX) +IMAX DS F highest prime array index +PRIME DS F prime array pointer +PRNT DC X'00' print enable flag +* +* message strings +* +MSGPERR OTXTDSC C'NMAX must be >= 10 and <= 10000000, abort' +MSGLIST OTXTDSC C'List of Primes up to ' +MSGPI OTXTDSC C'pi(' +MSGPISEP OTXTDSC C'): ' +* +* spill literal pool +* + LTORG +* +* other defs and end +* + YREGS , + END MAIN define main entry point +/* +//GO.SYSUDUMP DD SYSOUT=*,OUTLIM=2000 +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 10000000 0 +/* +// +./ ADD NAME=SOEPASMP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#ASM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC ASMFCLG, +// MAC1='SYS2.MACLIB', +// PARM.ASM='NOLIST,NOXREF,NORLD,NODECK,LOAD', +// PARM.LKED='MAP,LIST,LET,NCAL', +// COND.LKED=(8,LE,ASM), +// PARM.GO='', +// COND.GO=((8,LE,ASM),(4,LT,LKED)) +//ASM.SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(600,100)) +//ASM.SYSUT2 DD DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSUT3 DD DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSGO DD DSN=&&OBJSET,UNIT=SYSDA,SPACE=(80,(2000,500)) +//ASM.SYSIN DD * +* 1 2 3 4 5 6 71 +*23456789*12345*789012345678901234*678901234567890123456789012345678901 +* $Id: soep_asm.asm 972 2017-12-23 20:55:41Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software; you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +* 2017-11-12 961 1.0 Initial version +* 2017-10-03 954 0.1 First draft +* + PRINT NOGEN don't show macro expansions +* +* Prime number search +* RC = 0 ok +* RC = 4 NMAX out of range +* RC = 8 unexpected SYSIN EOF +* RC = 12 open SYSIN failed +* RC = 16 open SYSPRINT failed +* +* local macros -------------------------------------------------------- +* +* +* OTXTDSC - setup text descriptor for simple output system - +* + MACRO +&LABEL OTXTDSC &TEXT +TEXT CSECT +SPTR&SYSNDX DC &TEXT +&SYSECT CSECT + DS 0F +&LABEL DC AL1(L'SPTR&SYSNDX),AL3(SPTR&SYSNDX) + MEND +* +* main preamble ------------------------------------------------------- +* +MAIN START 0 start main code csect at base 0 + SAVE (14,12) Save input registers + LR R12,R15 base register := entry address + USING MAIN,R12 declare base register + ST R13,SAVE+4 set back pointer in current save area + LR R2,R13 remember callers save area + LA R13,SAVE setup current save area + ST R13,8(R2) set forw pointer in callers save area +* +* open datasets ------------------------------------------------------- +* + OPEN (SYSPRINT,OUTPUT) open SYSPRINT + LTR R15,R15 test return code + BE OOPENOK + MVI RC+3,X'10' + B EXIT quit with RC=16 +OOPENOK OPEN (SYSIN,INPUT) open SYSIN + LTR R15,R15 test return code + BE IOPENOK + MVI RC+3,X'0C' + B EXIT quit with RC=12 +IOPENOK EQU * +* +* read input parameters, and check range ------------------------------ +* + BAL R14,IGETLINE read input line + BAL R14,IINT10 get NMAX + ST R1,NMAX + BAL R14,IINT10 get PRNT + STC R1,PRNT +* + L R1,NMAX + C R1,=F'10' is NMAX >= 10 + BL NMAXBAD if < not + C R1,=F'10000000' is NMAX <= 10000000 + BNH NMAXOK if <= yes +NMAXBAD L R1,MSGPERR + BAL R14,OTEXT print error + BAL R14,OPUTLINE write line + MVI RC+3,X'04' + B EXIT quit with RC=4 +NMAXOK EQU * +* +* setup phase --------------------------------------------------------- +* +* calculate sqrt(nmax) ----------------------------------- +* use simple bi-section method +* R4 low bound +* R5 high bound +* R7 middle (low+high)/2 +* + LA R4,1 set low bound + L R5,NMAX set high bound + LA R6,32 set iteration limit +NMSQRTLP LR R7,R4 R7:= low + AR R7,R5 R7:= (low+high) + SRA R7,1 R7:= (low+high)/2 + LR R3,R7 + MR R2,R7 (R2,R3) := R7*R7 + LTR R2,R2 more than 32 bit ? + BNE NMSQRTHI if != yes, mid too high + CL R3,NMAX mid*mid > NMAX + BH NMSQRTHI if > yes, mid too high + LR R4,R7 here mid to low: low := mid + B NMSQRTGO +NMSQRTHI LR R5,R7 here mid to high: high := mid +NMSQRTGO LR R8,R5 R8 := high + SR R8,R4 R8 := high-low + LR R1,R6 + C R8,=F'1' spread <= 1 ? + BNH NMSQRTOK if <= yes, quit + BCT R6,NMSQRTLP + ABEND 99 abort if doesn't converge +NMSQRTOK EQU * + ST R4,NMSQRT + +* allocate PRIME array ----------------------------------- + L R2,NMAX + BCTR R2,0 NMAX-1 + SRA R2,1 (NMAX-1)/2 + ST R2,IMAX + LA R5,1(R2) IMAX+1 (24 bit enough) + GETMAIN RU,LV=(5) allocate storage for PRIME + ST R1,PRIME store sieve base + LR R9,R1 R9 := PRIME base +* +* set each PRIME array byte to X'01' --------------------- + LR R4,R1 R4 := PRIME +* R5 := IMAX+1 (still) + XR R6,R6 R6 := 0 + L R7,=X'01000000' R7 := padding=1 and length=0 + MVCL R4,R6 set all PRIME bytes to 1 +* +* sieve phase --------------------------------------------------------- +* outer loop: ind R6 n +* inc R4 2 +* lim R5 sqrt(NMAX) +* inner loop: ind R3 p +* inc R6 n +* lim R7 pmax +* R0,R1,R2 temporaries +* register usage: +* R0 temporary +* R1 temporary +* R2 temporary +* R3 inner loop ind p +* R4 outer loop inc 2 +* R5 outer loop lim sqrt(NMAX) +* R6 inner loop inc n (and outer loop ind !!) +* R7 inner loop lim pmax +* R8 -- unused -- +* R9 &prime +* R10 -- unused -- +* R11 -- unused -- +* +* +* equivalent C code: +* pmax = &prime[imax]; +* for (n=3; n<=nmsqrt; n+=2) { +* if (prime[(n-1)/2] == 0) continue; +* for (p=&prime[(n*n-1)/2]; p<=pmax; p+=n) *p = 0; +* } +* + LA R6,3 outer ind: R6:=3 + LA R4,2 outer inc: R4:=2 + L R5,NMSQRT outer lim: R5:=NMSQRT + LR R7,R9 R7:=&prime + A R7,IMAX inner lim: R7:=&prime[imax] +SIEVO LR R2,R6 R2:=n + SRA R2,1 R2:=n/2 + AR R2,R9 R2:=&prime[n/2] + CLI 0(R2),X'00' test prime candidate + BE SIEVOC if = not, continue outer loop +* + LR R1,R6 R1:=n + MR R0,R6 R1:=n*n (lower half, enough) + LR R3,R1 R3:=n*n too +* + SRA R3,1 R3:=(n*n)/2 + AR R3,R9 R3:=&prime[(n*n-1)/2] +* +SIEVI MVI 0(R3),X'00' *p=0 + BXLE R3,R6,SIEVI +* +SIEVOC BXLE R6,R4,SIEVO +* +* print primes table -------------------------------------------------- +* loop: ind R3 i +* inc R4 1 +* lim R5 imax +* R2 np +* + CLI PRNT,X'00' primes to be printed ? + BE NOPRNT if = skip + L R1,MSGLIST + BAL R14,OTEXT print heading + L R1,NMAX + BAL R14,OINT10 print nmax + BAL R14,OPUTLINE write line +* + LA R1,2 + BAL R14,OINT10 print "2" (1st prime...) + LA R2,1 np=1 + LA R3,1 ind: R3:=1 + LA R4,1 inc: R4:=1 + L R5,IMAX lim: R5:=IMAX +PRTLOOP LR R6,R3 R6:=i + AR R6,R9 R6:=&primes[i] + CLI 0(R6),X'00' test whether prime + BE PRTLOOPC if = not, continue + LR R1,R3 R1:=i + SLA R1,1 R1:=2*i + LA R1,1(R1) R1:=1+2*i + BAL R14,OINT10 and print F(10) + LA R2,1(R2) np+=1 + C R2,=F'10' check wheter = 10 + BNZ PRTLOOPC if != not, continue + BAL R14,OPUTLINE write line + XR R2,R2 np=0 +PRTLOOPC EQU * + BXLE R3,R4,PRTLOOP +* + LTR R2,R2 check prime count np + BZ NOPRNT + BAL R14,OPUTLINE write line +NOPRNT EQU * +* +* print primes count -------------------------------------------------- +* loop: ind R3 i +* inc R4 1 +* lim R5 imax +* R2 np +* R7 il +* R8 nl +* + LA R2,1 np=1 + LA R7,4 il=4 + LA R8,10 nl=10 + LA R3,1 ind: R3:=1 + LA R4,1 inc: R4:=1 + L R5,IMAX lim: R5:=IMAX +TBLLOOP LR R6,R3 R6:=i + AR R6,R9 R6:=&primes[i] + CLI 0(R6),X'00' test whether prime + BE NOPRIME if = not + LA R2,1(R2) np+= 1 +NOPRIME CR R3,R7 test i != il + BNE TBLLOOPC + LR R8,R7 nl=il + SLA R8,1 nl=2*il + LA R8,2(R8) nl=2+2*il +* + L R1,MSGPI + BAL R14,OTEXT print "pi(...." + LR R1,R8 + BAL R14,OINT10 print nl + L R1,MSGPISEP + BAL R14,OTEXT print "):..." + LR R1,R2 + BAL R14,OINT10 print np + BAL R14,OPUTLINE write line +* + LR R1,R7 R1:=il + LA R1,1(R1) R1:=il+1 + M R0,=F'10' R1:=10*(il+1) + S R1,=F'1' R1:=10*(il+1)-1 + LR R7,R1 update il +* +TBLLOOPC EQU * + BXLE R3,R4,TBLLOOP +* + C R8,NMAX is nl != nmax ? + BE TBLNOTR if = not, skip extra summary +* + L R1,MSGPI + BAL R14,OTEXT print "pi(...." + L R1,NMAX + BAL R14,OINT10 print nmax + L R1,MSGPISEP + BAL R14,OTEXT print "):..." + LR R1,R2 + BAL R14,OINT10 print np + BAL R14,OPUTLINE write line +* +TBLNOTR EQU * +* +* close datasets and return to OS ------------------------------------- +* +EXIT CLOSE SYSPRINT close SYSPRINT + CLOSE SYSIN close SYSIN + L R13,SAVE+4 get old save area back + L R0,RC get return code + ST R0,16(R13) store in old save R15 + RETURN (14,12) return to OS (will setup RC) +* +* include simple output system ---------------------------------------- +* +* simple output system procedures ------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* OSKIP02 -------------------------------------------------- +* add 2 blanks +* +OSKIP02 LA R1,2 +* +* OSKIP ---------------------------------------------------- +* add blanks, count in R1 +* +OSKIP A R1,OLPTR new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OTAB ---------------------------------------------------- +* set output column, position in R1 +* +OTAB A R1,=A(OLBUF+1) new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OSFILL --------------------------------------------------- +* add " ***" pattern, total length in R1 +* +OSFILL L R15,OLPTR R15 points to edit position + MVI 0(R15),C' ' initial blank + B OSFILLN +OSFILLL MVI 0(R15),C'*' further '*' +OSFILLN LA R15,1(R15) + BCT R1,OSFILLL + ST R15,OLPTR store pointer + BR R14 +* +* OTEXT ---------------------------------------------------- +* print text, R1 hold descriptor address +* descriptor format +* DC AL1() +* DC AL2(
) +* +OTEXT ST R14,OTEXTL save R14 + LR R14,R1 + SRL R14,24 R14 now string length + L R15,OLPTR R15 points to edit position + LR R0,R15 R0 too + AR R0,R14 push pointer, add length + ST R0,OLPTR store pointer + BCTR R14,0 decrement length for EX + EX R14,OTEXTMVC copy string via EX:MVC + L R14,OTEXTL restore R14 linkage + BR R14 +* +OTEXTMVC MVC 0(1,R15),0(R1) length via EX, dst R15, src R1 +OTEXTL DS F save area for R14 (return linkage) +* +* OPUTLINE ------------------------------------------------- +* write line to SYSPRINT +* +OPUTLINE ST R14,OPUTLNEL save R14 + L R15,=A(OLBUF) + CLI 133(R15),X'00' check fence byte + BNE OPUTLNEA crash if fence blown + L R1,=A(SYSPRINT) R1 point to DCB + LR R0,R15 R1 point to buffer + PUT (1),(0) write line + L R15,=A(OLBUF) point to CC of OLBUF + MVI 0(R15),C' ' blank OLBUF(0) + MVC 1(L'OLBUF-1,R15),0(R15) propagate blank + LA R15,1(R15) point to 1st print char in OLBUF + ST R15,OLPTR reset current position pointer + LA R15,1 + AH R15,OLCNT increment line counter + STH R15,OLCNT + SH R15,OLMAX R15 := OLCNT-OLMAX + BL OPUTLNES if < no new page + XR R15,R15 R15 := 0 + SH R15,OLCNT clear line counter + L R15,=A(OLBUF) point to CC of OLBUF +* MVI 0(R15),C'1' set new page CC in OLBUF +OPUTLNES L R14,OPUTLNEL restore R14 linkage + BR R14 +* +OPUTLNEA ABEND 255 abend in case of errors +* +OPUTLNEL DS F save area for R14 (return linkage) +* +* Work area for simple output system ------------------------ +* +OLPTR DC A(OLBUF+1) current output line position +OLCNT DC H'0' line counter +OLMAX DC H'60' lines per page +OCVD DS D buffer for CVD (8 byte, DW aligned) +* +ODTEMP DS D double buffer for conversions +ODNZERO DC X'4E000000',X'00000000' denormalized double zero +ODNONE DC X'4E000000',X'00000001' denormalized double one +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSPRINT DCB DSORG=PS,MACRF=PM,DDNAME=SYSPRINT, X + RECFM=FBA,LRECL=133,BLKSIZE=0 +OLBUF DC CL133' ',X'00' output line buffer and fence byte +* +MAIN CSECT +* +* OINT10 --------------------------------------------------- +* print integer, like PL/I F(10) or C %10d format +* very fast, for non-negative numbers only ! +* +OINT10 CL R1,=F'999999999' too large ? + BH OINT10F if > yes, do OSFILL + CVD R1,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEI10L,R15),OEI10 setup pattern + ED 0(OEI10L,R15),OCVD+3 and edit + LA R15,OEI10L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OINT10F LA R1,10 + B OSFILL +* +OEI10 DC C' ',7X'20',X'21',X'20' pat: bddddddd(d +OEI10L EQU *-OEI10 +* include simple input system ----------------------------------------- +* +* simple input system procedures -------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* IGETLINE ------------------------------------------------- +* read line from SYSIN +* EOF handling: +* - IEOFOK holds the 'EOF OK' flag +* - if EOF seen and IEOFOK = X'00', program ends with RC=8 +* - if EOF seen and IEOFOK != X'00', program ends with RC=0 +* +IGETLINE ST R14,IGETLNEL save R14 + L R1,=A(SYSIN) + L R0,=A(ILBUF) + GET (1),(0) read line + L R0,=A(ILBUF) + ST R0,ILPTR set input ptr to begin of line + L R14,IGETLNEL restore R14 linkage + BR R14 +* +IGETLNEL DS F save area for R14 (return linkage) +* +* IEOFHDL -------------------------------------------------- +* +IEOFHDL BALR R12,R0 where are we ? + LA R15,*-MAIN offset from MAIN to here + SR R12,R15 base reg now points to MAIN + LA R14,EXIT + CLI IEOFOK,X'00' is EOF ok ? + BNER R14 if != yes, jump to EXIT + MVI RC+3,X'08' otherwise set RC=8 + BR R14 and jump to EXIT +* +* Work area for simple output system ------------------------ +* +ILPTR DC A(ILBUF) current input line position +IEOFOK DS X'00' EOF ok flag +ICVB DS D buffer for CVB (8 byte, DW aligned) +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSIN DCB DSORG=PS,MACRF=GM,DDNAME=SYSIN,EODAD=IEOFHDL X + RECFM=FB,LRECL=80,BLKSIZE=0 +ILBUF DC CL80' ' input line buffer +MAIN CSECT +* +* IINT10 --------------------------------------------------- +* read integer, like PL/I F(10) or C %10d format +* +IINT10 L R15,ILPTR get input pointer + PACK ICVB(8),0(10,R15) pack next 10 char + CVB R1,ICVB and convert + LA R15,10(R15) push pointer by 10 char + ST R15,ILPTR and update + BR R14 +* +* Work area definitions ----------------------------------------------- +* +SAVE DS 18F local save area +RC DC F'0' return code +NMAX DC F'10000000' highest prime to search for +NMSQRT DS F sqrt(NMAX) +IMAX DS F highest prime array index +PRIME DS F prime array pointer +PRNT DC X'00' print enable flag +* +* message strings +* +MSGPERR OTXTDSC C'NMAX must be >= 10 and <= 10000000, abort' +MSGLIST OTXTDSC C'List of Primes up to ' +MSGPI OTXTDSC C'pi(' +MSGPISEP OTXTDSC C'): ' +* +* spill literal pool +* + LTORG +* +* other defs and end +* + YREGS , + END MAIN define main entry point +/* +//GO.SYSUDUMP DD SYSOUT=*,OUTLIM=2000 +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=100000 +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEPASMT,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#ASM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=128K,TIME=(1,0),PRTY=8 +//CLG EXEC ASMFCLG, +// MAC1='SYS2.MACLIB', +// PARM.ASM='NODECK,LOAD', +// PARM.LKED='MAP,LIST,LET,NCAL', +// COND.LKED=(8,LE,ASM), +// PARM.GO='', +// COND.GO=((8,LE,ASM),(4,LT,LKED)) +//ASM.SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(600,100)) +//ASM.SYSUT2 DD DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSUT3 DD DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSGO DD DSN=&&OBJSET,UNIT=SYSDA,SPACE=(80,(2000,500)) +//ASM.SYSIN DD * +* 1 2 3 4 5 6 71 +*23456789*12345*789012345678901234*678901234567890123456789012345678901 +* $Id: soep_asm.asm 972 2017-12-23 20:55:41Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software; you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +* 2017-11-12 961 1.0 Initial version +* 2017-10-03 954 0.1 First draft +* + PRINT NOGEN don't show macro expansions +* +* Prime number search +* RC = 0 ok +* RC = 4 NMAX out of range +* RC = 8 unexpected SYSIN EOF +* RC = 12 open SYSIN failed +* RC = 16 open SYSPRINT failed +* +* local macros -------------------------------------------------------- +* +* +* OTXTDSC - setup text descriptor for simple output system - +* + MACRO +&LABEL OTXTDSC &TEXT +TEXT CSECT +SPTR&SYSNDX DC &TEXT +&SYSECT CSECT + DS 0F +&LABEL DC AL1(L'SPTR&SYSNDX),AL3(SPTR&SYSNDX) + MEND +* +* main preamble ------------------------------------------------------- +* +MAIN START 0 start main code csect at base 0 + SAVE (14,12) Save input registers + LR R12,R15 base register := entry address + USING MAIN,R12 declare base register + ST R13,SAVE+4 set back pointer in current save area + LR R2,R13 remember callers save area + LA R13,SAVE setup current save area + ST R13,8(R2) set forw pointer in callers save area +* +* open datasets ------------------------------------------------------- +* + OPEN (SYSPRINT,OUTPUT) open SYSPRINT + LTR R15,R15 test return code + BE OOPENOK + MVI RC+3,X'10' + B EXIT quit with RC=16 +OOPENOK OPEN (SYSIN,INPUT) open SYSIN + LTR R15,R15 test return code + BE IOPENOK + MVI RC+3,X'0C' + B EXIT quit with RC=12 +IOPENOK EQU * +* +* read input parameters, and check range ------------------------------ +* + BAL R14,IGETLINE read input line + BAL R14,IINT10 get NMAX + ST R1,NMAX + BAL R14,IINT10 get PRNT + STC R1,PRNT +* + L R1,NMAX + C R1,=F'10' is NMAX >= 10 + BL NMAXBAD if < not + C R1,=F'10000000' is NMAX <= 10000000 + BNH NMAXOK if <= yes +NMAXBAD L R1,MSGPERR + BAL R14,OTEXT print error + BAL R14,OPUTLINE write line + MVI RC+3,X'04' + B EXIT quit with RC=4 +NMAXOK EQU * +* +* setup phase --------------------------------------------------------- +* +* calculate sqrt(nmax) ----------------------------------- +* use simple bi-section method +* R4 low bound +* R5 high bound +* R7 middle (low+high)/2 +* + LA R4,1 set low bound + L R5,NMAX set high bound + LA R6,32 set iteration limit +NMSQRTLP LR R7,R4 R7:= low + AR R7,R5 R7:= (low+high) + SRA R7,1 R7:= (low+high)/2 + LR R3,R7 + MR R2,R7 (R2,R3) := R7*R7 + LTR R2,R2 more than 32 bit ? + BNE NMSQRTHI if != yes, mid too high + CL R3,NMAX mid*mid > NMAX + BH NMSQRTHI if > yes, mid too high + LR R4,R7 here mid to low: low := mid + B NMSQRTGO +NMSQRTHI LR R5,R7 here mid to high: high := mid +NMSQRTGO LR R8,R5 R8 := high + SR R8,R4 R8 := high-low + LR R1,R6 + C R8,=F'1' spread <= 1 ? + BNH NMSQRTOK if <= yes, quit + BCT R6,NMSQRTLP + ABEND 99 abort if doesn't converge +NMSQRTOK EQU * + ST R4,NMSQRT + +* allocate PRIME array ----------------------------------- + L R2,NMAX + BCTR R2,0 NMAX-1 + SRA R2,1 (NMAX-1)/2 + ST R2,IMAX + LA R5,1(R2) IMAX+1 (24 bit enough) + GETMAIN RU,LV=(5) allocate storage for PRIME + ST R1,PRIME store sieve base + LR R9,R1 R9 := PRIME base +* +* set each PRIME array byte to X'01' --------------------- + LR R4,R1 R4 := PRIME +* R5 := IMAX+1 (still) + XR R6,R6 R6 := 0 + L R7,=X'01000000' R7 := padding=1 and length=0 + MVCL R4,R6 set all PRIME bytes to 1 +* +* sieve phase --------------------------------------------------------- +* outer loop: ind R6 n +* inc R4 2 +* lim R5 sqrt(NMAX) +* inner loop: ind R3 p +* inc R6 n +* lim R7 pmax +* R0,R1,R2 temporaries +* register usage: +* R0 temporary +* R1 temporary +* R2 temporary +* R3 inner loop ind p +* R4 outer loop inc 2 +* R5 outer loop lim sqrt(NMAX) +* R6 inner loop inc n (and outer loop ind !!) +* R7 inner loop lim pmax +* R8 -- unused -- +* R9 &prime +* R10 -- unused -- +* R11 -- unused -- +* +* +* equivalent C code: +* pmax = &prime[imax]; +* for (n=3; n<=nmsqrt; n+=2) { +* if (prime[(n-1)/2] == 0) continue; +* for (p=&prime[(n*n-1)/2]; p<=pmax; p+=n) *p = 0; +* } +* + LA R6,3 outer ind: R6:=3 + LA R4,2 outer inc: R4:=2 + L R5,NMSQRT outer lim: R5:=NMSQRT + LR R7,R9 R7:=&prime + A R7,IMAX inner lim: R7:=&prime[imax] +SIEVO LR R2,R6 R2:=n + SRA R2,1 R2:=n/2 + AR R2,R9 R2:=&prime[n/2] + CLI 0(R2),X'00' test prime candidate + BE SIEVOC if = not, continue outer loop +* + LR R1,R6 R1:=n + MR R0,R6 R1:=n*n (lower half, enough) + LR R3,R1 R3:=n*n too +* + SRA R3,1 R3:=(n*n)/2 + AR R3,R9 R3:=&prime[(n*n-1)/2] +* +SIEVI MVI 0(R3),X'00' *p=0 + BXLE R3,R6,SIEVI +* +SIEVOC BXLE R6,R4,SIEVO +* +* print primes table -------------------------------------------------- +* loop: ind R3 i +* inc R4 1 +* lim R5 imax +* R2 np +* + CLI PRNT,X'00' primes to be printed ? + BE NOPRNT if = skip + L R1,MSGLIST + BAL R14,OTEXT print heading + L R1,NMAX + BAL R14,OINT10 print nmax + BAL R14,OPUTLINE write line +* + LA R1,2 + BAL R14,OINT10 print "2" (1st prime...) + LA R2,1 np=1 + LA R3,1 ind: R3:=1 + LA R4,1 inc: R4:=1 + L R5,IMAX lim: R5:=IMAX +PRTLOOP LR R6,R3 R6:=i + AR R6,R9 R6:=&primes[i] + CLI 0(R6),X'00' test whether prime + BE PRTLOOPC if = not, continue + LR R1,R3 R1:=i + SLA R1,1 R1:=2*i + LA R1,1(R1) R1:=1+2*i + BAL R14,OINT10 and print F(10) + LA R2,1(R2) np+=1 + C R2,=F'10' check wheter = 10 + BNZ PRTLOOPC if != not, continue + BAL R14,OPUTLINE write line + XR R2,R2 np=0 +PRTLOOPC EQU * + BXLE R3,R4,PRTLOOP +* + LTR R2,R2 check prime count np + BZ NOPRNT + BAL R14,OPUTLINE write line +NOPRNT EQU * +* +* print primes count -------------------------------------------------- +* loop: ind R3 i +* inc R4 1 +* lim R5 imax +* R2 np +* R7 il +* R8 nl +* + LA R2,1 np=1 + LA R7,4 il=4 + LA R8,10 nl=10 + LA R3,1 ind: R3:=1 + LA R4,1 inc: R4:=1 + L R5,IMAX lim: R5:=IMAX +TBLLOOP LR R6,R3 R6:=i + AR R6,R9 R6:=&primes[i] + CLI 0(R6),X'00' test whether prime + BE NOPRIME if = not + LA R2,1(R2) np+= 1 +NOPRIME CR R3,R7 test i != il + BNE TBLLOOPC + LR R8,R7 nl=il + SLA R8,1 nl=2*il + LA R8,2(R8) nl=2+2*il +* + L R1,MSGPI + BAL R14,OTEXT print "pi(...." + LR R1,R8 + BAL R14,OINT10 print nl + L R1,MSGPISEP + BAL R14,OTEXT print "):..." + LR R1,R2 + BAL R14,OINT10 print np + BAL R14,OPUTLINE write line +* + LR R1,R7 R1:=il + LA R1,1(R1) R1:=il+1 + M R0,=F'10' R1:=10*(il+1) + S R1,=F'1' R1:=10*(il+1)-1 + LR R7,R1 update il +* +TBLLOOPC EQU * + BXLE R3,R4,TBLLOOP +* + C R8,NMAX is nl != nmax ? + BE TBLNOTR if = not, skip extra summary +* + L R1,MSGPI + BAL R14,OTEXT print "pi(...." + L R1,NMAX + BAL R14,OINT10 print nmax + L R1,MSGPISEP + BAL R14,OTEXT print "):..." + LR R1,R2 + BAL R14,OINT10 print np + BAL R14,OPUTLINE write line +* +TBLNOTR EQU * +* +* close datasets and return to OS ------------------------------------- +* +EXIT CLOSE SYSPRINT close SYSPRINT + CLOSE SYSIN close SYSIN + L R13,SAVE+4 get old save area back + L R0,RC get return code + ST R0,16(R13) store in old save R15 + RETURN (14,12) return to OS (will setup RC) +* +* include simple output system ---------------------------------------- +* +* simple output system procedures ------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* OSKIP02 -------------------------------------------------- +* add 2 blanks +* +OSKIP02 LA R1,2 +* +* OSKIP ---------------------------------------------------- +* add blanks, count in R1 +* +OSKIP A R1,OLPTR new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OTAB ---------------------------------------------------- +* set output column, position in R1 +* +OTAB A R1,=A(OLBUF+1) new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OSFILL --------------------------------------------------- +* add " ***" pattern, total length in R1 +* +OSFILL L R15,OLPTR R15 points to edit position + MVI 0(R15),C' ' initial blank + B OSFILLN +OSFILLL MVI 0(R15),C'*' further '*' +OSFILLN LA R15,1(R15) + BCT R1,OSFILLL + ST R15,OLPTR store pointer + BR R14 +* +* OTEXT ---------------------------------------------------- +* print text, R1 hold descriptor address +* descriptor format +* DC AL1() +* DC AL2(
) +* +OTEXT ST R14,OTEXTL save R14 + LR R14,R1 + SRL R14,24 R14 now string length + L R15,OLPTR R15 points to edit position + LR R0,R15 R0 too + AR R0,R14 push pointer, add length + ST R0,OLPTR store pointer + BCTR R14,0 decrement length for EX + EX R14,OTEXTMVC copy string via EX:MVC + L R14,OTEXTL restore R14 linkage + BR R14 +* +OTEXTMVC MVC 0(1,R15),0(R1) length via EX, dst R15, src R1 +OTEXTL DS F save area for R14 (return linkage) +* +* OPUTLINE ------------------------------------------------- +* write line to SYSPRINT +* +OPUTLINE ST R14,OPUTLNEL save R14 + L R15,=A(OLBUF) + CLI 133(R15),X'00' check fence byte + BNE OPUTLNEA crash if fence blown + L R1,=A(SYSPRINT) R1 point to DCB + LR R0,R15 R1 point to buffer + PUT (1),(0) write line + L R15,=A(OLBUF) point to CC of OLBUF + MVI 0(R15),C' ' blank OLBUF(0) + MVC 1(L'OLBUF-1,R15),0(R15) propagate blank + LA R15,1(R15) point to 1st print char in OLBUF + ST R15,OLPTR reset current position pointer + LA R15,1 + AH R15,OLCNT increment line counter + STH R15,OLCNT + SH R15,OLMAX R15 := OLCNT-OLMAX + BL OPUTLNES if < no new page + XR R15,R15 R15 := 0 + SH R15,OLCNT clear line counter + L R15,=A(OLBUF) point to CC of OLBUF +* MVI 0(R15),C'1' set new page CC in OLBUF +OPUTLNES L R14,OPUTLNEL restore R14 linkage + BR R14 +* +OPUTLNEA ABEND 255 abend in case of errors +* +OPUTLNEL DS F save area for R14 (return linkage) +* +* Work area for simple output system ------------------------ +* +OLPTR DC A(OLBUF+1) current output line position +OLCNT DC H'0' line counter +OLMAX DC H'60' lines per page +OCVD DS D buffer for CVD (8 byte, DW aligned) +* +ODTEMP DS D double buffer for conversions +ODNZERO DC X'4E000000',X'00000000' denormalized double zero +ODNONE DC X'4E000000',X'00000001' denormalized double one +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSPRINT DCB DSORG=PS,MACRF=PM,DDNAME=SYSPRINT, X + RECFM=FBA,LRECL=133,BLKSIZE=0 +OLBUF DC CL133' ',X'00' output line buffer and fence byte +* +MAIN CSECT +* +* OINT10 --------------------------------------------------- +* print integer, like PL/I F(10) or C %10d format +* very fast, for non-negative numbers only ! +* +OINT10 CL R1,=F'999999999' too large ? + BH OINT10F if > yes, do OSFILL + CVD R1,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEI10L,R15),OEI10 setup pattern + ED 0(OEI10L,R15),OCVD+3 and edit + LA R15,OEI10L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OINT10F LA R1,10 + B OSFILL +* +OEI10 DC C' ',7X'20',X'21',X'20' pat: bddddddd(d +OEI10L EQU *-OEI10 +* include simple input system ----------------------------------------- +* +* simple input system procedures -------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* IGETLINE ------------------------------------------------- +* read line from SYSIN +* EOF handling: +* - IEOFOK holds the 'EOF OK' flag +* - if EOF seen and IEOFOK = X'00', program ends with RC=8 +* - if EOF seen and IEOFOK != X'00', program ends with RC=0 +* +IGETLINE ST R14,IGETLNEL save R14 + L R1,=A(SYSIN) + L R0,=A(ILBUF) + GET (1),(0) read line + L R0,=A(ILBUF) + ST R0,ILPTR set input ptr to begin of line + L R14,IGETLNEL restore R14 linkage + BR R14 +* +IGETLNEL DS F save area for R14 (return linkage) +* +* IEOFHDL -------------------------------------------------- +* +IEOFHDL BALR R12,R0 where are we ? + LA R15,*-MAIN offset from MAIN to here + SR R12,R15 base reg now points to MAIN + LA R14,EXIT + CLI IEOFOK,X'00' is EOF ok ? + BNER R14 if != yes, jump to EXIT + MVI RC+3,X'08' otherwise set RC=8 + BR R14 and jump to EXIT +* +* Work area for simple output system ------------------------ +* +ILPTR DC A(ILBUF) current input line position +IEOFOK DS X'00' EOF ok flag +ICVB DS D buffer for CVB (8 byte, DW aligned) +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSIN DCB DSORG=PS,MACRF=GM,DDNAME=SYSIN,EODAD=IEOFHDL X + RECFM=FB,LRECL=80,BLKSIZE=0 +ILBUF DC CL80' ' input line buffer +MAIN CSECT +* +* IINT10 --------------------------------------------------- +* read integer, like PL/I F(10) or C %10d format +* +IINT10 L R15,ILPTR get input pointer + PACK ICVB(8),0(10,R15) pack next 10 char + CVB R1,ICVB and convert + LA R15,10(R15) push pointer by 10 char + ST R15,ILPTR and update + BR R14 +* +* Work area definitions ----------------------------------------------- +* +SAVE DS 18F local save area +RC DC F'0' return code +NMAX DC F'10000000' highest prime to search for +NMSQRT DS F sqrt(NMAX) +IMAX DS F highest prime array index +PRIME DS F prime array pointer +PRNT DC X'00' print enable flag +* +* message strings +* +MSGPERR OTXTDSC C'NMAX must be >= 10 and <= 10000000, abort' +MSGLIST OTXTDSC C'List of Primes up to ' +MSGPI OTXTDSC C'pi(' +MSGPISEP OTXTDSC C'): ' +* +* spill literal pool +* + LTORG +* +* other defs and end +* + YREGS , + END MAIN define main entry point +/* +//GO.SYSUDUMP DD SYSOUT=*,OUTLIM=2000 +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEPGCCF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#GCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC GCCCLG,COPTS='-O3', +// PARM.LKED='MAP,LIST' +//COMP.SYSIN DD DATA,DLM='/@' +/* $Id: soep_cc.c 972 2017-12-23 20:55:41Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 */ +/* 2017-10-15 956 1.0 Initial version */ +/* 2017-08-17 941 0.1 First draft */ + +#include +#include +#include + +int main() +{ + int nmax; + int nmsqrt; + int prnt; + int imax; + int i,n; + int np,il,nl; + char *prime; + char *p,*pmax; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &nmax, &prnt) != 2) { + printf("conversion error, abort\n"); + return 1; + } + if (nmax < 10) { + printf("nmax must be >= 10, abort\n"); + return 1; + } + + /* prime: i=(n-1)/2 --> 3->[1], 5->[2]; ... 99-> [49]; ... */ + nmsqrt = sqrt((double)nmax); + imax = (nmax-1)/2; + prime = malloc(imax+1); /* need [1,...,imax] */ + pmax = &prime[imax]; + + for (p=prime; p<=pmax;) *p++ = 1; + + for (n=3; n<=nmsqrt; n+=2) { + if (prime[n/2] == 0) continue; + for (p=&prime[(n*n)/2]; p<=pmax; p+=n) *p = 0; + } + + if (prnt) { + printf("List of Primes up to %d\n",nmax); + printf(" %7d",2); + np = 1; + for (i=1;i<=imax;i++) { + if (! prime[i]) continue; + printf(" %7d",1+2*i); + np += 1; + if (np != 10) continue; + printf("\n"); + np= 0; + } + if (np != 0) printf("\n"); + } + + il = 4; + nl = 10; + np = 1; + for (i=1;i<=imax;i++) { + if (prime[i]) np += 1; + if (i != il) continue; + nl = 2*il+2; + printf("pi(%10d): %10d\n",nl,np); + il = 10*(il+1)-1; + } + if (nl != nmax) printf("pi(%10d): %10d\n",nmax,np); + + return 0; +} +/@ +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 10000000 0 +/* +// +./ ADD NAME=SOEPGCCP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#GCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC GCCCLG,COPTS='-O3', +// PARM.LKED='MAP,LIST' +//COMP.SYSIN DD DATA,DLM='/@' +/* $Id: soep_cc.c 972 2017-12-23 20:55:41Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 */ +/* 2017-10-15 956 1.0 Initial version */ +/* 2017-08-17 941 0.1 First draft */ + +#include +#include +#include + +int main() +{ + int nmax; + int nmsqrt; + int prnt; + int imax; + int i,n; + int np,il,nl; + char *prime; + char *p,*pmax; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &nmax, &prnt) != 2) { + printf("conversion error, abort\n"); + return 1; + } + if (nmax < 10) { + printf("nmax must be >= 10, abort\n"); + return 1; + } + + /* prime: i=(n-1)/2 --> 3->[1], 5->[2]; ... 99-> [49]; ... */ + nmsqrt = sqrt((double)nmax); + imax = (nmax-1)/2; + prime = malloc(imax+1); /* need [1,...,imax] */ + pmax = &prime[imax]; + + for (p=prime; p<=pmax;) *p++ = 1; + + for (n=3; n<=nmsqrt; n+=2) { + if (prime[n/2] == 0) continue; + for (p=&prime[(n*n)/2]; p<=pmax; p+=n) *p = 0; + } + + if (prnt) { + printf("List of Primes up to %d\n",nmax); + printf(" %7d",2); + np = 1; + for (i=1;i<=imax;i++) { + if (! prime[i]) continue; + printf(" %7d",1+2*i); + np += 1; + if (np != 10) continue; + printf("\n"); + np= 0; + } + if (np != 0) printf("\n"); + } + + il = 4; + nl = 10; + np = 1; + for (i=1;i<=imax;i++) { + if (prime[i]) np += 1; + if (i != il) continue; + nl = 2*il+2; + printf("pi(%10d): %10d\n",nl,np); + il = 10*(il+1)-1; + } + if (nl != nmax) printf("pi(%10d): %10d\n",nmax,np); + + return 0; +} +/@ +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=100000 +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEPGCCT,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#GCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(1,0),PRTY=8 +//CLG EXEC GCCCLG,COPTS='-O3', +// PARM.LKED='MAP,LIST' +//COMP.SYSIN DD DATA,DLM='/@' +/* $Id: soep_cc.c 972 2017-12-23 20:55:41Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 */ +/* 2017-10-15 956 1.0 Initial version */ +/* 2017-08-17 941 0.1 First draft */ + +#include +#include +#include + +int main() +{ + int nmax; + int nmsqrt; + int prnt; + int imax; + int i,n; + int np,il,nl; + char *prime; + char *p,*pmax; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &nmax, &prnt) != 2) { + printf("conversion error, abort\n"); + return 1; + } + if (nmax < 10) { + printf("nmax must be >= 10, abort\n"); + return 1; + } + + /* prime: i=(n-1)/2 --> 3->[1], 5->[2]; ... 99-> [49]; ... */ + nmsqrt = sqrt((double)nmax); + imax = (nmax-1)/2; + prime = malloc(imax+1); /* need [1,...,imax] */ + pmax = &prime[imax]; + + for (p=prime; p<=pmax;) *p++ = 1; + + for (n=3; n<=nmsqrt; n+=2) { + if (prime[n/2] == 0) continue; + for (p=&prime[(n*n)/2]; p<=pmax; p+=n) *p = 0; + } + + if (prnt) { + printf("List of Primes up to %d\n",nmax); + printf(" %7d",2); + np = 1; + for (i=1;i<=imax;i++) { + if (! prime[i]) continue; + printf(" %7d",1+2*i); + np += 1; + if (np != 10) continue; + printf("\n"); + np= 0; + } + if (np != 0) printf("\n"); + } + + il = 4; + nl = 10; + np = 1; + for (i=1;i<=imax;i++) { + if (prime[i]) np += 1; + if (i != il) continue; + nl = 2*il+2; + printf("pi(%10d): %10d\n",nl,np); + il = 10*(il+1)-1; + } + if (nl != nmax) printf("pi(%10d): %10d\n",nmax,np); + + return 0; +} +/@ +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEPJCCF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#JCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC JCCCLG, +// JOPTS='-o', +// PARM.LKED='NCAL,MAP,LIST,NORENT' +//COMPILE.SYSIN DD DATA,DLM='/@' +/* $Id: soep_cc.c 972 2017-12-23 20:55:41Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 */ +/* 2017-10-15 956 1.0 Initial version */ +/* 2017-08-17 941 0.1 First draft */ + +#include +#include +#include + +int main() +{ + int nmax; + int nmsqrt; + int prnt; + int imax; + int i,n; + int np,il,nl; + char *prime; + char *p,*pmax; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &nmax, &prnt) != 2) { + printf("conversion error, abort\n"); + return 1; + } + if (nmax < 10) { + printf("nmax must be >= 10, abort\n"); + return 1; + } + + /* prime: i=(n-1)/2 --> 3->[1], 5->[2]; ... 99-> [49]; ... */ + nmsqrt = sqrt((double)nmax); + imax = (nmax-1)/2; + prime = malloc(imax+1); /* need [1,...,imax] */ + pmax = &prime[imax]; + + for (p=prime; p<=pmax;) *p++ = 1; + + for (n=3; n<=nmsqrt; n+=2) { + if (prime[n/2] == 0) continue; + for (p=&prime[(n*n)/2]; p<=pmax; p+=n) *p = 0; + } + + if (prnt) { + printf("List of Primes up to %d\n",nmax); + printf(" %7d",2); + np = 1; + for (i=1;i<=imax;i++) { + if (! prime[i]) continue; + printf(" %7d",1+2*i); + np += 1; + if (np != 10) continue; + printf("\n"); + np= 0; + } + if (np != 0) printf("\n"); + } + + il = 4; + nl = 10; + np = 1; + for (i=1;i<=imax;i++) { + if (prime[i]) np += 1; + if (i != il) continue; + nl = 2*il+2; + printf("pi(%10d): %10d\n",nl,np); + il = 10*(il+1)-1; + } + if (nl != nmax) printf("pi(%10d): %10d\n",nmax,np); + + return 0; +} +/@ +//GO.STDOUT DD SYSOUT=*,OUTLIM=5000 +//GO.STDERR DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 10000000 0 +/* +// +./ ADD NAME=SOEPJCCP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#JCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC JCCCLG, +// JOPTS='-o', +// PARM.LKED='NCAL,MAP,LIST,NORENT' +//COMPILE.SYSIN DD DATA,DLM='/@' +/* $Id: soep_cc.c 972 2017-12-23 20:55:41Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 */ +/* 2017-10-15 956 1.0 Initial version */ +/* 2017-08-17 941 0.1 First draft */ + +#include +#include +#include + +int main() +{ + int nmax; + int nmsqrt; + int prnt; + int imax; + int i,n; + int np,il,nl; + char *prime; + char *p,*pmax; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &nmax, &prnt) != 2) { + printf("conversion error, abort\n"); + return 1; + } + if (nmax < 10) { + printf("nmax must be >= 10, abort\n"); + return 1; + } + + /* prime: i=(n-1)/2 --> 3->[1], 5->[2]; ... 99-> [49]; ... */ + nmsqrt = sqrt((double)nmax); + imax = (nmax-1)/2; + prime = malloc(imax+1); /* need [1,...,imax] */ + pmax = &prime[imax]; + + for (p=prime; p<=pmax;) *p++ = 1; + + for (n=3; n<=nmsqrt; n+=2) { + if (prime[n/2] == 0) continue; + for (p=&prime[(n*n)/2]; p<=pmax; p+=n) *p = 0; + } + + if (prnt) { + printf("List of Primes up to %d\n",nmax); + printf(" %7d",2); + np = 1; + for (i=1;i<=imax;i++) { + if (! prime[i]) continue; + printf(" %7d",1+2*i); + np += 1; + if (np != 10) continue; + printf("\n"); + np= 0; + } + if (np != 0) printf("\n"); + } + + il = 4; + nl = 10; + np = 1; + for (i=1;i<=imax;i++) { + if (prime[i]) np += 1; + if (i != il) continue; + nl = 2*il+2; + printf("pi(%10d): %10d\n",nl,np); + il = 10*(il+1)-1; + } + if (nl != nmax) printf("pi(%10d): %10d\n",nmax,np); + + return 0; +} +/@ +//GO.STDOUT DD SYSOUT=*,OUTLIM=100000 +//GO.STDERR DD SYSOUT=*,OUTLIM=100000 +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEPJCCT,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#JCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(1,0),PRTY=8 +//CLG EXEC JCCCLG, +// JOPTS='-o', +// PARM.LKED='NCAL,MAP,LIST,NORENT' +//COMPILE.SYSIN DD DATA,DLM='/@' +/* $Id: soep_cc.c 972 2017-12-23 20:55:41Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 */ +/* 2017-10-15 956 1.0 Initial version */ +/* 2017-08-17 941 0.1 First draft */ + +#include +#include +#include + +int main() +{ + int nmax; + int nmsqrt; + int prnt; + int imax; + int i,n; + int np,il,nl; + char *prime; + char *p,*pmax; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &nmax, &prnt) != 2) { + printf("conversion error, abort\n"); + return 1; + } + if (nmax < 10) { + printf("nmax must be >= 10, abort\n"); + return 1; + } + + /* prime: i=(n-1)/2 --> 3->[1], 5->[2]; ... 99-> [49]; ... */ + nmsqrt = sqrt((double)nmax); + imax = (nmax-1)/2; + prime = malloc(imax+1); /* need [1,...,imax] */ + pmax = &prime[imax]; + + for (p=prime; p<=pmax;) *p++ = 1; + + for (n=3; n<=nmsqrt; n+=2) { + if (prime[n/2] == 0) continue; + for (p=&prime[(n*n)/2]; p<=pmax; p+=n) *p = 0; + } + + if (prnt) { + printf("List of Primes up to %d\n",nmax); + printf(" %7d",2); + np = 1; + for (i=1;i<=imax;i++) { + if (! prime[i]) continue; + printf(" %7d",1+2*i); + np += 1; + if (np != 10) continue; + printf("\n"); + np= 0; + } + if (np != 0) printf("\n"); + } + + il = 4; + nl = 10; + np = 1; + for (i=1;i<=imax;i++) { + if (prime[i]) np += 1; + if (i != il) continue; + nl = 2*il+2; + printf("pi(%10d): %10d\n",nl,np); + il = 10*(il+1)-1; + } + if (nl != nmax) printf("pi(%10d): %10d\n",nmax,np); + + return 0; +} +/@ +//GO.STDOUT DD SYSOUT=*,OUTLIM=5000 +//GO.STDERR DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEPFOGF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#FOG JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTGCLG, +// PARM.FORT='', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: soep_for.f 975 2017-12-25 19:22:43Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-25 975 1.1 use sqrt(nmax) as outer loop end +C 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +C 2017-09-17 951 1.0 Initial version +C 2017-08-26 942 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM SOEP + INTEGER NMAX,PRNT,IMAX,NMSQRT + INTEGER I,N,IMIN + INTEGER NP,IL,NL + INTEGER PLIST(10) + LOGICAL*1 PRIME(5000000) +C + READ(5,9000,ERR=910,END=900) NMAX,PRNT + IF (NMAX .LT. 10 .OR. NMAX .GT. 10000000) GOTO 920 +C + NMSQRT = IFIX(SQRT(FLOAT(NMAX))) + IMAX = (NMAX-1)/2 + DO 100 I=1,IMAX + PRIME(I) = .TRUE. +100 CONTINUE +C + DO 300 N=3,NMSQRT,2 + IF (.NOT. PRIME(N/2)) GOTO 300 + IMIN = (N*N)/2 + DO 200 I=IMIN,IMAX,N + PRIME(I) = .FALSE. +200 CONTINUE +300 CONTINUE +C + IF (PRNT .EQ. 0) GOTO 500 + WRITE(6,9010) NMAX + PLIST(1) = 2 + NP = 1 + DO 400 I=1,IMAX + IF (.NOT. PRIME(I)) GOTO 400 + NP = NP + 1 + PLIST(NP) = 1+2*I + IF (NP .LT. 10) GOTO 400 + WRITE(6,9020) PLIST + NP = 0 +400 CONTINUE + IF (NP .NE. 0) WRITE(6,9020) (PLIST(I),I=1,NP) +500 CONTINUE +C + IL = 4 + NL = 10 + NP = 1 + DO 600 I=1,IMAX + IF (PRIME(I)) NP = NP + 1 + IF (I .NE. IL) GOTO 650 + NL = 2*IL+2 + WRITE(6,9030) NL,NP + IL = 10*(IL+1)-1 +650 CONTINUE +600 CONTINUE + IF (NL .NE. NMAX) WRITE(6,9030) NMAX,NP +C +900 CONTINUE + STOP +910 WRITE(6,9040) + STOP +920 WRITE(6,9050) + STOP +C +9000 FORMAT(2I10) +9010 FORMAT(1X,'List of Primes up to',I8) +9020 FORMAT(10(1X,I7)) +9030 FORMAT(1X,'pi(',I8,'): ',I8) +9040 FORMAT(1X,'conversion error, abort') +9050 FORMAT(1X,'nmax out of range (10...10000000), abort') +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 10000000 0 +/* +// +./ ADD NAME=SOEPFOGP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#FOG JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTGCLG, +// PARM.FORT='', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: soep_for.f 975 2017-12-25 19:22:43Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-25 975 1.1 use sqrt(nmax) as outer loop end +C 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +C 2017-09-17 951 1.0 Initial version +C 2017-08-26 942 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM SOEP + INTEGER NMAX,PRNT,IMAX,NMSQRT + INTEGER I,N,IMIN + INTEGER NP,IL,NL + INTEGER PLIST(10) + LOGICAL*1 PRIME(5000000) +C + READ(5,9000,ERR=910,END=900) NMAX,PRNT + IF (NMAX .LT. 10 .OR. NMAX .GT. 10000000) GOTO 920 +C + NMSQRT = IFIX(SQRT(FLOAT(NMAX))) + IMAX = (NMAX-1)/2 + DO 100 I=1,IMAX + PRIME(I) = .TRUE. +100 CONTINUE +C + DO 300 N=3,NMSQRT,2 + IF (.NOT. PRIME(N/2)) GOTO 300 + IMIN = (N*N)/2 + DO 200 I=IMIN,IMAX,N + PRIME(I) = .FALSE. +200 CONTINUE +300 CONTINUE +C + IF (PRNT .EQ. 0) GOTO 500 + WRITE(6,9010) NMAX + PLIST(1) = 2 + NP = 1 + DO 400 I=1,IMAX + IF (.NOT. PRIME(I)) GOTO 400 + NP = NP + 1 + PLIST(NP) = 1+2*I + IF (NP .LT. 10) GOTO 400 + WRITE(6,9020) PLIST + NP = 0 +400 CONTINUE + IF (NP .NE. 0) WRITE(6,9020) (PLIST(I),I=1,NP) +500 CONTINUE +C + IL = 4 + NL = 10 + NP = 1 + DO 600 I=1,IMAX + IF (PRIME(I)) NP = NP + 1 + IF (I .NE. IL) GOTO 650 + NL = 2*IL+2 + WRITE(6,9030) NL,NP + IL = 10*(IL+1)-1 +650 CONTINUE +600 CONTINUE + IF (NL .NE. NMAX) WRITE(6,9030) NMAX,NP +C +900 CONTINUE + STOP +910 WRITE(6,9040) + STOP +920 WRITE(6,9050) + STOP +C +9000 FORMAT(2I10) +9010 FORMAT(1X,'List of Primes up to',I8) +9020 FORMAT(10(1X,I7)) +9030 FORMAT(1X,'pi(',I8,'): ',I8) +9040 FORMAT(1X,'conversion error, abort') +9050 FORMAT(1X,'nmax out of range (10...10000000), abort') +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=100000 +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEPFOGT,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#FOG JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTGCLG, +// PARM.FORT='', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: soep_for.f 975 2017-12-25 19:22:43Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-25 975 1.1 use sqrt(nmax) as outer loop end +C 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +C 2017-09-17 951 1.0 Initial version +C 2017-08-26 942 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM SOEP + INTEGER NMAX,PRNT,IMAX,NMSQRT + INTEGER I,N,IMIN + INTEGER NP,IL,NL + INTEGER PLIST(10) + LOGICAL*1 PRIME(5000000) +C + READ(5,9000,ERR=910,END=900) NMAX,PRNT + IF (NMAX .LT. 10 .OR. NMAX .GT. 10000000) GOTO 920 +C + NMSQRT = IFIX(SQRT(FLOAT(NMAX))) + IMAX = (NMAX-1)/2 + DO 100 I=1,IMAX + PRIME(I) = .TRUE. +100 CONTINUE +C + DO 300 N=3,NMSQRT,2 + IF (.NOT. PRIME(N/2)) GOTO 300 + IMIN = (N*N)/2 + DO 200 I=IMIN,IMAX,N + PRIME(I) = .FALSE. +200 CONTINUE +300 CONTINUE +C + IF (PRNT .EQ. 0) GOTO 500 + WRITE(6,9010) NMAX + PLIST(1) = 2 + NP = 1 + DO 400 I=1,IMAX + IF (.NOT. PRIME(I)) GOTO 400 + NP = NP + 1 + PLIST(NP) = 1+2*I + IF (NP .LT. 10) GOTO 400 + WRITE(6,9020) PLIST + NP = 0 +400 CONTINUE + IF (NP .NE. 0) WRITE(6,9020) (PLIST(I),I=1,NP) +500 CONTINUE +C + IL = 4 + NL = 10 + NP = 1 + DO 600 I=1,IMAX + IF (PRIME(I)) NP = NP + 1 + IF (I .NE. IL) GOTO 650 + NL = 2*IL+2 + WRITE(6,9030) NL,NP + IL = 10*(IL+1)-1 +650 CONTINUE +600 CONTINUE + IF (NL .NE. NMAX) WRITE(6,9030) NMAX,NP +C +900 CONTINUE + STOP +910 WRITE(6,9040) + STOP +920 WRITE(6,9050) + STOP +C +9000 FORMAT(2I10) +9010 FORMAT(1X,'List of Primes up to',I8) +9020 FORMAT(10(1X,I7)) +9030 FORMAT(1X,'pi(',I8,'): ',I8) +9040 FORMAT(1X,'conversion error, abort') +9050 FORMAT(1X,'nmax out of range (10...10000000), abort') +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEPFOHF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#FOH JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTHCLG, +// PARM.FORT='OPT=2', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: soep_for.f 975 2017-12-25 19:22:43Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-25 975 1.1 use sqrt(nmax) as outer loop end +C 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +C 2017-09-17 951 1.0 Initial version +C 2017-08-26 942 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM SOEP + INTEGER NMAX,PRNT,IMAX,NMSQRT + INTEGER I,N,IMIN + INTEGER NP,IL,NL + INTEGER PLIST(10) + LOGICAL*1 PRIME(5000000) +C + READ(5,9000,ERR=910,END=900) NMAX,PRNT + IF (NMAX .LT. 10 .OR. NMAX .GT. 10000000) GOTO 920 +C + NMSQRT = IFIX(SQRT(FLOAT(NMAX))) + IMAX = (NMAX-1)/2 + DO 100 I=1,IMAX + PRIME(I) = .TRUE. +100 CONTINUE +C + DO 300 N=3,NMSQRT,2 + IF (.NOT. PRIME(N/2)) GOTO 300 + IMIN = (N*N)/2 + DO 200 I=IMIN,IMAX,N + PRIME(I) = .FALSE. +200 CONTINUE +300 CONTINUE +C + IF (PRNT .EQ. 0) GOTO 500 + WRITE(6,9010) NMAX + PLIST(1) = 2 + NP = 1 + DO 400 I=1,IMAX + IF (.NOT. PRIME(I)) GOTO 400 + NP = NP + 1 + PLIST(NP) = 1+2*I + IF (NP .LT. 10) GOTO 400 + WRITE(6,9020) PLIST + NP = 0 +400 CONTINUE + IF (NP .NE. 0) WRITE(6,9020) (PLIST(I),I=1,NP) +500 CONTINUE +C + IL = 4 + NL = 10 + NP = 1 + DO 600 I=1,IMAX + IF (PRIME(I)) NP = NP + 1 + IF (I .NE. IL) GOTO 650 + NL = 2*IL+2 + WRITE(6,9030) NL,NP + IL = 10*(IL+1)-1 +650 CONTINUE +600 CONTINUE + IF (NL .NE. NMAX) WRITE(6,9030) NMAX,NP +C +900 CONTINUE + STOP +910 WRITE(6,9040) + STOP +920 WRITE(6,9050) + STOP +C +9000 FORMAT(2I10) +9010 FORMAT(1X,'List of Primes up to',I8) +9020 FORMAT(10(1X,I7)) +9030 FORMAT(1X,'pi(',I8,'): ',I8) +9040 FORMAT(1X,'conversion error, abort') +9050 FORMAT(1X,'nmax out of range (10...10000000), abort') +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 10000000 0 +/* +// +./ ADD NAME=SOEPFOHP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#FOH JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTHCLG, +// PARM.FORT='OPT=2', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: soep_for.f 975 2017-12-25 19:22:43Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-25 975 1.1 use sqrt(nmax) as outer loop end +C 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +C 2017-09-17 951 1.0 Initial version +C 2017-08-26 942 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM SOEP + INTEGER NMAX,PRNT,IMAX,NMSQRT + INTEGER I,N,IMIN + INTEGER NP,IL,NL + INTEGER PLIST(10) + LOGICAL*1 PRIME(5000000) +C + READ(5,9000,ERR=910,END=900) NMAX,PRNT + IF (NMAX .LT. 10 .OR. NMAX .GT. 10000000) GOTO 920 +C + NMSQRT = IFIX(SQRT(FLOAT(NMAX))) + IMAX = (NMAX-1)/2 + DO 100 I=1,IMAX + PRIME(I) = .TRUE. +100 CONTINUE +C + DO 300 N=3,NMSQRT,2 + IF (.NOT. PRIME(N/2)) GOTO 300 + IMIN = (N*N)/2 + DO 200 I=IMIN,IMAX,N + PRIME(I) = .FALSE. +200 CONTINUE +300 CONTINUE +C + IF (PRNT .EQ. 0) GOTO 500 + WRITE(6,9010) NMAX + PLIST(1) = 2 + NP = 1 + DO 400 I=1,IMAX + IF (.NOT. PRIME(I)) GOTO 400 + NP = NP + 1 + PLIST(NP) = 1+2*I + IF (NP .LT. 10) GOTO 400 + WRITE(6,9020) PLIST + NP = 0 +400 CONTINUE + IF (NP .NE. 0) WRITE(6,9020) (PLIST(I),I=1,NP) +500 CONTINUE +C + IL = 4 + NL = 10 + NP = 1 + DO 600 I=1,IMAX + IF (PRIME(I)) NP = NP + 1 + IF (I .NE. IL) GOTO 650 + NL = 2*IL+2 + WRITE(6,9030) NL,NP + IL = 10*(IL+1)-1 +650 CONTINUE +600 CONTINUE + IF (NL .NE. NMAX) WRITE(6,9030) NMAX,NP +C +900 CONTINUE + STOP +910 WRITE(6,9040) + STOP +920 WRITE(6,9050) + STOP +C +9000 FORMAT(2I10) +9010 FORMAT(1X,'List of Primes up to',I8) +9020 FORMAT(10(1X,I7)) +9030 FORMAT(1X,'pi(',I8,'): ',I8) +9040 FORMAT(1X,'conversion error, abort') +9050 FORMAT(1X,'nmax out of range (10...10000000), abort') +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=100000 +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEPFOHT,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#FOH JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTHCLG, +// PARM.FORT='OPT=2', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: soep_for.f 975 2017-12-25 19:22:43Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-25 975 1.1 use sqrt(nmax) as outer loop end +C 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +C 2017-09-17 951 1.0 Initial version +C 2017-08-26 942 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM SOEP + INTEGER NMAX,PRNT,IMAX,NMSQRT + INTEGER I,N,IMIN + INTEGER NP,IL,NL + INTEGER PLIST(10) + LOGICAL*1 PRIME(5000000) +C + READ(5,9000,ERR=910,END=900) NMAX,PRNT + IF (NMAX .LT. 10 .OR. NMAX .GT. 10000000) GOTO 920 +C + NMSQRT = IFIX(SQRT(FLOAT(NMAX))) + IMAX = (NMAX-1)/2 + DO 100 I=1,IMAX + PRIME(I) = .TRUE. +100 CONTINUE +C + DO 300 N=3,NMSQRT,2 + IF (.NOT. PRIME(N/2)) GOTO 300 + IMIN = (N*N)/2 + DO 200 I=IMIN,IMAX,N + PRIME(I) = .FALSE. +200 CONTINUE +300 CONTINUE +C + IF (PRNT .EQ. 0) GOTO 500 + WRITE(6,9010) NMAX + PLIST(1) = 2 + NP = 1 + DO 400 I=1,IMAX + IF (.NOT. PRIME(I)) GOTO 400 + NP = NP + 1 + PLIST(NP) = 1+2*I + IF (NP .LT. 10) GOTO 400 + WRITE(6,9020) PLIST + NP = 0 +400 CONTINUE + IF (NP .NE. 0) WRITE(6,9020) (PLIST(I),I=1,NP) +500 CONTINUE +C + IL = 4 + NL = 10 + NP = 1 + DO 600 I=1,IMAX + IF (PRIME(I)) NP = NP + 1 + IF (I .NE. IL) GOTO 650 + NL = 2*IL+2 + WRITE(6,9030) NL,NP + IL = 10*(IL+1)-1 +650 CONTINUE +600 CONTINUE + IF (NL .NE. NMAX) WRITE(6,9030) NMAX,NP +C +900 CONTINUE + STOP +910 WRITE(6,9040) + STOP +920 WRITE(6,9050) + STOP +C +9000 FORMAT(2I10) +9010 FORMAT(1X,'List of Primes up to',I8) +9020 FORMAT(10(1X,I7)) +9030 FORMAT(1X,'pi(',I8,'): ',I8) +9040 FORMAT(1X,'conversion error, abort') +9050 FORMAT(1X,'nmax out of range (10...10000000), abort') +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEPFOWF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#FOW JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC WATFIV +//SYSIN DD * +$JOB SOEP#FOW,T=(1,0),P=100,CHECK +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: soep_for.f 975 2017-12-25 19:22:43Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-25 975 1.1 use sqrt(nmax) as outer loop end +C 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +C 2017-09-17 951 1.0 Initial version +C 2017-08-26 942 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM SOEP + INTEGER NMAX,PRNT,IMAX,NMSQRT + INTEGER I,N,IMIN + INTEGER NP,IL,NL + INTEGER PLIST(10) + LOGICAL*1 PRIME(5000000) +C + READ(5,9000,ERR=910,END=900) NMAX,PRNT + IF (NMAX .LT. 10 .OR. NMAX .GT. 10000000) GOTO 920 +C + NMSQRT = IFIX(SQRT(FLOAT(NMAX))) + IMAX = (NMAX-1)/2 + DO 100 I=1,IMAX + PRIME(I) = .TRUE. +100 CONTINUE +C + DO 300 N=3,NMSQRT,2 + IF (.NOT. PRIME(N/2)) GOTO 300 + IMIN = (N*N)/2 + DO 200 I=IMIN,IMAX,N + PRIME(I) = .FALSE. +200 CONTINUE +300 CONTINUE +C + IF (PRNT .EQ. 0) GOTO 500 + WRITE(6,9010) NMAX + PLIST(1) = 2 + NP = 1 + DO 400 I=1,IMAX + IF (.NOT. PRIME(I)) GOTO 400 + NP = NP + 1 + PLIST(NP) = 1+2*I + IF (NP .LT. 10) GOTO 400 + WRITE(6,9020) PLIST + NP = 0 +400 CONTINUE + IF (NP .NE. 0) WRITE(6,9020) (PLIST(I),I=1,NP) +500 CONTINUE +C + IL = 4 + NL = 10 + NP = 1 + DO 600 I=1,IMAX + IF (PRIME(I)) NP = NP + 1 + IF (I .NE. IL) GOTO 650 + NL = 2*IL+2 + WRITE(6,9030) NL,NP + IL = 10*(IL+1)-1 +650 CONTINUE +600 CONTINUE + IF (NL .NE. NMAX) WRITE(6,9030) NMAX,NP +C +900 CONTINUE + STOP +910 WRITE(6,9040) + STOP +920 WRITE(6,9050) + STOP +C +9000 FORMAT(2I10) +9010 FORMAT(1X,'List of Primes up to',I8) +9020 FORMAT(10(1X,I7)) +9030 FORMAT(1X,'pi(',I8,'): ',I8) +9040 FORMAT(1X,'conversion error, abort') +9050 FORMAT(1X,'nmax out of range (10...10000000), abort') +C + END +$ENTRY + 10000000 0 +$STOP +/* +// +./ ADD NAME=SOEPFOWP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#FOW JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC WATFIV +//SYSIN DD * +$JOB SOEP#FOW,T=(1,0),P=2000,NOCHECK +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: soep_for.f 975 2017-12-25 19:22:43Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-25 975 1.1 use sqrt(nmax) as outer loop end +C 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +C 2017-09-17 951 1.0 Initial version +C 2017-08-26 942 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM SOEP + INTEGER NMAX,PRNT,IMAX,NMSQRT + INTEGER I,N,IMIN + INTEGER NP,IL,NL + INTEGER PLIST(10) + LOGICAL*1 PRIME(5000000) +C + READ(5,9000,ERR=910,END=900) NMAX,PRNT + IF (NMAX .LT. 10 .OR. NMAX .GT. 10000000) GOTO 920 +C + NMSQRT = IFIX(SQRT(FLOAT(NMAX))) + IMAX = (NMAX-1)/2 + DO 100 I=1,IMAX + PRIME(I) = .TRUE. +100 CONTINUE +C + DO 300 N=3,NMSQRT,2 + IF (.NOT. PRIME(N/2)) GOTO 300 + IMIN = (N*N)/2 + DO 200 I=IMIN,IMAX,N + PRIME(I) = .FALSE. +200 CONTINUE +300 CONTINUE +C + IF (PRNT .EQ. 0) GOTO 500 + WRITE(6,9010) NMAX + PLIST(1) = 2 + NP = 1 + DO 400 I=1,IMAX + IF (.NOT. PRIME(I)) GOTO 400 + NP = NP + 1 + PLIST(NP) = 1+2*I + IF (NP .LT. 10) GOTO 400 + WRITE(6,9020) PLIST + NP = 0 +400 CONTINUE + IF (NP .NE. 0) WRITE(6,9020) (PLIST(I),I=1,NP) +500 CONTINUE +C + IL = 4 + NL = 10 + NP = 1 + DO 600 I=1,IMAX + IF (PRIME(I)) NP = NP + 1 + IF (I .NE. IL) GOTO 650 + NL = 2*IL+2 + WRITE(6,9030) NL,NP + IL = 10*(IL+1)-1 +650 CONTINUE +600 CONTINUE + IF (NL .NE. NMAX) WRITE(6,9030) NMAX,NP +C +900 CONTINUE + STOP +910 WRITE(6,9040) + STOP +920 WRITE(6,9050) + STOP +C +9000 FORMAT(2I10) +9010 FORMAT(1X,'List of Primes up to',I8) +9020 FORMAT(10(1X,I7)) +9030 FORMAT(1X,'pi(',I8,'): ',I8) +9040 FORMAT(1X,'conversion error, abort') +9050 FORMAT(1X,'nmax out of range (10...10000000), abort') +C + END +$ENTRY + 10000000 1 +$STOP +/* +// +./ ADD NAME=SOEPFOWT,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#FOW JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC WATFIV +//SYSIN DD * +$JOB SOEP#FOW,T=(1,0),P=100,NOCHECK +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: soep_for.f 975 2017-12-25 19:22:43Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-25 975 1.1 use sqrt(nmax) as outer loop end +C 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +C 2017-09-17 951 1.0 Initial version +C 2017-08-26 942 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM SOEP + INTEGER NMAX,PRNT,IMAX,NMSQRT + INTEGER I,N,IMIN + INTEGER NP,IL,NL + INTEGER PLIST(10) + LOGICAL*1 PRIME(5000000) +C + READ(5,9000,ERR=910,END=900) NMAX,PRNT + IF (NMAX .LT. 10 .OR. NMAX .GT. 10000000) GOTO 920 +C + NMSQRT = IFIX(SQRT(FLOAT(NMAX))) + IMAX = (NMAX-1)/2 + DO 100 I=1,IMAX + PRIME(I) = .TRUE. +100 CONTINUE +C + DO 300 N=3,NMSQRT,2 + IF (.NOT. PRIME(N/2)) GOTO 300 + IMIN = (N*N)/2 + DO 200 I=IMIN,IMAX,N + PRIME(I) = .FALSE. +200 CONTINUE +300 CONTINUE +C + IF (PRNT .EQ. 0) GOTO 500 + WRITE(6,9010) NMAX + PLIST(1) = 2 + NP = 1 + DO 400 I=1,IMAX + IF (.NOT. PRIME(I)) GOTO 400 + NP = NP + 1 + PLIST(NP) = 1+2*I + IF (NP .LT. 10) GOTO 400 + WRITE(6,9020) PLIST + NP = 0 +400 CONTINUE + IF (NP .NE. 0) WRITE(6,9020) (PLIST(I),I=1,NP) +500 CONTINUE +C + IL = 4 + NL = 10 + NP = 1 + DO 600 I=1,IMAX + IF (PRIME(I)) NP = NP + 1 + IF (I .NE. IL) GOTO 650 + NL = 2*IL+2 + WRITE(6,9030) NL,NP + IL = 10*(IL+1)-1 +650 CONTINUE +600 CONTINUE + IF (NL .NE. NMAX) WRITE(6,9030) NMAX,NP +C +900 CONTINUE + STOP +910 WRITE(6,9040) + STOP +920 WRITE(6,9050) + STOP +C +9000 FORMAT(2I10) +9010 FORMAT(1X,'List of Primes up to',I8) +9020 FORMAT(10(1X,I7)) +9030 FORMAT(1X,'pi(',I8,'): ',I8) +9040 FORMAT(1X,'conversion error, abort') +9050 FORMAT(1X,'nmax out of range (10...10000000), abort') +C + END +$ENTRY + 100000 1 +$STOP +/* +// +./ ADD NAME=SOEPPASF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#PAS JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6500K,TIME=(1,0),PRTY=8 +//CLG EXEC PASCLG,GOTIME=3600,GOREG=6500K, +// OPT='M+,D-', +// GOPARM='/STACK=5500K' +//COMPILE.SYSIN DD * +(* $Id: soep_pas.pas 975 2017-12-25 19:22:43Z mueller $ *) +(* +(* Copyright 2017- by Walter F.J. Mueller *) +(* +(* This program is free software; you may redistribute and/or modify *) +(* it under the terms of the GNU General Public License version 3. *) +(* See Licence.txt in distribition directory for further details. *) +(* *) +(* Revision History: *) +(* Date Rev Version Comment *) +(* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end *) +(* 2017-12-25 974 1.1 5M sieve array *) +(* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 *) +(* 2017-09-07 948 1.0 Initial version *) + +program soep(input,output); +var + nmax,prnt,imax : integer; + nmsqrt : integer; + i,n,imin : integer; + np,il,nl : integer; + rnmax : real; + sieve : ARRAY[1 .. 5000000] of boolean; + +begin + + read(nmax); + read(prnt); + + if (nmax < 10) or (nmax > 10000000) then begin + writeln(' ', 'nmax out of range (10...10000000), abort'); + exit(8); + end; + + rnmax := nmax; + nmsqrt := trunc(sqrt(nmax)); + imax := (nmax-1) div 2; + for i := 1 to imax do sieve[i] := TRUE; + + n := 3; + while n <= nmsqrt do begin + if sieve[n div 2] then begin + i := (n*n) div 2; + while i <= imax do begin + sieve[i] := FALSE; + i := i + n; + end; + end; + n := n + 2; + end; + + if prnt > 0 then begin + writeln(' ', 'List of Primes up to ', nmax:8); + write(2:8); + np := 1; + for i := 1 to imax do begin + if sieve[i] then begin + write(1+2*i:8); + np := np + 1; + if np = 10 then begin + writeln(' '); + np := 0; + end; + end; + end; + if np > 0 then writeln(); + end; + + il := 4; + nl := 10; + np := 1; + for i := 1 to imax do begin + if sieve[i] then np := np + 1; + if i = il then begin + nl := 2*il + 2; + writeln(' ', 'pi(', nl:8, '): ', np:8); + il := 10*(il+1)-1; + end; + end; + + if nl < nmax then writeln(' ', 'pi(', nmax:8, '): ', np:8); + +end. +/* +//GO.OUTPUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 10000000 0 +/* +// +./ ADD NAME=SOEPPASP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#PAS JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6500K,TIME=(1,0),PRTY=8 +//CLG EXEC PASCLG,GOTIME=3600,GOREG=6500K, +// OPT='M+,D-', +// GOPARM='/STACK=5500K' +//COMPILE.SYSIN DD * +(* $Id: soep_pas.pas 975 2017-12-25 19:22:43Z mueller $ *) +(* +(* Copyright 2017- by Walter F.J. Mueller *) +(* +(* This program is free software; you may redistribute and/or modify *) +(* it under the terms of the GNU General Public License version 3. *) +(* See Licence.txt in distribition directory for further details. *) +(* *) +(* Revision History: *) +(* Date Rev Version Comment *) +(* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end *) +(* 2017-12-25 974 1.1 5M sieve array *) +(* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 *) +(* 2017-09-07 948 1.0 Initial version *) + +program soep(input,output); +var + nmax,prnt,imax : integer; + nmsqrt : integer; + i,n,imin : integer; + np,il,nl : integer; + rnmax : real; + sieve : ARRAY[1 .. 5000000] of boolean; + +begin + + read(nmax); + read(prnt); + + if (nmax < 10) or (nmax > 10000000) then begin + writeln(' ', 'nmax out of range (10...10000000), abort'); + exit(8); + end; + + rnmax := nmax; + nmsqrt := trunc(sqrt(nmax)); + imax := (nmax-1) div 2; + for i := 1 to imax do sieve[i] := TRUE; + + n := 3; + while n <= nmsqrt do begin + if sieve[n div 2] then begin + i := (n*n) div 2; + while i <= imax do begin + sieve[i] := FALSE; + i := i + n; + end; + end; + n := n + 2; + end; + + if prnt > 0 then begin + writeln(' ', 'List of Primes up to ', nmax:8); + write(2:8); + np := 1; + for i := 1 to imax do begin + if sieve[i] then begin + write(1+2*i:8); + np := np + 1; + if np = 10 then begin + writeln(' '); + np := 0; + end; + end; + end; + if np > 0 then writeln(); + end; + + il := 4; + nl := 10; + np := 1; + for i := 1 to imax do begin + if sieve[i] then np := np + 1; + if i = il then begin + nl := 2*il + 2; + writeln(' ', 'pi(', nl:8, '): ', np:8); + il := 10*(il+1)-1; + end; + end; + + if nl < nmax then writeln(' ', 'pi(', nmax:8, '): ', np:8); + +end. +/* +//GO.OUTPUT DD SYSOUT=*,OUTLIM=100000 +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEPPAST,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#PAS JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6500K,TIME=(1,0),PRTY=8 +//CLG EXEC PASCLG,GOTIME=3600,GOREG=6500K, +// OPT='M+', +// GOPARM='/STACK=5500K' +//COMPILE.SYSIN DD * +(* $Id: soep_pas.pas 975 2017-12-25 19:22:43Z mueller $ *) +(* +(* Copyright 2017- by Walter F.J. Mueller *) +(* +(* This program is free software; you may redistribute and/or modify *) +(* it under the terms of the GNU General Public License version 3. *) +(* See Licence.txt in distribition directory for further details. *) +(* *) +(* Revision History: *) +(* Date Rev Version Comment *) +(* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end *) +(* 2017-12-25 974 1.1 5M sieve array *) +(* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 *) +(* 2017-09-07 948 1.0 Initial version *) + +program soep(input,output); +var + nmax,prnt,imax : integer; + nmsqrt : integer; + i,n,imin : integer; + np,il,nl : integer; + rnmax : real; + sieve : ARRAY[1 .. 5000000] of boolean; + +begin + + read(nmax); + read(prnt); + + if (nmax < 10) or (nmax > 10000000) then begin + writeln(' ', 'nmax out of range (10...10000000), abort'); + exit(8); + end; + + rnmax := nmax; + nmsqrt := trunc(sqrt(nmax)); + imax := (nmax-1) div 2; + for i := 1 to imax do sieve[i] := TRUE; + + n := 3; + while n <= nmsqrt do begin + if sieve[n div 2] then begin + i := (n*n) div 2; + while i <= imax do begin + sieve[i] := FALSE; + i := i + n; + end; + end; + n := n + 2; + end; + + if prnt > 0 then begin + writeln(' ', 'List of Primes up to ', nmax:8); + write(2:8); + np := 1; + for i := 1 to imax do begin + if sieve[i] then begin + write(1+2*i:8); + np := np + 1; + if np = 10 then begin + writeln(' '); + np := 0; + end; + end; + end; + if np > 0 then writeln(); + end; + + il := 4; + nl := 10; + np := 1; + for i := 1 to imax do begin + if sieve[i] then np := np + 1; + if i = il then begin + nl := 2*il + 2; + writeln(' ', 'pi(', nl:8, '): ', np:8); + il := 10*(il+1)-1; + end; + end; + + if nl < nmax then writeln(' ', 'pi(', nmax:8, '): ', np:8); + +end. +/* +//GO.OUTPUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEPPLIF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#PLI JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=2200K,TIME=(1,0),PRTY=8 +//CLG EXEC PL1LFCLG, +// PARM.PL1L='LOAD,NODECK,OPT=2', +// PARM.LKED='MAP,LIST' +//PL1L.SYSLIN DD UNIT=SYSDA +//PL1L.SYSIN DD * +/* 1 2 3 4 5 6 7*/-------- +/*4567890123456789012345678901234567890123456789012345678901234567890*/-------- +/* $Id: soep_pli.pli 976 2017-12-26 15:35:59Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-26 976 1.3 use CHAR(1) array; go for max PRIME size*/ +/* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end */ +/* 2017-12-25 974 1.1 use 2-dim PRIME array */ +/* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 */ +/* 2017-09-17 951 1.0 Initial version */ +/* 2017-09-01 945 0.1 First draft */ + + SOEP: PROC OPTIONS(MAIN) REORDER; + DCL (NMAX,PRNT,IMAX) BIN FIXED(31) INIT(0); + DCL (NMSQRT) BIN FIXED(31) INIT(0); + DCL (I,N,IMIN) BIN FIXED(31) INIT(0); + DCL (NP,IL,NL) BIN FIXED(31) INIT(0); + /* In PL/I(F) V5.5 array bounds are BIN(15) ! limited to 32k !! */ + /* And the maximal aggregate size is 2 MByte !! */ + /* So go for a 2-dimensional array; 1954*1024 = 2000896; */ + /* Use 0 as lower bound to make index calculations easy: */ + /* PRIME(I) turns into PRIME(I/1024,MOD(I,1024)) */ + DCL PRIME(0:1953,0:1023) CHAR(1); + + ON ENDFILE(SYSIN) BEGIN; + PUT SKIP EDIT('Unexpected EOF, abort')(A); + GOTO DONE; + END; + ON CONVERSION BEGIN; + PUT SKIP EDIT('Conversion error, abort')(A); + GOTO DONE; + END; + + GET EDIT(NMAX,PRNT) (F(10),F(10)); + + /*IF NMAX < 10 | NMAX > 4000000 THEN DO;*/ + IF NMAX > 4000000 THEN DO; + PUT SKIP EDIT('nmax out of range (10...4000000), abort') (A); + GOTO DONE; + END; + + NMSQRT = FLOOR(SQRT(NMAX)); + IMAX = (NMAX-1)/2; + + DO I=1 TO IMAX; + PRIME(I/1024,MOD(I,1024)) = '1'; + END; + + DO N=3 TO NMSQRT BY 2; + I = N/2; + IF PRIME(I/1024,MOD(I,1024)) = '1' THEN DO; + IMIN = N*N/2; + DO I=IMIN TO IMAX BY N; + PRIME(I/1024,MOD(I,1024)) = '0'; + END; + END; + END; + + IF PRNT > 0 THEN DO; + PUT SKIP EDIT('List of Primes up to ',NMAX) (A,F(8)); + PUT SKIP EDIT(' ',2) (A,F(7)); + NP = 1; + DO I=1 TO IMAX; + IF PRIME(I/1024,MOD(I,1024)) = '1' THEN DO; + PUT EDIT(' ',1+2*I) (A,F(7)); + NP = NP + 1; + IF NP = 10 THEN DO; + PUT SKIP; + NP = 0; + END; + END; + END; + IF NP > 0 THEN PUT SKIP; + END; + + IL = 4; + NL = 10; + NP = 1; + DO I=1 TO IMAX; + IF PRIME(I/1024,MOD(I,1024)) = '1' THEN NP = NP + 1; + IF I = IL THEN DO; + NL = 2*IL + 2; + PUT SKIP EDIT('pi(',NL,'): ',NP) (A,F(8),A,F(8)); + IL = 10*(IL+1)-1; + END; + END; + + IF NL < NMAX THEN PUT SKIP EDIT('pi(',NMAX,'): ',NP) + (A,F(8),A,F(8)); + + DONE:; + + END SOEP; +/* +//LKED.SYSLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.STEPLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.SYSIN DD * + 4000000 0 +/* +// +./ ADD NAME=SOEPPLIP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#PLI JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=2200K,TIME=(1,0),PRTY=8 +//CLG EXEC PL1LFCLG, +// PARM.PL1L='LOAD,NODECK,OPT=2', +// PARM.LKED='MAP,LIST' +//PL1L.SYSLIN DD UNIT=SYSDA +//PL1L.SYSIN DD * +/* 1 2 3 4 5 6 7*/-------- +/*4567890123456789012345678901234567890123456789012345678901234567890*/-------- +/* $Id: soep_pli.pli 976 2017-12-26 15:35:59Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-26 976 1.3 use CHAR(1) array; go for max PRIME size*/ +/* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end */ +/* 2017-12-25 974 1.1 use 2-dim PRIME array */ +/* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 */ +/* 2017-09-17 951 1.0 Initial version */ +/* 2017-09-01 945 0.1 First draft */ + + SOEP: PROC OPTIONS(MAIN) REORDER; + DCL (NMAX,PRNT,IMAX) BIN FIXED(31) INIT(0); + DCL (NMSQRT) BIN FIXED(31) INIT(0); + DCL (I,N,IMIN) BIN FIXED(31) INIT(0); + DCL (NP,IL,NL) BIN FIXED(31) INIT(0); + /* In PL/I(F) V5.5 array bounds are BIN(15) ! limited to 32k !! */ + /* And the maximal aggregate size is 2 MByte !! */ + /* So go for a 2-dimensional array; 1954*1024 = 2000896; */ + /* Use 0 as lower bound to make index calculations easy: */ + /* PRIME(I) turns into PRIME(I/1024,MOD(I,1024)) */ + DCL PRIME(0:1953,0:1023) CHAR(1); + + ON ENDFILE(SYSIN) BEGIN; + PUT SKIP EDIT('Unexpected EOF, abort')(A); + GOTO DONE; + END; + ON CONVERSION BEGIN; + PUT SKIP EDIT('Conversion error, abort')(A); + GOTO DONE; + END; + + GET EDIT(NMAX,PRNT) (F(10),F(10)); + + /*IF NMAX < 10 | NMAX > 4000000 THEN DO;*/ + IF NMAX > 4000000 THEN DO; + PUT SKIP EDIT('nmax out of range (10...4000000), abort') (A); + GOTO DONE; + END; + + NMSQRT = FLOOR(SQRT(NMAX)); + IMAX = (NMAX-1)/2; + + DO I=1 TO IMAX; + PRIME(I/1024,MOD(I,1024)) = '1'; + END; + + DO N=3 TO NMSQRT BY 2; + I = N/2; + IF PRIME(I/1024,MOD(I,1024)) = '1' THEN DO; + IMIN = N*N/2; + DO I=IMIN TO IMAX BY N; + PRIME(I/1024,MOD(I,1024)) = '0'; + END; + END; + END; + + IF PRNT > 0 THEN DO; + PUT SKIP EDIT('List of Primes up to ',NMAX) (A,F(8)); + PUT SKIP EDIT(' ',2) (A,F(7)); + NP = 1; + DO I=1 TO IMAX; + IF PRIME(I/1024,MOD(I,1024)) = '1' THEN DO; + PUT EDIT(' ',1+2*I) (A,F(7)); + NP = NP + 1; + IF NP = 10 THEN DO; + PUT SKIP; + NP = 0; + END; + END; + END; + IF NP > 0 THEN PUT SKIP; + END; + + IL = 4; + NL = 10; + NP = 1; + DO I=1 TO IMAX; + IF PRIME(I/1024,MOD(I,1024)) = '1' THEN NP = NP + 1; + IF I = IL THEN DO; + NL = 2*IL + 2; + PUT SKIP EDIT('pi(',NL,'): ',NP) (A,F(8),A,F(8)); + IL = 10*(IL+1)-1; + END; + END; + + IF NL < NMAX THEN PUT SKIP EDIT('pi(',NMAX,'): ',NP) + (A,F(8),A,F(8)); + + DONE:; + + END SOEP; +/* +//LKED.SYSLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.STEPLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.SYSIN DD * + 4000000 1 +/* +// +./ ADD NAME=SOEPPLIT,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#PLI JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=2200K,TIME=(1,0),PRTY=8 +//CLG EXEC PL1LFCLG, +// PARM.PL1L='LOAD,NODECK,OPT=2', +// PARM.LKED='MAP,LIST' +//PL1L.SYSLIN DD UNIT=SYSDA +//PL1L.SYSIN DD * +/* 1 2 3 4 5 6 7*/-------- +/*4567890123456789012345678901234567890123456789012345678901234567890*/-------- +/* $Id: soep_pli.pli 976 2017-12-26 15:35:59Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-26 976 1.3 use CHAR(1) array; go for max PRIME size*/ +/* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end */ +/* 2017-12-25 974 1.1 use 2-dim PRIME array */ +/* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 */ +/* 2017-09-17 951 1.0 Initial version */ +/* 2017-09-01 945 0.1 First draft */ + + SOEP: PROC OPTIONS(MAIN) REORDER; + DCL (NMAX,PRNT,IMAX) BIN FIXED(31) INIT(0); + DCL (NMSQRT) BIN FIXED(31) INIT(0); + DCL (I,N,IMIN) BIN FIXED(31) INIT(0); + DCL (NP,IL,NL) BIN FIXED(31) INIT(0); + /* In PL/I(F) V5.5 array bounds are BIN(15) ! limited to 32k !! */ + /* And the maximal aggregate size is 2 MByte !! */ + /* So go for a 2-dimensional array; 1954*1024 = 2000896; */ + /* Use 0 as lower bound to make index calculations easy: */ + /* PRIME(I) turns into PRIME(I/1024,MOD(I,1024)) */ + DCL PRIME(0:1953,0:1023) CHAR(1); + + ON ENDFILE(SYSIN) BEGIN; + PUT SKIP EDIT('Unexpected EOF, abort')(A); + GOTO DONE; + END; + ON CONVERSION BEGIN; + PUT SKIP EDIT('Conversion error, abort')(A); + GOTO DONE; + END; + + GET EDIT(NMAX,PRNT) (F(10),F(10)); + + /*IF NMAX < 10 | NMAX > 4000000 THEN DO;*/ + IF NMAX > 4000000 THEN DO; + PUT SKIP EDIT('nmax out of range (10...4000000), abort') (A); + GOTO DONE; + END; + + NMSQRT = FLOOR(SQRT(NMAX)); + IMAX = (NMAX-1)/2; + + DO I=1 TO IMAX; + PRIME(I/1024,MOD(I,1024)) = '1'; + END; + + DO N=3 TO NMSQRT BY 2; + I = N/2; + IF PRIME(I/1024,MOD(I,1024)) = '1' THEN DO; + IMIN = N*N/2; + DO I=IMIN TO IMAX BY N; + PRIME(I/1024,MOD(I,1024)) = '0'; + END; + END; + END; + + IF PRNT > 0 THEN DO; + PUT SKIP EDIT('List of Primes up to ',NMAX) (A,F(8)); + PUT SKIP EDIT(' ',2) (A,F(7)); + NP = 1; + DO I=1 TO IMAX; + IF PRIME(I/1024,MOD(I,1024)) = '1' THEN DO; + PUT EDIT(' ',1+2*I) (A,F(7)); + NP = NP + 1; + IF NP = 10 THEN DO; + PUT SKIP; + NP = 0; + END; + END; + END; + IF NP > 0 THEN PUT SKIP; + END; + + IL = 4; + NL = 10; + NP = 1; + DO I=1 TO IMAX; + IF PRIME(I/1024,MOD(I,1024)) = '1' THEN NP = NP + 1; + IF I = IL THEN DO; + NL = 2*IL + 2; + PUT SKIP EDIT('pi(',NL,'): ',NP) (A,F(8),A,F(8)); + IL = 10*(IL+1)-1; + END; + END; + + IF NL < NMAX THEN PUT SKIP EDIT('pi(',NMAX,'): ',NP) + (A,F(8),A,F(8)); + + DONE:; + + END SOEP; +/* +//LKED.SYSLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.STEPLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEPSIMF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#SIM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC SIMCLG, +// PARM.SIM=NOSUBCHK, +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='LINECNT=64' +//SIM.SYSIN DD * +COMMENT +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end +* 2017-12-24 973 1.1 use WHILE not FOR to avoid compiler bug +* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +* 2017-09-17 951 1.0 Initial version +* 2017-09-08 949 0.1 First draft +* +* Note on SIMULA 67 (VERS 12.00) complier bug workaround +* - an inner loop codes as +* FOR i:= n2 // 2 STEP n UNTIL imax DO prime(i) := FALSE +* fails with 'FIXED POINT OVFL at line' of the FOR loop. +* - The equivalent WHILE loop used below works. +*; + +BEGIN + INTEGER nmax,prnt,imax,nmsqrt; + INTEGER i,n,imin; + INTEGER np,il,nl; + BOOLEAN ARRAY prime(1:5000000); + + nmax := InInt; + prnt := InInt; + + IF nmax < 10 OR nmax > 10000000 THEN BEGIN + OutText("nmax out of range (10...10000000), abort"); + GOTO done; + END; + + nmsqrt := Entier(Sqrt(nmax)); + imax := (nmax-1) // 2; + FOR i := 1 STEP 1 UNTIL imax DO prime(i) := TRUE; + + FOR n := 3 STEP 2 UNTIL nmsqrt DO BEGIN + IF prime(n//2) THEN BEGIN + i := (n*n) // 2; + WHILE i <= imax DO BEGIN + prime(i) := FALSE; + i:= i + n; + END; + END; + END; + + IF prnt > 0 THEN BEGIN + OutText("List of Primes up to "); + OutInt(nmax,8); + OutImage; + OutInt(2,8); + np := 1; + FOR i := 1 STEP 1 UNTIL imax DO BEGIN + IF prime(i) THEN BEGIN + OutInt(1+2*i,8); + np := np + 1; + IF np = 10 THEN BEGIN + OutImage; + np := 0; + END; + END; + END; + IF np > 0 THEN OutImage; + END; + + il := 4; + nl := 10; + np := 1; + + FOR i := 1 STEP 1 UNTIL imax DO BEGIN + IF prime(i) THEN np := np + 1; + IF i = il THEN BEGIN + nl := 2*il + 2; + OutText("pi("); + OutInt(nl,8); + OutText(")="); + OutInt(np,8); + OutImage; + il := 10*(il+1)-1; + END; + END; + + IF nl < nmax THEN BEGIN + OutText("pi("); + OutInt(nmax,8); + OutText(")="); + OutInt(np,8); + OutImage; + END; + + done: + OutImage; +END; +/* +//GO.SYSOUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 10000000 0 +/* +// +./ ADD NAME=SOEPSIMP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#SIM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC SIMCLG, +// PARM.SIM=NOSUBCHK, +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='LINECNT=64' +//SIM.SYSIN DD * +COMMENT +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end +* 2017-12-24 973 1.1 use WHILE not FOR to avoid compiler bug +* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +* 2017-09-17 951 1.0 Initial version +* 2017-09-08 949 0.1 First draft +* +* Note on SIMULA 67 (VERS 12.00) complier bug workaround +* - an inner loop codes as +* FOR i:= n2 // 2 STEP n UNTIL imax DO prime(i) := FALSE +* fails with 'FIXED POINT OVFL at line' of the FOR loop. +* - The equivalent WHILE loop used below works. +*; + +BEGIN + INTEGER nmax,prnt,imax,nmsqrt; + INTEGER i,n,imin; + INTEGER np,il,nl; + BOOLEAN ARRAY prime(1:5000000); + + nmax := InInt; + prnt := InInt; + + IF nmax < 10 OR nmax > 10000000 THEN BEGIN + OutText("nmax out of range (10...10000000), abort"); + GOTO done; + END; + + nmsqrt := Entier(Sqrt(nmax)); + imax := (nmax-1) // 2; + FOR i := 1 STEP 1 UNTIL imax DO prime(i) := TRUE; + + FOR n := 3 STEP 2 UNTIL nmsqrt DO BEGIN + IF prime(n//2) THEN BEGIN + i := (n*n) // 2; + WHILE i <= imax DO BEGIN + prime(i) := FALSE; + i:= i + n; + END; + END; + END; + + IF prnt > 0 THEN BEGIN + OutText("List of Primes up to "); + OutInt(nmax,8); + OutImage; + OutInt(2,8); + np := 1; + FOR i := 1 STEP 1 UNTIL imax DO BEGIN + IF prime(i) THEN BEGIN + OutInt(1+2*i,8); + np := np + 1; + IF np = 10 THEN BEGIN + OutImage; + np := 0; + END; + END; + END; + IF np > 0 THEN OutImage; + END; + + il := 4; + nl := 10; + np := 1; + + FOR i := 1 STEP 1 UNTIL imax DO BEGIN + IF prime(i) THEN np := np + 1; + IF i = il THEN BEGIN + nl := 2*il + 2; + OutText("pi("); + OutInt(nl,8); + OutText(")="); + OutInt(np,8); + OutImage; + il := 10*(il+1)-1; + END; + END; + + IF nl < nmax THEN BEGIN + OutText("pi("); + OutInt(nmax,8); + OutText(")="); + OutInt(np,8); + OutImage; + END; + + done: + OutImage; +END; +/* +//GO.SYSOUT DD SYSOUT=*,OUTLIM=100000 +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEPSIMT,LEVEL=00,SOURCE=0,LIST=ALL +//SOEP#SIM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC SIMCLG, +// PARM.SIM='', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='LINECNT=64' +//SIM.SYSIN DD * +COMMENT +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end +* 2017-12-24 973 1.1 use WHILE not FOR to avoid compiler bug +* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +* 2017-09-17 951 1.0 Initial version +* 2017-09-08 949 0.1 First draft +* +* Note on SIMULA 67 (VERS 12.00) complier bug workaround +* - an inner loop codes as +* FOR i:= n2 // 2 STEP n UNTIL imax DO prime(i) := FALSE +* fails with 'FIXED POINT OVFL at line' of the FOR loop. +* - The equivalent WHILE loop used below works. +*; + +BEGIN + INTEGER nmax,prnt,imax,nmsqrt; + INTEGER i,n,imin; + INTEGER np,il,nl; + BOOLEAN ARRAY prime(1:5000000); + + nmax := InInt; + prnt := InInt; + + IF nmax < 10 OR nmax > 10000000 THEN BEGIN + OutText("nmax out of range (10...10000000), abort"); + GOTO done; + END; + + nmsqrt := Entier(Sqrt(nmax)); + imax := (nmax-1) // 2; + FOR i := 1 STEP 1 UNTIL imax DO prime(i) := TRUE; + + FOR n := 3 STEP 2 UNTIL nmsqrt DO BEGIN + IF prime(n//2) THEN BEGIN + i := (n*n) // 2; + WHILE i <= imax DO BEGIN + prime(i) := FALSE; + i:= i + n; + END; + END; + END; + + IF prnt > 0 THEN BEGIN + OutText("List of Primes up to "); + OutInt(nmax,8); + OutImage; + OutInt(2,8); + np := 1; + FOR i := 1 STEP 1 UNTIL imax DO BEGIN + IF prime(i) THEN BEGIN + OutInt(1+2*i,8); + np := np + 1; + IF np = 10 THEN BEGIN + OutImage; + np := 0; + END; + END; + END; + IF np > 0 THEN OutImage; + END; + + il := 4; + nl := 10; + np := 1; + + FOR i := 1 STEP 1 UNTIL imax DO BEGIN + IF prime(i) THEN np := np + 1; + IF i = il THEN BEGIN + nl := 2*il + 2; + OutText("pi("); + OutInt(nl,8); + OutText(")="); + OutInt(np,8); + OutImage; + il := 10*(il+1)-1; + END; + END; + + IF nl < nmax THEN BEGIN + OutText("pi("); + OutInt(nmax,8); + OutText(")="); + OutInt(np,8); + OutImage; + END; + + done: + OutImage; +END; +/* +//GO.SYSOUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEQASMF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#ASM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6500K,TIME=(1,0),PRTY=8 +//CLG EXEC ASMFCLG, +// MAC1='SYS2.MACLIB', +// PARM.ASM='NOLIST,NOXREF,NORLD,NODECK,LOAD', +// PARM.LKED='MAP,LIST,LET,NCAL', +// COND.LKED=(8,LE,ASM), +// PARM.GO='', +// COND.GO=((8,LE,ASM),(4,LT,LKED)) +//ASM.SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(600,100)) +//ASM.SYSUT2 DD DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSUT3 DD DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSGO DD DSN=&&OBJSET,UNIT=SYSDA,SPACE=(80,(2000,500)) +//ASM.SYSIN DD * +* 1 2 3 4 5 6 71 +*23456789*12345*789012345678901234*678901234567890123456789012345678901 +* $Id: soeq_asm.asm 972 2017-12-23 20:55:41Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software; you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +* 2017-11-19 965 1.1 no XR in inner loop, bit reversed prime[] +* 2017-11-18 963 1.0 Initial version +* + PRINT NOGEN don't show macro expansions +* +* Prime number search +* RC = 0 ok +* RC = 4 open SYSPRINT failed +* RC = 8 open SYSIN failed +* RC = 12 unexpected SYSIN EOF +* RC = 16 NMAX out of range +* +* local macros -------------------------------------------------------- +* +* +* OTXTDSC - setup text descriptor for simple output system - +* + MACRO +&LABEL OTXTDSC &TEXT +TEXT CSECT +SPTR&SYSNDX DC &TEXT +&SYSECT CSECT + DS 0F +&LABEL DC AL1(L'SPTR&SYSNDX),AL3(SPTR&SYSNDX) + MEND +* +* main preamble ------------------------------------------------------- +* +MAIN START 0 start main code csect at base 0 + SAVE (14,12) Save input registers + LR R12,R15 base register := entry address + USING MAIN,R12 declare base register + ST R13,SAVE+4 set back pointer in current save area + LR R2,R13 remember callers save area + LA R13,SAVE setup current save area + ST R13,8(R2) set forw pointer in callers save area +* +* open datasets ------------------------------------------------------- +* + OPEN (SYSPRINT,OUTPUT) open SYSPRINT + LTR R15,R15 test return code + BE OOPENOK + MVI RC+3,X'04' + B EXIT quit with RC=4 +OOPENOK OPEN (SYSIN,INPUT) open SYSIN + LTR R15,R15 test return code + BE IOPENOK + MVI RC+3,X'08' + B EXIT quit with RC=8 +IOPENOK EQU * +* +* read input parameters, and check range ------------------------------ +* + BAL R14,IGETLINE read input line + BAL R14,IINT10 get NMAX + ST R1,NMAX + BAL R14,IINT10 get PRNT + STC R1,PRNT +* + L R1,NMAX + C R1,=F'10' is NMAX >= 10 + BL NMAXBAD if < not + C R1,=F'100000000' is NMAX <= 100000000 + BNH NMAXOK if <= yes +NMAXBAD L R1,MSGPERR + BAL R14,OTEXT print error + BAL R14,OPUTLINE write line + MVI RC+3,X'10' + B EXIT quit with RC=16 +NMAXOK EQU * +* +* setup phase --------------------------------------------------------- +* +* calculate sqrt(nmax) ----------------------------------- +* use simple bi-section method +* R4 low bound +* R5 high bound +* R7 middle (low+high)/2 +* + LA R4,1 set low bound + L R5,NMAX set high bound + LA R6,32 set iteration limit +NMSQRTLP LR R7,R4 R7:= low + AR R7,R5 R7:= (low+high) + SRA R7,1 R7:= (low+high)/2 + LR R3,R7 + MR R2,R7 (R2,R3) := R7*R7 + LTR R2,R2 more than 32 bit ? + BNE NMSQRTHI if != yes, mid too high + CL R3,NMAX mid*mid > NMAX + BH NMSQRTHI if > yes, mid too high + LR R4,R7 here mid to low: low := mid + B NMSQRTGO +NMSQRTHI LR R5,R7 here mid to high: high := mid +NMSQRTGO LR R8,R5 R8 := high + SR R8,R4 R8 := high-low + LR R1,R6 + C R8,=F'1' spread <= 1 ? + BNH NMSQRTOK if <= yes, quit + BCT R6,NMSQRTLP + ABEND 99 abort if doesn't converge +NMSQRTOK EQU * + ST R4,NMSQRT + +* allocate PRIME array ----------------------------------- + L R2,NMAX + BCTR R2,0 NMAX-1 + SRA R2,1 (NMAX-1)/2 + ST R2,BIMAX + A R2,=F'7' BIMAX+7 + SRA R2,3 (BIMAX+7)/8 + ST R2,WIMAX + LR R5,R2 + A R5,=F'1' WIMAX+1 + GETMAIN RU,LV=(5) allocate storage for PRIME + ST R1,PRIME store sieve base + LR R9,R1 R9 := PRIME base +* +* set each PRIME array byte to X'01' --------------------- + LR R4,R1 R4 := PRIME +* R5 := sizeof(PRIME) (still) + XR R6,R6 R6 := 0 + L R7,=X'FF000000' R7 := padding=0xFF and length=0 + MVCL R4,R6 set all PRIME words to 0xFFFF +* +* sieve phase --------------------------------------------------------- +* outer loop: ind R6 n +* inc R4 2 +* lim R5 sqrt(NMAX) +* inner loop: ind R3 i +* inc R6 n +* lim R7 bimax +* R9 &prime +* R8 0x80 +* R10 0x07 +* R11 0xFF7F +* R0,R1,R2,R15 temporaries +* +* +* equivalent C code: +* for (n=3; n<=nmsqrt; n+=2) { +* i = n/2; +* if ((prime[i>>3] & (0x80>>(i&0x7))) == 0) continue; +* for (i=(n*n)/2; i<=bimax ; i+=n) { +* prime[i>>3] &= (0xff7f>>(i&0x7); '!!pseudo code !!' +* } +* } +* + LA R6,3 outer ind: R6:=3 + LA R4,2 outer inc: R4:=2 + L R5,NMSQRT outer lim: R5:=NMSQRT + L R7,BIMAX inner lim: R7:=BIMAX + LA R8,X'80' R8:=0x80 + LA R10,X'07' R10:=0x07 + L R11,=X'FFFFFF7F' R11:=0xffffff7f +* +SIEVO LR R2,R6 R2:=n + SRA R2,1 R2:=n/2 + LR R15,R2 i + NR R15,R10 i&0x07 + LR R1,R8 0x80 + SRL R1,0(R15) 0x80>>(i&0x7) + SRL R2,3 i>>3 + IC R2,0(R2,R9) prime[i>>3] + NR R2,R1 prime[i>>3] & (0x80>>(i&0x7)) + BZ SIEVOC if =0 not, continue outer loop +* + LR R1,R6 R1:=n + MR R0,R6 R1:=n*n (lower half, enough) + LR R3,R1 R3:=n*n too + SRA R3,1 R3:=(n*n)/2 +* +SIEVI LR R2,R3 i + NR R2,R10 i&0x7 + LR R1,R11 0xff7f + SRL R1,0(R2) 0xff7f>>(i&0x7) + LR R2,R3 i + SRL R2,3 i>>3 + IC R0,0(R2,R9) prime[i>>3] + NR R0,R1 & 0xff7f>>(i&0x7) + STC R0,0(R2,R9) prime[i>>3] &= 0xff7f>>(i&0x7) + BXLE R3,R6,SIEVI +* +SIEVOC BXLE R6,R4,SIEVO +* +* print primes table -------------------------------------------------- +* loop: ind R3 i +* inc R4 1 +* lim R5 imax +* R2 np +* R9 &prime +* R8 0x80 +* R10 0x07 +* R11 1 +PRT EQU * + CLI PRNT,X'00' primes to be printed ? + BE NOPRNT if = skip + L R1,MSGLIST + BAL R14,OTEXT print heading + L R1,NMAX + BAL R14,OINT10 print nmax + BAL R14,OPUTLINE write line +* + LA R1,2 + BAL R14,OINT10 print "2" (1st prime...) + LA R2,1 np=1 + LA R3,1 ind: R3:=1 + LA R4,1 inc: R4:=1 + L R5,BIMAX lim: R5:=BIMAX + LA R8,X'80' R8:=0x80 + LA R10,X'07' R10:=0x07 + LA R11,1 R11:=1 +PRTLOOP LR R6,R3 i + NR R6,R10 i&0x7 + LR R1,R8 0x80 + SRL R1,0(R6) 0x80>>(i&0x7) + LR R6,R3 i + SRL R6,3 i>>3 + IC R0,0(R6,R9) prime[i>>3] + NR R0,R1 prime[i>>3] & (0x80>>(i&0x7)) + BE PRTLOOPC if = not, continue + LR R1,R3 R1:=i + SLA R1,1 R1:=2*i + AR R1,R11 R1:=1+2*i + BAL R14,OINT10 and print F(10) + AR R2,R11 np+=1 + C R2,=F'10' check whether = 10 + BNZ PRTLOOPC if != not, continue + BAL R14,OPUTLINE write line + XR R2,R2 np=0 +PRTLOOPC EQU * + BXLE R3,R4,PRTLOOP +* + LTR R2,R2 check prime count np + BZ NOPRNT + BAL R14,OPUTLINE write line +NOPRNT EQU * +* +* print primes count -------------------------------------------------- +* loop: ind R3 i +* inc R4 1 +* lim R5 imax +* R2 np +* R7 il +* R6 nl +* R9 &prime +* R8 0x80 +* R10 0x07 +* R11 1 +* +TBL EQU * + LA R2,1 np=1 + LA R7,4 il=4 + LA R6,10 nl=10 + LA R3,1 ind: R3:=1 + LA R4,1 inc: R4:=1 + L R5,BIMAX lim: R5:=BIMAX + LA R8,X'80' R8:=0x80 + LA R10,X'07' R10:=0x07 + LA R11,1 R11:=1 +TBLLOOP LR R15,R3 i + NR R15,R10 i&0x7 + LR R1,R8 0x80 + SRL R1,0(R15) 0x80>>(i&0x7) + LR R15,R3 i + SRL R15,3 i>>3 + IC R0,0(R15,R9) prime[i>>3] + NR R0,R1 prime[i>>3] & (1<<(i&0x7)) + BE NOPRIME if = not + AR R2,R11 np+= 1 +NOPRIME CR R3,R7 test i != il + BNE TBLLOOPC + LR R6,R7 nl=il + SLA R6,1 nl=2*il + A R6,=F'2' nl=2+2*il +* + L R1,MSGPI + BAL R14,OTEXT print "pi(...." + LR R1,R6 + BAL R14,OINT10 print nl + L R1,MSGPISEP + BAL R14,OTEXT print "):..." + LR R1,R2 + BAL R14,OINT10 print np + BAL R14,OPUTLINE write line +* + LR R1,R7 R1:=il + AR R1,R11 R1:=il+1 + M R0,=F'10' R1:=10*(il+1) + SR R1,R11 R1:=10*(il+1)-1 + LR R7,R1 update il +* +TBLLOOPC EQU * + BXLE R3,R4,TBLLOOP +* + C R6,NMAX is nl != nmax ? + BE TBLNOTR if = not, skip extra summary +* + L R1,MSGPI + BAL R14,OTEXT print "pi(...." + L R1,NMAX + BAL R14,OINT10 print nmax + L R1,MSGPISEP + BAL R14,OTEXT print "):..." + LR R1,R2 + BAL R14,OINT10 print np + BAL R14,OPUTLINE write line +* +TBLNOTR EQU * +* +* close datasets and return to OS ------------------------------------- +* +EXIT CLOSE SYSPRINT close SYSPRINT + CLOSE SYSIN close SYSIN + L R13,SAVE+4 get old save area back + L R0,RC get return code + ST R0,16(R13) store in old save R15 + RETURN (14,12) return to OS (will setup RC) +* +* include simple output system ---------------------------------------- +* +* simple output system procedures ------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* OSKIP02 -------------------------------------------------- +* add 2 blanks +* +OSKIP02 LA R1,2 +* +* OSKIP ---------------------------------------------------- +* add blanks, count in R1 +* +OSKIP A R1,OLPTR new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OTAB ---------------------------------------------------- +* set output column, position in R1 +* +OTAB A R1,=A(OLBUF+1) new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OSFILL --------------------------------------------------- +* add " ***" pattern, total length in R1 +* +OSFILL L R15,OLPTR R15 points to edit position + MVI 0(R15),C' ' initial blank + B OSFILLN +OSFILLL MVI 0(R15),C'*' further '*' +OSFILLN LA R15,1(R15) + BCT R1,OSFILLL + ST R15,OLPTR store pointer + BR R14 +* +* OTEXT ---------------------------------------------------- +* print text, R1 hold descriptor address +* descriptor format +* DC AL1() +* DC AL2(
) +* +OTEXT ST R14,OTEXTL save R14 + LR R14,R1 + SRL R14,24 R14 now string length + L R15,OLPTR R15 points to edit position + LR R0,R15 R0 too + AR R0,R14 push pointer, add length + ST R0,OLPTR store pointer + BCTR R14,0 decrement length for EX + EX R14,OTEXTMVC copy string via EX:MVC + L R14,OTEXTL restore R14 linkage + BR R14 +* +OTEXTMVC MVC 0(1,R15),0(R1) length via EX, dst R15, src R1 +OTEXTL DS F save area for R14 (return linkage) +* +* OPUTLINE ------------------------------------------------- +* write line to SYSPRINT +* +OPUTLINE ST R14,OPUTLNEL save R14 + L R15,=A(OLBUF) + CLI 133(R15),X'00' check fence byte + BNE OPUTLNEA crash if fence blown + L R1,=A(SYSPRINT) R1 point to DCB + LR R0,R15 R1 point to buffer + PUT (1),(0) write line + L R15,=A(OLBUF) point to CC of OLBUF + MVI 0(R15),C' ' blank OLBUF(0) + MVC 1(L'OLBUF-1,R15),0(R15) propagate blank + LA R15,1(R15) point to 1st print char in OLBUF + ST R15,OLPTR reset current position pointer + LA R15,1 + AH R15,OLCNT increment line counter + STH R15,OLCNT + SH R15,OLMAX R15 := OLCNT-OLMAX + BL OPUTLNES if < no new page + XR R15,R15 R15 := 0 + SH R15,OLCNT clear line counter + L R15,=A(OLBUF) point to CC of OLBUF +* MVI 0(R15),C'1' set new page CC in OLBUF +OPUTLNES L R14,OPUTLNEL restore R14 linkage + BR R14 +* +OPUTLNEA ABEND 255 abend in case of errors +* +OPUTLNEL DS F save area for R14 (return linkage) +* +* Work area for simple output system ------------------------ +* +OLPTR DC A(OLBUF+1) current output line position +OLCNT DC H'0' line counter +OLMAX DC H'60' lines per page +OCVD DS D buffer for CVD (8 byte, DW aligned) +* +ODTEMP DS D double buffer for conversions +ODNZERO DC X'4E000000',X'00000000' denormalized double zero +ODNONE DC X'4E000000',X'00000001' denormalized double one +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSPRINT DCB DSORG=PS,MACRF=PM,DDNAME=SYSPRINT, X + RECFM=FBA,LRECL=133,BLKSIZE=0 +OLBUF DC CL133' ',X'00' output line buffer and fence byte +* +MAIN CSECT +* +* OINT10 --------------------------------------------------- +* print integer, like PL/I F(10) or C %10d format +* very fast, for non-negative numbers only ! +* +OINT10 CL R1,=F'999999999' too large ? + BH OINT10F if > yes, do OSFILL + CVD R1,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEI10L,R15),OEI10 setup pattern + ED 0(OEI10L,R15),OCVD+3 and edit + LA R15,OEI10L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OINT10F LA R1,10 + B OSFILL +* +OEI10 DC C' ',7X'20',X'21',X'20' pat: bddddddd(d +OEI10L EQU *-OEI10 +* include simple input system ----------------------------------------- +* +* simple input system procedures -------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* IGETLINE ------------------------------------------------- +* read line from SYSIN +* EOF handling: +* - IEOFOK holds the 'EOF OK' flag +* - if EOF seen and IEOFOK = X'00', program ends with RC=8 +* - if EOF seen and IEOFOK != X'00', program ends with RC=0 +* +IGETLINE ST R14,IGETLNEL save R14 + L R1,=A(SYSIN) + L R0,=A(ILBUF) + GET (1),(0) read line + L R0,=A(ILBUF) + ST R0,ILPTR set input ptr to begin of line + L R14,IGETLNEL restore R14 linkage + BR R14 +* +IGETLNEL DS F save area for R14 (return linkage) +* +* IEOFHDL -------------------------------------------------- +* +IEOFHDL BALR R12,R0 where are we ? + LA R15,*-MAIN offset from MAIN to here + SR R12,R15 base reg now points to MAIN + LA R14,EXIT + CLI IEOFOK,X'00' is EOF ok ? + BNER R14 if != yes, jump to EXIT + MVI RC+3,X'08' otherwise set RC=8 + BR R14 and jump to EXIT +* +* Work area for simple output system ------------------------ +* +ILPTR DC A(ILBUF) current input line position +IEOFOK DS X'00' EOF ok flag +ICVB DS D buffer for CVB (8 byte, DW aligned) +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSIN DCB DSORG=PS,MACRF=GM,DDNAME=SYSIN,EODAD=IEOFHDL X + RECFM=FB,LRECL=80,BLKSIZE=0 +ILBUF DC CL80' ' input line buffer +MAIN CSECT +* +* IINT10 --------------------------------------------------- +* read integer, like PL/I F(10) or C %10d format +* +IINT10 L R15,ILPTR get input pointer + PACK ICVB(8),0(10,R15) pack next 10 char + CVB R1,ICVB and convert + LA R15,10(R15) push pointer by 10 char + ST R15,ILPTR and update + BR R14 +* +* Work area definitions ----------------------------------------------- +* +SAVE DS 18F local save area +RC DC F'0' return code +NMAX DC F'10000000' highest prime to search for +NMSQRT DS F sqrt(NMAX) +BIMAX DS F highest prime array bit index +WIMAX DS F highest prime array word index +PRIME DS F prime array pointer +PRNT DC X'00' print enable flag +* +* message strings +* +MSGPERR OTXTDSC C'NMAX must be >= 10 and <= 100000000, abort' +MSGLIST OTXTDSC C'List of Primes up to ' +MSGPI OTXTDSC C'pi(' +MSGPISEP OTXTDSC C'): ' +* +* spill literal pool +* + LTORG +* +* other defs and end +* + YREGS , + END MAIN define main entry point +/* +//GO.SYSUDUMP DD SYSOUT=*,OUTLIM=2000 +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +100000000 0 +/* +// +./ ADD NAME=SOEQASMP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#ASM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=650K,TIME=(1,0),PRTY=8 +//CLG EXEC ASMFCLG, +// MAC1='SYS2.MACLIB', +// PARM.ASM='NOLIST,NOXREF,NORLD,NODECK,LOAD', +// PARM.LKED='MAP,LIST,LET,NCAL', +// COND.LKED=(8,LE,ASM), +// PARM.GO='', +// COND.GO=((8,LE,ASM),(4,LT,LKED)) +//ASM.SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(600,100)) +//ASM.SYSUT2 DD DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSUT3 DD DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSGO DD DSN=&&OBJSET,UNIT=SYSDA,SPACE=(80,(2000,500)) +//ASM.SYSIN DD * +* 1 2 3 4 5 6 71 +*23456789*12345*789012345678901234*678901234567890123456789012345678901 +* $Id: soeq_asm.asm 972 2017-12-23 20:55:41Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software; you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +* 2017-11-19 965 1.1 no XR in inner loop, bit reversed prime[] +* 2017-11-18 963 1.0 Initial version +* + PRINT NOGEN don't show macro expansions +* +* Prime number search +* RC = 0 ok +* RC = 4 open SYSPRINT failed +* RC = 8 open SYSIN failed +* RC = 12 unexpected SYSIN EOF +* RC = 16 NMAX out of range +* +* local macros -------------------------------------------------------- +* +* +* OTXTDSC - setup text descriptor for simple output system - +* + MACRO +&LABEL OTXTDSC &TEXT +TEXT CSECT +SPTR&SYSNDX DC &TEXT +&SYSECT CSECT + DS 0F +&LABEL DC AL1(L'SPTR&SYSNDX),AL3(SPTR&SYSNDX) + MEND +* +* main preamble ------------------------------------------------------- +* +MAIN START 0 start main code csect at base 0 + SAVE (14,12) Save input registers + LR R12,R15 base register := entry address + USING MAIN,R12 declare base register + ST R13,SAVE+4 set back pointer in current save area + LR R2,R13 remember callers save area + LA R13,SAVE setup current save area + ST R13,8(R2) set forw pointer in callers save area +* +* open datasets ------------------------------------------------------- +* + OPEN (SYSPRINT,OUTPUT) open SYSPRINT + LTR R15,R15 test return code + BE OOPENOK + MVI RC+3,X'04' + B EXIT quit with RC=4 +OOPENOK OPEN (SYSIN,INPUT) open SYSIN + LTR R15,R15 test return code + BE IOPENOK + MVI RC+3,X'08' + B EXIT quit with RC=8 +IOPENOK EQU * +* +* read input parameters, and check range ------------------------------ +* + BAL R14,IGETLINE read input line + BAL R14,IINT10 get NMAX + ST R1,NMAX + BAL R14,IINT10 get PRNT + STC R1,PRNT +* + L R1,NMAX + C R1,=F'10' is NMAX >= 10 + BL NMAXBAD if < not + C R1,=F'100000000' is NMAX <= 100000000 + BNH NMAXOK if <= yes +NMAXBAD L R1,MSGPERR + BAL R14,OTEXT print error + BAL R14,OPUTLINE write line + MVI RC+3,X'10' + B EXIT quit with RC=16 +NMAXOK EQU * +* +* setup phase --------------------------------------------------------- +* +* calculate sqrt(nmax) ----------------------------------- +* use simple bi-section method +* R4 low bound +* R5 high bound +* R7 middle (low+high)/2 +* + LA R4,1 set low bound + L R5,NMAX set high bound + LA R6,32 set iteration limit +NMSQRTLP LR R7,R4 R7:= low + AR R7,R5 R7:= (low+high) + SRA R7,1 R7:= (low+high)/2 + LR R3,R7 + MR R2,R7 (R2,R3) := R7*R7 + LTR R2,R2 more than 32 bit ? + BNE NMSQRTHI if != yes, mid too high + CL R3,NMAX mid*mid > NMAX + BH NMSQRTHI if > yes, mid too high + LR R4,R7 here mid to low: low := mid + B NMSQRTGO +NMSQRTHI LR R5,R7 here mid to high: high := mid +NMSQRTGO LR R8,R5 R8 := high + SR R8,R4 R8 := high-low + LR R1,R6 + C R8,=F'1' spread <= 1 ? + BNH NMSQRTOK if <= yes, quit + BCT R6,NMSQRTLP + ABEND 99 abort if doesn't converge +NMSQRTOK EQU * + ST R4,NMSQRT + +* allocate PRIME array ----------------------------------- + L R2,NMAX + BCTR R2,0 NMAX-1 + SRA R2,1 (NMAX-1)/2 + ST R2,BIMAX + A R2,=F'7' BIMAX+7 + SRA R2,3 (BIMAX+7)/8 + ST R2,WIMAX + LR R5,R2 + A R5,=F'1' WIMAX+1 + GETMAIN RU,LV=(5) allocate storage for PRIME + ST R1,PRIME store sieve base + LR R9,R1 R9 := PRIME base +* +* set each PRIME array byte to X'01' --------------------- + LR R4,R1 R4 := PRIME +* R5 := sizeof(PRIME) (still) + XR R6,R6 R6 := 0 + L R7,=X'FF000000' R7 := padding=0xFF and length=0 + MVCL R4,R6 set all PRIME words to 0xFFFF +* +* sieve phase --------------------------------------------------------- +* outer loop: ind R6 n +* inc R4 2 +* lim R5 sqrt(NMAX) +* inner loop: ind R3 i +* inc R6 n +* lim R7 bimax +* R9 &prime +* R8 0x80 +* R10 0x07 +* R11 0xFF7F +* R0,R1,R2,R15 temporaries +* +* +* equivalent C code: +* for (n=3; n<=nmsqrt; n+=2) { +* i = n/2; +* if ((prime[i>>3] & (0x80>>(i&0x7))) == 0) continue; +* for (i=(n*n)/2; i<=bimax ; i+=n) { +* prime[i>>3] &= (0xff7f>>(i&0x7); '!!pseudo code !!' +* } +* } +* + LA R6,3 outer ind: R6:=3 + LA R4,2 outer inc: R4:=2 + L R5,NMSQRT outer lim: R5:=NMSQRT + L R7,BIMAX inner lim: R7:=BIMAX + LA R8,X'80' R8:=0x80 + LA R10,X'07' R10:=0x07 + L R11,=X'FFFFFF7F' R11:=0xffffff7f +* +SIEVO LR R2,R6 R2:=n + SRA R2,1 R2:=n/2 + LR R15,R2 i + NR R15,R10 i&0x07 + LR R1,R8 0x80 + SRL R1,0(R15) 0x80>>(i&0x7) + SRL R2,3 i>>3 + IC R2,0(R2,R9) prime[i>>3] + NR R2,R1 prime[i>>3] & (0x80>>(i&0x7)) + BZ SIEVOC if =0 not, continue outer loop +* + LR R1,R6 R1:=n + MR R0,R6 R1:=n*n (lower half, enough) + LR R3,R1 R3:=n*n too + SRA R3,1 R3:=(n*n)/2 +* +SIEVI LR R2,R3 i + NR R2,R10 i&0x7 + LR R1,R11 0xff7f + SRL R1,0(R2) 0xff7f>>(i&0x7) + LR R2,R3 i + SRL R2,3 i>>3 + IC R0,0(R2,R9) prime[i>>3] + NR R0,R1 & 0xff7f>>(i&0x7) + STC R0,0(R2,R9) prime[i>>3] &= 0xff7f>>(i&0x7) + BXLE R3,R6,SIEVI +* +SIEVOC BXLE R6,R4,SIEVO +* +* print primes table -------------------------------------------------- +* loop: ind R3 i +* inc R4 1 +* lim R5 imax +* R2 np +* R9 &prime +* R8 0x80 +* R10 0x07 +* R11 1 +PRT EQU * + CLI PRNT,X'00' primes to be printed ? + BE NOPRNT if = skip + L R1,MSGLIST + BAL R14,OTEXT print heading + L R1,NMAX + BAL R14,OINT10 print nmax + BAL R14,OPUTLINE write line +* + LA R1,2 + BAL R14,OINT10 print "2" (1st prime...) + LA R2,1 np=1 + LA R3,1 ind: R3:=1 + LA R4,1 inc: R4:=1 + L R5,BIMAX lim: R5:=BIMAX + LA R8,X'80' R8:=0x80 + LA R10,X'07' R10:=0x07 + LA R11,1 R11:=1 +PRTLOOP LR R6,R3 i + NR R6,R10 i&0x7 + LR R1,R8 0x80 + SRL R1,0(R6) 0x80>>(i&0x7) + LR R6,R3 i + SRL R6,3 i>>3 + IC R0,0(R6,R9) prime[i>>3] + NR R0,R1 prime[i>>3] & (0x80>>(i&0x7)) + BE PRTLOOPC if = not, continue + LR R1,R3 R1:=i + SLA R1,1 R1:=2*i + AR R1,R11 R1:=1+2*i + BAL R14,OINT10 and print F(10) + AR R2,R11 np+=1 + C R2,=F'10' check whether = 10 + BNZ PRTLOOPC if != not, continue + BAL R14,OPUTLINE write line + XR R2,R2 np=0 +PRTLOOPC EQU * + BXLE R3,R4,PRTLOOP +* + LTR R2,R2 check prime count np + BZ NOPRNT + BAL R14,OPUTLINE write line +NOPRNT EQU * +* +* print primes count -------------------------------------------------- +* loop: ind R3 i +* inc R4 1 +* lim R5 imax +* R2 np +* R7 il +* R6 nl +* R9 &prime +* R8 0x80 +* R10 0x07 +* R11 1 +* +TBL EQU * + LA R2,1 np=1 + LA R7,4 il=4 + LA R6,10 nl=10 + LA R3,1 ind: R3:=1 + LA R4,1 inc: R4:=1 + L R5,BIMAX lim: R5:=BIMAX + LA R8,X'80' R8:=0x80 + LA R10,X'07' R10:=0x07 + LA R11,1 R11:=1 +TBLLOOP LR R15,R3 i + NR R15,R10 i&0x7 + LR R1,R8 0x80 + SRL R1,0(R15) 0x80>>(i&0x7) + LR R15,R3 i + SRL R15,3 i>>3 + IC R0,0(R15,R9) prime[i>>3] + NR R0,R1 prime[i>>3] & (1<<(i&0x7)) + BE NOPRIME if = not + AR R2,R11 np+= 1 +NOPRIME CR R3,R7 test i != il + BNE TBLLOOPC + LR R6,R7 nl=il + SLA R6,1 nl=2*il + A R6,=F'2' nl=2+2*il +* + L R1,MSGPI + BAL R14,OTEXT print "pi(...." + LR R1,R6 + BAL R14,OINT10 print nl + L R1,MSGPISEP + BAL R14,OTEXT print "):..." + LR R1,R2 + BAL R14,OINT10 print np + BAL R14,OPUTLINE write line +* + LR R1,R7 R1:=il + AR R1,R11 R1:=il+1 + M R0,=F'10' R1:=10*(il+1) + SR R1,R11 R1:=10*(il+1)-1 + LR R7,R1 update il +* +TBLLOOPC EQU * + BXLE R3,R4,TBLLOOP +* + C R6,NMAX is nl != nmax ? + BE TBLNOTR if = not, skip extra summary +* + L R1,MSGPI + BAL R14,OTEXT print "pi(...." + L R1,NMAX + BAL R14,OINT10 print nmax + L R1,MSGPISEP + BAL R14,OTEXT print "):..." + LR R1,R2 + BAL R14,OINT10 print np + BAL R14,OPUTLINE write line +* +TBLNOTR EQU * +* +* close datasets and return to OS ------------------------------------- +* +EXIT CLOSE SYSPRINT close SYSPRINT + CLOSE SYSIN close SYSIN + L R13,SAVE+4 get old save area back + L R0,RC get return code + ST R0,16(R13) store in old save R15 + RETURN (14,12) return to OS (will setup RC) +* +* include simple output system ---------------------------------------- +* +* simple output system procedures ------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* OSKIP02 -------------------------------------------------- +* add 2 blanks +* +OSKIP02 LA R1,2 +* +* OSKIP ---------------------------------------------------- +* add blanks, count in R1 +* +OSKIP A R1,OLPTR new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OTAB ---------------------------------------------------- +* set output column, position in R1 +* +OTAB A R1,=A(OLBUF+1) new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OSFILL --------------------------------------------------- +* add " ***" pattern, total length in R1 +* +OSFILL L R15,OLPTR R15 points to edit position + MVI 0(R15),C' ' initial blank + B OSFILLN +OSFILLL MVI 0(R15),C'*' further '*' +OSFILLN LA R15,1(R15) + BCT R1,OSFILLL + ST R15,OLPTR store pointer + BR R14 +* +* OTEXT ---------------------------------------------------- +* print text, R1 hold descriptor address +* descriptor format +* DC AL1() +* DC AL2(
) +* +OTEXT ST R14,OTEXTL save R14 + LR R14,R1 + SRL R14,24 R14 now string length + L R15,OLPTR R15 points to edit position + LR R0,R15 R0 too + AR R0,R14 push pointer, add length + ST R0,OLPTR store pointer + BCTR R14,0 decrement length for EX + EX R14,OTEXTMVC copy string via EX:MVC + L R14,OTEXTL restore R14 linkage + BR R14 +* +OTEXTMVC MVC 0(1,R15),0(R1) length via EX, dst R15, src R1 +OTEXTL DS F save area for R14 (return linkage) +* +* OPUTLINE ------------------------------------------------- +* write line to SYSPRINT +* +OPUTLINE ST R14,OPUTLNEL save R14 + L R15,=A(OLBUF) + CLI 133(R15),X'00' check fence byte + BNE OPUTLNEA crash if fence blown + L R1,=A(SYSPRINT) R1 point to DCB + LR R0,R15 R1 point to buffer + PUT (1),(0) write line + L R15,=A(OLBUF) point to CC of OLBUF + MVI 0(R15),C' ' blank OLBUF(0) + MVC 1(L'OLBUF-1,R15),0(R15) propagate blank + LA R15,1(R15) point to 1st print char in OLBUF + ST R15,OLPTR reset current position pointer + LA R15,1 + AH R15,OLCNT increment line counter + STH R15,OLCNT + SH R15,OLMAX R15 := OLCNT-OLMAX + BL OPUTLNES if < no new page + XR R15,R15 R15 := 0 + SH R15,OLCNT clear line counter + L R15,=A(OLBUF) point to CC of OLBUF +* MVI 0(R15),C'1' set new page CC in OLBUF +OPUTLNES L R14,OPUTLNEL restore R14 linkage + BR R14 +* +OPUTLNEA ABEND 255 abend in case of errors +* +OPUTLNEL DS F save area for R14 (return linkage) +* +* Work area for simple output system ------------------------ +* +OLPTR DC A(OLBUF+1) current output line position +OLCNT DC H'0' line counter +OLMAX DC H'60' lines per page +OCVD DS D buffer for CVD (8 byte, DW aligned) +* +ODTEMP DS D double buffer for conversions +ODNZERO DC X'4E000000',X'00000000' denormalized double zero +ODNONE DC X'4E000000',X'00000001' denormalized double one +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSPRINT DCB DSORG=PS,MACRF=PM,DDNAME=SYSPRINT, X + RECFM=FBA,LRECL=133,BLKSIZE=0 +OLBUF DC CL133' ',X'00' output line buffer and fence byte +* +MAIN CSECT +* +* OINT10 --------------------------------------------------- +* print integer, like PL/I F(10) or C %10d format +* very fast, for non-negative numbers only ! +* +OINT10 CL R1,=F'999999999' too large ? + BH OINT10F if > yes, do OSFILL + CVD R1,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEI10L,R15),OEI10 setup pattern + ED 0(OEI10L,R15),OCVD+3 and edit + LA R15,OEI10L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OINT10F LA R1,10 + B OSFILL +* +OEI10 DC C' ',7X'20',X'21',X'20' pat: bddddddd(d +OEI10L EQU *-OEI10 +* include simple input system ----------------------------------------- +* +* simple input system procedures -------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* IGETLINE ------------------------------------------------- +* read line from SYSIN +* EOF handling: +* - IEOFOK holds the 'EOF OK' flag +* - if EOF seen and IEOFOK = X'00', program ends with RC=8 +* - if EOF seen and IEOFOK != X'00', program ends with RC=0 +* +IGETLINE ST R14,IGETLNEL save R14 + L R1,=A(SYSIN) + L R0,=A(ILBUF) + GET (1),(0) read line + L R0,=A(ILBUF) + ST R0,ILPTR set input ptr to begin of line + L R14,IGETLNEL restore R14 linkage + BR R14 +* +IGETLNEL DS F save area for R14 (return linkage) +* +* IEOFHDL -------------------------------------------------- +* +IEOFHDL BALR R12,R0 where are we ? + LA R15,*-MAIN offset from MAIN to here + SR R12,R15 base reg now points to MAIN + LA R14,EXIT + CLI IEOFOK,X'00' is EOF ok ? + BNER R14 if != yes, jump to EXIT + MVI RC+3,X'08' otherwise set RC=8 + BR R14 and jump to EXIT +* +* Work area for simple output system ------------------------ +* +ILPTR DC A(ILBUF) current input line position +IEOFOK DS X'00' EOF ok flag +ICVB DS D buffer for CVB (8 byte, DW aligned) +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSIN DCB DSORG=PS,MACRF=GM,DDNAME=SYSIN,EODAD=IEOFHDL X + RECFM=FB,LRECL=80,BLKSIZE=0 +ILBUF DC CL80' ' input line buffer +MAIN CSECT +* +* IINT10 --------------------------------------------------- +* read integer, like PL/I F(10) or C %10d format +* +IINT10 L R15,ILPTR get input pointer + PACK ICVB(8),0(10,R15) pack next 10 char + CVB R1,ICVB and convert + LA R15,10(R15) push pointer by 10 char + ST R15,ILPTR and update + BR R14 +* +* Work area definitions ----------------------------------------------- +* +SAVE DS 18F local save area +RC DC F'0' return code +NMAX DC F'10000000' highest prime to search for +NMSQRT DS F sqrt(NMAX) +BIMAX DS F highest prime array bit index +WIMAX DS F highest prime array word index +PRIME DS F prime array pointer +PRNT DC X'00' print enable flag +* +* message strings +* +MSGPERR OTXTDSC C'NMAX must be >= 10 and <= 100000000, abort' +MSGLIST OTXTDSC C'List of Primes up to ' +MSGPI OTXTDSC C'pi(' +MSGPISEP OTXTDSC C'): ' +* +* spill literal pool +* + LTORG +* +* other defs and end +* + YREGS , + END MAIN define main entry point +/* +//GO.SYSUDUMP DD SYSOUT=*,OUTLIM=2000 +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=100000 +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEQASMT,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#ASM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=128K,TIME=(1,0),PRTY=8 +//CLG EXEC ASMFCLG, +// MAC1='SYS2.MACLIB', +// PARM.ASM='NODECK,LOAD', +// PARM.LKED='MAP,LIST,LET,NCAL', +// COND.LKED=(8,LE,ASM), +// PARM.GO='', +// COND.GO=((8,LE,ASM),(4,LT,LKED)) +//ASM.SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(600,100)) +//ASM.SYSUT2 DD DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSUT3 DD DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSGO DD DSN=&&OBJSET,UNIT=SYSDA,SPACE=(80,(2000,500)) +//ASM.SYSIN DD * +* 1 2 3 4 5 6 71 +*23456789*12345*789012345678901234*678901234567890123456789012345678901 +* $Id: soeq_asm.asm 972 2017-12-23 20:55:41Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software; you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 +* 2017-11-19 965 1.1 no XR in inner loop, bit reversed prime[] +* 2017-11-18 963 1.0 Initial version +* + PRINT NOGEN don't show macro expansions +* +* Prime number search +* RC = 0 ok +* RC = 4 open SYSPRINT failed +* RC = 8 open SYSIN failed +* RC = 12 unexpected SYSIN EOF +* RC = 16 NMAX out of range +* +* local macros -------------------------------------------------------- +* +* +* OTXTDSC - setup text descriptor for simple output system - +* + MACRO +&LABEL OTXTDSC &TEXT +TEXT CSECT +SPTR&SYSNDX DC &TEXT +&SYSECT CSECT + DS 0F +&LABEL DC AL1(L'SPTR&SYSNDX),AL3(SPTR&SYSNDX) + MEND +* +* main preamble ------------------------------------------------------- +* +MAIN START 0 start main code csect at base 0 + SAVE (14,12) Save input registers + LR R12,R15 base register := entry address + USING MAIN,R12 declare base register + ST R13,SAVE+4 set back pointer in current save area + LR R2,R13 remember callers save area + LA R13,SAVE setup current save area + ST R13,8(R2) set forw pointer in callers save area +* +* open datasets ------------------------------------------------------- +* + OPEN (SYSPRINT,OUTPUT) open SYSPRINT + LTR R15,R15 test return code + BE OOPENOK + MVI RC+3,X'04' + B EXIT quit with RC=4 +OOPENOK OPEN (SYSIN,INPUT) open SYSIN + LTR R15,R15 test return code + BE IOPENOK + MVI RC+3,X'08' + B EXIT quit with RC=8 +IOPENOK EQU * +* +* read input parameters, and check range ------------------------------ +* + BAL R14,IGETLINE read input line + BAL R14,IINT10 get NMAX + ST R1,NMAX + BAL R14,IINT10 get PRNT + STC R1,PRNT +* + L R1,NMAX + C R1,=F'10' is NMAX >= 10 + BL NMAXBAD if < not + C R1,=F'100000000' is NMAX <= 100000000 + BNH NMAXOK if <= yes +NMAXBAD L R1,MSGPERR + BAL R14,OTEXT print error + BAL R14,OPUTLINE write line + MVI RC+3,X'10' + B EXIT quit with RC=16 +NMAXOK EQU * +* +* setup phase --------------------------------------------------------- +* +* calculate sqrt(nmax) ----------------------------------- +* use simple bi-section method +* R4 low bound +* R5 high bound +* R7 middle (low+high)/2 +* + LA R4,1 set low bound + L R5,NMAX set high bound + LA R6,32 set iteration limit +NMSQRTLP LR R7,R4 R7:= low + AR R7,R5 R7:= (low+high) + SRA R7,1 R7:= (low+high)/2 + LR R3,R7 + MR R2,R7 (R2,R3) := R7*R7 + LTR R2,R2 more than 32 bit ? + BNE NMSQRTHI if != yes, mid too high + CL R3,NMAX mid*mid > NMAX + BH NMSQRTHI if > yes, mid too high + LR R4,R7 here mid to low: low := mid + B NMSQRTGO +NMSQRTHI LR R5,R7 here mid to high: high := mid +NMSQRTGO LR R8,R5 R8 := high + SR R8,R4 R8 := high-low + LR R1,R6 + C R8,=F'1' spread <= 1 ? + BNH NMSQRTOK if <= yes, quit + BCT R6,NMSQRTLP + ABEND 99 abort if doesn't converge +NMSQRTOK EQU * + ST R4,NMSQRT + +* allocate PRIME array ----------------------------------- + L R2,NMAX + BCTR R2,0 NMAX-1 + SRA R2,1 (NMAX-1)/2 + ST R2,BIMAX + A R2,=F'7' BIMAX+7 + SRA R2,3 (BIMAX+7)/8 + ST R2,WIMAX + LR R5,R2 + A R5,=F'1' WIMAX+1 + GETMAIN RU,LV=(5) allocate storage for PRIME + ST R1,PRIME store sieve base + LR R9,R1 R9 := PRIME base +* +* set each PRIME array byte to X'01' --------------------- + LR R4,R1 R4 := PRIME +* R5 := sizeof(PRIME) (still) + XR R6,R6 R6 := 0 + L R7,=X'FF000000' R7 := padding=0xFF and length=0 + MVCL R4,R6 set all PRIME words to 0xFFFF +* +* sieve phase --------------------------------------------------------- +* outer loop: ind R6 n +* inc R4 2 +* lim R5 sqrt(NMAX) +* inner loop: ind R3 i +* inc R6 n +* lim R7 bimax +* R9 &prime +* R8 0x80 +* R10 0x07 +* R11 0xFF7F +* R0,R1,R2,R15 temporaries +* +* +* equivalent C code: +* for (n=3; n<=nmsqrt; n+=2) { +* i = n/2; +* if ((prime[i>>3] & (0x80>>(i&0x7))) == 0) continue; +* for (i=(n*n)/2; i<=bimax ; i+=n) { +* prime[i>>3] &= (0xff7f>>(i&0x7); '!!pseudo code !!' +* } +* } +* + LA R6,3 outer ind: R6:=3 + LA R4,2 outer inc: R4:=2 + L R5,NMSQRT outer lim: R5:=NMSQRT + L R7,BIMAX inner lim: R7:=BIMAX + LA R8,X'80' R8:=0x80 + LA R10,X'07' R10:=0x07 + L R11,=X'FFFFFF7F' R11:=0xffffff7f +* +SIEVO LR R2,R6 R2:=n + SRA R2,1 R2:=n/2 + LR R15,R2 i + NR R15,R10 i&0x07 + LR R1,R8 0x80 + SRL R1,0(R15) 0x80>>(i&0x7) + SRL R2,3 i>>3 + IC R2,0(R2,R9) prime[i>>3] + NR R2,R1 prime[i>>3] & (0x80>>(i&0x7)) + BZ SIEVOC if =0 not, continue outer loop +* + LR R1,R6 R1:=n + MR R0,R6 R1:=n*n (lower half, enough) + LR R3,R1 R3:=n*n too + SRA R3,1 R3:=(n*n)/2 +* +SIEVI LR R2,R3 i + NR R2,R10 i&0x7 + LR R1,R11 0xff7f + SRL R1,0(R2) 0xff7f>>(i&0x7) + LR R2,R3 i + SRL R2,3 i>>3 + IC R0,0(R2,R9) prime[i>>3] + NR R0,R1 & 0xff7f>>(i&0x7) + STC R0,0(R2,R9) prime[i>>3] &= 0xff7f>>(i&0x7) + BXLE R3,R6,SIEVI +* +SIEVOC BXLE R6,R4,SIEVO +* +* print primes table -------------------------------------------------- +* loop: ind R3 i +* inc R4 1 +* lim R5 imax +* R2 np +* R9 &prime +* R8 0x80 +* R10 0x07 +* R11 1 +PRT EQU * + CLI PRNT,X'00' primes to be printed ? + BE NOPRNT if = skip + L R1,MSGLIST + BAL R14,OTEXT print heading + L R1,NMAX + BAL R14,OINT10 print nmax + BAL R14,OPUTLINE write line +* + LA R1,2 + BAL R14,OINT10 print "2" (1st prime...) + LA R2,1 np=1 + LA R3,1 ind: R3:=1 + LA R4,1 inc: R4:=1 + L R5,BIMAX lim: R5:=BIMAX + LA R8,X'80' R8:=0x80 + LA R10,X'07' R10:=0x07 + LA R11,1 R11:=1 +PRTLOOP LR R6,R3 i + NR R6,R10 i&0x7 + LR R1,R8 0x80 + SRL R1,0(R6) 0x80>>(i&0x7) + LR R6,R3 i + SRL R6,3 i>>3 + IC R0,0(R6,R9) prime[i>>3] + NR R0,R1 prime[i>>3] & (0x80>>(i&0x7)) + BE PRTLOOPC if = not, continue + LR R1,R3 R1:=i + SLA R1,1 R1:=2*i + AR R1,R11 R1:=1+2*i + BAL R14,OINT10 and print F(10) + AR R2,R11 np+=1 + C R2,=F'10' check whether = 10 + BNZ PRTLOOPC if != not, continue + BAL R14,OPUTLINE write line + XR R2,R2 np=0 +PRTLOOPC EQU * + BXLE R3,R4,PRTLOOP +* + LTR R2,R2 check prime count np + BZ NOPRNT + BAL R14,OPUTLINE write line +NOPRNT EQU * +* +* print primes count -------------------------------------------------- +* loop: ind R3 i +* inc R4 1 +* lim R5 imax +* R2 np +* R7 il +* R6 nl +* R9 &prime +* R8 0x80 +* R10 0x07 +* R11 1 +* +TBL EQU * + LA R2,1 np=1 + LA R7,4 il=4 + LA R6,10 nl=10 + LA R3,1 ind: R3:=1 + LA R4,1 inc: R4:=1 + L R5,BIMAX lim: R5:=BIMAX + LA R8,X'80' R8:=0x80 + LA R10,X'07' R10:=0x07 + LA R11,1 R11:=1 +TBLLOOP LR R15,R3 i + NR R15,R10 i&0x7 + LR R1,R8 0x80 + SRL R1,0(R15) 0x80>>(i&0x7) + LR R15,R3 i + SRL R15,3 i>>3 + IC R0,0(R15,R9) prime[i>>3] + NR R0,R1 prime[i>>3] & (1<<(i&0x7)) + BE NOPRIME if = not + AR R2,R11 np+= 1 +NOPRIME CR R3,R7 test i != il + BNE TBLLOOPC + LR R6,R7 nl=il + SLA R6,1 nl=2*il + A R6,=F'2' nl=2+2*il +* + L R1,MSGPI + BAL R14,OTEXT print "pi(...." + LR R1,R6 + BAL R14,OINT10 print nl + L R1,MSGPISEP + BAL R14,OTEXT print "):..." + LR R1,R2 + BAL R14,OINT10 print np + BAL R14,OPUTLINE write line +* + LR R1,R7 R1:=il + AR R1,R11 R1:=il+1 + M R0,=F'10' R1:=10*(il+1) + SR R1,R11 R1:=10*(il+1)-1 + LR R7,R1 update il +* +TBLLOOPC EQU * + BXLE R3,R4,TBLLOOP +* + C R6,NMAX is nl != nmax ? + BE TBLNOTR if = not, skip extra summary +* + L R1,MSGPI + BAL R14,OTEXT print "pi(...." + L R1,NMAX + BAL R14,OINT10 print nmax + L R1,MSGPISEP + BAL R14,OTEXT print "):..." + LR R1,R2 + BAL R14,OINT10 print np + BAL R14,OPUTLINE write line +* +TBLNOTR EQU * +* +* close datasets and return to OS ------------------------------------- +* +EXIT CLOSE SYSPRINT close SYSPRINT + CLOSE SYSIN close SYSIN + L R13,SAVE+4 get old save area back + L R0,RC get return code + ST R0,16(R13) store in old save R15 + RETURN (14,12) return to OS (will setup RC) +* +* include simple output system ---------------------------------------- +* +* simple output system procedures ------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* OSKIP02 -------------------------------------------------- +* add 2 blanks +* +OSKIP02 LA R1,2 +* +* OSKIP ---------------------------------------------------- +* add blanks, count in R1 +* +OSKIP A R1,OLPTR new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OTAB ---------------------------------------------------- +* set output column, position in R1 +* +OTAB A R1,=A(OLBUF+1) new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OSFILL --------------------------------------------------- +* add " ***" pattern, total length in R1 +* +OSFILL L R15,OLPTR R15 points to edit position + MVI 0(R15),C' ' initial blank + B OSFILLN +OSFILLL MVI 0(R15),C'*' further '*' +OSFILLN LA R15,1(R15) + BCT R1,OSFILLL + ST R15,OLPTR store pointer + BR R14 +* +* OTEXT ---------------------------------------------------- +* print text, R1 hold descriptor address +* descriptor format +* DC AL1() +* DC AL2(
) +* +OTEXT ST R14,OTEXTL save R14 + LR R14,R1 + SRL R14,24 R14 now string length + L R15,OLPTR R15 points to edit position + LR R0,R15 R0 too + AR R0,R14 push pointer, add length + ST R0,OLPTR store pointer + BCTR R14,0 decrement length for EX + EX R14,OTEXTMVC copy string via EX:MVC + L R14,OTEXTL restore R14 linkage + BR R14 +* +OTEXTMVC MVC 0(1,R15),0(R1) length via EX, dst R15, src R1 +OTEXTL DS F save area for R14 (return linkage) +* +* OPUTLINE ------------------------------------------------- +* write line to SYSPRINT +* +OPUTLINE ST R14,OPUTLNEL save R14 + L R15,=A(OLBUF) + CLI 133(R15),X'00' check fence byte + BNE OPUTLNEA crash if fence blown + L R1,=A(SYSPRINT) R1 point to DCB + LR R0,R15 R1 point to buffer + PUT (1),(0) write line + L R15,=A(OLBUF) point to CC of OLBUF + MVI 0(R15),C' ' blank OLBUF(0) + MVC 1(L'OLBUF-1,R15),0(R15) propagate blank + LA R15,1(R15) point to 1st print char in OLBUF + ST R15,OLPTR reset current position pointer + LA R15,1 + AH R15,OLCNT increment line counter + STH R15,OLCNT + SH R15,OLMAX R15 := OLCNT-OLMAX + BL OPUTLNES if < no new page + XR R15,R15 R15 := 0 + SH R15,OLCNT clear line counter + L R15,=A(OLBUF) point to CC of OLBUF +* MVI 0(R15),C'1' set new page CC in OLBUF +OPUTLNES L R14,OPUTLNEL restore R14 linkage + BR R14 +* +OPUTLNEA ABEND 255 abend in case of errors +* +OPUTLNEL DS F save area for R14 (return linkage) +* +* Work area for simple output system ------------------------ +* +OLPTR DC A(OLBUF+1) current output line position +OLCNT DC H'0' line counter +OLMAX DC H'60' lines per page +OCVD DS D buffer for CVD (8 byte, DW aligned) +* +ODTEMP DS D double buffer for conversions +ODNZERO DC X'4E000000',X'00000000' denormalized double zero +ODNONE DC X'4E000000',X'00000001' denormalized double one +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSPRINT DCB DSORG=PS,MACRF=PM,DDNAME=SYSPRINT, X + RECFM=FBA,LRECL=133,BLKSIZE=0 +OLBUF DC CL133' ',X'00' output line buffer and fence byte +* +MAIN CSECT +* +* OINT10 --------------------------------------------------- +* print integer, like PL/I F(10) or C %10d format +* very fast, for non-negative numbers only ! +* +OINT10 CL R1,=F'999999999' too large ? + BH OINT10F if > yes, do OSFILL + CVD R1,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEI10L,R15),OEI10 setup pattern + ED 0(OEI10L,R15),OCVD+3 and edit + LA R15,OEI10L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OINT10F LA R1,10 + B OSFILL +* +OEI10 DC C' ',7X'20',X'21',X'20' pat: bddddddd(d +OEI10L EQU *-OEI10 +* include simple input system ----------------------------------------- +* +* simple input system procedures -------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* IGETLINE ------------------------------------------------- +* read line from SYSIN +* EOF handling: +* - IEOFOK holds the 'EOF OK' flag +* - if EOF seen and IEOFOK = X'00', program ends with RC=8 +* - if EOF seen and IEOFOK != X'00', program ends with RC=0 +* +IGETLINE ST R14,IGETLNEL save R14 + L R1,=A(SYSIN) + L R0,=A(ILBUF) + GET (1),(0) read line + L R0,=A(ILBUF) + ST R0,ILPTR set input ptr to begin of line + L R14,IGETLNEL restore R14 linkage + BR R14 +* +IGETLNEL DS F save area for R14 (return linkage) +* +* IEOFHDL -------------------------------------------------- +* +IEOFHDL BALR R12,R0 where are we ? + LA R15,*-MAIN offset from MAIN to here + SR R12,R15 base reg now points to MAIN + LA R14,EXIT + CLI IEOFOK,X'00' is EOF ok ? + BNER R14 if != yes, jump to EXIT + MVI RC+3,X'08' otherwise set RC=8 + BR R14 and jump to EXIT +* +* Work area for simple output system ------------------------ +* +ILPTR DC A(ILBUF) current input line position +IEOFOK DS X'00' EOF ok flag +ICVB DS D buffer for CVB (8 byte, DW aligned) +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSIN DCB DSORG=PS,MACRF=GM,DDNAME=SYSIN,EODAD=IEOFHDL X + RECFM=FB,LRECL=80,BLKSIZE=0 +ILBUF DC CL80' ' input line buffer +MAIN CSECT +* +* IINT10 --------------------------------------------------- +* read integer, like PL/I F(10) or C %10d format +* +IINT10 L R15,ILPTR get input pointer + PACK ICVB(8),0(10,R15) pack next 10 char + CVB R1,ICVB and convert + LA R15,10(R15) push pointer by 10 char + ST R15,ILPTR and update + BR R14 +* +* Work area definitions ----------------------------------------------- +* +SAVE DS 18F local save area +RC DC F'0' return code +NMAX DC F'10000000' highest prime to search for +NMSQRT DS F sqrt(NMAX) +BIMAX DS F highest prime array bit index +WIMAX DS F highest prime array word index +PRIME DS F prime array pointer +PRNT DC X'00' print enable flag +* +* message strings +* +MSGPERR OTXTDSC C'NMAX must be >= 10 and <= 100000000, abort' +MSGLIST OTXTDSC C'List of Primes up to ' +MSGPI OTXTDSC C'pi(' +MSGPISEP OTXTDSC C'): ' +* +* spill literal pool +* + LTORG +* +* other defs and end +* + YREGS , + END MAIN define main entry point +/* +//GO.SYSUDUMP DD SYSOUT=*,OUTLIM=2000 +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEQGCCF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#GCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=7000K,TIME=(1,0),PRTY=8 +//CLG EXEC GCCCLG,COPTS='-O3', +// PARM.LKED='MAP,LIST' +//COMP.SYSIN DD DATA,DLM='/@' +/* $Id: soeq_cc.c 972 2017-12-23 20:55:41Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-23 972 1.1.1 change (n-1)/2 --> n/2 */ +/* 2017-11-20 966 1.1 add LOOKUP,STATISTICS ifdefs */ +/* 2017-11-17 962 1.0 Initial version */ +/* 2017-10-15 956 0.1 First draft */ + +#include +#include +#include + +/* #define LOOKUP */ +/* #define STATISTICS */ + +#ifdef LOOKUP +#define TSTMASK(ind) tstmask[ind] +#define CLRMASK(ind) clrmask[ind] +const unsigned char tstmask[] = {0x01,0x02,0x04,0x08, + 0x10,0x20,0x40,0x80}; +const unsigned char clrmask[] = {0xfe,0xfd,0xfb,0xf7, + 0xef,0xdf,0xbf,0x7f}; + +#else +#define TSTMASK(ind) (1<<(ind)) +#define CLRMASK(ind) ~(1<<(ind)) +#endif + +#ifdef STATISTICS +#define SCOUNT(var) var += 1; +double StatOloop = 0.; +double StatIloop = 0.; +#else +#define SCOUNT(var) +#endif + + +int main() +{ + int nmax; + int nmsqrt; + int prnt; + int bimax; + int wimax; + int i,n; + int np,il,nl; + unsigned char *prime; + unsigned char *p,*pmax; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &nmax, &prnt) != 2) { + printf("conversion error, abort\n"); + return 1; + } + if (nmax < 10) { + printf("nmax must be >= 10, abort\n"); + return 1; + } + + /* prime: i=(n-1)/2 --> 3->[1], 5->[2]; ... 99-> [49]; ... */ + nmsqrt = sqrt((double)nmax); + bimax = (nmax-1)/2; + wimax = (bimax+7)/8; + prime = malloc(sizeof(char)*(wimax+1)); /* need [1,...,wimax] */ + pmax = &prime[wimax]; + + for (p=prime; p<=pmax;) *p++ = 0xff; + + for (n=3; n<=nmsqrt; n+=2) { + i = n/2; + if ((prime[i>>3] & TSTMASK(i&0x7)) == 0) continue; + SCOUNT(StatOloop); + for (i=(n*n)/2; i<=bimax ; i+=n) { + prime[i>>3] &= CLRMASK(i&0x7); + SCOUNT(StatIloop); + } + } + + if (prnt) { + printf("List of Primes up to %d\n",nmax); + printf(" %7d",2); + np = 1; + for (i=1;i<=bimax;i++) { + if ((prime[i>>3] & TSTMASK(i&0x7)) == 0) continue; + printf(" %7d",1+2*i); + np += 1; + if (np != 10) continue; + printf("\n"); + np= 0; + } + if (np != 0) printf("\n"); + } + + il = 4; + nl = 10; + np = 1; + for (i=1;i<=bimax;i++) { + if ((prime[i>>3] & TSTMASK(i&0x7))) np += 1; + if (i != il) continue; + nl = 2*il+2; + printf("pi(%10d): %10d\n",nl,np); + il = 10*(il+1)-1; + } + if (nl != nmax) printf("pi(%10d): %10d\n",nmax,np); + +#ifdef STATISTICS + printf("StatOloop: %20.0f\n",StatOloop); + printf("StatIloop: %20.0f\n",StatIloop); +#endif + +return 0; +} +/@ +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +100000000 0 +/* +// +./ ADD NAME=SOEQGCCP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#GCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(1,0),PRTY=8 +//CLG EXEC GCCCLG,COPTS='-O3', +// PARM.LKED='MAP,LIST' +//COMP.SYSIN DD DATA,DLM='/@' +/* $Id: soeq_cc.c 972 2017-12-23 20:55:41Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-23 972 1.1.1 change (n-1)/2 --> n/2 */ +/* 2017-11-20 966 1.1 add LOOKUP,STATISTICS ifdefs */ +/* 2017-11-17 962 1.0 Initial version */ +/* 2017-10-15 956 0.1 First draft */ + +#include +#include +#include + +/* #define LOOKUP */ +/* #define STATISTICS */ + +#ifdef LOOKUP +#define TSTMASK(ind) tstmask[ind] +#define CLRMASK(ind) clrmask[ind] +const unsigned char tstmask[] = {0x01,0x02,0x04,0x08, + 0x10,0x20,0x40,0x80}; +const unsigned char clrmask[] = {0xfe,0xfd,0xfb,0xf7, + 0xef,0xdf,0xbf,0x7f}; + +#else +#define TSTMASK(ind) (1<<(ind)) +#define CLRMASK(ind) ~(1<<(ind)) +#endif + +#ifdef STATISTICS +#define SCOUNT(var) var += 1; +double StatOloop = 0.; +double StatIloop = 0.; +#else +#define SCOUNT(var) +#endif + + +int main() +{ + int nmax; + int nmsqrt; + int prnt; + int bimax; + int wimax; + int i,n; + int np,il,nl; + unsigned char *prime; + unsigned char *p,*pmax; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &nmax, &prnt) != 2) { + printf("conversion error, abort\n"); + return 1; + } + if (nmax < 10) { + printf("nmax must be >= 10, abort\n"); + return 1; + } + + /* prime: i=(n-1)/2 --> 3->[1], 5->[2]; ... 99-> [49]; ... */ + nmsqrt = sqrt((double)nmax); + bimax = (nmax-1)/2; + wimax = (bimax+7)/8; + prime = malloc(sizeof(char)*(wimax+1)); /* need [1,...,wimax] */ + pmax = &prime[wimax]; + + for (p=prime; p<=pmax;) *p++ = 0xff; + + for (n=3; n<=nmsqrt; n+=2) { + i = n/2; + if ((prime[i>>3] & TSTMASK(i&0x7)) == 0) continue; + SCOUNT(StatOloop); + for (i=(n*n)/2; i<=bimax ; i+=n) { + prime[i>>3] &= CLRMASK(i&0x7); + SCOUNT(StatIloop); + } + } + + if (prnt) { + printf("List of Primes up to %d\n",nmax); + printf(" %7d",2); + np = 1; + for (i=1;i<=bimax;i++) { + if ((prime[i>>3] & TSTMASK(i&0x7)) == 0) continue; + printf(" %7d",1+2*i); + np += 1; + if (np != 10) continue; + printf("\n"); + np= 0; + } + if (np != 0) printf("\n"); + } + + il = 4; + nl = 10; + np = 1; + for (i=1;i<=bimax;i++) { + if ((prime[i>>3] & TSTMASK(i&0x7))) np += 1; + if (i != il) continue; + nl = 2*il+2; + printf("pi(%10d): %10d\n",nl,np); + il = 10*(il+1)-1; + } + if (nl != nmax) printf("pi(%10d): %10d\n",nmax,np); + +#ifdef STATISTICS + printf("StatOloop: %20.0f\n",StatOloop); + printf("StatIloop: %20.0f\n",StatIloop); +#endif + +return 0; +} +/@ +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=100000 +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEQGCCT,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#GCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=6000K,TIME=(1,0),PRTY=8 +//CLG EXEC GCCCLG,COPTS='-O3', +// PARM.LKED='MAP,LIST' +//COMP.SYSIN DD DATA,DLM='/@' +/* $Id: soeq_cc.c 972 2017-12-23 20:55:41Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-23 972 1.1.1 change (n-1)/2 --> n/2 */ +/* 2017-11-20 966 1.1 add LOOKUP,STATISTICS ifdefs */ +/* 2017-11-17 962 1.0 Initial version */ +/* 2017-10-15 956 0.1 First draft */ + +#include +#include +#include + +/* #define LOOKUP */ +/* #define STATISTICS */ + +#ifdef LOOKUP +#define TSTMASK(ind) tstmask[ind] +#define CLRMASK(ind) clrmask[ind] +const unsigned char tstmask[] = {0x01,0x02,0x04,0x08, + 0x10,0x20,0x40,0x80}; +const unsigned char clrmask[] = {0xfe,0xfd,0xfb,0xf7, + 0xef,0xdf,0xbf,0x7f}; + +#else +#define TSTMASK(ind) (1<<(ind)) +#define CLRMASK(ind) ~(1<<(ind)) +#endif + +#ifdef STATISTICS +#define SCOUNT(var) var += 1; +double StatOloop = 0.; +double StatIloop = 0.; +#else +#define SCOUNT(var) +#endif + + +int main() +{ + int nmax; + int nmsqrt; + int prnt; + int bimax; + int wimax; + int i,n; + int np,il,nl; + unsigned char *prime; + unsigned char *p,*pmax; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &nmax, &prnt) != 2) { + printf("conversion error, abort\n"); + return 1; + } + if (nmax < 10) { + printf("nmax must be >= 10, abort\n"); + return 1; + } + + /* prime: i=(n-1)/2 --> 3->[1], 5->[2]; ... 99-> [49]; ... */ + nmsqrt = sqrt((double)nmax); + bimax = (nmax-1)/2; + wimax = (bimax+7)/8; + prime = malloc(sizeof(char)*(wimax+1)); /* need [1,...,wimax] */ + pmax = &prime[wimax]; + + for (p=prime; p<=pmax;) *p++ = 0xff; + + for (n=3; n<=nmsqrt; n+=2) { + i = n/2; + if ((prime[i>>3] & TSTMASK(i&0x7)) == 0) continue; + SCOUNT(StatOloop); + for (i=(n*n)/2; i<=bimax ; i+=n) { + prime[i>>3] &= CLRMASK(i&0x7); + SCOUNT(StatIloop); + } + } + + if (prnt) { + printf("List of Primes up to %d\n",nmax); + printf(" %7d",2); + np = 1; + for (i=1;i<=bimax;i++) { + if ((prime[i>>3] & TSTMASK(i&0x7)) == 0) continue; + printf(" %7d",1+2*i); + np += 1; + if (np != 10) continue; + printf("\n"); + np= 0; + } + if (np != 0) printf("\n"); + } + + il = 4; + nl = 10; + np = 1; + for (i=1;i<=bimax;i++) { + if ((prime[i>>3] & TSTMASK(i&0x7))) np += 1; + if (i != il) continue; + nl = 2*il+2; + printf("pi(%10d): %10d\n",nl,np); + il = 10*(il+1)-1; + } + if (nl != nmax) printf("pi(%10d): %10d\n",nmax,np); + +#ifdef STATISTICS + printf("StatOloop: %20.0f\n",StatOloop); + printf("StatIloop: %20.0f\n",StatIloop); +#endif + +return 0; +} +/@ +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEQJCCF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#JCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=7000K,TIME=(1,0),PRTY=8 +//CLG EXEC JCCCLG, +// JOPTS='-o', +// PARM.LKED='NCAL,MAP,LIST,NORENT' +//COMPILE.SYSIN DD DATA,DLM='/@' +/* $Id: soeq_cc.c 972 2017-12-23 20:55:41Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-23 972 1.1.1 change (n-1)/2 --> n/2 */ +/* 2017-11-20 966 1.1 add LOOKUP,STATISTICS ifdefs */ +/* 2017-11-17 962 1.0 Initial version */ +/* 2017-10-15 956 0.1 First draft */ + +#include +#include +#include + +/* #define LOOKUP */ +/* #define STATISTICS */ + +#ifdef LOOKUP +#define TSTMASK(ind) tstmask[ind] +#define CLRMASK(ind) clrmask[ind] +const unsigned char tstmask[] = {0x01,0x02,0x04,0x08, + 0x10,0x20,0x40,0x80}; +const unsigned char clrmask[] = {0xfe,0xfd,0xfb,0xf7, + 0xef,0xdf,0xbf,0x7f}; + +#else +#define TSTMASK(ind) (1<<(ind)) +#define CLRMASK(ind) ~(1<<(ind)) +#endif + +#ifdef STATISTICS +#define SCOUNT(var) var += 1; +double StatOloop = 0.; +double StatIloop = 0.; +#else +#define SCOUNT(var) +#endif + + +int main() +{ + int nmax; + int nmsqrt; + int prnt; + int bimax; + int wimax; + int i,n; + int np,il,nl; + unsigned char *prime; + unsigned char *p,*pmax; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &nmax, &prnt) != 2) { + printf("conversion error, abort\n"); + return 1; + } + if (nmax < 10) { + printf("nmax must be >= 10, abort\n"); + return 1; + } + + /* prime: i=(n-1)/2 --> 3->[1], 5->[2]; ... 99-> [49]; ... */ + nmsqrt = sqrt((double)nmax); + bimax = (nmax-1)/2; + wimax = (bimax+7)/8; + prime = malloc(sizeof(char)*(wimax+1)); /* need [1,...,wimax] */ + pmax = &prime[wimax]; + + for (p=prime; p<=pmax;) *p++ = 0xff; + + for (n=3; n<=nmsqrt; n+=2) { + i = n/2; + if ((prime[i>>3] & TSTMASK(i&0x7)) == 0) continue; + SCOUNT(StatOloop); + for (i=(n*n)/2; i<=bimax ; i+=n) { + prime[i>>3] &= CLRMASK(i&0x7); + SCOUNT(StatIloop); + } + } + + if (prnt) { + printf("List of Primes up to %d\n",nmax); + printf(" %7d",2); + np = 1; + for (i=1;i<=bimax;i++) { + if ((prime[i>>3] & TSTMASK(i&0x7)) == 0) continue; + printf(" %7d",1+2*i); + np += 1; + if (np != 10) continue; + printf("\n"); + np= 0; + } + if (np != 0) printf("\n"); + } + + il = 4; + nl = 10; + np = 1; + for (i=1;i<=bimax;i++) { + if ((prime[i>>3] & TSTMASK(i&0x7))) np += 1; + if (i != il) continue; + nl = 2*il+2; + printf("pi(%10d): %10d\n",nl,np); + il = 10*(il+1)-1; + } + if (nl != nmax) printf("pi(%10d): %10d\n",nmax,np); + +#ifdef STATISTICS + printf("StatOloop: %20.0f\n",StatOloop); + printf("StatIloop: %20.0f\n",StatIloop); +#endif + +return 0; +} +/@ +//GO.STDOUT DD SYSOUT=*,OUTLIM=5000 +//GO.STDERR DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +100000000 0 +/* +// +./ ADD NAME=SOEQJCCP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#JCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(1,0),PRTY=8 +//CLG EXEC JCCCLG, +// JOPTS='-o', +// PARM.LKED='NCAL,MAP,LIST,NORENT' +//COMPILE.SYSIN DD DATA,DLM='/@' +/* $Id: soeq_cc.c 972 2017-12-23 20:55:41Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-23 972 1.1.1 change (n-1)/2 --> n/2 */ +/* 2017-11-20 966 1.1 add LOOKUP,STATISTICS ifdefs */ +/* 2017-11-17 962 1.0 Initial version */ +/* 2017-10-15 956 0.1 First draft */ + +#include +#include +#include + +/* #define LOOKUP */ +/* #define STATISTICS */ + +#ifdef LOOKUP +#define TSTMASK(ind) tstmask[ind] +#define CLRMASK(ind) clrmask[ind] +const unsigned char tstmask[] = {0x01,0x02,0x04,0x08, + 0x10,0x20,0x40,0x80}; +const unsigned char clrmask[] = {0xfe,0xfd,0xfb,0xf7, + 0xef,0xdf,0xbf,0x7f}; + +#else +#define TSTMASK(ind) (1<<(ind)) +#define CLRMASK(ind) ~(1<<(ind)) +#endif + +#ifdef STATISTICS +#define SCOUNT(var) var += 1; +double StatOloop = 0.; +double StatIloop = 0.; +#else +#define SCOUNT(var) +#endif + + +int main() +{ + int nmax; + int nmsqrt; + int prnt; + int bimax; + int wimax; + int i,n; + int np,il,nl; + unsigned char *prime; + unsigned char *p,*pmax; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &nmax, &prnt) != 2) { + printf("conversion error, abort\n"); + return 1; + } + if (nmax < 10) { + printf("nmax must be >= 10, abort\n"); + return 1; + } + + /* prime: i=(n-1)/2 --> 3->[1], 5->[2]; ... 99-> [49]; ... */ + nmsqrt = sqrt((double)nmax); + bimax = (nmax-1)/2; + wimax = (bimax+7)/8; + prime = malloc(sizeof(char)*(wimax+1)); /* need [1,...,wimax] */ + pmax = &prime[wimax]; + + for (p=prime; p<=pmax;) *p++ = 0xff; + + for (n=3; n<=nmsqrt; n+=2) { + i = n/2; + if ((prime[i>>3] & TSTMASK(i&0x7)) == 0) continue; + SCOUNT(StatOloop); + for (i=(n*n)/2; i<=bimax ; i+=n) { + prime[i>>3] &= CLRMASK(i&0x7); + SCOUNT(StatIloop); + } + } + + if (prnt) { + printf("List of Primes up to %d\n",nmax); + printf(" %7d",2); + np = 1; + for (i=1;i<=bimax;i++) { + if ((prime[i>>3] & TSTMASK(i&0x7)) == 0) continue; + printf(" %7d",1+2*i); + np += 1; + if (np != 10) continue; + printf("\n"); + np= 0; + } + if (np != 0) printf("\n"); + } + + il = 4; + nl = 10; + np = 1; + for (i=1;i<=bimax;i++) { + if ((prime[i>>3] & TSTMASK(i&0x7))) np += 1; + if (i != il) continue; + nl = 2*il+2; + printf("pi(%10d): %10d\n",nl,np); + il = 10*(il+1)-1; + } + if (nl != nmax) printf("pi(%10d): %10d\n",nmax,np); + +#ifdef STATISTICS + printf("StatOloop: %20.0f\n",StatOloop); + printf("StatIloop: %20.0f\n",StatIloop); +#endif + +return 0; +} +/@ +//GO.STDOUT DD SYSOUT=*,OUTLIM=100000 +//GO.STDERR DD SYSOUT=*,OUTLIM=100000 +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEQJCCT,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#JCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(1,0),PRTY=8 +//CLG EXEC JCCCLG, +// JOPTS='-o', +// PARM.LKED='NCAL,MAP,LIST,NORENT' +//COMPILE.SYSIN DD DATA,DLM='/@' +/* $Id: soeq_cc.c 972 2017-12-23 20:55:41Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-23 972 1.1.1 change (n-1)/2 --> n/2 */ +/* 2017-11-20 966 1.1 add LOOKUP,STATISTICS ifdefs */ +/* 2017-11-17 962 1.0 Initial version */ +/* 2017-10-15 956 0.1 First draft */ + +#include +#include +#include + +/* #define LOOKUP */ +/* #define STATISTICS */ + +#ifdef LOOKUP +#define TSTMASK(ind) tstmask[ind] +#define CLRMASK(ind) clrmask[ind] +const unsigned char tstmask[] = {0x01,0x02,0x04,0x08, + 0x10,0x20,0x40,0x80}; +const unsigned char clrmask[] = {0xfe,0xfd,0xfb,0xf7, + 0xef,0xdf,0xbf,0x7f}; + +#else +#define TSTMASK(ind) (1<<(ind)) +#define CLRMASK(ind) ~(1<<(ind)) +#endif + +#ifdef STATISTICS +#define SCOUNT(var) var += 1; +double StatOloop = 0.; +double StatIloop = 0.; +#else +#define SCOUNT(var) +#endif + + +int main() +{ + int nmax; + int nmsqrt; + int prnt; + int bimax; + int wimax; + int i,n; + int np,il,nl; + unsigned char *prime; + unsigned char *p,*pmax; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &nmax, &prnt) != 2) { + printf("conversion error, abort\n"); + return 1; + } + if (nmax < 10) { + printf("nmax must be >= 10, abort\n"); + return 1; + } + + /* prime: i=(n-1)/2 --> 3->[1], 5->[2]; ... 99-> [49]; ... */ + nmsqrt = sqrt((double)nmax); + bimax = (nmax-1)/2; + wimax = (bimax+7)/8; + prime = malloc(sizeof(char)*(wimax+1)); /* need [1,...,wimax] */ + pmax = &prime[wimax]; + + for (p=prime; p<=pmax;) *p++ = 0xff; + + for (n=3; n<=nmsqrt; n+=2) { + i = n/2; + if ((prime[i>>3] & TSTMASK(i&0x7)) == 0) continue; + SCOUNT(StatOloop); + for (i=(n*n)/2; i<=bimax ; i+=n) { + prime[i>>3] &= CLRMASK(i&0x7); + SCOUNT(StatIloop); + } + } + + if (prnt) { + printf("List of Primes up to %d\n",nmax); + printf(" %7d",2); + np = 1; + for (i=1;i<=bimax;i++) { + if ((prime[i>>3] & TSTMASK(i&0x7)) == 0) continue; + printf(" %7d",1+2*i); + np += 1; + if (np != 10) continue; + printf("\n"); + np= 0; + } + if (np != 0) printf("\n"); + } + + il = 4; + nl = 10; + np = 1; + for (i=1;i<=bimax;i++) { + if ((prime[i>>3] & TSTMASK(i&0x7))) np += 1; + if (i != il) continue; + nl = 2*il+2; + printf("pi(%10d): %10d\n",nl,np); + il = 10*(il+1)-1; + } + if (nl != nmax) printf("pi(%10d): %10d\n",nmax,np); + +#ifdef STATISTICS + printf("StatOloop: %20.0f\n",StatOloop); + printf("StatIloop: %20.0f\n",StatIloop); +#endif + +return 0; +} +/@ +//GO.STDOUT DD SYSOUT=*,OUTLIM=5000 +//GO.STDERR DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEQPASF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#PAS JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=7500K,TIME=(5,0),PRTY=2 +//CLG EXEC PASCLG,GOTIME=3600,GOREG=7500K, +// OPT='M+,D-', +// GOPARM='/STACK=6500K' +//COMPILE.SYSIN DD * +(* $Id: soeq_pas.pas 977 2017-12-27 12:46:21Z mueller $ *) +(* +(* Copyright 2017- by Walter F.J. Mueller *) +(* +(* This program is free software; you may redistribute and/or modify *) +(* it under the terms of the GNU General Public License version 3. *) +(* See Licence.txt in distribition directory for further details. *) +(* *) +(* Remarks: *) +(* - The MVS Compiler uses 8 bytes to represent a set, sets are *) +(* limited to 64 members. seoq uses therefore sets with 64 members.*) +(* - the '<=' operator is slightly faster than the 'in' operator. *) +(* - the set '*' operator is slightly faster than the '-' operator. *) +(* - all this leads to a slightly different implementation than the *) +(* one scetched in 'Pascal User Manual and Report. 2nd Edition', *) +(* published 1975 by Springer. *) +(* *) +(* Revision History: *) +(* Date Rev Version Comment *) +(* 2017-12-27 977 1.1 use '<=' and '*' instead of 'in' and '-'*) +(* 2017-12-26 976 1.0 Initial version (derived from soeq_pas) *) + +program soep(input,output); +type + bits = (b00,b01,b02,b03,b04,b05,b06,b07, + b08,b09,b10,b11,b12,b13,b14,b15, + b16,b17,b18,b19,b20,b21,b22,b23, + b24,b25,b26,b27,b28,b29,b30,b31, + b32,b33,b34,b35,b36,b37,b38,b39, + b40,b41,b42,b43,b44,b45,b46,b47, + b48,b49,b50,b51,b52,b53,b54,b55, + b56,b57,b58,b59,b60,b61,b62,b63); + bset = set of bits; +var + nmax,prnt,imax : integer; + nmsqrt : integer; + wimax,iw : integer; + i,n,imin : integer; + np,il,nl : integer; + rnmax : real; + sieve : ARRAY[0 .. 781250] of bset; + btst : ARRAY[0 .. 63 ] of bset; + bclr : ARRAY[0 .. 63 ] of bset; + b : bits; + ball : bset; +begin + + ball := [b00 .. b63]; + b := b00; + btst[0] := [b]; + bclr[0] := ball - [b]; + for i := 1 to 63 do begin + b := succ(b); + btst[i] := [b]; + bclr[i] := ball - [b]; + end; + + read(nmax); + read(prnt); + + if (nmax < 10) or (nmax > 100000000) then begin + writeln(' ', 'nmax out of range (10...100000000), abort'); + exit(8); + end; + + rnmax := nmax; + nmsqrt := trunc(sqrt(nmax)); + imax := (nmax-1) div 2; + wimax := (imax+63) div 64; + for i := 0 to wimax do sieve[i] := ball; + + n := 3; + while n <= nmsqrt do begin + i := n div 2; + if btst[i mod 64] <= sieve[i div 64] then begin + i := (n*n) div 2; + while i <= imax do begin + iw := i div 64; + sieve[iw] := sieve[iw] * bclr[i mod 64]; + i := i + n; + end; + end; + n := n + 2; + end; + + if prnt > 0 then begin + writeln(' ', 'List of Primes up to ', nmax:9); + write(2:8); + np := 1; + for i := 1 to imax do begin + if btst[i mod 64] <= sieve[i div 64] then begin + write(1+2*i:8); + np := np + 1; + if np = 10 then begin + writeln(' '); + np := 0; + end; + end; + end; + if np > 0 then writeln(); + end; + + il := 4; + nl := 10; + np := 1; + for i := 1 to imax do begin + if btst[i mod 64] <= sieve[i div 64] then np := np + 1; + if i = il then begin + nl := 2*il + 2; + writeln(' ', 'pi(', nl:9, '): ', np:9); + il := 10*(il+1)-1; + end; + end; + + if nl < nmax then writeln(' ', 'pi(', nmax:9, '): ', np:9); + +end. +/* +//GO.OUTPUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * +100000000 0 +/* +// +./ ADD NAME=SOEQPASP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#PAS JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=7500K,TIME=(1,0),PRTY=8 +//CLG EXEC PASCLG,GOTIME=3600,GOREG=7500K, +// OPT='M+,D-', +// GOPARM='/STACK=6500K' +//COMPILE.SYSIN DD * +(* $Id: soeq_pas.pas 977 2017-12-27 12:46:21Z mueller $ *) +(* +(* Copyright 2017- by Walter F.J. Mueller *) +(* +(* This program is free software; you may redistribute and/or modify *) +(* it under the terms of the GNU General Public License version 3. *) +(* See Licence.txt in distribition directory for further details. *) +(* *) +(* Remarks: *) +(* - The MVS Compiler uses 8 bytes to represent a set, sets are *) +(* limited to 64 members. seoq uses therefore sets with 64 members.*) +(* - the '<=' operator is slightly faster than the 'in' operator. *) +(* - the set '*' operator is slightly faster than the '-' operator. *) +(* - all this leads to a slightly different implementation than the *) +(* one scetched in 'Pascal User Manual and Report. 2nd Edition', *) +(* published 1975 by Springer. *) +(* *) +(* Revision History: *) +(* Date Rev Version Comment *) +(* 2017-12-27 977 1.1 use '<=' and '*' instead of 'in' and '-'*) +(* 2017-12-26 976 1.0 Initial version (derived from soeq_pas) *) + +program soep(input,output); +type + bits = (b00,b01,b02,b03,b04,b05,b06,b07, + b08,b09,b10,b11,b12,b13,b14,b15, + b16,b17,b18,b19,b20,b21,b22,b23, + b24,b25,b26,b27,b28,b29,b30,b31, + b32,b33,b34,b35,b36,b37,b38,b39, + b40,b41,b42,b43,b44,b45,b46,b47, + b48,b49,b50,b51,b52,b53,b54,b55, + b56,b57,b58,b59,b60,b61,b62,b63); + bset = set of bits; +var + nmax,prnt,imax : integer; + nmsqrt : integer; + wimax,iw : integer; + i,n,imin : integer; + np,il,nl : integer; + rnmax : real; + sieve : ARRAY[0 .. 781250] of bset; + btst : ARRAY[0 .. 63 ] of bset; + bclr : ARRAY[0 .. 63 ] of bset; + b : bits; + ball : bset; +begin + + ball := [b00 .. b63]; + b := b00; + btst[0] := [b]; + bclr[0] := ball - [b]; + for i := 1 to 63 do begin + b := succ(b); + btst[i] := [b]; + bclr[i] := ball - [b]; + end; + + read(nmax); + read(prnt); + + if (nmax < 10) or (nmax > 100000000) then begin + writeln(' ', 'nmax out of range (10...100000000), abort'); + exit(8); + end; + + rnmax := nmax; + nmsqrt := trunc(sqrt(nmax)); + imax := (nmax-1) div 2; + wimax := (imax+63) div 64; + for i := 0 to wimax do sieve[i] := ball; + + n := 3; + while n <= nmsqrt do begin + i := n div 2; + if btst[i mod 64] <= sieve[i div 64] then begin + i := (n*n) div 2; + while i <= imax do begin + iw := i div 64; + sieve[iw] := sieve[iw] * bclr[i mod 64]; + i := i + n; + end; + end; + n := n + 2; + end; + + if prnt > 0 then begin + writeln(' ', 'List of Primes up to ', nmax:9); + write(2:8); + np := 1; + for i := 1 to imax do begin + if btst[i mod 64] <= sieve[i div 64] then begin + write(1+2*i:8); + np := np + 1; + if np = 10 then begin + writeln(' '); + np := 0; + end; + end; + end; + if np > 0 then writeln(); + end; + + il := 4; + nl := 10; + np := 1; + for i := 1 to imax do begin + if btst[i mod 64] <= sieve[i div 64] then np := np + 1; + if i = il then begin + nl := 2*il + 2; + writeln(' ', 'pi(', nl:9, '): ', np:9); + il := 10*(il+1)-1; + end; + end; + + if nl < nmax then writeln(' ', 'pi(', nmax:9, '): ', np:9); + +end. +/* +//GO.OUTPUT DD SYSOUT=*,OUTLIM=100000 +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEQPAST,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#PAS JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=7500K,TIME=(1,0),PRTY=8 +//CLG EXEC PASCLG,GOTIME=3600,GOREG=7500K, +// OPT='M+', +// GOPARM='/STACK=6500K' +//COMPILE.SYSIN DD * +(* $Id: soeq_pas.pas 977 2017-12-27 12:46:21Z mueller $ *) +(* +(* Copyright 2017- by Walter F.J. Mueller *) +(* +(* This program is free software; you may redistribute and/or modify *) +(* it under the terms of the GNU General Public License version 3. *) +(* See Licence.txt in distribition directory for further details. *) +(* *) +(* Remarks: *) +(* - The MVS Compiler uses 8 bytes to represent a set, sets are *) +(* limited to 64 members. seoq uses therefore sets with 64 members.*) +(* - the '<=' operator is slightly faster than the 'in' operator. *) +(* - the set '*' operator is slightly faster than the '-' operator. *) +(* - all this leads to a slightly different implementation than the *) +(* one scetched in 'Pascal User Manual and Report. 2nd Edition', *) +(* published 1975 by Springer. *) +(* *) +(* Revision History: *) +(* Date Rev Version Comment *) +(* 2017-12-27 977 1.1 use '<=' and '*' instead of 'in' and '-'*) +(* 2017-12-26 976 1.0 Initial version (derived from soeq_pas) *) + +program soep(input,output); +type + bits = (b00,b01,b02,b03,b04,b05,b06,b07, + b08,b09,b10,b11,b12,b13,b14,b15, + b16,b17,b18,b19,b20,b21,b22,b23, + b24,b25,b26,b27,b28,b29,b30,b31, + b32,b33,b34,b35,b36,b37,b38,b39, + b40,b41,b42,b43,b44,b45,b46,b47, + b48,b49,b50,b51,b52,b53,b54,b55, + b56,b57,b58,b59,b60,b61,b62,b63); + bset = set of bits; +var + nmax,prnt,imax : integer; + nmsqrt : integer; + wimax,iw : integer; + i,n,imin : integer; + np,il,nl : integer; + rnmax : real; + sieve : ARRAY[0 .. 781250] of bset; + btst : ARRAY[0 .. 63 ] of bset; + bclr : ARRAY[0 .. 63 ] of bset; + b : bits; + ball : bset; +begin + + ball := [b00 .. b63]; + b := b00; + btst[0] := [b]; + bclr[0] := ball - [b]; + for i := 1 to 63 do begin + b := succ(b); + btst[i] := [b]; + bclr[i] := ball - [b]; + end; + + read(nmax); + read(prnt); + + if (nmax < 10) or (nmax > 100000000) then begin + writeln(' ', 'nmax out of range (10...100000000), abort'); + exit(8); + end; + + rnmax := nmax; + nmsqrt := trunc(sqrt(nmax)); + imax := (nmax-1) div 2; + wimax := (imax+63) div 64; + for i := 0 to wimax do sieve[i] := ball; + + n := 3; + while n <= nmsqrt do begin + i := n div 2; + if btst[i mod 64] <= sieve[i div 64] then begin + i := (n*n) div 2; + while i <= imax do begin + iw := i div 64; + sieve[iw] := sieve[iw] * bclr[i mod 64]; + i := i + n; + end; + end; + n := n + 2; + end; + + if prnt > 0 then begin + writeln(' ', 'List of Primes up to ', nmax:9); + write(2:8); + np := 1; + for i := 1 to imax do begin + if btst[i mod 64] <= sieve[i div 64] then begin + write(1+2*i:8); + np := np + 1; + if np = 10 then begin + writeln(' '); + np := 0; + end; + end; + end; + if np > 0 then writeln(); + end; + + il := 4; + nl := 10; + np := 1; + for i := 1 to imax do begin + if btst[i mod 64] <= sieve[i div 64] then np := np + 1; + if i = il then begin + nl := 2*il + 2; + writeln(' ', 'pi(', nl:9, '): ', np:9); + il := 10*(il+1)-1; + end; + end; + + if nl < nmax then writeln(' ', 'pi(', nmax:9, '): ', np:9); + +end. +/* +//GO.OUTPUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=SOEQPLIF,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#PLI JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=2200K,TIME=(5,0),PRTY=2 +//CLG EXEC PL1LFCLG, +// PARM.PL1L='LOAD,NODECK,OPT=2', +// PARM.LKED='MAP,LIST' +//PL1L.SYSLIN DD UNIT=SYSDA +//PL1L.SYSIN DD * +/* 1 2 3 4 5 6 7*/-------- +/*4567890123456789012345678901234567890123456789012345678901234567890*/-------- +/* $Id: soeq_pli.pli 976 2017-12-26 15:35:59Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-26 976 1.3 rename to SOEQ; go for max PRIME size */ +/* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end */ +/* 2017-12-25 974 1.1 use 2-dim PRIME array */ +/* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 */ +/* 2017-09-17 951 1.0 Initial version */ +/* 2017-09-01 945 0.1 First draft */ + + SOEQ: PROC OPTIONS(MAIN) REORDER; + DCL (NMAX,PRNT,IMAX) BIN FIXED(31) INIT(0); + DCL (NMSQRT) BIN FIXED(31) INIT(0); + DCL (I,N,IMIN) BIN FIXED(31) INIT(0); + DCL (NP,IL,NL) BIN FIXED(31) INIT(0); + /* in PL/I(F) V5.5 array bounds are BIN(15) ! limited to 32k !! */ + /* And the maximal aggregate size is 2 MByte !! BIT arrays are */ + /* bit packed, so maximal total bit array size is 16 M entries. */ + /* So go for a 2-dimensional array; 15626*1024 = 16001024; */ + /* use 0 as lower bound to make index calculations easy: */ + /* PRIME(I) turns into PRIME(I/1024,MOD(I,1024)) */ + DCL PRIME(0:15625,0:1023) BIT(1); + + ON ENDFILE(SYSIN) BEGIN; + PUT SKIP EDIT('Unexpected EOF, abort')(A); + GOTO DONE; + END; + ON CONVERSION BEGIN; + PUT SKIP EDIT('Conversion error, abort')(A); + GOTO DONE; + END; + + GET EDIT(NMAX,PRNT) (F(10),F(10)); + + /*IF NMAX < 10 | NMAX > 32000000 THEN DO;*/ + IF NMAX > 32000000 THEN DO; + PUT SKIP EDIT('nmax out of range (10...32000000), abort') (A); + GOTO DONE; + END; + + NMSQRT = FLOOR(SQRT(NMAX)); + IMAX = (NMAX-1)/2; + + DO I=1 TO IMAX; + PRIME(I/1024,MOD(I,1024)) = '1'B; + END; + + DO N=3 TO NMSQRT BY 2; + I = N/2; + IF PRIME(I/1024,MOD(I,1024)) THEN DO; + IMIN = N*N/2; + DO I=IMIN TO IMAX BY N; + PRIME(I/1024,MOD(I,1024)) = '0'B; + END; + END; + END; + + IF PRNT > 0 THEN DO; + PUT SKIP EDIT('List of Primes up to ',NMAX) (A,F(8)); + PUT SKIP EDIT(' ',2) (A,F(7)); + NP = 1; + DO I=1 TO IMAX; + IF PRIME(I/1024,MOD(I,1024)) THEN DO; + PUT EDIT(' ',1+2*I) (A,F(7)); + NP = NP + 1; + IF NP = 10 THEN DO; + PUT SKIP; + NP = 0; + END; + END; + END; + IF NP > 0 THEN PUT SKIP; + END; + + IL = 4; + NL = 10; + NP = 1; + DO I=1 TO IMAX; + IF PRIME(I/1024,MOD(I,1024)) THEN NP = NP + 1; + IF I = IL THEN DO; + NL = 2*IL + 2; + PUT SKIP EDIT('pi(',NL,'): ',NP) (A,F(8),A,F(8)); + IL = 10*(IL+1)-1; + END; + END; + + IF NL < NMAX THEN PUT SKIP EDIT('pi(',NMAX,'): ',NP) + (A,F(8),A,F(8)); + + DONE:; + + END SOEQ; +/* +//LKED.SYSLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.STEPLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.SYSIN DD * + 32000000 0 +/* +// +./ ADD NAME=SOEQPLIP,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#PLI JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=2200K,TIME=(2,0),PRTY=8 +//CLG EXEC PL1LFCLG, +// PARM.PL1L='LOAD,NODECK,OPT=2', +// PARM.LKED='MAP,LIST' +//PL1L.SYSLIN DD UNIT=SYSDA +//PL1L.SYSIN DD * +/* 1 2 3 4 5 6 7*/-------- +/*4567890123456789012345678901234567890123456789012345678901234567890*/-------- +/* $Id: soeq_pli.pli 976 2017-12-26 15:35:59Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-26 976 1.3 rename to SOEQ; go for max PRIME size */ +/* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end */ +/* 2017-12-25 974 1.1 use 2-dim PRIME array */ +/* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 */ +/* 2017-09-17 951 1.0 Initial version */ +/* 2017-09-01 945 0.1 First draft */ + + SOEQ: PROC OPTIONS(MAIN) REORDER; + DCL (NMAX,PRNT,IMAX) BIN FIXED(31) INIT(0); + DCL (NMSQRT) BIN FIXED(31) INIT(0); + DCL (I,N,IMIN) BIN FIXED(31) INIT(0); + DCL (NP,IL,NL) BIN FIXED(31) INIT(0); + /* in PL/I(F) V5.5 array bounds are BIN(15) ! limited to 32k !! */ + /* And the maximal aggregate size is 2 MByte !! BIT arrays are */ + /* bit packed, so maximal total bit array size is 16 M entries. */ + /* So go for a 2-dimensional array; 15626*1024 = 16001024; */ + /* use 0 as lower bound to make index calculations easy: */ + /* PRIME(I) turns into PRIME(I/1024,MOD(I,1024)) */ + DCL PRIME(0:15625,0:1023) BIT(1); + + ON ENDFILE(SYSIN) BEGIN; + PUT SKIP EDIT('Unexpected EOF, abort')(A); + GOTO DONE; + END; + ON CONVERSION BEGIN; + PUT SKIP EDIT('Conversion error, abort')(A); + GOTO DONE; + END; + + GET EDIT(NMAX,PRNT) (F(10),F(10)); + + /*IF NMAX < 10 | NMAX > 32000000 THEN DO;*/ + IF NMAX > 32000000 THEN DO; + PUT SKIP EDIT('nmax out of range (10...32000000), abort') (A); + GOTO DONE; + END; + + NMSQRT = FLOOR(SQRT(NMAX)); + IMAX = (NMAX-1)/2; + + DO I=1 TO IMAX; + PRIME(I/1024,MOD(I,1024)) = '1'B; + END; + + DO N=3 TO NMSQRT BY 2; + I = N/2; + IF PRIME(I/1024,MOD(I,1024)) THEN DO; + IMIN = N*N/2; + DO I=IMIN TO IMAX BY N; + PRIME(I/1024,MOD(I,1024)) = '0'B; + END; + END; + END; + + IF PRNT > 0 THEN DO; + PUT SKIP EDIT('List of Primes up to ',NMAX) (A,F(8)); + PUT SKIP EDIT(' ',2) (A,F(7)); + NP = 1; + DO I=1 TO IMAX; + IF PRIME(I/1024,MOD(I,1024)) THEN DO; + PUT EDIT(' ',1+2*I) (A,F(7)); + NP = NP + 1; + IF NP = 10 THEN DO; + PUT SKIP; + NP = 0; + END; + END; + END; + IF NP > 0 THEN PUT SKIP; + END; + + IL = 4; + NL = 10; + NP = 1; + DO I=1 TO IMAX; + IF PRIME(I/1024,MOD(I,1024)) THEN NP = NP + 1; + IF I = IL THEN DO; + NL = 2*IL + 2; + PUT SKIP EDIT('pi(',NL,'): ',NP) (A,F(8),A,F(8)); + IL = 10*(IL+1)-1; + END; + END; + + IF NL < NMAX THEN PUT SKIP EDIT('pi(',NMAX,'): ',NP) + (A,F(8),A,F(8)); + + DONE:; + + END SOEQ; +/* +//LKED.SYSLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.STEPLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.SYSIN DD * + 10000000 1 +/* +// +./ ADD NAME=SOEQPLIT,LEVEL=00,SOURCE=0,LIST=ALL +//SOEQ#PLI JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=2200K,TIME=(1,0),PRTY=8 +//CLG EXEC PL1LFCLG, +// PARM.PL1L='LOAD,NODECK,OPT=2', +// PARM.LKED='MAP,LIST' +//PL1L.SYSLIN DD UNIT=SYSDA +//PL1L.SYSIN DD * +/* 1 2 3 4 5 6 7*/-------- +/*4567890123456789012345678901234567890123456789012345678901234567890*/-------- +/* $Id: soeq_pli.pli 976 2017-12-26 15:35:59Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-26 976 1.3 rename to SOEQ; go for max PRIME size */ +/* 2017-12-25 975 1.2 use sqrt(nmax) as outer loop end */ +/* 2017-12-25 974 1.1 use 2-dim PRIME array */ +/* 2017-12-23 972 1.0.1 change (n-1)/2 --> n/2 */ +/* 2017-09-17 951 1.0 Initial version */ +/* 2017-09-01 945 0.1 First draft */ + + SOEQ: PROC OPTIONS(MAIN) REORDER; + DCL (NMAX,PRNT,IMAX) BIN FIXED(31) INIT(0); + DCL (NMSQRT) BIN FIXED(31) INIT(0); + DCL (I,N,IMIN) BIN FIXED(31) INIT(0); + DCL (NP,IL,NL) BIN FIXED(31) INIT(0); + /* in PL/I(F) V5.5 array bounds are BIN(15) ! limited to 32k !! */ + /* And the maximal aggregate size is 2 MByte !! BIT arrays are */ + /* bit packed, so maximal total bit array size is 16 M entries. */ + /* So go for a 2-dimensional array; 15626*1024 = 16001024; */ + /* use 0 as lower bound to make index calculations easy: */ + /* PRIME(I) turns into PRIME(I/1024,MOD(I,1024)) */ + DCL PRIME(0:15625,0:1023) BIT(1); + + ON ENDFILE(SYSIN) BEGIN; + PUT SKIP EDIT('Unexpected EOF, abort')(A); + GOTO DONE; + END; + ON CONVERSION BEGIN; + PUT SKIP EDIT('Conversion error, abort')(A); + GOTO DONE; + END; + + GET EDIT(NMAX,PRNT) (F(10),F(10)); + + /*IF NMAX < 10 | NMAX > 32000000 THEN DO;*/ + IF NMAX > 32000000 THEN DO; + PUT SKIP EDIT('nmax out of range (10...32000000), abort') (A); + GOTO DONE; + END; + + NMSQRT = FLOOR(SQRT(NMAX)); + IMAX = (NMAX-1)/2; + + DO I=1 TO IMAX; + PRIME(I/1024,MOD(I,1024)) = '1'B; + END; + + DO N=3 TO NMSQRT BY 2; + I = N/2; + IF PRIME(I/1024,MOD(I,1024)) THEN DO; + IMIN = N*N/2; + DO I=IMIN TO IMAX BY N; + PRIME(I/1024,MOD(I,1024)) = '0'B; + END; + END; + END; + + IF PRNT > 0 THEN DO; + PUT SKIP EDIT('List of Primes up to ',NMAX) (A,F(8)); + PUT SKIP EDIT(' ',2) (A,F(7)); + NP = 1; + DO I=1 TO IMAX; + IF PRIME(I/1024,MOD(I,1024)) THEN DO; + PUT EDIT(' ',1+2*I) (A,F(7)); + NP = NP + 1; + IF NP = 10 THEN DO; + PUT SKIP; + NP = 0; + END; + END; + END; + IF NP > 0 THEN PUT SKIP; + END; + + IL = 4; + NL = 10; + NP = 1; + DO I=1 TO IMAX; + IF PRIME(I/1024,MOD(I,1024)) THEN NP = NP + 1; + IF I = IL THEN DO; + NL = 2*IL + 2; + PUT SKIP EDIT('pi(',NL,'): ',NP) (A,F(8),A,F(8)); + IL = 10*(IL+1)-1; + END; + END; + + IF NL < NMAX THEN PUT SKIP EDIT('pi(',NMAX,'): ',NP) + (A,F(8),A,F(8)); + + DONE:; + + END SOEQ; +/* +//LKED.SYSLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.STEPLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.SYSIN DD * + 100000 1 +/* +// +./ ADD NAME=TOWHA60F,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#A60 JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(10,0),PRTY=2 +//CLG EXEC ALGOFCLG, +// PARM.ALGOL='', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='' +//ALGOL.SYSIN DD * +'BEGIN' +'COMMENT' +* $Id: towh_a60.a60 964 2017-11-19 08:47:46Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-09-05 946 1.0 Initial version +*; + + 'INTEGER' NCALL,NMOVE; + 'INTEGER' CURSTK,MAXSTK; + 'INTEGER' MAXDSK,TRACE; + 'INTEGER' 'ARRAY' TOW[1:3]; + 'INTEGER' NDSK; + + 'PROCEDURE' TRC(TXT,N,F,T); + 'STRING' TXT; + 'VALUE' N,F,T; + 'INTEGER' N,F,T; + 'BEGIN' + OUTSTRING (1, TXT); + OUTINTEGER(1, NDSK); + OUTSTRING (1,'(' :')'); + OUTINTEGER(1, N); + OUTINTEGER(1, F); + OUTINTEGER(1, T); + OUTSTRING (1,'(' :')'); + OUTTARRAY (1, TOW); + SYSACT(1,14,1); + 'END'; + + 'PROCEDURE' MOV(N,F,T); + 'VALUE' N,F,T; + 'INTEGER' N,F,T; + 'BEGIN' + 'INTEGER' O; + O := 6-(F+T); + CURSTK := CURSTK + 1; + NCALL := NCALL + 1; + 'IF' CURSTK > MAXSTK 'THEN' MAXSTK := CURSTK; + + 'IF' N = 1 'THEN' 'BEGIN' + NMOVE := NMOVE + 1; + TOW[F] := TOW[F] - 1; + TOW[T] := TOW[T] + 1; + 'IF' TRACE > 0 'THEN' TRC('('mov-do: ')',N,F,T); + 'END' + 'ELSE' 'BEGIN' + 'IF' TRACE > 0 'THEN' TRC('('mov-go: ')',N,F,T); + MOV(N-1,F,O); + MOV(1,F,T); + MOV(N-1,O,T); + 'END'; + + CURSTK := CURSTK - 1; + 'END'; + + 'COMMENT' set record lenth = 132 and page length = 62; + SYSACT(1,6,132); + SYSACT(1,8,64); + + ININTEGER(0,MAXDSK); + ININTEGER(0,TRACE); + + 'FOR' NDSK := 2 'STEP' 1 'UNTIL' MAXDSK 'DO' 'BEGIN' + NCALL := 0; + NMOVE := 0; + MAXSTK := 0; + CURSTK := 0; + TOW[1] := NDSK; + TOW[2] := 0; + TOW[3] := 0; + 'IF' TRACE > 0 'THEN' 'BEGIN' + OUTSTRING (1,'('STRT ndsk=')'); + OUTINTEGER(1, NDSK); + SYSACT(1,14,1); + 'END'; + MOV(NDSK,1,3); + OUTSTRING (1,'('DONE ndsk=')'); + OUTINTEGER(1, NDSK); + OUTSTRING (1,'(': maxstk=')'); + OUTINTEGER(1, MAXSTK); + OUTSTRING (1,'(' ncall=')'); + OUTINTEGER(1, NCALL); + OUTSTRING (1,'(' nmove=')'); + OUTINTEGER(1, NMOVE); + SYSACT(1,14,1); + 'END'; + +'END' +/* +//GO.ALGLDD01 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 22 0 +/* +// +./ ADD NAME=TOWHA60T,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#A60 JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(1,0),PRTY=8 +//CLG EXEC ALGOFCLG, +// PARM.ALGOL='', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='' +//ALGOL.SYSIN DD * +'BEGIN' +'COMMENT' +* $Id: towh_a60.a60 964 2017-11-19 08:47:46Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-09-05 946 1.0 Initial version +*; + + 'INTEGER' NCALL,NMOVE; + 'INTEGER' CURSTK,MAXSTK; + 'INTEGER' MAXDSK,TRACE; + 'INTEGER' 'ARRAY' TOW[1:3]; + 'INTEGER' NDSK; + + 'PROCEDURE' TRC(TXT,N,F,T); + 'STRING' TXT; + 'VALUE' N,F,T; + 'INTEGER' N,F,T; + 'BEGIN' + OUTSTRING (1, TXT); + OUTINTEGER(1, NDSK); + OUTSTRING (1,'(' :')'); + OUTINTEGER(1, N); + OUTINTEGER(1, F); + OUTINTEGER(1, T); + OUTSTRING (1,'(' :')'); + OUTTARRAY (1, TOW); + SYSACT(1,14,1); + 'END'; + + 'PROCEDURE' MOV(N,F,T); + 'VALUE' N,F,T; + 'INTEGER' N,F,T; + 'BEGIN' + 'INTEGER' O; + O := 6-(F+T); + CURSTK := CURSTK + 1; + NCALL := NCALL + 1; + 'IF' CURSTK > MAXSTK 'THEN' MAXSTK := CURSTK; + + 'IF' N = 1 'THEN' 'BEGIN' + NMOVE := NMOVE + 1; + TOW[F] := TOW[F] - 1; + TOW[T] := TOW[T] + 1; + 'IF' TRACE > 0 'THEN' TRC('('mov-do: ')',N,F,T); + 'END' + 'ELSE' 'BEGIN' + 'IF' TRACE > 0 'THEN' TRC('('mov-go: ')',N,F,T); + MOV(N-1,F,O); + MOV(1,F,T); + MOV(N-1,O,T); + 'END'; + + CURSTK := CURSTK - 1; + 'END'; + + 'COMMENT' set record lenth = 132 and page length = 62; + SYSACT(1,6,132); + SYSACT(1,8,64); + + ININTEGER(0,MAXDSK); + ININTEGER(0,TRACE); + + 'FOR' NDSK := 2 'STEP' 1 'UNTIL' MAXDSK 'DO' 'BEGIN' + NCALL := 0; + NMOVE := 0; + MAXSTK := 0; + CURSTK := 0; + TOW[1] := NDSK; + TOW[2] := 0; + TOW[3] := 0; + 'IF' TRACE > 0 'THEN' 'BEGIN' + OUTSTRING (1,'('STRT ndsk=')'); + OUTINTEGER(1, NDSK); + SYSACT(1,14,1); + 'END'; + MOV(NDSK,1,3); + OUTSTRING (1,'('DONE ndsk=')'); + OUTINTEGER(1, NDSK); + OUTSTRING (1,'(': maxstk=')'); + OUTINTEGER(1, MAXSTK); + OUTSTRING (1,'(' ncall=')'); + OUTINTEGER(1, NCALL); + OUTSTRING (1,'(' nmove=')'); + OUTINTEGER(1, NMOVE); + SYSACT(1,14,1); + 'END'; + +'END' +/* +//GO.ALGLDD01 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 4 1 +/* +// +./ ADD NAME=TOWHASMF,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#ASM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=128K,TIME=(10,0),PRTY=2 +//CLG EXEC ASMFCLG, +// MAC1='SYS2.MACLIB', +// PARM.ASM='NOLIST,NOXREF,NORLD,NODECK,LOAD', +// PARM.LKED='MAP,LIST,LET,NCAL', +// COND.LKED=(8,LE,ASM), +// PARM.GO='', +// COND.GO=((8,LE,ASM),(4,LT,LKED)) +//ASM.SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(600,100)) +//ASM.SYSUT2 DD DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSUT3 DD DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSGO DD DSN=&&OBJSET,UNIT=SYSDA,SPACE=(80,(2000,500)) +//ASM.SYSIN DD * +* 1 2 3 4 5 6 71 +*23456789*12345*789012345678901234*678901234567890123456789012345678901 +* $Id: towh_asm.asm 968 2017-12-03 16:58:43Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software; you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-11-12 961 1.0 Initial version +* 2017-10-10 955 0.1 First draft +* + PRINT NOGEN don't show macro expansions +* +* Tower of Hanoi +* RC = 0 ok +* RC = 4 MAXDSK out of range +* RC = 8 unexpected SYSIN EOF +* RC = 12 open SYSIN failed +* RC = 16 open SYSPRINT failed +* +* local macros -------------------------------------------------------- +* +* +* OTXTDSC - setup text descriptor for simple output system - +* + MACRO +&LABEL OTXTDSC &TEXT +TEXT CSECT +SPTR&SYSNDX DC &TEXT +&SYSECT CSECT + DS 0F +&LABEL DC AL1(L'SPTR&SYSNDX),AL3(SPTR&SYSNDX) + MEND +* +* main preamble ------------------------------------------------------- +* +MAIN START 0 start main code csect at base 0 + SAVE (14,12) Save input registers + LR R12,R15 base register := entry address + USING MAIN,R12 declare base register + L R15,=A(STACK) R15 := current save area + ST R13,4(R15) set back pointer in current save area + LR R2,R13 remember callers save area + LR R13,R15 setup current save area + ST R13,8(R2) set forw pointer in callers save area +* +* open datasets ------------------------------------------------------- +* + OPEN (SYSPRINT,OUTPUT) open SYSPRINT + LTR R15,R15 test return code + BE OOPENOK + MVI RC+3,X'10' + B EXIT quit with RC=16 +OOPENOK OPEN (SYSIN,INPUT) open SYSIN + LTR R15,R15 test return code + BE IOPENOK + MVI RC+3,X'0C' + B EXIT quit with RC=12 +IOPENOK EQU * +* +* read input parameters, and check range ------------------------------ +* + BAL R14,IGETLINE read input line + BAL R14,IINT05 get NMAX + ST R1,MAXDSK + BAL R14,IINT05 get PRNT + STC R1,TRACE +* + L R1,MAXDSK + C R1,=F'2' is MAXDSK >= 2 + BL MAXDBAD if < not + C R1,=F'30' is MAXDSK <= 30 + BNH MAXDOK if <= yes +MAXDBAD L R1,MSGPERR + BAL R14,OTEXT print error + BAL R14,OPUTLINE write line + MVI RC+3,X'04' + B EXIT quit with RC=4 +MAXDOK EQU * +* +* outer loop over ndsk cases ------------------------------------------ +* +DLOOP XR R2,R2 R2 := 0 + ST R2,NCALL ncall = 0 + ST R2,NMOVE nmove = 0 + ST R2,MAXSTK maxstk = 0 + ST R2,CURSTK curstk = 0 + L R3,NDSK + ST R3,TOW+4 tow[1] = ndsk + ST R2,TOW+8 tow[2] = 0 + ST R2,TOW+12 tow[3] = 0 +* + CLI TRACE,X'00' trace enabled ? + BE NOTRCLP + L R1,MSGSTRT + BAL R14,OTEXT print "STRT..." + LR R1,R3 + BAL R14,OINT04 print ndsk + BAL R14,OPUTLINE write line +NOTRCLP EQU * +* + LR R0,R3 + LA R1,1 + LA R2,3 + LA R15,MOV + BALR R14,R15 mov(ndsk,1,3) +* + L R1,MSGDONE + BAL R14,OTEXT print "DONE..." + L R1,NDSK + BAL R14,OINT04 print ndsk + L R1,MSGDOSTK + BAL R14,OTEXT print " maxstk..." + L R1,MAXSTK + BAL R14,OINT04 print maxstk + L R1,MSGDONCA + BAL R14,OTEXT print " ncall..." + L R1,NCALL + BAL R14,OINT10 print ncall + L R1,MSGDONMO + BAL R14,OTEXT print " nmove..." + L R1,NMOVE + BAL R14,OINT10 print nmove + BAL R14,OPUTLINE write line +* + L R1,NDSK R1 := ndsk + LA R1,1(R1) R1 := ndsk + 1 + C R1,MAXDSK is ndsk+1 <= maxdsk + ST R1,NDSK ndsk++ + BNH DLOOP if <= yes, go for next size +* +* close datasets and return to OS ------------------------------------- +* +EXIT CLOSE SYSPRINT close SYSPRINT + CLOSE SYSIN close SYSIN + L R15,=A(STACK) + L R13,4(R15) get old save area back + L R0,RC get return code + ST R0,16(R13) store in old save R15 + RETURN (14,12) return to OS (will setup RC) +* +* mov function (called recursively) ----------------------------------- +* +* mov(n,f,t) +* Register usage +* R0 n (input) +* R1 f (input) +* R2 t (input) +* R3 copy of n +* R4 copy of f +* R5 copy of t +* R6 work register +* R7 work register +* R8 constant 1 (used often) +* R9 used as linkage for MOVTRC +* R10 not used +* R11 not used +* R12 base (kept from caller !) +* +* +* +MOV SAVE (14,10) Save input registers (not R11,R12) + LA R15,(4*18)(R13) R15 := current save area + ST R13,4(R15) set back pointer in current save area + LR R3,R13 remember callers save area + LR R13,R15 setup current save area + ST R13,8(R3) set forw pointer in callers save area +* + LR R3,R0 keep n + LR R4,R1 keep f + LR R5,R2 keep t + LA R8,1 constant 1 (often used below) +* + L R6,CURSTK + AR R6,R8 + ST R6,CURSTK curstk++ + C R6,MAXSTK is curstk > maxstk ? + BNH MAXSTKOK if <= not, skip maxstk + ST R6,MAXSTK maxstk = curstk +MAXSTKOK EQU * +* + L R6,NCALL + AR R6,R8 + ST R6,NCALL ncall++ +* + CR R3,R8 is n == 1 ? + BNE MOVGO if != not, mov-go case +* +* mov-do case +* + L R6,NMOVE + AR R6,R8 + ST R6,NMOVE nmove++ + LR R7,R4 R7 := f + SLA R7,2 + L R6,TOW(R7) R6 := tow[f] + SR R6,R8 + ST R6,TOW(R7) tow[f]-- + LR R7,R5 R7 := t + SLA R7,2 + L R6,TOW(R7) R6 := tow[t] + AR R6,R8 + ST R6,TOW(R7) tow[t]++ +* + CLI TRACE,X'00' trace enabled ? + BE NOTRCDO + L R1,MSGTRCDO + BAL R9,MOVTRC +NOTRCDO EQU * +* + B MOVEND +* +* mov-go case +* +MOVGO EQU * + CLI TRACE,X'00' trace enabled ? + BE NOTRCGO + L R1,MSGTRCGO + BAL R9,MOVTRC +NOTRCGO EQU * +* + LR R6,R3 + SR R6,R8 R6 := n-1 + LA R7,6 + SR R7,R4 + SR R7,R5 R7 := 6-(f+t) +* + LA R15,MOV + LR R0,R6 R0 := n-1 + LR R1,R4 R1 := f + LR R2,R7 R2 := o + BALR R14,R15 mov(n-1,f,o) +* + LA R0,1 R0 := 1 + LR R1,R4 R1 := f + LR R2,R5 R2 := t + BALR R14,R15 mov(1,f,t) +* + LR R0,R6 R0 := n-1 + LR R1,R7 R0 := o + LR R2,R5 R0 := t + BALR R14,R15 mov(n-1,o,t) +* +MOVEND EQU * + L R5,CURSTK + SR R5,R8 + ST R5,CURSTK curstk-- + L R13,4(R13) get old save area back + RETURN (14,10),T return to caller +* +* local print handler +* used with BAL 9, no local frame !! +* +MOVTRC BAL R14,OTEXT print prefix + L R1,CURSTK + BAL R14,OINT04 print curstk + L R1,MSGCSEP + BAL R14,OTEXT print " : " + LR R1,R3 + BAL R14,OINT04 print n + LR R1,R4 + BAL R14,OINT04 print f + LR R1,R5 + BAL R14,OINT04 print t + L R1,MSGCSEP + BAL R14,OTEXT print " : " + L R1,TOW+4 + BAL R14,OINT04 print tow[1] + L R1,TOW+8 + BAL R14,OINT04 print tow[2] + L R1,TOW+12 + BAL R14,OINT04 print tow[3] + BAL R14,OPUTLINE write line + BR R9 +* +* include simple output system ---------------------------------------- +* +* simple output system procedures ------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* OSKIP02 -------------------------------------------------- +* add 2 blanks +* +OSKIP02 LA R1,2 +* +* OSKIP ---------------------------------------------------- +* add blanks, count in R1 +* +OSKIP A R1,OLPTR new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OTAB ---------------------------------------------------- +* set output column, position in R1 +* +OTAB A R1,=A(OLBUF+1) new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OSFILL --------------------------------------------------- +* add " ***" pattern, total length in R1 +* +OSFILL L R15,OLPTR R15 points to edit position + MVI 0(R15),C' ' initial blank + B OSFILLN +OSFILLL MVI 0(R15),C'*' further '*' +OSFILLN LA R15,1(R15) + BCT R1,OSFILLL + ST R15,OLPTR store pointer + BR R14 +* +* OTEXT ---------------------------------------------------- +* print text, R1 hold descriptor address +* descriptor format +* DC AL1() +* DC AL2(
) +* +OTEXT ST R14,OTEXTL save R14 + LR R14,R1 + SRL R14,24 R14 now string length + L R15,OLPTR R15 points to edit position + LR R0,R15 R0 too + AR R0,R14 push pointer, add length + ST R0,OLPTR store pointer + BCTR R14,0 decrement length for EX + EX R14,OTEXTMVC copy string via EX:MVC + L R14,OTEXTL restore R14 linkage + BR R14 +* +OTEXTMVC MVC 0(1,R15),0(R1) length via EX, dst R15, src R1 +OTEXTL DS F save area for R14 (return linkage) +* +* OPUTLINE ------------------------------------------------- +* write line to SYSPRINT +* +OPUTLINE ST R14,OPUTLNEL save R14 + L R15,=A(OLBUF) + CLI 133(R15),X'00' check fence byte + BNE OPUTLNEA crash if fence blown + L R1,=A(SYSPRINT) R1 point to DCB + LR R0,R15 R1 point to buffer + PUT (1),(0) write line + L R15,=A(OLBUF) point to CC of OLBUF + MVI 0(R15),C' ' blank OLBUF(0) + MVC 1(L'OLBUF-1,R15),0(R15) propagate blank + LA R15,1(R15) point to 1st print char in OLBUF + ST R15,OLPTR reset current position pointer + LA R15,1 + AH R15,OLCNT increment line counter + STH R15,OLCNT + SH R15,OLMAX R15 := OLCNT-OLMAX + BL OPUTLNES if < no new page + XR R15,R15 R15 := 0 + SH R15,OLCNT clear line counter + L R15,=A(OLBUF) point to CC of OLBUF +* MVI 0(R15),C'1' set new page CC in OLBUF +OPUTLNES L R14,OPUTLNEL restore R14 linkage + BR R14 +* +OPUTLNEA ABEND 255 abend in case of errors +* +OPUTLNEL DS F save area for R14 (return linkage) +* +* Work area for simple output system ------------------------ +* +OLPTR DC A(OLBUF+1) current output line position +OLCNT DC H'0' line counter +OLMAX DC H'60' lines per page +OCVD DS D buffer for CVD (8 byte, DW aligned) +* +ODTEMP DS D double buffer for conversions +ODNZERO DC X'4E000000',X'00000000' denormalized double zero +ODNONE DC X'4E000000',X'00000001' denormalized double one +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSPRINT DCB DSORG=PS,MACRF=PM,DDNAME=SYSPRINT, X + RECFM=FBA,LRECL=133,BLKSIZE=0 +OLBUF DC CL133' ',X'00' output line buffer and fence byte +* +MAIN CSECT +* +* OINT10 --------------------------------------------------- +* print integer, like PL/I F(10) or C %10d format +* very fast, for non-negative numbers only ! +* +OINT10 CL R1,=F'999999999' too large ? + BH OINT10F if > yes, do OSFILL + CVD R1,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEI10L,R15),OEI10 setup pattern + ED 0(OEI10L,R15),OCVD+3 and edit + LA R15,OEI10L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OINT10F LA R1,10 + B OSFILL +* +OEI10 DC C' ',7X'20',X'21',X'20' pat: bddddddd(d +OEI10L EQU *-OEI10 +* +* OINT04 --------------------------------------------------- +* print integer, like PL/I F(4) or C %4d format +* very fast, for non-negative numbers only ! +* +OINT04 LA R15,999 + CLR R1,R15 too large ? + BH OINT04F if > yes, do OSFILL + CVD R1,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEI04L,R15),OEI04 setup pattern + ED 0(OEI04L,R15),OCVD+6 and edit + LA R15,OEI04L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OINT04F LA R1,4 + B OSFILL +* +OEI04 DC C' ',X'20',X'21',X'20' ED pattern: bd(d +OEI04L EQU *-OEI04 +* include simple input system ----------------------------------------- +* +* simple input system procedures -------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* IGETLINE ------------------------------------------------- +* read line from SYSIN +* EOF handling: +* - IEOFOK holds the 'EOF OK' flag +* - if EOF seen and IEOFOK = X'00', program ends with RC=8 +* - if EOF seen and IEOFOK != X'00', program ends with RC=0 +* +IGETLINE ST R14,IGETLNEL save R14 + L R1,=A(SYSIN) + L R0,=A(ILBUF) + GET (1),(0) read line + L R0,=A(ILBUF) + ST R0,ILPTR set input ptr to begin of line + L R14,IGETLNEL restore R14 linkage + BR R14 +* +IGETLNEL DS F save area for R14 (return linkage) +* +* IEOFHDL -------------------------------------------------- +* +IEOFHDL BALR R12,R0 where are we ? + LA R15,*-MAIN offset from MAIN to here + SR R12,R15 base reg now points to MAIN + LA R14,EXIT + CLI IEOFOK,X'00' is EOF ok ? + BNER R14 if != yes, jump to EXIT + MVI RC+3,X'08' otherwise set RC=8 + BR R14 and jump to EXIT +* +* Work area for simple output system ------------------------ +* +ILPTR DC A(ILBUF) current input line position +IEOFOK DS X'00' EOF ok flag +ICVB DS D buffer for CVB (8 byte, DW aligned) +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSIN DCB DSORG=PS,MACRF=GM,DDNAME=SYSIN,EODAD=IEOFHDL X + RECFM=FB,LRECL=80,BLKSIZE=0 +ILBUF DC CL80' ' input line buffer +MAIN CSECT +* +* IINT05 --------------------------------------------------- +* read integer, like PL/I F(5) or C %5d format +* +IINT05 L R15,ILPTR get input pointer + PACK ICVB(8),0(5,R15) pack next 5 char + CVB R1,ICVB and convert + LA R15,5(R15) push pointer by 5 char + ST R15,ILPTR and update + BR R14 +* +* Work area definitions ----------------------------------------------- +* +RC DC F'0' return code +MAXDSK DC F'10' maximal number of disks +TRACE DC X'00' trace enable flag +* +NDSK DC F'2' +NCALL DC F'0' +NMOVE DC F'0' +MAXSTK DC F'0' +CURSTK DC F'0' +TOW DC 4F'0' +* +* message strings +* +MSGPERR OTXTDSC C'maxdsk out of range (2...30), abort' +MSGSTRT OTXTDSC C'STRT ndsk=' +MSGDONE OTXTDSC C'DONE ndsk=' +MSGDOSTK OTXTDSC C': maxstk=' +MSGDONCA OTXTDSC C' ncall=' +MSGDONMO OTXTDSC C' nmove=' +MSGTRCDO OTXTDSC C'mov-do: ' +MSGTRCGO OTXTDSC C'mov-go: ' +MSGCSEP OTXTDSC C' : ' +* +* spill literal pool +* + LTORG +* +* Place the STACK in separate CSECT. Is quite large (~2 kByte) +* +DATA CSECT +STACK DS (32*18)F save area STACK +* +* other defs and end +* + YREGS , + END MAIN define main entry point +/* +//GO.SYSUDUMP DD SYSOUT=*,OUTLIM=2000 +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 22 0 +/* +// +./ ADD NAME=TOWHASMT,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#ASM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=128K,TIME=(1,0),PRTY=8 +//CLG EXEC ASMFCLG, +// MAC1='SYS2.MACLIB', +// PARM.ASM='NODECK,LOAD', +// PARM.LKED='MAP,LIST,LET,NCAL', +// COND.LKED=(8,LE,ASM), +// PARM.GO='', +// COND.GO=((8,LE,ASM),(4,LT,LKED)) +//ASM.SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(600,100)) +//ASM.SYSUT2 DD DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSUT3 DD DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSGO DD DSN=&&OBJSET,UNIT=SYSDA,SPACE=(80,(2000,500)) +//ASM.SYSIN DD * +* 1 2 3 4 5 6 71 +*23456789*12345*789012345678901234*678901234567890123456789012345678901 +* $Id: towh_asm.asm 968 2017-12-03 16:58:43Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software; you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-11-12 961 1.0 Initial version +* 2017-10-10 955 0.1 First draft +* + PRINT NOGEN don't show macro expansions +* +* Tower of Hanoi +* RC = 0 ok +* RC = 4 MAXDSK out of range +* RC = 8 unexpected SYSIN EOF +* RC = 12 open SYSIN failed +* RC = 16 open SYSPRINT failed +* +* local macros -------------------------------------------------------- +* +* +* OTXTDSC - setup text descriptor for simple output system - +* + MACRO +&LABEL OTXTDSC &TEXT +TEXT CSECT +SPTR&SYSNDX DC &TEXT +&SYSECT CSECT + DS 0F +&LABEL DC AL1(L'SPTR&SYSNDX),AL3(SPTR&SYSNDX) + MEND +* +* main preamble ------------------------------------------------------- +* +MAIN START 0 start main code csect at base 0 + SAVE (14,12) Save input registers + LR R12,R15 base register := entry address + USING MAIN,R12 declare base register + L R15,=A(STACK) R15 := current save area + ST R13,4(R15) set back pointer in current save area + LR R2,R13 remember callers save area + LR R13,R15 setup current save area + ST R13,8(R2) set forw pointer in callers save area +* +* open datasets ------------------------------------------------------- +* + OPEN (SYSPRINT,OUTPUT) open SYSPRINT + LTR R15,R15 test return code + BE OOPENOK + MVI RC+3,X'10' + B EXIT quit with RC=16 +OOPENOK OPEN (SYSIN,INPUT) open SYSIN + LTR R15,R15 test return code + BE IOPENOK + MVI RC+3,X'0C' + B EXIT quit with RC=12 +IOPENOK EQU * +* +* read input parameters, and check range ------------------------------ +* + BAL R14,IGETLINE read input line + BAL R14,IINT05 get NMAX + ST R1,MAXDSK + BAL R14,IINT05 get PRNT + STC R1,TRACE +* + L R1,MAXDSK + C R1,=F'2' is MAXDSK >= 2 + BL MAXDBAD if < not + C R1,=F'30' is MAXDSK <= 30 + BNH MAXDOK if <= yes +MAXDBAD L R1,MSGPERR + BAL R14,OTEXT print error + BAL R14,OPUTLINE write line + MVI RC+3,X'04' + B EXIT quit with RC=4 +MAXDOK EQU * +* +* outer loop over ndsk cases ------------------------------------------ +* +DLOOP XR R2,R2 R2 := 0 + ST R2,NCALL ncall = 0 + ST R2,NMOVE nmove = 0 + ST R2,MAXSTK maxstk = 0 + ST R2,CURSTK curstk = 0 + L R3,NDSK + ST R3,TOW+4 tow[1] = ndsk + ST R2,TOW+8 tow[2] = 0 + ST R2,TOW+12 tow[3] = 0 +* + CLI TRACE,X'00' trace enabled ? + BE NOTRCLP + L R1,MSGSTRT + BAL R14,OTEXT print "STRT..." + LR R1,R3 + BAL R14,OINT04 print ndsk + BAL R14,OPUTLINE write line +NOTRCLP EQU * +* + LR R0,R3 + LA R1,1 + LA R2,3 + LA R15,MOV + BALR R14,R15 mov(ndsk,1,3) +* + L R1,MSGDONE + BAL R14,OTEXT print "DONE..." + L R1,NDSK + BAL R14,OINT04 print ndsk + L R1,MSGDOSTK + BAL R14,OTEXT print " maxstk..." + L R1,MAXSTK + BAL R14,OINT04 print maxstk + L R1,MSGDONCA + BAL R14,OTEXT print " ncall..." + L R1,NCALL + BAL R14,OINT10 print ncall + L R1,MSGDONMO + BAL R14,OTEXT print " nmove..." + L R1,NMOVE + BAL R14,OINT10 print nmove + BAL R14,OPUTLINE write line +* + L R1,NDSK R1 := ndsk + LA R1,1(R1) R1 := ndsk + 1 + C R1,MAXDSK is ndsk+1 <= maxdsk + ST R1,NDSK ndsk++ + BNH DLOOP if <= yes, go for next size +* +* close datasets and return to OS ------------------------------------- +* +EXIT CLOSE SYSPRINT close SYSPRINT + CLOSE SYSIN close SYSIN + L R15,=A(STACK) + L R13,4(R15) get old save area back + L R0,RC get return code + ST R0,16(R13) store in old save R15 + RETURN (14,12) return to OS (will setup RC) +* +* mov function (called recursively) ----------------------------------- +* +* mov(n,f,t) +* Register usage +* R0 n (input) +* R1 f (input) +* R2 t (input) +* R3 copy of n +* R4 copy of f +* R5 copy of t +* R6 work register +* R7 work register +* R8 constant 1 (used often) +* R9 used as linkage for MOVTRC +* R10 not used +* R11 not used +* R12 base (kept from caller !) +* +* +* +MOV SAVE (14,10) Save input registers (not R11,R12) + LA R15,(4*18)(R13) R15 := current save area + ST R13,4(R15) set back pointer in current save area + LR R3,R13 remember callers save area + LR R13,R15 setup current save area + ST R13,8(R3) set forw pointer in callers save area +* + LR R3,R0 keep n + LR R4,R1 keep f + LR R5,R2 keep t + LA R8,1 constant 1 (often used below) +* + L R6,CURSTK + AR R6,R8 + ST R6,CURSTK curstk++ + C R6,MAXSTK is curstk > maxstk ? + BNH MAXSTKOK if <= not, skip maxstk + ST R6,MAXSTK maxstk = curstk +MAXSTKOK EQU * +* + L R6,NCALL + AR R6,R8 + ST R6,NCALL ncall++ +* + CR R3,R8 is n == 1 ? + BNE MOVGO if != not, mov-go case +* +* mov-do case +* + L R6,NMOVE + AR R6,R8 + ST R6,NMOVE nmove++ + LR R7,R4 R7 := f + SLA R7,2 + L R6,TOW(R7) R6 := tow[f] + SR R6,R8 + ST R6,TOW(R7) tow[f]-- + LR R7,R5 R7 := t + SLA R7,2 + L R6,TOW(R7) R6 := tow[t] + AR R6,R8 + ST R6,TOW(R7) tow[t]++ +* + CLI TRACE,X'00' trace enabled ? + BE NOTRCDO + L R1,MSGTRCDO + BAL R9,MOVTRC +NOTRCDO EQU * +* + B MOVEND +* +* mov-go case +* +MOVGO EQU * + CLI TRACE,X'00' trace enabled ? + BE NOTRCGO + L R1,MSGTRCGO + BAL R9,MOVTRC +NOTRCGO EQU * +* + LR R6,R3 + SR R6,R8 R6 := n-1 + LA R7,6 + SR R7,R4 + SR R7,R5 R7 := 6-(f+t) +* + LA R15,MOV + LR R0,R6 R0 := n-1 + LR R1,R4 R1 := f + LR R2,R7 R2 := o + BALR R14,R15 mov(n-1,f,o) +* + LA R0,1 R0 := 1 + LR R1,R4 R1 := f + LR R2,R5 R2 := t + BALR R14,R15 mov(1,f,t) +* + LR R0,R6 R0 := n-1 + LR R1,R7 R0 := o + LR R2,R5 R0 := t + BALR R14,R15 mov(n-1,o,t) +* +MOVEND EQU * + L R5,CURSTK + SR R5,R8 + ST R5,CURSTK curstk-- + L R13,4(R13) get old save area back + RETURN (14,10),T return to caller +* +* local print handler +* used with BAL 9, no local frame !! +* +MOVTRC BAL R14,OTEXT print prefix + L R1,CURSTK + BAL R14,OINT04 print curstk + L R1,MSGCSEP + BAL R14,OTEXT print " : " + LR R1,R3 + BAL R14,OINT04 print n + LR R1,R4 + BAL R14,OINT04 print f + LR R1,R5 + BAL R14,OINT04 print t + L R1,MSGCSEP + BAL R14,OTEXT print " : " + L R1,TOW+4 + BAL R14,OINT04 print tow[1] + L R1,TOW+8 + BAL R14,OINT04 print tow[2] + L R1,TOW+12 + BAL R14,OINT04 print tow[3] + BAL R14,OPUTLINE write line + BR R9 +* +* include simple output system ---------------------------------------- +* +* simple output system procedures ------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* OSKIP02 -------------------------------------------------- +* add 2 blanks +* +OSKIP02 LA R1,2 +* +* OSKIP ---------------------------------------------------- +* add blanks, count in R1 +* +OSKIP A R1,OLPTR new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OTAB ---------------------------------------------------- +* set output column, position in R1 +* +OTAB A R1,=A(OLBUF+1) new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OSFILL --------------------------------------------------- +* add " ***" pattern, total length in R1 +* +OSFILL L R15,OLPTR R15 points to edit position + MVI 0(R15),C' ' initial blank + B OSFILLN +OSFILLL MVI 0(R15),C'*' further '*' +OSFILLN LA R15,1(R15) + BCT R1,OSFILLL + ST R15,OLPTR store pointer + BR R14 +* +* OTEXT ---------------------------------------------------- +* print text, R1 hold descriptor address +* descriptor format +* DC AL1() +* DC AL2(
) +* +OTEXT ST R14,OTEXTL save R14 + LR R14,R1 + SRL R14,24 R14 now string length + L R15,OLPTR R15 points to edit position + LR R0,R15 R0 too + AR R0,R14 push pointer, add length + ST R0,OLPTR store pointer + BCTR R14,0 decrement length for EX + EX R14,OTEXTMVC copy string via EX:MVC + L R14,OTEXTL restore R14 linkage + BR R14 +* +OTEXTMVC MVC 0(1,R15),0(R1) length via EX, dst R15, src R1 +OTEXTL DS F save area for R14 (return linkage) +* +* OPUTLINE ------------------------------------------------- +* write line to SYSPRINT +* +OPUTLINE ST R14,OPUTLNEL save R14 + L R15,=A(OLBUF) + CLI 133(R15),X'00' check fence byte + BNE OPUTLNEA crash if fence blown + L R1,=A(SYSPRINT) R1 point to DCB + LR R0,R15 R1 point to buffer + PUT (1),(0) write line + L R15,=A(OLBUF) point to CC of OLBUF + MVI 0(R15),C' ' blank OLBUF(0) + MVC 1(L'OLBUF-1,R15),0(R15) propagate blank + LA R15,1(R15) point to 1st print char in OLBUF + ST R15,OLPTR reset current position pointer + LA R15,1 + AH R15,OLCNT increment line counter + STH R15,OLCNT + SH R15,OLMAX R15 := OLCNT-OLMAX + BL OPUTLNES if < no new page + XR R15,R15 R15 := 0 + SH R15,OLCNT clear line counter + L R15,=A(OLBUF) point to CC of OLBUF +* MVI 0(R15),C'1' set new page CC in OLBUF +OPUTLNES L R14,OPUTLNEL restore R14 linkage + BR R14 +* +OPUTLNEA ABEND 255 abend in case of errors +* +OPUTLNEL DS F save area for R14 (return linkage) +* +* Work area for simple output system ------------------------ +* +OLPTR DC A(OLBUF+1) current output line position +OLCNT DC H'0' line counter +OLMAX DC H'60' lines per page +OCVD DS D buffer for CVD (8 byte, DW aligned) +* +ODTEMP DS D double buffer for conversions +ODNZERO DC X'4E000000',X'00000000' denormalized double zero +ODNONE DC X'4E000000',X'00000001' denormalized double one +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSPRINT DCB DSORG=PS,MACRF=PM,DDNAME=SYSPRINT, X + RECFM=FBA,LRECL=133,BLKSIZE=0 +OLBUF DC CL133' ',X'00' output line buffer and fence byte +* +MAIN CSECT +* +* OINT10 --------------------------------------------------- +* print integer, like PL/I F(10) or C %10d format +* very fast, for non-negative numbers only ! +* +OINT10 CL R1,=F'999999999' too large ? + BH OINT10F if > yes, do OSFILL + CVD R1,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEI10L,R15),OEI10 setup pattern + ED 0(OEI10L,R15),OCVD+3 and edit + LA R15,OEI10L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OINT10F LA R1,10 + B OSFILL +* +OEI10 DC C' ',7X'20',X'21',X'20' pat: bddddddd(d +OEI10L EQU *-OEI10 +* +* OINT04 --------------------------------------------------- +* print integer, like PL/I F(4) or C %4d format +* very fast, for non-negative numbers only ! +* +OINT04 LA R15,999 + CLR R1,R15 too large ? + BH OINT04F if > yes, do OSFILL + CVD R1,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEI04L,R15),OEI04 setup pattern + ED 0(OEI04L,R15),OCVD+6 and edit + LA R15,OEI04L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OINT04F LA R1,4 + B OSFILL +* +OEI04 DC C' ',X'20',X'21',X'20' ED pattern: bd(d +OEI04L EQU *-OEI04 +* include simple input system ----------------------------------------- +* +* simple input system procedures -------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* IGETLINE ------------------------------------------------- +* read line from SYSIN +* EOF handling: +* - IEOFOK holds the 'EOF OK' flag +* - if EOF seen and IEOFOK = X'00', program ends with RC=8 +* - if EOF seen and IEOFOK != X'00', program ends with RC=0 +* +IGETLINE ST R14,IGETLNEL save R14 + L R1,=A(SYSIN) + L R0,=A(ILBUF) + GET (1),(0) read line + L R0,=A(ILBUF) + ST R0,ILPTR set input ptr to begin of line + L R14,IGETLNEL restore R14 linkage + BR R14 +* +IGETLNEL DS F save area for R14 (return linkage) +* +* IEOFHDL -------------------------------------------------- +* +IEOFHDL BALR R12,R0 where are we ? + LA R15,*-MAIN offset from MAIN to here + SR R12,R15 base reg now points to MAIN + LA R14,EXIT + CLI IEOFOK,X'00' is EOF ok ? + BNER R14 if != yes, jump to EXIT + MVI RC+3,X'08' otherwise set RC=8 + BR R14 and jump to EXIT +* +* Work area for simple output system ------------------------ +* +ILPTR DC A(ILBUF) current input line position +IEOFOK DS X'00' EOF ok flag +ICVB DS D buffer for CVB (8 byte, DW aligned) +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSIN DCB DSORG=PS,MACRF=GM,DDNAME=SYSIN,EODAD=IEOFHDL X + RECFM=FB,LRECL=80,BLKSIZE=0 +ILBUF DC CL80' ' input line buffer +MAIN CSECT +* +* IINT05 --------------------------------------------------- +* read integer, like PL/I F(5) or C %5d format +* +IINT05 L R15,ILPTR get input pointer + PACK ICVB(8),0(5,R15) pack next 5 char + CVB R1,ICVB and convert + LA R15,5(R15) push pointer by 5 char + ST R15,ILPTR and update + BR R14 +* +* Work area definitions ----------------------------------------------- +* +RC DC F'0' return code +MAXDSK DC F'10' maximal number of disks +TRACE DC X'00' trace enable flag +* +NDSK DC F'2' +NCALL DC F'0' +NMOVE DC F'0' +MAXSTK DC F'0' +CURSTK DC F'0' +TOW DC 4F'0' +* +* message strings +* +MSGPERR OTXTDSC C'maxdsk out of range (2...30), abort' +MSGSTRT OTXTDSC C'STRT ndsk=' +MSGDONE OTXTDSC C'DONE ndsk=' +MSGDOSTK OTXTDSC C': maxstk=' +MSGDONCA OTXTDSC C' ncall=' +MSGDONMO OTXTDSC C' nmove=' +MSGTRCDO OTXTDSC C'mov-do: ' +MSGTRCGO OTXTDSC C'mov-go: ' +MSGCSEP OTXTDSC C' : ' +* +* spill literal pool +* + LTORG +* +* Place the STACK in separate CSECT. Is quite large (~2 kByte) +* +DATA CSECT +STACK DS (32*18)F save area STACK +* +* other defs and end +* + YREGS , + END MAIN define main entry point +/* +//GO.SYSUDUMP DD SYSOUT=*,OUTLIM=2000 +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 4 1 +/* +// +./ ADD NAME=TOWHGCCF,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#GCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(10,0),PRTY=2 +//CLG EXEC GCCCLG,COPTS='-O3', +// PARM.LKED='MAP,LIST' +//COMP.SYSIN DD DATA,DLM='/@' +/* $Id: towh_cc.c 964 2017-11-19 08:47:46Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-08-09 934 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + +#include + +void mov(int n, int f, int t); + +int ncall = 0; +int nmove = 0; +int curstk = 0; +int maxstk = 0; +int maxdsk = 0; +int trace = 0; +int tow[4]; + +int main(argc, argv) +int argc; +char *argv[]; +{ + int ndsk; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &maxdsk, &trace) != 2) { + printf("conversion error, abort\n"); + return 1; + } + + /* avoid | here, lots of fun with ASCII -> EBCDIC mapping */ + /* if (maxdsk < 2 || maxdsk > 32) { */ + if ((maxdsk < 2) + (maxdsk > 32)) { + printf("maxdsk out of range (2...32), abort\n"); + return 1; + } + + for (ndsk=2; ndsk<=maxdsk; ndsk++) { + ncall = 0; + nmove = 0; + maxstk = 0; + curstk = 0; + tow[1] = ndsk; + tow[2] = 0; + tow[3] = 0; + + if (trace) printf("STRT ndsk=%2d\n", ndsk); + mov(ndsk,1,3); + printf("DONE ndsk=%2d: maxstk=%2d ncall=%10d nmove=%10d\n", + ndsk,maxstk,ncall,nmove); + } + return 0; +} + +void mov(int n, int f, int t) +{ + int o = 6-(f+t); + curstk++; + ncall++; + if (curstk > maxstk) maxstk = curstk; + if(n == 1) { + nmove++; + tow[f]--; + tow[t]++; + if (trace) printf("mov-do: %2d : %2d %2d %2d : %2d %2d %2d\n", + curstk,n,f,t,tow[1],tow[2],tow[3]); + } else { + if (trace) printf("mov-go: %2d : %2d %2d %2d : %2d %2d %2d\n", + curstk,n,f,t,tow[1],tow[2],tow[3]); + mov(n-1,f,o); + mov(1,f,t); + mov(n-1,o,t); + } + curstk--; + return; +} +/@ +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 22 0 +/* +// +./ ADD NAME=TOWHGCCT,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#GCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(1,0),PRTY=8 +//CLG EXEC GCCCLG,COPTS='-O3', +// PARM.LKED='MAP,LIST' +//COMP.SYSIN DD DATA,DLM='/@' +/* $Id: towh_cc.c 964 2017-11-19 08:47:46Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-08-09 934 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + +#include + +void mov(int n, int f, int t); + +int ncall = 0; +int nmove = 0; +int curstk = 0; +int maxstk = 0; +int maxdsk = 0; +int trace = 0; +int tow[4]; + +int main(argc, argv) +int argc; +char *argv[]; +{ + int ndsk; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &maxdsk, &trace) != 2) { + printf("conversion error, abort\n"); + return 1; + } + + /* avoid | here, lots of fun with ASCII -> EBCDIC mapping */ + /* if (maxdsk < 2 || maxdsk > 32) { */ + if ((maxdsk < 2) + (maxdsk > 32)) { + printf("maxdsk out of range (2...32), abort\n"); + return 1; + } + + for (ndsk=2; ndsk<=maxdsk; ndsk++) { + ncall = 0; + nmove = 0; + maxstk = 0; + curstk = 0; + tow[1] = ndsk; + tow[2] = 0; + tow[3] = 0; + + if (trace) printf("STRT ndsk=%2d\n", ndsk); + mov(ndsk,1,3); + printf("DONE ndsk=%2d: maxstk=%2d ncall=%10d nmove=%10d\n", + ndsk,maxstk,ncall,nmove); + } + return 0; +} + +void mov(int n, int f, int t) +{ + int o = 6-(f+t); + curstk++; + ncall++; + if (curstk > maxstk) maxstk = curstk; + if(n == 1) { + nmove++; + tow[f]--; + tow[t]++; + if (trace) printf("mov-do: %2d : %2d %2d %2d : %2d %2d %2d\n", + curstk,n,f,t,tow[1],tow[2],tow[3]); + } else { + if (trace) printf("mov-go: %2d : %2d %2d %2d : %2d %2d %2d\n", + curstk,n,f,t,tow[1],tow[2],tow[3]); + mov(n-1,f,o); + mov(1,f,t); + mov(n-1,o,t); + } + curstk--; + return; +} +/@ +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 4 1 +/* +// +./ ADD NAME=TOWHJCCF,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#JCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(10,0),PRTY=2 +//CLG EXEC JCCCLG, +// JOPTS='-o', +// PARM.LKED='NCAL,MAP,LIST,NORENT' +//COMPILE.SYSIN DD DATA,DLM='/@' +/* $Id: towh_cc.c 964 2017-11-19 08:47:46Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-08-09 934 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + +#include + +void mov(int n, int f, int t); + +int ncall = 0; +int nmove = 0; +int curstk = 0; +int maxstk = 0; +int maxdsk = 0; +int trace = 0; +int tow[4]; + +int main(argc, argv) +int argc; +char *argv[]; +{ + int ndsk; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &maxdsk, &trace) != 2) { + printf("conversion error, abort\n"); + return 1; + } + + /* avoid | here, lots of fun with ASCII -> EBCDIC mapping */ + /* if (maxdsk < 2 || maxdsk > 32) { */ + if ((maxdsk < 2) + (maxdsk > 32)) { + printf("maxdsk out of range (2...32), abort\n"); + return 1; + } + + for (ndsk=2; ndsk<=maxdsk; ndsk++) { + ncall = 0; + nmove = 0; + maxstk = 0; + curstk = 0; + tow[1] = ndsk; + tow[2] = 0; + tow[3] = 0; + + if (trace) printf("STRT ndsk=%2d\n", ndsk); + mov(ndsk,1,3); + printf("DONE ndsk=%2d: maxstk=%2d ncall=%10d nmove=%10d\n", + ndsk,maxstk,ncall,nmove); + } + return 0; +} + +void mov(int n, int f, int t) +{ + int o = 6-(f+t); + curstk++; + ncall++; + if (curstk > maxstk) maxstk = curstk; + if(n == 1) { + nmove++; + tow[f]--; + tow[t]++; + if (trace) printf("mov-do: %2d : %2d %2d %2d : %2d %2d %2d\n", + curstk,n,f,t,tow[1],tow[2],tow[3]); + } else { + if (trace) printf("mov-go: %2d : %2d %2d %2d : %2d %2d %2d\n", + curstk,n,f,t,tow[1],tow[2],tow[3]); + mov(n-1,f,o); + mov(1,f,t); + mov(n-1,o,t); + } + curstk--; + return; +} +/@ +//GO.STDOUT DD SYSOUT=*,OUTLIM=5000 +//GO.STDERR DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 22 0 +/* +// +./ ADD NAME=TOWHJCCT,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#JCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(1,0),PRTY=8 +//CLG EXEC JCCCLG, +// JOPTS='-o', +// PARM.LKED='NCAL,MAP,LIST,NORENT' +//COMPILE.SYSIN DD DATA,DLM='/@' +/* $Id: towh_cc.c 964 2017-11-19 08:47:46Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-08-09 934 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + +#include + +void mov(int n, int f, int t); + +int ncall = 0; +int nmove = 0; +int curstk = 0; +int maxstk = 0; +int maxdsk = 0; +int trace = 0; +int tow[4]; + +int main(argc, argv) +int argc; +char *argv[]; +{ + int ndsk; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d", &maxdsk, &trace) != 2) { + printf("conversion error, abort\n"); + return 1; + } + + /* avoid | here, lots of fun with ASCII -> EBCDIC mapping */ + /* if (maxdsk < 2 || maxdsk > 32) { */ + if ((maxdsk < 2) + (maxdsk > 32)) { + printf("maxdsk out of range (2...32), abort\n"); + return 1; + } + + for (ndsk=2; ndsk<=maxdsk; ndsk++) { + ncall = 0; + nmove = 0; + maxstk = 0; + curstk = 0; + tow[1] = ndsk; + tow[2] = 0; + tow[3] = 0; + + if (trace) printf("STRT ndsk=%2d\n", ndsk); + mov(ndsk,1,3); + printf("DONE ndsk=%2d: maxstk=%2d ncall=%10d nmove=%10d\n", + ndsk,maxstk,ncall,nmove); + } + return 0; +} + +void mov(int n, int f, int t) +{ + int o = 6-(f+t); + curstk++; + ncall++; + if (curstk > maxstk) maxstk = curstk; + if(n == 1) { + nmove++; + tow[f]--; + tow[t]++; + if (trace) printf("mov-do: %2d : %2d %2d %2d : %2d %2d %2d\n", + curstk,n,f,t,tow[1],tow[2],tow[3]); + } else { + if (trace) printf("mov-go: %2d : %2d %2d %2d : %2d %2d %2d\n", + curstk,n,f,t,tow[1],tow[2],tow[3]); + mov(n-1,f,o); + mov(1,f,t); + mov(n-1,o,t); + } + curstk--; + return; +} +/@ +//GO.STDOUT DD SYSOUT=*,OUTLIM=5000 +//GO.STDERR DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 4 1 +/* +// +./ ADD NAME=TOWHFOGF,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#FOG JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(10,0),PRTY=2 +//CLG EXEC FORTGCLG, +// PARM.FORT='', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: towh_for.f 964 2017-11-19 08:47:46Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-08-09 934 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM TOWH +C + IMPLICIT LOGICAL (A-Z) + COMMON /DAT1/NCALL,NMOVE,MAXSTK,MAXDSK,TRACE,TOW(3) + INTEGER NCALL,NMOVE,MAXDSK,MAXSTK,TRACE,TOW + COMMON /DAT2/L,LN(32),LF(32),LT(32),LS(32) + INTEGER L,LN,LF,LT,LS +C + INTEGER NDSK +C + READ(5,9000,ERR=910,END=900) MAXDSK,TRACE +C + DO 100 NDSK=2,MAXDSK + NCALL = 0 + NMOVE = 0 + MAXSTK = 0 + TOW(1) = NDSK + TOW(2) = 0 + TOW(3) = 0 + IF (TRACE .NE. 0) WRITE(6,9010) NDSK + CALL MOV(NDSK,1,3) + WRITE(6,9020) NDSK,MAXSTK,NCALL,NMOVE + 100 CONTINUE +C +900 CONTINUE + STOP +910 WRITE(6,9030) + STOP +C +9000 FORMAT(2I5) +9010 FORMAT(1X,'STRT ndsk=',I2) +9020 FORMAT(1X,'DONE ndsk=',I2,': maxstk=',I2,' ncall=',I10, + * ' nmove=',I10) +9030 FORMAT(1X,'conversion error, abort') + END +C +C --- subroutine mov ------------------------------------------------- +C + SUBROUTINE MOV(N,F,T) + IMPLICIT LOGICAL (A-Z) + INTEGER N,F,T + INTEGER O,L1,S +C + COMMON /DAT1/NCALL,NMOVE,MAXSTK,MAXDSK,TRACE,TOW(3) + INTEGER NCALL,NMOVE,MAXDSK,MAXSTK,TRACE,TOW + COMMON /DAT2/L,LN(32),LF(32),LT(32),LS(32) + INTEGER L,LN,LF,LT,LS +C + L = 1 + LN(1) = N + LF(1) = F + LT(1) = T +C +1000 CONTINUE + NCALL = NCALL + 1 + IF (L .GT. MAXSTK) MAXSTK = L + LS(L) = 1 +C + IF (LN(L) .NE. 1) GOTO 1900 + NMOVE = NMOVE + 1 + TOW(LF(L)) = TOW(LF(L)) - 1 + TOW(LT(L)) = TOW(LT(L)) + 1 + IF (TRACE .NE. 0) WRITE(6,9000) L,LN(L),LF(L),LT(L),TOW + L = L - 1 + IF (L .EQ. 0) RETURN + GOTO 2000 +C +1900 IF (TRACE .NE. 0) WRITE(6,9010) L,LN(L),LF(L),LT(L),TOW +C +2000 CONTINUE + IF (TRACE .GT. 1) WRITE(6,9020) L,LN(L),LF(L),LT(L),TOW,L,LS(L) + O = 6-(LF(L)+LT(L)) + L1 = L + 1 +C Fortran IV(1966): computed GOTO selectors must be un-subscripted integers + S = LS(L) + GOTO (2100,2200,2300,2400), S +C +2100 LN(L1) = LN(L)-1 + LF(L1) = LF(L) + LT(L1) = O + LS(L) = 2 + L = L1 + GOTO 1000 +C +2200 LN(L1) = 1 + LF(L1) = LF(L) + LT(L1) = LT(L) + LS(L) = 3 + L = L1 + GOTO 1000 +C +2300 LN(L1) = LN(L)-1 + LF(L1) = O + LT(L1) = LT(L) + LS(L) = 4 + L = L1 + GOTO 1000 +C +2400 L = L - 1 + IF (L .EQ. 0) RETURN + GOTO 2000 +C +9000 FORMAT(1X,'mov-do: ',I2,' :',3(1X,I2),' :',3(1X,I2)) +9010 FORMAT(1X,'mov-go: ',I2,' :',3(1X,I2),' :',3(1X,I2)) +9020 FORMAT(1X,'step: ',I2,' :',3(1X,I2),' :',3(1X,I2), + * ' :',I2,'-',I2) +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 22 0 +/* +// +./ ADD NAME=TOWHFOGT,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#FOG JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTGCLG, +// PARM.FORT='', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: towh_for.f 964 2017-11-19 08:47:46Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-08-09 934 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM TOWH +C + IMPLICIT LOGICAL (A-Z) + COMMON /DAT1/NCALL,NMOVE,MAXSTK,MAXDSK,TRACE,TOW(3) + INTEGER NCALL,NMOVE,MAXDSK,MAXSTK,TRACE,TOW + COMMON /DAT2/L,LN(32),LF(32),LT(32),LS(32) + INTEGER L,LN,LF,LT,LS +C + INTEGER NDSK +C + READ(5,9000,ERR=910,END=900) MAXDSK,TRACE +C + DO 100 NDSK=2,MAXDSK + NCALL = 0 + NMOVE = 0 + MAXSTK = 0 + TOW(1) = NDSK + TOW(2) = 0 + TOW(3) = 0 + IF (TRACE .NE. 0) WRITE(6,9010) NDSK + CALL MOV(NDSK,1,3) + WRITE(6,9020) NDSK,MAXSTK,NCALL,NMOVE + 100 CONTINUE +C +900 CONTINUE + STOP +910 WRITE(6,9030) + STOP +C +9000 FORMAT(2I5) +9010 FORMAT(1X,'STRT ndsk=',I2) +9020 FORMAT(1X,'DONE ndsk=',I2,': maxstk=',I2,' ncall=',I10, + * ' nmove=',I10) +9030 FORMAT(1X,'conversion error, abort') + END +C +C --- subroutine mov ------------------------------------------------- +C + SUBROUTINE MOV(N,F,T) + IMPLICIT LOGICAL (A-Z) + INTEGER N,F,T + INTEGER O,L1,S +C + COMMON /DAT1/NCALL,NMOVE,MAXSTK,MAXDSK,TRACE,TOW(3) + INTEGER NCALL,NMOVE,MAXDSK,MAXSTK,TRACE,TOW + COMMON /DAT2/L,LN(32),LF(32),LT(32),LS(32) + INTEGER L,LN,LF,LT,LS +C + L = 1 + LN(1) = N + LF(1) = F + LT(1) = T +C +1000 CONTINUE + NCALL = NCALL + 1 + IF (L .GT. MAXSTK) MAXSTK = L + LS(L) = 1 +C + IF (LN(L) .NE. 1) GOTO 1900 + NMOVE = NMOVE + 1 + TOW(LF(L)) = TOW(LF(L)) - 1 + TOW(LT(L)) = TOW(LT(L)) + 1 + IF (TRACE .NE. 0) WRITE(6,9000) L,LN(L),LF(L),LT(L),TOW + L = L - 1 + IF (L .EQ. 0) RETURN + GOTO 2000 +C +1900 IF (TRACE .NE. 0) WRITE(6,9010) L,LN(L),LF(L),LT(L),TOW +C +2000 CONTINUE + IF (TRACE .GT. 1) WRITE(6,9020) L,LN(L),LF(L),LT(L),TOW,L,LS(L) + O = 6-(LF(L)+LT(L)) + L1 = L + 1 +C Fortran IV(1966): computed GOTO selectors must be un-subscripted integers + S = LS(L) + GOTO (2100,2200,2300,2400), S +C +2100 LN(L1) = LN(L)-1 + LF(L1) = LF(L) + LT(L1) = O + LS(L) = 2 + L = L1 + GOTO 1000 +C +2200 LN(L1) = 1 + LF(L1) = LF(L) + LT(L1) = LT(L) + LS(L) = 3 + L = L1 + GOTO 1000 +C +2300 LN(L1) = LN(L)-1 + LF(L1) = O + LT(L1) = LT(L) + LS(L) = 4 + L = L1 + GOTO 1000 +C +2400 L = L - 1 + IF (L .EQ. 0) RETURN + GOTO 2000 +C +9000 FORMAT(1X,'mov-do: ',I2,' :',3(1X,I2),' :',3(1X,I2)) +9010 FORMAT(1X,'mov-go: ',I2,' :',3(1X,I2),' :',3(1X,I2)) +9020 FORMAT(1X,'step: ',I2,' :',3(1X,I2),' :',3(1X,I2), + * ' :',I2,'-',I2) +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 4 1 +/* +// +./ ADD NAME=TOWHFOHF,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#FOH JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(10,0),PRTY=2 +//CLG EXEC FORTHCLG, +// PARM.FORT='OPT=2', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: towh_for.f 964 2017-11-19 08:47:46Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-08-09 934 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM TOWH +C + IMPLICIT LOGICAL (A-Z) + COMMON /DAT1/NCALL,NMOVE,MAXSTK,MAXDSK,TRACE,TOW(3) + INTEGER NCALL,NMOVE,MAXDSK,MAXSTK,TRACE,TOW + COMMON /DAT2/L,LN(32),LF(32),LT(32),LS(32) + INTEGER L,LN,LF,LT,LS +C + INTEGER NDSK +C + READ(5,9000,ERR=910,END=900) MAXDSK,TRACE +C + DO 100 NDSK=2,MAXDSK + NCALL = 0 + NMOVE = 0 + MAXSTK = 0 + TOW(1) = NDSK + TOW(2) = 0 + TOW(3) = 0 + IF (TRACE .NE. 0) WRITE(6,9010) NDSK + CALL MOV(NDSK,1,3) + WRITE(6,9020) NDSK,MAXSTK,NCALL,NMOVE + 100 CONTINUE +C +900 CONTINUE + STOP +910 WRITE(6,9030) + STOP +C +9000 FORMAT(2I5) +9010 FORMAT(1X,'STRT ndsk=',I2) +9020 FORMAT(1X,'DONE ndsk=',I2,': maxstk=',I2,' ncall=',I10, + * ' nmove=',I10) +9030 FORMAT(1X,'conversion error, abort') + END +C +C --- subroutine mov ------------------------------------------------- +C + SUBROUTINE MOV(N,F,T) + IMPLICIT LOGICAL (A-Z) + INTEGER N,F,T + INTEGER O,L1,S +C + COMMON /DAT1/NCALL,NMOVE,MAXSTK,MAXDSK,TRACE,TOW(3) + INTEGER NCALL,NMOVE,MAXDSK,MAXSTK,TRACE,TOW + COMMON /DAT2/L,LN(32),LF(32),LT(32),LS(32) + INTEGER L,LN,LF,LT,LS +C + L = 1 + LN(1) = N + LF(1) = F + LT(1) = T +C +1000 CONTINUE + NCALL = NCALL + 1 + IF (L .GT. MAXSTK) MAXSTK = L + LS(L) = 1 +C + IF (LN(L) .NE. 1) GOTO 1900 + NMOVE = NMOVE + 1 + TOW(LF(L)) = TOW(LF(L)) - 1 + TOW(LT(L)) = TOW(LT(L)) + 1 + IF (TRACE .NE. 0) WRITE(6,9000) L,LN(L),LF(L),LT(L),TOW + L = L - 1 + IF (L .EQ. 0) RETURN + GOTO 2000 +C +1900 IF (TRACE .NE. 0) WRITE(6,9010) L,LN(L),LF(L),LT(L),TOW +C +2000 CONTINUE + IF (TRACE .GT. 1) WRITE(6,9020) L,LN(L),LF(L),LT(L),TOW,L,LS(L) + O = 6-(LF(L)+LT(L)) + L1 = L + 1 +C Fortran IV(1966): computed GOTO selectors must be un-subscripted integers + S = LS(L) + GOTO (2100,2200,2300,2400), S +C +2100 LN(L1) = LN(L)-1 + LF(L1) = LF(L) + LT(L1) = O + LS(L) = 2 + L = L1 + GOTO 1000 +C +2200 LN(L1) = 1 + LF(L1) = LF(L) + LT(L1) = LT(L) + LS(L) = 3 + L = L1 + GOTO 1000 +C +2300 LN(L1) = LN(L)-1 + LF(L1) = O + LT(L1) = LT(L) + LS(L) = 4 + L = L1 + GOTO 1000 +C +2400 L = L - 1 + IF (L .EQ. 0) RETURN + GOTO 2000 +C +9000 FORMAT(1X,'mov-do: ',I2,' :',3(1X,I2),' :',3(1X,I2)) +9010 FORMAT(1X,'mov-go: ',I2,' :',3(1X,I2),' :',3(1X,I2)) +9020 FORMAT(1X,'step: ',I2,' :',3(1X,I2),' :',3(1X,I2), + * ' :',I2,'-',I2) +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 22 0 +/* +// +./ ADD NAME=TOWHFOHT,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#FOH JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTHCLG, +// PARM.FORT='OPT=2', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: towh_for.f 964 2017-11-19 08:47:46Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-08-09 934 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM TOWH +C + IMPLICIT LOGICAL (A-Z) + COMMON /DAT1/NCALL,NMOVE,MAXSTK,MAXDSK,TRACE,TOW(3) + INTEGER NCALL,NMOVE,MAXDSK,MAXSTK,TRACE,TOW + COMMON /DAT2/L,LN(32),LF(32),LT(32),LS(32) + INTEGER L,LN,LF,LT,LS +C + INTEGER NDSK +C + READ(5,9000,ERR=910,END=900) MAXDSK,TRACE +C + DO 100 NDSK=2,MAXDSK + NCALL = 0 + NMOVE = 0 + MAXSTK = 0 + TOW(1) = NDSK + TOW(2) = 0 + TOW(3) = 0 + IF (TRACE .NE. 0) WRITE(6,9010) NDSK + CALL MOV(NDSK,1,3) + WRITE(6,9020) NDSK,MAXSTK,NCALL,NMOVE + 100 CONTINUE +C +900 CONTINUE + STOP +910 WRITE(6,9030) + STOP +C +9000 FORMAT(2I5) +9010 FORMAT(1X,'STRT ndsk=',I2) +9020 FORMAT(1X,'DONE ndsk=',I2,': maxstk=',I2,' ncall=',I10, + * ' nmove=',I10) +9030 FORMAT(1X,'conversion error, abort') + END +C +C --- subroutine mov ------------------------------------------------- +C + SUBROUTINE MOV(N,F,T) + IMPLICIT LOGICAL (A-Z) + INTEGER N,F,T + INTEGER O,L1,S +C + COMMON /DAT1/NCALL,NMOVE,MAXSTK,MAXDSK,TRACE,TOW(3) + INTEGER NCALL,NMOVE,MAXDSK,MAXSTK,TRACE,TOW + COMMON /DAT2/L,LN(32),LF(32),LT(32),LS(32) + INTEGER L,LN,LF,LT,LS +C + L = 1 + LN(1) = N + LF(1) = F + LT(1) = T +C +1000 CONTINUE + NCALL = NCALL + 1 + IF (L .GT. MAXSTK) MAXSTK = L + LS(L) = 1 +C + IF (LN(L) .NE. 1) GOTO 1900 + NMOVE = NMOVE + 1 + TOW(LF(L)) = TOW(LF(L)) - 1 + TOW(LT(L)) = TOW(LT(L)) + 1 + IF (TRACE .NE. 0) WRITE(6,9000) L,LN(L),LF(L),LT(L),TOW + L = L - 1 + IF (L .EQ. 0) RETURN + GOTO 2000 +C +1900 IF (TRACE .NE. 0) WRITE(6,9010) L,LN(L),LF(L),LT(L),TOW +C +2000 CONTINUE + IF (TRACE .GT. 1) WRITE(6,9020) L,LN(L),LF(L),LT(L),TOW,L,LS(L) + O = 6-(LF(L)+LT(L)) + L1 = L + 1 +C Fortran IV(1966): computed GOTO selectors must be un-subscripted integers + S = LS(L) + GOTO (2100,2200,2300,2400), S +C +2100 LN(L1) = LN(L)-1 + LF(L1) = LF(L) + LT(L1) = O + LS(L) = 2 + L = L1 + GOTO 1000 +C +2200 LN(L1) = 1 + LF(L1) = LF(L) + LT(L1) = LT(L) + LS(L) = 3 + L = L1 + GOTO 1000 +C +2300 LN(L1) = LN(L)-1 + LF(L1) = O + LT(L1) = LT(L) + LS(L) = 4 + L = L1 + GOTO 1000 +C +2400 L = L - 1 + IF (L .EQ. 0) RETURN + GOTO 2000 +C +9000 FORMAT(1X,'mov-do: ',I2,' :',3(1X,I2),' :',3(1X,I2)) +9010 FORMAT(1X,'mov-go: ',I2,' :',3(1X,I2),' :',3(1X,I2)) +9020 FORMAT(1X,'step: ',I2,' :',3(1X,I2),' :',3(1X,I2), + * ' :',I2,'-',I2) +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 4 1 +/* +// +./ ADD NAME=TOWHFOWF,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#FOW JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(20,0),PRTY=2 +//CLG EXEC WATFIV +//SYSIN DD * +$JOB TOWH#FOW,T=(20,0),P=100,NOCHECK +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: towh_for.f 964 2017-11-19 08:47:46Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-08-09 934 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM TOWH +C + IMPLICIT LOGICAL (A-Z) + COMMON /DAT1/NCALL,NMOVE,MAXSTK,MAXDSK,TRACE,TOW(3) + INTEGER NCALL,NMOVE,MAXDSK,MAXSTK,TRACE,TOW + COMMON /DAT2/L,LN(32),LF(32),LT(32),LS(32) + INTEGER L,LN,LF,LT,LS +C + INTEGER NDSK +C + READ(5,9000,ERR=910,END=900) MAXDSK,TRACE +C + DO 100 NDSK=2,MAXDSK + NCALL = 0 + NMOVE = 0 + MAXSTK = 0 + TOW(1) = NDSK + TOW(2) = 0 + TOW(3) = 0 + IF (TRACE .NE. 0) WRITE(6,9010) NDSK + CALL MOV(NDSK,1,3) + WRITE(6,9020) NDSK,MAXSTK,NCALL,NMOVE + 100 CONTINUE +C +900 CONTINUE + STOP +910 WRITE(6,9030) + STOP +C +9000 FORMAT(2I5) +9010 FORMAT(1X,'STRT ndsk=',I2) +9020 FORMAT(1X,'DONE ndsk=',I2,': maxstk=',I2,' ncall=',I10, + * ' nmove=',I10) +9030 FORMAT(1X,'conversion error, abort') + END +C +C --- subroutine mov ------------------------------------------------- +C + SUBROUTINE MOV(N,F,T) + IMPLICIT LOGICAL (A-Z) + INTEGER N,F,T + INTEGER O,L1,S +C + COMMON /DAT1/NCALL,NMOVE,MAXSTK,MAXDSK,TRACE,TOW(3) + INTEGER NCALL,NMOVE,MAXDSK,MAXSTK,TRACE,TOW + COMMON /DAT2/L,LN(32),LF(32),LT(32),LS(32) + INTEGER L,LN,LF,LT,LS +C + L = 1 + LN(1) = N + LF(1) = F + LT(1) = T +C +1000 CONTINUE + NCALL = NCALL + 1 + IF (L .GT. MAXSTK) MAXSTK = L + LS(L) = 1 +C + IF (LN(L) .NE. 1) GOTO 1900 + NMOVE = NMOVE + 1 + TOW(LF(L)) = TOW(LF(L)) - 1 + TOW(LT(L)) = TOW(LT(L)) + 1 + IF (TRACE .NE. 0) WRITE(6,9000) L,LN(L),LF(L),LT(L),TOW + L = L - 1 + IF (L .EQ. 0) RETURN + GOTO 2000 +C +1900 IF (TRACE .NE. 0) WRITE(6,9010) L,LN(L),LF(L),LT(L),TOW +C +2000 CONTINUE + IF (TRACE .GT. 1) WRITE(6,9020) L,LN(L),LF(L),LT(L),TOW,L,LS(L) + O = 6-(LF(L)+LT(L)) + L1 = L + 1 +C Fortran IV(1966): computed GOTO selectors must be un-subscripted integers + S = LS(L) + GOTO (2100,2200,2300,2400), S +C +2100 LN(L1) = LN(L)-1 + LF(L1) = LF(L) + LT(L1) = O + LS(L) = 2 + L = L1 + GOTO 1000 +C +2200 LN(L1) = 1 + LF(L1) = LF(L) + LT(L1) = LT(L) + LS(L) = 3 + L = L1 + GOTO 1000 +C +2300 LN(L1) = LN(L)-1 + LF(L1) = O + LT(L1) = LT(L) + LS(L) = 4 + L = L1 + GOTO 1000 +C +2400 L = L - 1 + IF (L .EQ. 0) RETURN + GOTO 2000 +C +9000 FORMAT(1X,'mov-do: ',I2,' :',3(1X,I2),' :',3(1X,I2)) +9010 FORMAT(1X,'mov-go: ',I2,' :',3(1X,I2),' :',3(1X,I2)) +9020 FORMAT(1X,'step: ',I2,' :',3(1X,I2),' :',3(1X,I2), + * ' :',I2,'-',I2) +C + END +$ENTRY + 22 0 +$STOP +/* +// +./ ADD NAME=TOWHFOWT,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#FOW JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC WATFIV +//SYSIN DD * +$JOB TOWH#FOW,T=(1,0),P=100,CHECK +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: towh_for.f 964 2017-11-19 08:47:46Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-08-09 934 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- main program --------------------------------------------------- +C PROGRAM TOWH +C + IMPLICIT LOGICAL (A-Z) + COMMON /DAT1/NCALL,NMOVE,MAXSTK,MAXDSK,TRACE,TOW(3) + INTEGER NCALL,NMOVE,MAXDSK,MAXSTK,TRACE,TOW + COMMON /DAT2/L,LN(32),LF(32),LT(32),LS(32) + INTEGER L,LN,LF,LT,LS +C + INTEGER NDSK +C + READ(5,9000,ERR=910,END=900) MAXDSK,TRACE +C + DO 100 NDSK=2,MAXDSK + NCALL = 0 + NMOVE = 0 + MAXSTK = 0 + TOW(1) = NDSK + TOW(2) = 0 + TOW(3) = 0 + IF (TRACE .NE. 0) WRITE(6,9010) NDSK + CALL MOV(NDSK,1,3) + WRITE(6,9020) NDSK,MAXSTK,NCALL,NMOVE + 100 CONTINUE +C +900 CONTINUE + STOP +910 WRITE(6,9030) + STOP +C +9000 FORMAT(2I5) +9010 FORMAT(1X,'STRT ndsk=',I2) +9020 FORMAT(1X,'DONE ndsk=',I2,': maxstk=',I2,' ncall=',I10, + * ' nmove=',I10) +9030 FORMAT(1X,'conversion error, abort') + END +C +C --- subroutine mov ------------------------------------------------- +C + SUBROUTINE MOV(N,F,T) + IMPLICIT LOGICAL (A-Z) + INTEGER N,F,T + INTEGER O,L1,S +C + COMMON /DAT1/NCALL,NMOVE,MAXSTK,MAXDSK,TRACE,TOW(3) + INTEGER NCALL,NMOVE,MAXDSK,MAXSTK,TRACE,TOW + COMMON /DAT2/L,LN(32),LF(32),LT(32),LS(32) + INTEGER L,LN,LF,LT,LS +C + L = 1 + LN(1) = N + LF(1) = F + LT(1) = T +C +1000 CONTINUE + NCALL = NCALL + 1 + IF (L .GT. MAXSTK) MAXSTK = L + LS(L) = 1 +C + IF (LN(L) .NE. 1) GOTO 1900 + NMOVE = NMOVE + 1 + TOW(LF(L)) = TOW(LF(L)) - 1 + TOW(LT(L)) = TOW(LT(L)) + 1 + IF (TRACE .NE. 0) WRITE(6,9000) L,LN(L),LF(L),LT(L),TOW + L = L - 1 + IF (L .EQ. 0) RETURN + GOTO 2000 +C +1900 IF (TRACE .NE. 0) WRITE(6,9010) L,LN(L),LF(L),LT(L),TOW +C +2000 CONTINUE + IF (TRACE .GT. 1) WRITE(6,9020) L,LN(L),LF(L),LT(L),TOW,L,LS(L) + O = 6-(LF(L)+LT(L)) + L1 = L + 1 +C Fortran IV(1966): computed GOTO selectors must be un-subscripted integers + S = LS(L) + GOTO (2100,2200,2300,2400), S +C +2100 LN(L1) = LN(L)-1 + LF(L1) = LF(L) + LT(L1) = O + LS(L) = 2 + L = L1 + GOTO 1000 +C +2200 LN(L1) = 1 + LF(L1) = LF(L) + LT(L1) = LT(L) + LS(L) = 3 + L = L1 + GOTO 1000 +C +2300 LN(L1) = LN(L)-1 + LF(L1) = O + LT(L1) = LT(L) + LS(L) = 4 + L = L1 + GOTO 1000 +C +2400 L = L - 1 + IF (L .EQ. 0) RETURN + GOTO 2000 +C +9000 FORMAT(1X,'mov-do: ',I2,' :',3(1X,I2),' :',3(1X,I2)) +9010 FORMAT(1X,'mov-go: ',I2,' :',3(1X,I2),' :',3(1X,I2)) +9020 FORMAT(1X,'step: ',I2,' :',3(1X,I2),' :',3(1X,I2), + * ' :',I2,'-',I2) +C + END +$ENTRY + 4 1 +$STOP +/* +// +./ ADD NAME=TOWHPASF,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#PAS JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(10,0),PRTY=2 +//CLG EXEC PASCLG,GOTIME=3600,GOREG=1024K, +// OPT='M+,D-', +// GOPARM='/STACK=512k' +//COMPILE.SYSIN DD * +(* $Id: towh_pas.pas 964 2017-11-19 08:47:46Z mueller $ *) +(* +(* Copyright 2017- by Walter F.J. Mueller *) +(* +(* This program is free software; you may redistribute and/or modify *) +(* it under the terms of the GNU General Public License version 3. *) +(* See Licence.txt in distribition directory for further details. *) +(* *) +(* Revision History: *) +(* Date Rev Version Comment *) +(* 2017-09-07 948 0.1 Initial version *) + +program towh(input,output); +var + ncall,nmove : integer; + curstk,maxstk : integer; + maxdsk,trace : integer; + ndsk : integer; + tow : ARRAY[1 .. 3] of integer; + +procedure mov(n,f,t: integer); +var + o : integer; +begin + o := 6-(f+t); + curstk := curstk + 1; + ncall := ncall + 1; + if maxstk < curstk then maxstk := curstk; + if n = 1 then begin + nmove := nmove + 1; + tow[f] := tow[f] - 1; + tow[t] := tow[t] + 1; + if trace > 0 then writeln(' ','mov-do: ',curstk:2, + ' :',n:3,f:3,t:3, + ' :',tow[1]:3,tow[2]:3,tow[3]:3); + end else begin + if trace > 0 then writeln(' ','mov-go: ',curstk:2, + ' :',n:3,f:3,t:3, + ' :',tow[1]:3,tow[2]:3,tow[3]:3); + mov(n-1,f,o); + mov(1,f,t); + mov(n-1,o,t); + end; + curstk := curstk - 1; +end; + +begin + + read(maxdsk); + read(trace); + + for ndsk := 2 to maxdsk do begin + ncall := 0; + nmove := 0; + maxstk := 0; + curstk := 0; + tow[1] := ndsk; + tow[2] := 0; + tow[3] := 0; + if trace > 0 then writeln(' ','STRT ndsk=',ndsk:2); + mov(ndsk,1,3); + writeln(' ','DONE ndsk=',ndsk:2,': maxstk=',maxstk:2, + ' ncall=',ncall:10,' nmove=',nmove:10); + end; + +end. +/* +//GO.OUTPUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 22 0 +/* +// +./ ADD NAME=TOWHPAST,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#PAS JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(1,0),PRTY=8 +//CLG EXEC PASCLG,GOTIME=3600,GOREG=1024K, +// OPT='M+', +// GOPARM='/STACK=512k' +//COMPILE.SYSIN DD * +(* $Id: towh_pas.pas 964 2017-11-19 08:47:46Z mueller $ *) +(* +(* Copyright 2017- by Walter F.J. Mueller *) +(* +(* This program is free software; you may redistribute and/or modify *) +(* it under the terms of the GNU General Public License version 3. *) +(* See Licence.txt in distribition directory for further details. *) +(* *) +(* Revision History: *) +(* Date Rev Version Comment *) +(* 2017-09-07 948 0.1 Initial version *) + +program towh(input,output); +var + ncall,nmove : integer; + curstk,maxstk : integer; + maxdsk,trace : integer; + ndsk : integer; + tow : ARRAY[1 .. 3] of integer; + +procedure mov(n,f,t: integer); +var + o : integer; +begin + o := 6-(f+t); + curstk := curstk + 1; + ncall := ncall + 1; + if maxstk < curstk then maxstk := curstk; + if n = 1 then begin + nmove := nmove + 1; + tow[f] := tow[f] - 1; + tow[t] := tow[t] + 1; + if trace > 0 then writeln(' ','mov-do: ',curstk:2, + ' :',n:3,f:3,t:3, + ' :',tow[1]:3,tow[2]:3,tow[3]:3); + end else begin + if trace > 0 then writeln(' ','mov-go: ',curstk:2, + ' :',n:3,f:3,t:3, + ' :',tow[1]:3,tow[2]:3,tow[3]:3); + mov(n-1,f,o); + mov(1,f,t); + mov(n-1,o,t); + end; + curstk := curstk - 1; +end; + +begin + + read(maxdsk); + read(trace); + + for ndsk := 2 to maxdsk do begin + ncall := 0; + nmove := 0; + maxstk := 0; + curstk := 0; + tow[1] := ndsk; + tow[2] := 0; + tow[3] := 0; + if trace > 0 then writeln(' ','STRT ndsk=',ndsk:2); + mov(ndsk,1,3); + writeln(' ','DONE ndsk=',ndsk:2,': maxstk=',maxstk:2, + ' ncall=',ncall:10,' nmove=',nmove:10); + end; + +end. +/* +//GO.OUTPUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 4 1 +/* +// +./ ADD NAME=TOWHPLIF,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#PLI JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(10,0),PRTY=2 +//CLG EXEC PL1LFCLG, +// PARM.PL1L='LOAD,NODECK,OPT=2', +// PARM.LKED='MAP,LIST' +//PL1L.SYSLIN DD UNIT=SYSDA +//PL1L.SYSIN DD * +/* 1 2 3 4 5 6 7*/-------- +/*4567890123456789012345678901234567890123456789012345678901234567890*/-------- +/* $Id: towh_pli.pli 981 2018-01-02 13:30:49Z mueller $ */ +/* +/* Copyright 2017-2018 by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2018-01-02 981 1.0 add ON units for ENDFILE and CONVERSION */ +/* 2017-09-07 947 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + + TOWH: PROC OPTIONS(MAIN) REORDER; + DCL (NCALL,NMOVE) BIN FIXED(31) INIT(0); + DCL (CURSTK,MAXSTK) BIN FIXED(31) INIT(0); + DCL (MAXDSK,TRACE) BIN FIXED(31) INIT(0); + DCL TOW(3) BIN FIXED(31) INIT((3)0); + DCL NDSK BIN FIXED(31); + + DCL MOV ENTRY(BIN FIXED(31),BIN FIXED(31),BIN FIXED(31)); + + ON ENDFILE(SYSIN) BEGIN; + PUT SKIP EDIT('Unexpected EOF, abort')(A); + GOTO DONE; + END; + ON CONVERSION BEGIN; + PUT SKIP EDIT('Conversion error, abort')(A); + GOTO DONE; + END; + + GET EDIT(MAXDSK,TRACE) (F(5),F(5)); + + DO NDSK=2 TO MAXDSK; + NCALL = 0; + NMOVE = 0; + MAXSTK = 0; + CURSTK = 0; + TOW(1) = NDSK; + TOW(2) = 0; + TOW(3) = 0; + IF TRACE > 0 THEN PUT SKIP EDIT('STRT ndsk=',NDSK) (A,F(2)); + CALL MOV(NDSK,1,3); + PUT SKIP EDIT('DONE ndsk=',NDSK, ': maxstk=',MAXSTK, + ' ncall=',NCALL, ' nmove=',NMOVE) + (2(A,F(2)),2(A,F(10))); + END; + DONE:; + + /* procedure MOV -----------------------------------------------*/ + MOV: PROC(N,F,T) RECURSIVE; + DCL (N,F,T) BIN FIXED(31); + DCL O BIN FIXED(31); + O = 6-(F+T); + CURSTK = CURSTK + 1; + NCALL = NCALL + 1; + MAXSTK = MAX(MAXSTK,CURSTK); + IF N = 1 THEN DO; + NMOVE = NMOVE + 1; + TOW(F) = TOW(F) - 1; + TOW(T) = TOW(T) + 1; + IF TRACE > 0 THEN PUT SKIP EDIT('mov-do: ',CURSTK, + ' :',N,F,T, ' :',TOW) + (A,F(2),2(A,3(X(1),F(2)))); + END; + ELSE DO; + IF TRACE > 0 THEN PUT SKIP EDIT('mov-go: ',CURSTK, + ' :',N,F,T, ' :',TOW) + (A,F(2),2(A,3(X(1),F(2)))); + CALL MOV(N-1,F,O); + CALL MOV(1,F,T); + CALL MOV(N-1,O,T); + END; + CURSTK = CURSTK - 1; + END MOV; + + END TOWH; + +/* +//LKED.SYSLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.STEPLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.SYSIN DD * + 22 0 +/* +// +./ ADD NAME=TOWHPLIT,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#PLI JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC PL1LFCLG, +// PARM.PL1L='LOAD,NODECK,OPT=2', +// PARM.LKED='MAP,LIST' +//PL1L.SYSLIN DD UNIT=SYSDA +//PL1L.SYSIN DD * +/* 1 2 3 4 5 6 7*/-------- +/*4567890123456789012345678901234567890123456789012345678901234567890*/-------- +/* $Id: towh_pli.pli 981 2018-01-02 13:30:49Z mueller $ */ +/* +/* Copyright 2017-2018 by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2018-01-02 981 1.0 add ON units for ENDFILE and CONVERSION */ +/* 2017-09-07 947 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + + TOWH: PROC OPTIONS(MAIN) REORDER; + DCL (NCALL,NMOVE) BIN FIXED(31) INIT(0); + DCL (CURSTK,MAXSTK) BIN FIXED(31) INIT(0); + DCL (MAXDSK,TRACE) BIN FIXED(31) INIT(0); + DCL TOW(3) BIN FIXED(31) INIT((3)0); + DCL NDSK BIN FIXED(31); + + DCL MOV ENTRY(BIN FIXED(31),BIN FIXED(31),BIN FIXED(31)); + + ON ENDFILE(SYSIN) BEGIN; + PUT SKIP EDIT('Unexpected EOF, abort')(A); + GOTO DONE; + END; + ON CONVERSION BEGIN; + PUT SKIP EDIT('Conversion error, abort')(A); + GOTO DONE; + END; + + GET EDIT(MAXDSK,TRACE) (F(5),F(5)); + + DO NDSK=2 TO MAXDSK; + NCALL = 0; + NMOVE = 0; + MAXSTK = 0; + CURSTK = 0; + TOW(1) = NDSK; + TOW(2) = 0; + TOW(3) = 0; + IF TRACE > 0 THEN PUT SKIP EDIT('STRT ndsk=',NDSK) (A,F(2)); + CALL MOV(NDSK,1,3); + PUT SKIP EDIT('DONE ndsk=',NDSK, ': maxstk=',MAXSTK, + ' ncall=',NCALL, ' nmove=',NMOVE) + (2(A,F(2)),2(A,F(10))); + END; + DONE:; + + /* procedure MOV -----------------------------------------------*/ + MOV: PROC(N,F,T) RECURSIVE; + DCL (N,F,T) BIN FIXED(31); + DCL O BIN FIXED(31); + O = 6-(F+T); + CURSTK = CURSTK + 1; + NCALL = NCALL + 1; + MAXSTK = MAX(MAXSTK,CURSTK); + IF N = 1 THEN DO; + NMOVE = NMOVE + 1; + TOW(F) = TOW(F) - 1; + TOW(T) = TOW(T) + 1; + IF TRACE > 0 THEN PUT SKIP EDIT('mov-do: ',CURSTK, + ' :',N,F,T, ' :',TOW) + (A,F(2),2(A,3(X(1),F(2)))); + END; + ELSE DO; + IF TRACE > 0 THEN PUT SKIP EDIT('mov-go: ',CURSTK, + ' :',N,F,T, ' :',TOW) + (A,F(2),2(A,3(X(1),F(2)))); + CALL MOV(N-1,F,O); + CALL MOV(1,F,T); + CALL MOV(N-1,O,T); + END; + CURSTK = CURSTK - 1; + END MOV; + + END TOWH; + +/* +//LKED.SYSLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.STEPLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.SYSIN DD * + 4 1 +/* +// +./ ADD NAME=TOWHSIMF,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#SIM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1000K,TIME=(10,0),PRTY=2 +//CLG EXEC SIMCLG, +// PARM.SIM=NOSUBCHK, +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='LINECNT=64' +//SIM.SYSIN DD * +COMMENT +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-09-08 950 1.0 Initial version +*; + +BEGIN + INTEGER ncall,nmove; + INTEGER curstk,maxstk; + INTEGER maxdsk,trace; + INTEGER ndsk; + INTEGER ARRAY tow(1:4); + + PROCEDURE trc(txt,n,f,t); + VALUE txt; + TEXT txt; + INTEGER n,f,t; + BEGIN + OutText(txt); + OutInt(curstk,2); + OutText(" :"); + OutInt(n,3); + OutInt(f,3); + OutInt(t,3); + OutText(" :"); + OutInt(tow(1),3); + OutInt(tow(2),3); + OutInt(tow(3),3); + OutImage; + END; + + PROCEDURE mov(n,f,t); + INTEGER n,f,t; + BEGIN + INTEGER o; + o := 6-(f+t); + curstk := curstk + 1; + ncall := ncall + 1; + IF maxstk < curstk THEN maxstk := curstk; + IF n = 1 THEN BEGIN + nmove := nmove + 1; + tow(f) := tow(f) - 1; + tow(t) := tow(t) + 1; + IF trace > 0 THEN trc("mov-do: ",n,f,t); + END ELSE BEGIN; + IF trace > 0 THEN trc("mov-go: ",n,f,t); + mov(n-1,f,o); + mov(1,f,t); + mov(n-1,o,t); + END; + curstk := curstk - 1; + END; + + maxdsk := InInt; + trace := InInt; + + FOR ndsk := 2 STEP 1 UNTIL maxdsk DO BEGIN + ncall := 0; + nmove := 0; + maxstk := 0; + curstk := 0; + tow(1) := ndsk; + tow(2) := 0; + tow(3) := 0; + IF trace > 0 THEN BEGIN + OutText("STRT ndsk="); + OutInt(ndsk,2); + OutImage; + END; + mov(ndsk,1,3); + OutText("DONE ndsk="); + OutInt(ndsk,2); + OutText(": maxstk="); + OutInt(ndsk,2); + OutText(" ncall="); + OutInt(ncall,10); + OutText(" nmove="); + OutInt(nmove,10); + OutImage; + END; +END; +/* +//GO.SYSOUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 22 0 +/* +// +./ ADD NAME=TOWHSIMT,LEVEL=00,SOURCE=0,LIST=ALL +//TOWH#SIM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1000K,TIME=(1,0),PRTY=8 +//CLG EXEC SIMCLG, +// PARM.SIM='', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='LINECNT=64' +//SIM.SYSIN DD * +COMMENT +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-09-08 950 1.0 Initial version +*; + +BEGIN + INTEGER ncall,nmove; + INTEGER curstk,maxstk; + INTEGER maxdsk,trace; + INTEGER ndsk; + INTEGER ARRAY tow(1:4); + + PROCEDURE trc(txt,n,f,t); + VALUE txt; + TEXT txt; + INTEGER n,f,t; + BEGIN + OutText(txt); + OutInt(curstk,2); + OutText(" :"); + OutInt(n,3); + OutInt(f,3); + OutInt(t,3); + OutText(" :"); + OutInt(tow(1),3); + OutInt(tow(2),3); + OutInt(tow(3),3); + OutImage; + END; + + PROCEDURE mov(n,f,t); + INTEGER n,f,t; + BEGIN + INTEGER o; + o := 6-(f+t); + curstk := curstk + 1; + ncall := ncall + 1; + IF maxstk < curstk THEN maxstk := curstk; + IF n = 1 THEN BEGIN + nmove := nmove + 1; + tow(f) := tow(f) - 1; + tow(t) := tow(t) + 1; + IF trace > 0 THEN trc("mov-do: ",n,f,t); + END ELSE BEGIN; + IF trace > 0 THEN trc("mov-go: ",n,f,t); + mov(n-1,f,o); + mov(1,f,t); + mov(n-1,o,t); + END; + curstk := curstk - 1; + END; + + maxdsk := InInt; + trace := InInt; + + FOR ndsk := 2 STEP 1 UNTIL maxdsk DO BEGIN + ncall := 0; + nmove := 0; + maxstk := 0; + curstk := 0; + tow(1) := ndsk; + tow(2) := 0; + tow(3) := 0; + IF trace > 0 THEN BEGIN + OutText("STRT ndsk="); + OutInt(ndsk,2); + OutImage; + END; + mov(ndsk,1,3); + OutText("DONE ndsk="); + OutInt(ndsk,2); + OutText(": maxstk="); + OutInt(ndsk,2); + OutText(" ncall="); + OutInt(ncall,10); + OutText(" nmove="); + OutInt(nmove,10); + OutImage; + END; +END; +/* +//GO.SYSOUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 4 1 +/* +// +./ ADD NAME=MCPIA60F,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#A60 JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(10,0),PRTY=2 +//CLG EXEC ALGOFCLG, +// PARM.ALGOL='LONG', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='' +//ALGOL.SYSIN DD * +'BEGIN' +'COMMENT' +* $Id: mcpi_a60.a60 978 2017-12-28 21:32:18Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-28 978 1.1 use inverse to avoid divide by constant +* 2017-09-17 951 1.0 Initial version +*; + + 'REAL' RR32,RDIV,PI,RR32I,RDIVI; + 'REAL' RSEED,RLAST; + 'BOOLEAN' RANINI; + 'INTEGER' IDBGRR,IDBGRN,IDBGMC; + 'INTEGER' I,NTRY,NHIT,NGO; + 'REAL' PIEST,PIERR; + 'REAL' RHIT,RTRY; + 'REAL' X,Y,R; + 'REAL' 'ARRAY' RSHUF[0:127]; + + 'REAL' 'PROCEDURE' RANRAW; + 'BEGIN' + 'REAL' RFAC,RNEW; + RNEW := RSEED * 69069.0; + RFAC := RNEW * RR32I; + RFAC := ENTIER(RFAC); + RNEW := RNEW - RFAC * RR32; + 'IF' IDBGRR > 0 'THEN' 'BEGIN' + OUTSTRING (1,'('RR:')'); + OUTREAL(1, RSEED); + OUTREAL(1, RNEW); + SYSACT(1,14,1); + 'END'; + RSEED := RNEW; + RANRAW := RNEW; + 'END'; + + 'REAL' 'PROCEDURE' RANNUM; + 'BEGIN' + 'REAL' RNEW; + 'INTEGER' I; + 'IF' 'NOT' RANINI 'THEN' 'BEGIN' + 'FOR' I := 0 'STEP' 1 'UNTIL' 127 'DO' RSHUF[I] := RANRAW; + RANINI := 'TRUE'; + 'END'; + + I := ENTIER(RLAST*RDIVI); + RLAST := RSHUF[I]; + RSHUF[I] := RANRAW; + RNEW := RLAST * RR32I; + 'IF' IDBGRN > 0 'THEN' 'BEGIN' + OUTSTRING (1,'('RN:')'); + OUTINTEGER(1, I); + OUTREAL(1, RLAST); + OUTREAL(1, RNEW); + SYSACT(1,14,1); + 'END'; + RANNUM := RNEW; + 'END'; + + 'COMMENT' setup constants; + RR32 := 4294967296.0; + RDIV := 33554432.0; + PI := 3.141592653589793; + RR32I := 1.0/RR32; + RDIVI := 1.0/RDIV; + RSEED := 12345.0; + RANINI := 'FALSE'; + + 'COMMENT' set record lenth = 132 and page length = 64; + SYSACT(1,6,132); + SYSACT(1,8,64); + + ININTEGER(0,IDBGRR); + ININTEGER(0,IDBGRN); + ININTEGER(0,IDBGMC); + + 'IF' IDBGRR = 0 'AND' IDBGRN = 0 'AND' IDBGMC = 0 'THEN' 'BEGIN' + OUTSTRING (1,'(' ntry nhit')'); + OUTSTRING (1,'(' pi-est pi-err')'); + OUTSTRING (1,'(' seed')'); + SYSACT(1,14,1); + 'END'; + + LOOP: + ININTEGER(0,NGO); + 'IF' NGO = 0 'THEN' 'GOTO' DONE; + 'FOR' I := 1 'STEP' 1 'UNTIL' NGO 'DO' 'BEGIN' + X := 2.0 * RANNUM - 1.0; + Y := 2.0 * RANNUM - 1.0; + R := X*X + Y*Y; + NTRY := NTRY + 1; + 'IF' R <= 1.0 'THEN' NHIT := NHIT + 1; + 'IF' IDBGMC > 0 'THEN' 'BEGIN' + OUTSTRING (1,'('MC:')'); + OUTREAL(1, X); + OUTREAL(1, Y); + OUTREAL(1, R); + OUTINTEGER(1, NHIT); + SYSACT(1,14,1); + 'END'; + 'END'; + + RTRY := NTRY; + RHIT := NHIT; + PIEST := 4.0 * (RHIT / RTRY); + PIERR := PIEST - PI; + OUTSTRING (1,'('PI:')'); + OUTINTEGER(1, NTRY); + OUTINTEGER(1, NHIT); + OUTREAL(1, PIEST); + OUTREAL(1, PIERR); + OUTREAL(1, RLAST); + SYSACT(1,14,1); + 'GOTO' LOOP; + + DONE: +'END'; + +/* +//GO.ALGLDD01 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 0 0 0 + 100 + 200 + 700 + 2000 + 7000 + 20000 + 70000 + 200000 + 700000 + 2000000 + 0 +/* +// +./ ADD NAME=MCPIA60T,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#A60 JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(1,0),PRTY=8 +//CLG EXEC ALGOFCLG, +// PARM.ALGOL='LONG', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='' +//ALGOL.SYSIN DD * +'BEGIN' +'COMMENT' +* $Id: mcpi_a60.a60 978 2017-12-28 21:32:18Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-28 978 1.1 use inverse to avoid divide by constant +* 2017-09-17 951 1.0 Initial version +*; + + 'REAL' RR32,RDIV,PI,RR32I,RDIVI; + 'REAL' RSEED,RLAST; + 'BOOLEAN' RANINI; + 'INTEGER' IDBGRR,IDBGRN,IDBGMC; + 'INTEGER' I,NTRY,NHIT,NGO; + 'REAL' PIEST,PIERR; + 'REAL' RHIT,RTRY; + 'REAL' X,Y,R; + 'REAL' 'ARRAY' RSHUF[0:127]; + + 'REAL' 'PROCEDURE' RANRAW; + 'BEGIN' + 'REAL' RFAC,RNEW; + RNEW := RSEED * 69069.0; + RFAC := RNEW * RR32I; + RFAC := ENTIER(RFAC); + RNEW := RNEW - RFAC * RR32; + 'IF' IDBGRR > 0 'THEN' 'BEGIN' + OUTSTRING (1,'('RR:')'); + OUTREAL(1, RSEED); + OUTREAL(1, RNEW); + SYSACT(1,14,1); + 'END'; + RSEED := RNEW; + RANRAW := RNEW; + 'END'; + + 'REAL' 'PROCEDURE' RANNUM; + 'BEGIN' + 'REAL' RNEW; + 'INTEGER' I; + 'IF' 'NOT' RANINI 'THEN' 'BEGIN' + 'FOR' I := 0 'STEP' 1 'UNTIL' 127 'DO' RSHUF[I] := RANRAW; + RANINI := 'TRUE'; + 'END'; + + I := ENTIER(RLAST*RDIVI); + RLAST := RSHUF[I]; + RSHUF[I] := RANRAW; + RNEW := RLAST * RR32I; + 'IF' IDBGRN > 0 'THEN' 'BEGIN' + OUTSTRING (1,'('RN:')'); + OUTINTEGER(1, I); + OUTREAL(1, RLAST); + OUTREAL(1, RNEW); + SYSACT(1,14,1); + 'END'; + RANNUM := RNEW; + 'END'; + + 'COMMENT' setup constants; + RR32 := 4294967296.0; + RDIV := 33554432.0; + PI := 3.141592653589793; + RR32I := 1.0/RR32; + RDIVI := 1.0/RDIV; + RSEED := 12345.0; + RANINI := 'FALSE'; + + 'COMMENT' set record lenth = 132 and page length = 64; + SYSACT(1,6,132); + SYSACT(1,8,64); + + ININTEGER(0,IDBGRR); + ININTEGER(0,IDBGRN); + ININTEGER(0,IDBGMC); + + 'IF' IDBGRR = 0 'AND' IDBGRN = 0 'AND' IDBGMC = 0 'THEN' 'BEGIN' + OUTSTRING (1,'(' ntry nhit')'); + OUTSTRING (1,'(' pi-est pi-err')'); + OUTSTRING (1,'(' seed')'); + SYSACT(1,14,1); + 'END'; + + LOOP: + ININTEGER(0,NGO); + 'IF' NGO = 0 'THEN' 'GOTO' DONE; + 'FOR' I := 1 'STEP' 1 'UNTIL' NGO 'DO' 'BEGIN' + X := 2.0 * RANNUM - 1.0; + Y := 2.0 * RANNUM - 1.0; + R := X*X + Y*Y; + NTRY := NTRY + 1; + 'IF' R <= 1.0 'THEN' NHIT := NHIT + 1; + 'IF' IDBGMC > 0 'THEN' 'BEGIN' + OUTSTRING (1,'('MC:')'); + OUTREAL(1, X); + OUTREAL(1, Y); + OUTREAL(1, R); + OUTINTEGER(1, NHIT); + SYSACT(1,14,1); + 'END'; + 'END'; + + RTRY := NTRY; + RHIT := NHIT; + PIEST := 4.0 * (RHIT / RTRY); + PIERR := PIEST - PI; + OUTSTRING (1,'('PI:')'); + OUTINTEGER(1, NTRY); + OUTINTEGER(1, NHIT); + OUTREAL(1, PIEST); + OUTREAL(1, PIERR); + OUTREAL(1, RLAST); + SYSACT(1,14,1); + 'GOTO' LOOP; + + DONE: +'END'; + +/* +//GO.ALGLDD01 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 1 1 1 + 10 + 0 +/* +// +./ ADD NAME=MCPIASMF,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#ASM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=128K,TIME=(10,0),PRTY=2 +//CLG EXEC ASMFCLG, +// MAC1='SYS2.MACLIB', +// PARM.ASM='NOLIST,NOXREF,NORLD,NODECK,LOAD', +// PARM.LKED='MAP,LIST,LET,NCAL', +// COND.LKED=(8,LE,ASM), +// PARM.GO='', +// COND.GO=((8,LE,ASM),(4,LT,LKED)) +//ASM.SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(600,100)) +//ASM.SYSUT2 DD DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSUT3 DD DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSGO DD DSN=&&OBJSET,UNIT=SYSDA,SPACE=(80,(2000,500)) +//ASM.SYSIN DD * +* 1 2 3 4 5 6 71 +*23456789*12345*789012345678901234*678901234567890123456789012345678901 +* $Id: mcpi_asm.asm 979 2017-12-29 18:40:40Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software; you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-29 979 1.2 some more code optimizations +* 2017-12-28 978 1.1 use inverse to avoid divide by constant +* 2017-11-12 961 1.0 Initial version +* 2017-10-10 955 0.1 First draft +* + PRINT NOGEN don't show macro expansions +* +* Prime number search +* RC = 0 ok +* RC = 8 unexpected SYSIN EOF +* RC = 12 open SYSIN failed +* RC = 16 open SYSPRINT failed +* +* local macros -------------------------------------------------------- +* +* +* OTXTDSC - setup text descriptor for simple output system - +* + MACRO +&LABEL OTXTDSC &TEXT +TEXT CSECT +SPTR&SYSNDX DC &TEXT +&SYSECT CSECT + DS 0F +&LABEL DC AL1(L'SPTR&SYSNDX),AL3(SPTR&SYSNDX) + MEND +* +* main preamble ------------------------------------------------------- +* +MAIN START 0 start main code csect at base 0 + SAVE (14,12) Save input registers + LR R12,R15 base register := entry address + USING MAIN,R12 declare base register + ST R13,SAVE+4 set back pointer in current save area + LR R2,R13 remember callers save area + LA R13,SAVE setup current save area + ST R13,8(R2) set forw pointer in callers save area +* +* open datasets ------------------------------------------------------- +* + OPEN (SYSPRINT,OUTPUT) open SYSPRINT + LTR R15,R15 test return code + BE OOPENOK + MVI RC+3,X'10' + B EXIT quit with RC=16 +OOPENOK OPEN (SYSIN,INPUT) open SYSIN + LTR R15,R15 test return code + BE IOPENOK + MVI RC+3,X'0C' + B EXIT quit with RC=12 +IOPENOK EQU * +* + LD FR0,=D'1.' + LDR FR2,FR0 + DD FR0,RR32 + STD FR0,RR32I RR32I = 1./RR32 +* +* read debug flags ---------------------------------------------------- +* + BAL R14,IGETLINE read input line + BAL R14,IINT10 get PRNT + STC R1,IDBGRR + BAL R14,IINT10 get PRNT + STC R1,IDBGRN + BAL R14,IINT10 get PRNT + STC R1,IDBGMC + MVI IEOFOK,X'01' expect EOF from now on +* + CLI IDBGRR,X'00' if any trace skip header print + BNE NOHDPRT + CLI IDBGRN,X'00' + BNE NOHDPRT + CLI IDBGMC,X'00' + BNE NOHDPRT + L R1,MSGHD1 + BAL R14,OTEXT + L R1,MSGHD2 + BAL R14,OTEXT + BAL R14,OPUTLINE write header +NOHDPRT EQU * +* +* main body ----------------------------------------------------------- +* +* outer loop +* + XR R3,R3 ntry = 0 + XR R4,R4 nhit = 0 +* +OLOOP BAL R14,IGETLINE read input line + BAL R14,IINT10 get PRNT + LTR R1,R1 is ngo == 0 + BE OLOOPE if = yes, quit outer loop +* +* inner loop +* + LR R2,R1 loop counter +* +ILOOP EQU * + BAL R8,RANNUM + MD FR0,=D'2.' + SD FR0,=D'1.' + STD FR0,X + BAL R8,RANNUM + MD FR0,=D'2.' + SD FR0,=D'1.' + STD FR0,Y + MDR FR0,FR0 + LD FR2,X + MDR FR2,FR2 + ADR FR0,FR2 + STD FR0,R + A R3,=F'1' + CD FR0,=D'1.' + BH CMISS + A R4,=F'1' +CMISS EQU * + CLI IDBGMC,X'00' + BE NODBGMC + L R1,MSGMC + BAL R14,OTEXT print "MC: " + LD FR0,X + BAL R14,OFIX1308 print x + LD FR0,Y + BAL R14,OFIX1308 print y + LD FR0,R + BAL R14,OFIX1308 print r + LR R1,R4 + BAL R14,OINT10 print nhit + BAL R14,OPUTLINE write line +* +NODBGMC EQU * + BCT R2,ILOOP +* + L R0,ODNZERO + ST R0,ODTEMP + ST R4,ODTEMP+4 nhit as denorm float + SDR FR0,FR0 FR0 := 0. + AD FR0,ODTEMP add to re-normalize, FR0:=nhit + ST R3,ODTEMP+4 ntry as denorm float + SDR FR2,FR2 FR2 := 0. + AD FR2,ODTEMP add to re-normalize, FR2:=ntry + DDR FR0,FR2 nhit/ntry + MD FR0,=D'4.' piest = 4.*nhit/ntry + STD FR0,PIEST + SD FR0,PI piest - pi + LPDR FR0,FR0 pierr = abs(piest - pi) + STD FR0,PIERR +* + L R1,MSGPI + BAL R14,OTEXT print "PI: " + LR R1,R3 + BAL R14,OINT10 print ntry + LR R1,R4 + BAL R14,OINT10 print nhit + LD FR0,PIEST + BAL R14,OFIX1308 print piest + LD R0,PIERR + BAL R14,OFIX1308 print pierr + LD FR0,RLAST + BAL R14,OFIX1200 print rlast + BAL R14,OPUTLINE write line +* + B OLOOP +OLOOPE EQU * +* +* close datasets and return to OS ------------------------------------- +* +EXIT CLOSE SYSPRINT close SYSPRINT + CLOSE SYSIN close SYSIN + L R13,SAVE+4 get old save area back + L R0,RC get return code + ST R0,16(R13) store in old save R15 + RETURN (14,12) return to OS (will setup RC) +* +* RANNUM -------------------------------------------------------------- +* uses all float regs +* uses R0,R1,R6,R7,R8,R9,R14,R15 +* keeps R2-R5,R10-R11 +* +RANNUM CLI RANINI,X'00' init done ? + BNE RANNUMGO if != yes +* + L R6,=A(RSHUF) pointer to rshuf + LA R7,128 loop count +RANNUML BAL R9,RANRAW get raw + STD FR0,0(R6) store + LA R6,8(R6) push pointer + BCT R7,RANNUML and loop + MVI RANINI,X'01' ranini = true +* +RANNUMGO L R6,=A(RSHUF) pointer to rshuf + LD FR0,RLAST + AW FR0,ODNZERO denormalize + STD FR0,RFAC1 + L R7,RFAC1+4 int(rlast) + SRL R7,25 int(rlast/rdiv) + SLA R7,3 convert index to offset + LD FR0,0(R7,R6) rshuf[i] + STD FR0,RLAST rlast = rshuf[i] + BAL R9,RANRAW get new random number + STD FR0,0(R7,R6) rshuf[i] = ranraw() + LD FR0,RLAST + MD FR0,RR32I rlast*rr32i + CLI IDBGRN,X'00' RN trace ? + BE RANNUMNT +* + STD FR0,RNEW save rnew + L R1,MSGRN + BAL R14,OTEXT print "RN: " + LR R1,R7 + SRA R1,3 convert back to index + BAL R14,OINT10 print i + LD FR0,RLAST + BAL R14,OFIX1200 print rlast + LD FR0,RNEW + BAL R14,OFIX1308 print rnew + BAL R14,OPUTLINE write line + LD FR0,RNEW restore rnew +* +RANNUMNT EQU * +* + BR R8 +* +* RANRAW -------------------------------------------------------------- +* uses all float regs +* uses R0,R1,R14,R15 +* keeps R2-R11 + +RANRAW LD FR0,RSEED + MD FR0,RFACTOR rnew1 = rseed * 69069. + LDR FR6,FR0 save rnew1 + LDR FR2,FR0 rmsb = rnew1 + AW FR2,ODNZERO denormalize + STD FR2,RFAC1 save + XR R1,R1 R1:=0 + ST R1,RFAC1+4 clear lower 32 bits of rmsb + SD FR0,RFAC1 rnew = rnew1 modulo 2^32 !! + STD FR0,RNEW + CLI IDBGRR,X'00' RR trace ? + BE RANRAWNT +* + STD FR4,RFAC really save rfac + STD FR6,RNEW1 really save rnew1 + L R1,MSGRR + BAL R14,OTEXT print "RR: " + LD FR0,RSEED + BAL R14,OFIX1200 print rseed + LD FR0,RNEW + BAL R14,OFIX1200 print rnew + L R1,MSGCSEP + BAL R14,OTEXT print " : " + L R1,RFAC+4 + BAL R14,OINT10 print ifac + BAL R14,OPUTLINE write line +* +RANRAWNT LD FR0,RNEW + STD FR0,RSEED + BR R9 +* +* include simple output system ---------------------------------------- +* +* simple output system procedures ------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* OSKIP02 -------------------------------------------------- +* add 2 blanks +* +OSKIP02 LA R1,2 +* +* OSKIP ---------------------------------------------------- +* add blanks, count in R1 +* +OSKIP A R1,OLPTR new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OTAB ---------------------------------------------------- +* set output column, position in R1 +* +OTAB A R1,=A(OLBUF+1) new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OSFILL --------------------------------------------------- +* add " ***" pattern, total length in R1 +* +OSFILL L R15,OLPTR R15 points to edit position + MVI 0(R15),C' ' initial blank + B OSFILLN +OSFILLL MVI 0(R15),C'*' further '*' +OSFILLN LA R15,1(R15) + BCT R1,OSFILLL + ST R15,OLPTR store pointer + BR R14 +* +* OTEXT ---------------------------------------------------- +* print text, R1 hold descriptor address +* descriptor format +* DC AL1() +* DC AL2(
) +* +OTEXT ST R14,OTEXTL save R14 + LR R14,R1 + SRL R14,24 R14 now string length + L R15,OLPTR R15 points to edit position + LR R0,R15 R0 too + AR R0,R14 push pointer, add length + ST R0,OLPTR store pointer + BCTR R14,0 decrement length for EX + EX R14,OTEXTMVC copy string via EX:MVC + L R14,OTEXTL restore R14 linkage + BR R14 +* +OTEXTMVC MVC 0(1,R15),0(R1) length via EX, dst R15, src R1 +OTEXTL DS F save area for R14 (return linkage) +* +* OPUTLINE ------------------------------------------------- +* write line to SYSPRINT +* +OPUTLINE ST R14,OPUTLNEL save R14 + L R15,=A(OLBUF) + CLI 133(R15),X'00' check fence byte + BNE OPUTLNEA crash if fence blown + L R1,=A(SYSPRINT) R1 point to DCB + LR R0,R15 R1 point to buffer + PUT (1),(0) write line + L R15,=A(OLBUF) point to CC of OLBUF + MVI 0(R15),C' ' blank OLBUF(0) + MVC 1(L'OLBUF-1,R15),0(R15) propagate blank + LA R15,1(R15) point to 1st print char in OLBUF + ST R15,OLPTR reset current position pointer + LA R15,1 + AH R15,OLCNT increment line counter + STH R15,OLCNT + SH R15,OLMAX R15 := OLCNT-OLMAX + BL OPUTLNES if < no new page + XR R15,R15 R15 := 0 + SH R15,OLCNT clear line counter + L R15,=A(OLBUF) point to CC of OLBUF +* MVI 0(R15),C'1' set new page CC in OLBUF +OPUTLNES L R14,OPUTLNEL restore R14 linkage + BR R14 +* +OPUTLNEA ABEND 255 abend in case of errors +* +OPUTLNEL DS F save area for R14 (return linkage) +* +* Work area for simple output system ------------------------ +* +OLPTR DC A(OLBUF+1) current output line position +OLCNT DC H'0' line counter +OLMAX DC H'60' lines per page +OCVD DS D buffer for CVD (8 byte, DW aligned) +* +ODTEMP DS D double buffer for conversions +ODNZERO DC X'4E000000',X'00000000' denormalized double zero +ODNONE DC X'4E000000',X'00000001' denormalized double one +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSPRINT DCB DSORG=PS,MACRF=PM,DDNAME=SYSPRINT, X + RECFM=FBA,LRECL=133,BLKSIZE=0 +OLBUF DC CL133' ',X'00' output line buffer and fence byte +* +MAIN CSECT +* +* OINT10 --------------------------------------------------- +* print integer, like PL/I F(10) or C %10d format +* very fast, for non-negative numbers only ! +* +OINT10 CL R1,=F'999999999' too large ? + BH OINT10F if > yes, do OSFILL + CVD R1,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEI10L,R15),OEI10 setup pattern + ED 0(OEI10L,R15),OCVD+3 and edit + LA R15,OEI10L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OINT10F LA R1,10 + B OSFILL +* +OEI10 DC C' ',7X'20',X'21',X'20' pat: bddddddd(d +OEI10L EQU *-OEI10 +* +* OHEX10 --------------------------------------------------- +* print integer, like C " %8.8x" format +* +OHEX10 ST R14,OHEX10L save R14 + L R15,OLPTR R15 points to edit position + LA R15,2(R15) add two blanks + LA R14,8(R15) end of buffer +* +OHEX10NL XR R0,R0 R0 := 0 + SLDA R0,4 get next 4 bits into R0 + AH R0,=X'00F0' add '0' + CH R0,=X'00F9' above 9 ? + BNH OHEX10OK if <= no, skip A-F correction + SH R0,=X'0039' sub (0xF0('0')+10)-0xC1('A')=0x39 +OHEX10OK STC R0,0(R15) store hex digit + LA R15,1(R15) push pointer + CR R15,R14 beyond end ? + BL OHEX10NL if < not, do next nibble +* + ST R15,OLPTR store pointer + L R14,OHEX10L restore R14 linkage + BR R14 +* +OHEX10L DS F save area for R14 (return linkage) +* +* OHEX210 -------------------------------------------------- +* print 64 field as two 32 bit hex numbers +* R1 points to memory location of 64 bit value +* rendered as " %8.8x %8.8x" +* +OHEX210 ST R14,OHEX210L save R14 + ST R1,OHEX210V save R1 + L R1,0(R1) get high part + BAL R14,OHEX10 convert + L R1,OHEX210V + L R1,4(R1) get low part + BAL R14,OHEX10 convert + L R14,OHEX210L restore R14 linkage + BR R14 and return +* +OHEX210L DS F save area for R14 (return linkage) +OHEX210V DS F save area for R1 (value ptr) +* +* OFIX1308, OFIX1306 - ------------------------------------- +* print double, like +* OFIX1308: PL/I F(13,8) or C %13.8f format +* OFIX1306: PL/I F(13,6) or C %13.6f format +* input value in floating reg FR0 +* handles signed numbers +* +OFIX1308 MD FR0,=D'1.E8' 'shift' 8 digits left + LA R1,OEF1308 pointer to edit pattern + LA R0,3 offset to one behind X'21' position + B OFIX13XX +* +OFIX1306 MD FR0,=D'1.E6' 'shift' 6 digits left + LA R1,OEF1306 pointer to edit pattern + LA R0,5 offset to one behind X'21' position +* +OFIX13XX LPDR FR2,FR0 get abbs() value + CD FR2,=D'2.E9' too large ? + BNL OFX13XXF if >= yes, do OSFILL +* + LDR FR4,FR2 + AW FR4,ODNZERO FR4 := de-normalized FR2 + SDR FR6,FR6 FR6 := 0. + ADR FR6,FR4 get integer part + SDR FR2,FR4 get fractional part + CD FR2,=D'0.5' check if >= 0.5 + BL OFX13XXR if < no need to round up + AW FR4,ODNONE otherwise add LSB DENORM +OFX13XXR STD FR4,ODTEMP roll-out to memory + L R15,ODTEMP+4 get integer part + CVD R15,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEF13XXL,R15),0(R1) setup pattern + LR R1,R15 setup R1 in case of miss + AR R1,R0 to one behind X'21' position + EDMK 0(OEF13XXL,R15),OCVD+2 and edit (and set R1) + LTDR FR0,FR0 negative number ? + BNM OFX13XXP if >= not + BCTR R1,0 decrement pointer + MVI 0(R1),C'-' write '-' sign +OFX13XXP LA R15,OEF13XXL(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OFX13XXF LA R1,OEF13XXL + B OSFILL +* +OEF1306 DC C' ',3X'20',X'21',X'20',C'.',6X'20' pat: bddd(d.dddddd +OEF1308 DC C' ',1X'20',X'21',X'20',C'.',8X'20' pat: bd(d.dddddddd +OEF13XXL EQU *-OEF1308 + +* +* OFIX1200 ------------------------------------------------- +* print double, like PL/I F(12,0) or C %12.0f format +* input value in floating reg FR0 +* only for non-negatve numbers +* +OFIX1200 LTDR FR0,FR0 check whether negative + BL OFX1200F if < yes, do OSFILL + CD FR0,=D'99999999999.' too large ? + BH OFX1200F if > yes, do OSFILL + AW FR0,ODNZERO de-normalize + STD FR0,ODTEMP roll-out to memory + L R1,ODTEMP+4 + L R0,ODTEMP + N R0,=X'00FFFFFF' + D R0,=F'100000000' now R0 lower 9, R1 upper digits + CVD R0,OCVD BCD convert lower part + L R15,OLPTR R15 points to edit position + LA R15,2(R15) add two blanks + LTR R1,R1 upper != 0 + BNZ OFX1200B if != yes, handle large number +* + MVC 0(OEI10L,R15),OEI10 setup pattern (from OINT10) + ED 0(OEI10L,R15),OCVD+3 and edit + LA R15,OEI10L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OFX1200B EQU * + MVC 0(OEF10LL,R15),OEF10L setup pattern + ED 0(OEF10LL,R15),OCVD+3 and edit + CVD R1,OCVD BCD convert upper part + L R15,OLPTR R15 points to edit position + MVC 0(OEF10UL,R15),OEF10U setup pattern + ED 0(OEF10UL,R15),OCVD+6 and edit + LA R15,12(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OFX1200F LA R1,12 + B OSFILL +* +OEF10L DC C' ',X'21',8X'20' pat: b(dddddddd +OEF10LL EQU *-OEF10L +OEF10U DC C' ',X'20',X'21',X'20' pat: bd(d +OEF10UL EQU *-OEF10U +* include simple input system ----------------------------------------- +* +* simple input system procedures -------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* IGETLINE ------------------------------------------------- +* read line from SYSIN +* EOF handling: +* - IEOFOK holds the 'EOF OK' flag +* - if EOF seen and IEOFOK = X'00', program ends with RC=8 +* - if EOF seen and IEOFOK != X'00', program ends with RC=0 +* +IGETLINE ST R14,IGETLNEL save R14 + L R1,=A(SYSIN) + L R0,=A(ILBUF) + GET (1),(0) read line + L R0,=A(ILBUF) + ST R0,ILPTR set input ptr to begin of line + L R14,IGETLNEL restore R14 linkage + BR R14 +* +IGETLNEL DS F save area for R14 (return linkage) +* +* IEOFHDL -------------------------------------------------- +* +IEOFHDL BALR R12,R0 where are we ? + LA R15,*-MAIN offset from MAIN to here + SR R12,R15 base reg now points to MAIN + LA R14,EXIT + CLI IEOFOK,X'00' is EOF ok ? + BNER R14 if != yes, jump to EXIT + MVI RC+3,X'08' otherwise set RC=8 + BR R14 and jump to EXIT +* +* Work area for simple output system ------------------------ +* +ILPTR DC A(ILBUF) current input line position +IEOFOK DS X'00' EOF ok flag +ICVB DS D buffer for CVB (8 byte, DW aligned) +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSIN DCB DSORG=PS,MACRF=GM,DDNAME=SYSIN,EODAD=IEOFHDL X + RECFM=FB,LRECL=80,BLKSIZE=0 +ILBUF DC CL80' ' input line buffer +MAIN CSECT +* +* IINT10 --------------------------------------------------- +* read integer, like PL/I F(10) or C %10d format +* +IINT10 L R15,ILPTR get input pointer + PACK ICVB(8),0(10,R15) pack next 10 char + CVB R1,ICVB and convert + LA R15,10(R15) push pointer by 10 char + ST R15,ILPTR and update + BR R14 +* +* Work area definitions ----------------------------------------------- +* +SAVE DS 18F local save area +RC DC F'0' return code +IDBGRR DC X'00' trace RR enable +IDBGRN DC X'00' trace RN enable +IDBGMC DC X'00' trace MC enable +RANINI DC X'00' init RSHUF done flag + DS 0D +RFACTOR DC D'69069.' +RSEED DC D'12345.' +RLAST DC D'0.' +RR32 DC D'4294967296.' is 4*1024*1024*1024 +RR32I DS D +RNEW DS D +RNEW1 DS D +RFAC DS D +RFAC1 DS D +* +PI DC D'3.141592653589793' +PIEST DS D +PIERR DS D +* +X DS D +Y DS D +R DS D +* +* message strings +* +MSGHD1 OTXTDSC C' ntry nhit pi-est' +MSGHD2 OTXTDSC C' pi-err seed' +MSGMC OTXTDSC C'MC: ' +MSGPI OTXTDSC C'PI: ' +MSGRR OTXTDSC C'RR: ' +MSGRN OTXTDSC C'RN: ' +MSGCSEP OTXTDSC C' : ' +* +* spill literal pool +* + LTORG +* +* data section +* +DATA CSECT +RSHUF DS 128D +* +* other defs and end +* + YREGS , +FR0 EQU 0 +FR2 EQU 2 +FR4 EQU 4 +FR6 EQU 6 + END MAIN define main entry point +/* +//GO.SYSUDUMP DD SYSOUT=*,OUTLIM=2000 +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 0 0 0 + 100 + 200 + 700 + 2000 + 7000 + 20000 + 70000 + 200000 + 700000 + 2000000 + 0 +/* +// +./ ADD NAME=MCPIASMT,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#ASM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=128K,TIME=(1,0),PRTY=8 +//CLG EXEC ASMFCLG, +// MAC1='SYS2.MACLIB', +// PARM.ASM='NODECK,LOAD', +// PARM.LKED='MAP,LIST,LET,NCAL', +// COND.LKED=(8,LE,ASM), +// PARM.GO='', +// COND.GO=((8,LE,ASM),(4,LT,LKED)) +//ASM.SYSUT1 DD DSN=&&SYSUT1,UNIT=SYSDA,SPACE=(1700,(600,100)) +//ASM.SYSUT2 DD DSN=&&SYSUT2,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSUT3 DD DSN=&&SYSUT3,UNIT=SYSDA,SPACE=(1700,(300,50)) +//ASM.SYSGO DD DSN=&&OBJSET,UNIT=SYSDA,SPACE=(80,(2000,500)) +//ASM.SYSIN DD * +* 1 2 3 4 5 6 71 +*23456789*12345*789012345678901234*678901234567890123456789012345678901 +* $Id: mcpi_asm.asm 979 2017-12-29 18:40:40Z mueller $ +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software; you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-29 979 1.2 some more code optimizations +* 2017-12-28 978 1.1 use inverse to avoid divide by constant +* 2017-11-12 961 1.0 Initial version +* 2017-10-10 955 0.1 First draft +* + PRINT NOGEN don't show macro expansions +* +* Prime number search +* RC = 0 ok +* RC = 8 unexpected SYSIN EOF +* RC = 12 open SYSIN failed +* RC = 16 open SYSPRINT failed +* +* local macros -------------------------------------------------------- +* +* +* OTXTDSC - setup text descriptor for simple output system - +* + MACRO +&LABEL OTXTDSC &TEXT +TEXT CSECT +SPTR&SYSNDX DC &TEXT +&SYSECT CSECT + DS 0F +&LABEL DC AL1(L'SPTR&SYSNDX),AL3(SPTR&SYSNDX) + MEND +* +* main preamble ------------------------------------------------------- +* +MAIN START 0 start main code csect at base 0 + SAVE (14,12) Save input registers + LR R12,R15 base register := entry address + USING MAIN,R12 declare base register + ST R13,SAVE+4 set back pointer in current save area + LR R2,R13 remember callers save area + LA R13,SAVE setup current save area + ST R13,8(R2) set forw pointer in callers save area +* +* open datasets ------------------------------------------------------- +* + OPEN (SYSPRINT,OUTPUT) open SYSPRINT + LTR R15,R15 test return code + BE OOPENOK + MVI RC+3,X'10' + B EXIT quit with RC=16 +OOPENOK OPEN (SYSIN,INPUT) open SYSIN + LTR R15,R15 test return code + BE IOPENOK + MVI RC+3,X'0C' + B EXIT quit with RC=12 +IOPENOK EQU * +* + LD FR0,=D'1.' + LDR FR2,FR0 + DD FR0,RR32 + STD FR0,RR32I RR32I = 1./RR32 +* +* read debug flags ---------------------------------------------------- +* + BAL R14,IGETLINE read input line + BAL R14,IINT10 get PRNT + STC R1,IDBGRR + BAL R14,IINT10 get PRNT + STC R1,IDBGRN + BAL R14,IINT10 get PRNT + STC R1,IDBGMC + MVI IEOFOK,X'01' expect EOF from now on +* + CLI IDBGRR,X'00' if any trace skip header print + BNE NOHDPRT + CLI IDBGRN,X'00' + BNE NOHDPRT + CLI IDBGMC,X'00' + BNE NOHDPRT + L R1,MSGHD1 + BAL R14,OTEXT + L R1,MSGHD2 + BAL R14,OTEXT + BAL R14,OPUTLINE write header +NOHDPRT EQU * +* +* main body ----------------------------------------------------------- +* +* outer loop +* + XR R3,R3 ntry = 0 + XR R4,R4 nhit = 0 +* +OLOOP BAL R14,IGETLINE read input line + BAL R14,IINT10 get PRNT + LTR R1,R1 is ngo == 0 + BE OLOOPE if = yes, quit outer loop +* +* inner loop +* + LR R2,R1 loop counter +* +ILOOP EQU * + BAL R8,RANNUM + MD FR0,=D'2.' + SD FR0,=D'1.' + STD FR0,X + BAL R8,RANNUM + MD FR0,=D'2.' + SD FR0,=D'1.' + STD FR0,Y + MDR FR0,FR0 + LD FR2,X + MDR FR2,FR2 + ADR FR0,FR2 + STD FR0,R + A R3,=F'1' + CD FR0,=D'1.' + BH CMISS + A R4,=F'1' +CMISS EQU * + CLI IDBGMC,X'00' + BE NODBGMC + L R1,MSGMC + BAL R14,OTEXT print "MC: " + LD FR0,X + BAL R14,OFIX1308 print x + LD FR0,Y + BAL R14,OFIX1308 print y + LD FR0,R + BAL R14,OFIX1308 print r + LR R1,R4 + BAL R14,OINT10 print nhit + BAL R14,OPUTLINE write line +* +NODBGMC EQU * + BCT R2,ILOOP +* + L R0,ODNZERO + ST R0,ODTEMP + ST R4,ODTEMP+4 nhit as denorm float + SDR FR0,FR0 FR0 := 0. + AD FR0,ODTEMP add to re-normalize, FR0:=nhit + ST R3,ODTEMP+4 ntry as denorm float + SDR FR2,FR2 FR2 := 0. + AD FR2,ODTEMP add to re-normalize, FR2:=ntry + DDR FR0,FR2 nhit/ntry + MD FR0,=D'4.' piest = 4.*nhit/ntry + STD FR0,PIEST + SD FR0,PI piest - pi + LPDR FR0,FR0 pierr = abs(piest - pi) + STD FR0,PIERR +* + L R1,MSGPI + BAL R14,OTEXT print "PI: " + LR R1,R3 + BAL R14,OINT10 print ntry + LR R1,R4 + BAL R14,OINT10 print nhit + LD FR0,PIEST + BAL R14,OFIX1308 print piest + LD R0,PIERR + BAL R14,OFIX1308 print pierr + LD FR0,RLAST + BAL R14,OFIX1200 print rlast + BAL R14,OPUTLINE write line +* + B OLOOP +OLOOPE EQU * +* +* close datasets and return to OS ------------------------------------- +* +EXIT CLOSE SYSPRINT close SYSPRINT + CLOSE SYSIN close SYSIN + L R13,SAVE+4 get old save area back + L R0,RC get return code + ST R0,16(R13) store in old save R15 + RETURN (14,12) return to OS (will setup RC) +* +* RANNUM -------------------------------------------------------------- +* uses all float regs +* uses R0,R1,R6,R7,R8,R9,R14,R15 +* keeps R2-R5,R10-R11 +* +RANNUM CLI RANINI,X'00' init done ? + BNE RANNUMGO if != yes +* + L R6,=A(RSHUF) pointer to rshuf + LA R7,128 loop count +RANNUML BAL R9,RANRAW get raw + STD FR0,0(R6) store + LA R6,8(R6) push pointer + BCT R7,RANNUML and loop + MVI RANINI,X'01' ranini = true +* +RANNUMGO L R6,=A(RSHUF) pointer to rshuf + LD FR0,RLAST + AW FR0,ODNZERO denormalize + STD FR0,RFAC1 + L R7,RFAC1+4 int(rlast) + SRL R7,25 int(rlast/rdiv) + SLA R7,3 convert index to offset + LD FR0,0(R7,R6) rshuf[i] + STD FR0,RLAST rlast = rshuf[i] + BAL R9,RANRAW get new random number + STD FR0,0(R7,R6) rshuf[i] = ranraw() + LD FR0,RLAST + MD FR0,RR32I rlast*rr32i + CLI IDBGRN,X'00' RN trace ? + BE RANNUMNT +* + STD FR0,RNEW save rnew + L R1,MSGRN + BAL R14,OTEXT print "RN: " + LR R1,R7 + SRA R1,3 convert back to index + BAL R14,OINT10 print i + LD FR0,RLAST + BAL R14,OFIX1200 print rlast + LD FR0,RNEW + BAL R14,OFIX1308 print rnew + BAL R14,OPUTLINE write line + LD FR0,RNEW restore rnew +* +RANNUMNT EQU * +* + BR R8 +* +* RANRAW -------------------------------------------------------------- +* uses all float regs +* uses R0,R1,R14,R15 +* keeps R2-R11 + +RANRAW LD FR0,RSEED + MD FR0,RFACTOR rnew1 = rseed * 69069. + LDR FR6,FR0 save rnew1 + LDR FR2,FR0 rmsb = rnew1 + AW FR2,ODNZERO denormalize + STD FR2,RFAC1 save + XR R1,R1 R1:=0 + ST R1,RFAC1+4 clear lower 32 bits of rmsb + SD FR0,RFAC1 rnew = rnew1 modulo 2^32 !! + STD FR0,RNEW + CLI IDBGRR,X'00' RR trace ? + BE RANRAWNT +* + STD FR4,RFAC really save rfac + STD FR6,RNEW1 really save rnew1 + L R1,MSGRR + BAL R14,OTEXT print "RR: " + LD FR0,RSEED + BAL R14,OFIX1200 print rseed + LD FR0,RNEW + BAL R14,OFIX1200 print rnew + L R1,MSGCSEP + BAL R14,OTEXT print " : " + L R1,RFAC+4 + BAL R14,OINT10 print ifac + BAL R14,OPUTLINE write line +* +RANRAWNT LD FR0,RNEW + STD FR0,RSEED + BR R9 +* +* include simple output system ---------------------------------------- +* +* simple output system procedures ------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* OSKIP02 -------------------------------------------------- +* add 2 blanks +* +OSKIP02 LA R1,2 +* +* OSKIP ---------------------------------------------------- +* add blanks, count in R1 +* +OSKIP A R1,OLPTR new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OTAB ---------------------------------------------------- +* set output column, position in R1 +* +OTAB A R1,=A(OLBUF+1) new edit position + ST R1,OLPTR store pointer + BR R14 +* +* OSFILL --------------------------------------------------- +* add " ***" pattern, total length in R1 +* +OSFILL L R15,OLPTR R15 points to edit position + MVI 0(R15),C' ' initial blank + B OSFILLN +OSFILLL MVI 0(R15),C'*' further '*' +OSFILLN LA R15,1(R15) + BCT R1,OSFILLL + ST R15,OLPTR store pointer + BR R14 +* +* OTEXT ---------------------------------------------------- +* print text, R1 hold descriptor address +* descriptor format +* DC AL1() +* DC AL2(
) +* +OTEXT ST R14,OTEXTL save R14 + LR R14,R1 + SRL R14,24 R14 now string length + L R15,OLPTR R15 points to edit position + LR R0,R15 R0 too + AR R0,R14 push pointer, add length + ST R0,OLPTR store pointer + BCTR R14,0 decrement length for EX + EX R14,OTEXTMVC copy string via EX:MVC + L R14,OTEXTL restore R14 linkage + BR R14 +* +OTEXTMVC MVC 0(1,R15),0(R1) length via EX, dst R15, src R1 +OTEXTL DS F save area for R14 (return linkage) +* +* OPUTLINE ------------------------------------------------- +* write line to SYSPRINT +* +OPUTLINE ST R14,OPUTLNEL save R14 + L R15,=A(OLBUF) + CLI 133(R15),X'00' check fence byte + BNE OPUTLNEA crash if fence blown + L R1,=A(SYSPRINT) R1 point to DCB + LR R0,R15 R1 point to buffer + PUT (1),(0) write line + L R15,=A(OLBUF) point to CC of OLBUF + MVI 0(R15),C' ' blank OLBUF(0) + MVC 1(L'OLBUF-1,R15),0(R15) propagate blank + LA R15,1(R15) point to 1st print char in OLBUF + ST R15,OLPTR reset current position pointer + LA R15,1 + AH R15,OLCNT increment line counter + STH R15,OLCNT + SH R15,OLMAX R15 := OLCNT-OLMAX + BL OPUTLNES if < no new page + XR R15,R15 R15 := 0 + SH R15,OLCNT clear line counter + L R15,=A(OLBUF) point to CC of OLBUF +* MVI 0(R15),C'1' set new page CC in OLBUF +OPUTLNES L R14,OPUTLNEL restore R14 linkage + BR R14 +* +OPUTLNEA ABEND 255 abend in case of errors +* +OPUTLNEL DS F save area for R14 (return linkage) +* +* Work area for simple output system ------------------------ +* +OLPTR DC A(OLBUF+1) current output line position +OLCNT DC H'0' line counter +OLMAX DC H'60' lines per page +OCVD DS D buffer for CVD (8 byte, DW aligned) +* +ODTEMP DS D double buffer for conversions +ODNZERO DC X'4E000000',X'00000000' denormalized double zero +ODNONE DC X'4E000000',X'00000001' denormalized double one +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSPRINT DCB DSORG=PS,MACRF=PM,DDNAME=SYSPRINT, X + RECFM=FBA,LRECL=133,BLKSIZE=0 +OLBUF DC CL133' ',X'00' output line buffer and fence byte +* +MAIN CSECT +* +* OINT10 --------------------------------------------------- +* print integer, like PL/I F(10) or C %10d format +* very fast, for non-negative numbers only ! +* +OINT10 CL R1,=F'999999999' too large ? + BH OINT10F if > yes, do OSFILL + CVD R1,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEI10L,R15),OEI10 setup pattern + ED 0(OEI10L,R15),OCVD+3 and edit + LA R15,OEI10L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OINT10F LA R1,10 + B OSFILL +* +OEI10 DC C' ',7X'20',X'21',X'20' pat: bddddddd(d +OEI10L EQU *-OEI10 +* +* OHEX10 --------------------------------------------------- +* print integer, like C " %8.8x" format +* +OHEX10 ST R14,OHEX10L save R14 + L R15,OLPTR R15 points to edit position + LA R15,2(R15) add two blanks + LA R14,8(R15) end of buffer +* +OHEX10NL XR R0,R0 R0 := 0 + SLDA R0,4 get next 4 bits into R0 + AH R0,=X'00F0' add '0' + CH R0,=X'00F9' above 9 ? + BNH OHEX10OK if <= no, skip A-F correction + SH R0,=X'0039' sub (0xF0('0')+10)-0xC1('A')=0x39 +OHEX10OK STC R0,0(R15) store hex digit + LA R15,1(R15) push pointer + CR R15,R14 beyond end ? + BL OHEX10NL if < not, do next nibble +* + ST R15,OLPTR store pointer + L R14,OHEX10L restore R14 linkage + BR R14 +* +OHEX10L DS F save area for R14 (return linkage) +* +* OHEX210 -------------------------------------------------- +* print 64 field as two 32 bit hex numbers +* R1 points to memory location of 64 bit value +* rendered as " %8.8x %8.8x" +* +OHEX210 ST R14,OHEX210L save R14 + ST R1,OHEX210V save R1 + L R1,0(R1) get high part + BAL R14,OHEX10 convert + L R1,OHEX210V + L R1,4(R1) get low part + BAL R14,OHEX10 convert + L R14,OHEX210L restore R14 linkage + BR R14 and return +* +OHEX210L DS F save area for R14 (return linkage) +OHEX210V DS F save area for R1 (value ptr) +* +* OFIX1308, OFIX1306 - ------------------------------------- +* print double, like +* OFIX1308: PL/I F(13,8) or C %13.8f format +* OFIX1306: PL/I F(13,6) or C %13.6f format +* input value in floating reg FR0 +* handles signed numbers +* +OFIX1308 MD FR0,=D'1.E8' 'shift' 8 digits left + LA R1,OEF1308 pointer to edit pattern + LA R0,3 offset to one behind X'21' position + B OFIX13XX +* +OFIX1306 MD FR0,=D'1.E6' 'shift' 6 digits left + LA R1,OEF1306 pointer to edit pattern + LA R0,5 offset to one behind X'21' position +* +OFIX13XX LPDR FR2,FR0 get abbs() value + CD FR2,=D'2.E9' too large ? + BNL OFX13XXF if >= yes, do OSFILL +* + LDR FR4,FR2 + AW FR4,ODNZERO FR4 := de-normalized FR2 + SDR FR6,FR6 FR6 := 0. + ADR FR6,FR4 get integer part + SDR FR2,FR4 get fractional part + CD FR2,=D'0.5' check if >= 0.5 + BL OFX13XXR if < no need to round up + AW FR4,ODNONE otherwise add LSB DENORM +OFX13XXR STD FR4,ODTEMP roll-out to memory + L R15,ODTEMP+4 get integer part + CVD R15,OCVD convert + L R15,OLPTR R15 points to edit position + MVC 0(OEF13XXL,R15),0(R1) setup pattern + LR R1,R15 setup R1 in case of miss + AR R1,R0 to one behind X'21' position + EDMK 0(OEF13XXL,R15),OCVD+2 and edit (and set R1) + LTDR FR0,FR0 negative number ? + BNM OFX13XXP if >= not + BCTR R1,0 decrement pointer + MVI 0(R1),C'-' write '-' sign +OFX13XXP LA R15,OEF13XXL(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OFX13XXF LA R1,OEF13XXL + B OSFILL +* +OEF1306 DC C' ',3X'20',X'21',X'20',C'.',6X'20' pat: bddd(d.dddddd +OEF1308 DC C' ',1X'20',X'21',X'20',C'.',8X'20' pat: bd(d.dddddddd +OEF13XXL EQU *-OEF1308 + +* +* OFIX1200 ------------------------------------------------- +* print double, like PL/I F(12,0) or C %12.0f format +* input value in floating reg FR0 +* only for non-negatve numbers +* +OFIX1200 LTDR FR0,FR0 check whether negative + BL OFX1200F if < yes, do OSFILL + CD FR0,=D'99999999999.' too large ? + BH OFX1200F if > yes, do OSFILL + AW FR0,ODNZERO de-normalize + STD FR0,ODTEMP roll-out to memory + L R1,ODTEMP+4 + L R0,ODTEMP + N R0,=X'00FFFFFF' + D R0,=F'100000000' now R0 lower 9, R1 upper digits + CVD R0,OCVD BCD convert lower part + L R15,OLPTR R15 points to edit position + LA R15,2(R15) add two blanks + LTR R1,R1 upper != 0 + BNZ OFX1200B if != yes, handle large number +* + MVC 0(OEI10L,R15),OEI10 setup pattern (from OINT10) + ED 0(OEI10L,R15),OCVD+3 and edit + LA R15,OEI10L(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OFX1200B EQU * + MVC 0(OEF10LL,R15),OEF10L setup pattern + ED 0(OEF10LL,R15),OCVD+3 and edit + CVD R1,OCVD BCD convert upper part + L R15,OLPTR R15 points to edit position + MVC 0(OEF10UL,R15),OEF10U setup pattern + ED 0(OEF10UL,R15),OCVD+6 and edit + LA R15,12(R15) push pointer + ST R15,OLPTR store pointer + BR R14 +* +OFX1200F LA R1,12 + B OSFILL +* +OEF10L DC C' ',X'21',8X'20' pat: b(dddddddd +OEF10LL EQU *-OEF10L +OEF10U DC C' ',X'20',X'21',X'20' pat: bd(d +OEF10UL EQU *-OEF10U +* include simple input system ----------------------------------------- +* +* simple input system procedures -------------------------------------- +* calling and register convention: +* R1 holds value (or descriptor pointer) +* R0,R1 may be modified +* R14,R15 may be modified +* R2-R11 are not changed +* +* in short +* R1 holds input or output value (or pointer) +* call with BAL R14, +* +* IGETLINE ------------------------------------------------- +* read line from SYSIN +* EOF handling: +* - IEOFOK holds the 'EOF OK' flag +* - if EOF seen and IEOFOK = X'00', program ends with RC=8 +* - if EOF seen and IEOFOK != X'00', program ends with RC=0 +* +IGETLINE ST R14,IGETLNEL save R14 + L R1,=A(SYSIN) + L R0,=A(ILBUF) + GET (1),(0) read line + L R0,=A(ILBUF) + ST R0,ILPTR set input ptr to begin of line + L R14,IGETLNEL restore R14 linkage + BR R14 +* +IGETLNEL DS F save area for R14 (return linkage) +* +* IEOFHDL -------------------------------------------------- +* +IEOFHDL BALR R12,R0 where are we ? + LA R15,*-MAIN offset from MAIN to here + SR R12,R15 base reg now points to MAIN + LA R14,EXIT + CLI IEOFOK,X'00' is EOF ok ? + BNER R14 if != yes, jump to EXIT + MVI RC+3,X'08' otherwise set RC=8 + BR R14 and jump to EXIT +* +* Work area for simple output system ------------------------ +* +ILPTR DC A(ILBUF) current input line position +IEOFOK DS X'00' EOF ok flag +ICVB DS D buffer for CVB (8 byte, DW aligned) +* +* DCB and OLBUF in separate CSECT +* +SIOSDATA CSECT + DS 0F +SYSIN DCB DSORG=PS,MACRF=GM,DDNAME=SYSIN,EODAD=IEOFHDL X + RECFM=FB,LRECL=80,BLKSIZE=0 +ILBUF DC CL80' ' input line buffer +MAIN CSECT +* +* IINT10 --------------------------------------------------- +* read integer, like PL/I F(10) or C %10d format +* +IINT10 L R15,ILPTR get input pointer + PACK ICVB(8),0(10,R15) pack next 10 char + CVB R1,ICVB and convert + LA R15,10(R15) push pointer by 10 char + ST R15,ILPTR and update + BR R14 +* +* Work area definitions ----------------------------------------------- +* +SAVE DS 18F local save area +RC DC F'0' return code +IDBGRR DC X'00' trace RR enable +IDBGRN DC X'00' trace RN enable +IDBGMC DC X'00' trace MC enable +RANINI DC X'00' init RSHUF done flag + DS 0D +RFACTOR DC D'69069.' +RSEED DC D'12345.' +RLAST DC D'0.' +RR32 DC D'4294967296.' is 4*1024*1024*1024 +RR32I DS D +RNEW DS D +RNEW1 DS D +RFAC DS D +RFAC1 DS D +* +PI DC D'3.141592653589793' +PIEST DS D +PIERR DS D +* +X DS D +Y DS D +R DS D +* +* message strings +* +MSGHD1 OTXTDSC C' ntry nhit pi-est' +MSGHD2 OTXTDSC C' pi-err seed' +MSGMC OTXTDSC C'MC: ' +MSGPI OTXTDSC C'PI: ' +MSGRR OTXTDSC C'RR: ' +MSGRN OTXTDSC C'RN: ' +MSGCSEP OTXTDSC C' : ' +* +* spill literal pool +* + LTORG +* +* data section +* +DATA CSECT +RSHUF DS 128D +* +* other defs and end +* + YREGS , +FR0 EQU 0 +FR2 EQU 2 +FR4 EQU 4 +FR6 EQU 6 + END MAIN define main entry point +/* +//GO.SYSUDUMP DD SYSOUT=*,OUTLIM=2000 +//GO.SYSPRINT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 1 1 1 + 10 + 0 +/* +// +./ ADD NAME=MCPIGCCF,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#GCC JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=8192K,TIME=(10,0),PRTY=2 +//CLG EXEC GCCCLG,COPTS='-O3', +// PARM.LKED='MAP,LIST' +//COMP.SYSIN DD DATA,DLM='/@' +/* $Id: mcpi_cc.c 978 2017-12-28 21:32:18Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-28 978 1.1 use inverse to avoid divide by constant */ +/* 2017-08-12 938 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + +#include +#include + +double rseed = 12345.; +double rlast = 0.; +double rshuf[128]; +double rr32 = 4294967296.; /* 4*1024*1024*1024 */ +double rdiv = 33554432.; /* rr32 / 128 */ +double rr32i; /* setup in main() */ +double rdivi; /* setup in main() */ +int ranini = 0; +int idbgrr = 0; +int idbgrn = 0; +int idbgmc = 0; + +double ranraw() +{ + double rnew,rnew1; + double rfac; + int ifac; + + rnew1 = rseed * 69069.; + rfac = rnew1 * rr32i; + ifac = rfac; + rfac = ifac; + rnew = rnew1 - rfac * rr32; + if (idbgrr) printf("RR: %12.0f %12.0f : %16.0f %9d\n", + rseed,rnew, rnew1,ifac); + rseed = rnew; + return rnew; +} + +double rannum() +{ + int i; + double rnew; + + if (ranini == 0) { + for (i=0; i<128; i++) rshuf[i] = ranraw(); + ranini = 1; + } + + i = rlast * rdivi; + rlast = rshuf[i]; + rshuf[i] = ranraw(); + rnew = rlast * rr32i; + if (idbgrn) printf("RN: %12d %12.0f %12.8f\n", i,rlast,rnew); + return rnew; +} + +int main() +{ + int i; + int ntry = 0; + int nhit = 0; + int ngo; + double pi = 3.141592653589793; + double piest; + double pierr; + + /* setup global constants */ + rr32i = 1./rr32; + rdivi = 1./rdiv; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d %d", &idbgrr, &idbgrn, &idbgmc) != 3) { + printf("conversion error, abort\n"); + return 1; + } + + if (idbgrr == 0 && idbgrn == 0 && idbgmc == 0) + printf(" ntry nhit pi-est" + " pi-err seed\n"); + + while (scanf(" %d", &ngo) == 1 && ngo > 0) { + for (i=0; i */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-28 978 1.1 use inverse to avoid divide by constant */ +/* 2017-08-12 938 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + +#include +#include + +double rseed = 12345.; +double rlast = 0.; +double rshuf[128]; +double rr32 = 4294967296.; /* 4*1024*1024*1024 */ +double rdiv = 33554432.; /* rr32 / 128 */ +double rr32i; /* setup in main() */ +double rdivi; /* setup in main() */ +int ranini = 0; +int idbgrr = 0; +int idbgrn = 0; +int idbgmc = 0; + +double ranraw() +{ + double rnew,rnew1; + double rfac; + int ifac; + + rnew1 = rseed * 69069.; + rfac = rnew1 * rr32i; + ifac = rfac; + rfac = ifac; + rnew = rnew1 - rfac * rr32; + if (idbgrr) printf("RR: %12.0f %12.0f : %16.0f %9d\n", + rseed,rnew, rnew1,ifac); + rseed = rnew; + return rnew; +} + +double rannum() +{ + int i; + double rnew; + + if (ranini == 0) { + for (i=0; i<128; i++) rshuf[i] = ranraw(); + ranini = 1; + } + + i = rlast * rdivi; + rlast = rshuf[i]; + rshuf[i] = ranraw(); + rnew = rlast * rr32i; + if (idbgrn) printf("RN: %12d %12.0f %12.8f\n", i,rlast,rnew); + return rnew; +} + +int main() +{ + int i; + int ntry = 0; + int nhit = 0; + int ngo; + double pi = 3.141592653589793; + double piest; + double pierr; + + /* setup global constants */ + rr32i = 1./rr32; + rdivi = 1./rdiv; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d %d", &idbgrr, &idbgrn, &idbgmc) != 3) { + printf("conversion error, abort\n"); + return 1; + } + + if (idbgrr == 0 && idbgrn == 0 && idbgmc == 0) + printf(" ntry nhit pi-est" + " pi-err seed\n"); + + while (scanf(" %d", &ngo) == 1 && ngo > 0) { + for (i=0; i */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-28 978 1.1 use inverse to avoid divide by constant */ +/* 2017-08-12 938 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + +#include +#include + +double rseed = 12345.; +double rlast = 0.; +double rshuf[128]; +double rr32 = 4294967296.; /* 4*1024*1024*1024 */ +double rdiv = 33554432.; /* rr32 / 128 */ +double rr32i; /* setup in main() */ +double rdivi; /* setup in main() */ +int ranini = 0; +int idbgrr = 0; +int idbgrn = 0; +int idbgmc = 0; + +double ranraw() +{ + double rnew,rnew1; + double rfac; + int ifac; + + rnew1 = rseed * 69069.; + rfac = rnew1 * rr32i; + ifac = rfac; + rfac = ifac; + rnew = rnew1 - rfac * rr32; + if (idbgrr) printf("RR: %12.0f %12.0f : %16.0f %9d\n", + rseed,rnew, rnew1,ifac); + rseed = rnew; + return rnew; +} + +double rannum() +{ + int i; + double rnew; + + if (ranini == 0) { + for (i=0; i<128; i++) rshuf[i] = ranraw(); + ranini = 1; + } + + i = rlast * rdivi; + rlast = rshuf[i]; + rshuf[i] = ranraw(); + rnew = rlast * rr32i; + if (idbgrn) printf("RN: %12d %12.0f %12.8f\n", i,rlast,rnew); + return rnew; +} + +int main() +{ + int i; + int ntry = 0; + int nhit = 0; + int ngo; + double pi = 3.141592653589793; + double piest; + double pierr; + + /* setup global constants */ + rr32i = 1./rr32; + rdivi = 1./rdiv; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d %d", &idbgrr, &idbgrn, &idbgmc) != 3) { + printf("conversion error, abort\n"); + return 1; + } + + if (idbgrr == 0 && idbgrn == 0 && idbgmc == 0) + printf(" ntry nhit pi-est" + " pi-err seed\n"); + + while (scanf(" %d", &ngo) == 1 && ngo > 0) { + for (i=0; i */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-28 978 1.1 use inverse to avoid divide by constant */ +/* 2017-08-12 938 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + +#include +#include + +double rseed = 12345.; +double rlast = 0.; +double rshuf[128]; +double rr32 = 4294967296.; /* 4*1024*1024*1024 */ +double rdiv = 33554432.; /* rr32 / 128 */ +double rr32i; /* setup in main() */ +double rdivi; /* setup in main() */ +int ranini = 0; +int idbgrr = 0; +int idbgrn = 0; +int idbgmc = 0; + +double ranraw() +{ + double rnew,rnew1; + double rfac; + int ifac; + + rnew1 = rseed * 69069.; + rfac = rnew1 * rr32i; + ifac = rfac; + rfac = ifac; + rnew = rnew1 - rfac * rr32; + if (idbgrr) printf("RR: %12.0f %12.0f : %16.0f %9d\n", + rseed,rnew, rnew1,ifac); + rseed = rnew; + return rnew; +} + +double rannum() +{ + int i; + double rnew; + + if (ranini == 0) { + for (i=0; i<128; i++) rshuf[i] = ranraw(); + ranini = 1; + } + + i = rlast * rdivi; + rlast = rshuf[i]; + rshuf[i] = ranraw(); + rnew = rlast * rr32i; + if (idbgrn) printf("RN: %12d %12.0f %12.8f\n", i,rlast,rnew); + return rnew; +} + +int main() +{ + int i; + int ntry = 0; + int nhit = 0; + int ngo; + double pi = 3.141592653589793; + double piest; + double pierr; + + /* setup global constants */ + rr32i = 1./rr32; + rdivi = 1./rdiv; + + /* JCC on MVS doesn't skip initial white space, add leading ' ' to force */ + if (scanf(" %d %d %d", &idbgrr, &idbgrn, &idbgmc) != 3) { + printf("conversion error, abort\n"); + return 1; + } + + if (idbgrr == 0 && idbgrn == 0 && idbgmc == 0) + printf(" ntry nhit pi-est" + " pi-err seed\n"); + + while (scanf(" %d", &ngo) == 1 && ngo > 0) { + for (i=0; i +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-28 978 1.1 use inverse to avoid divide by constant +C 2017-08-12 938 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- function ranraw ------------------------------------------------ +C +C Fortran IV(1966): function syntax is: 'type FUNCTION name*precision (args) +C however gfortran -std=legacy wants: 'type*precision FUNCTION name (args) + REAL FUNCTION RANRAW*8 (DUMMY) +C + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + REAL*8 DUMMY + REAL*8 RFAC,RNEW + INTEGER IFAC +C + RNEW = RSEED * 69069.D0 + RFAC = RNEW * RR32I + IFAC = RFAC + RFAC = IFAC + RNEW = RNEW - RFAC * RR32 + IF (IDBGRR .NE. 0) WRITE(6,9000) RSEED,RNEW + RSEED = RNEW + RANRAW = RNEW + RETURN +C +9000 FORMAT(1X,'RR: ',F12.0,1X,F12.0) + END +C +C --- function rannum ------------------------------------------------ +C + REAL FUNCTION RANNUM*8 (DUMMY) +C + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + REAL*8 DUMMY + REAL*8 RANRAW + INTEGER I +C + IF (RANINI) GOTO 1000 + DO 100 I=1,128 + RSHUF(I) = RANRAW(DUMMY) +100 CONTINUE + RANINI = .TRUE. +1000 CONTINUE +C + I = RLAST * RDIVI + RLAST = RSHUF(I+1) + RSHUF(I+1) = RANRAW(DUMMY) + RANNUM = RLAST * RR32I + IF (IDBGRN .NE. 0) WRITE(6,9000) I,RLAST,RANNUM + RETURN +C +9000 FORMAT(1X,'RN: ',I12,1X,F12.0,1X,F12.8) + END +C +C --- main program --------------------------------------------------- +C PROGRAM MCPI + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + INTEGER I + INTEGER NTRY,NHIT,NGO + REAL*8 PI,PIEST,PIERR + REAL*8 X,Y,R + REAL*8 DUMMY + REAL*8 RANNUM + REAL*8 RTRY,RHIT + DATA PI /3.141592653589793D0/ + DATA NTRY /0/ + DATA NHIT /0/ +C + RR32 = 4294967296.D0 + RR32I = 1./RR32 + RDIV = 33554432.D0 + RDIVI = 1./RDIV +C + RSEED = 12345.D0 + RLAST = 0.D0 + RANINI = .FALSE. +C + READ(5,9000,ERR=910,END=900) IDBGRR,IDBGRN,IDBGMC +C + IF (IDBGRR.EQ.0 .AND. IDBGRN.EQ.0 .AND. IDBGMC.EQ.0) + X WRITE(6,9005) +C +100 READ(5,9010,ERR=910,END=900) NGO + IF (NGO .LE. 0) GOTO 900 +C + DO 200 I=1,NGO + X = 2.*RANNUM(DUMMY) - 1. + Y = 2.*RANNUM(DUMMY) - 1. + R = X*X + Y*Y + NTRY = NTRY + 1 + IF (R .LE. 1.) NHIT = NHIT + 1 + IF (IDBGMC .NE. 0) WRITE(6,9030) X,Y,R,NHIT +200 CONTINUE +C + RTRY = NTRY + RHIT = NHIT + PIEST = 4.* RHIT / RTRY + PIERR = PIEST - PI + IF (PIERR .LT. 0.) PIERR = -PIERR + WRITE(6,9020) NTRY, NHIT,PIEST,PIERR,RLAST + GOTO 100 +C +900 CONTINUE +C + STOP +C +910 WRITE(6,9040) + STOP +C +9000 FORMAT(3I10) +9005 FORMAT(1X,' ntry nhit pi-est', + X ' pi-err seed') +9010 FORMAT(I10) +9020 FORMAT(1X,'PI: ',I12,1X,I12,1X,F12.8,1X,F12.8,1X,F12.0) +9030 FORMAT(1X,'MC: ',F12.8,1X,F12.8,1X,F12.8,1X,I12) +9040 FORMAT(1X,'conversion error, abort') +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 0 0 0 + 100 + 200 + 700 + 2000 + 7000 + 20000 + 70000 + 200000 + 700000 + 2000000 + 0 +/* +// +./ ADD NAME=MCPIFOGT,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#FOG JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTGCLG, +// PARM.FORT='', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: mcpi_for.f 978 2017-12-28 21:32:18Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-28 978 1.1 use inverse to avoid divide by constant +C 2017-08-12 938 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- function ranraw ------------------------------------------------ +C +C Fortran IV(1966): function syntax is: 'type FUNCTION name*precision (args) +C however gfortran -std=legacy wants: 'type*precision FUNCTION name (args) + REAL FUNCTION RANRAW*8 (DUMMY) +C + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + REAL*8 DUMMY + REAL*8 RFAC,RNEW + INTEGER IFAC +C + RNEW = RSEED * 69069.D0 + RFAC = RNEW * RR32I + IFAC = RFAC + RFAC = IFAC + RNEW = RNEW - RFAC * RR32 + IF (IDBGRR .NE. 0) WRITE(6,9000) RSEED,RNEW + RSEED = RNEW + RANRAW = RNEW + RETURN +C +9000 FORMAT(1X,'RR: ',F12.0,1X,F12.0) + END +C +C --- function rannum ------------------------------------------------ +C + REAL FUNCTION RANNUM*8 (DUMMY) +C + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + REAL*8 DUMMY + REAL*8 RANRAW + INTEGER I +C + IF (RANINI) GOTO 1000 + DO 100 I=1,128 + RSHUF(I) = RANRAW(DUMMY) +100 CONTINUE + RANINI = .TRUE. +1000 CONTINUE +C + I = RLAST * RDIVI + RLAST = RSHUF(I+1) + RSHUF(I+1) = RANRAW(DUMMY) + RANNUM = RLAST * RR32I + IF (IDBGRN .NE. 0) WRITE(6,9000) I,RLAST,RANNUM + RETURN +C +9000 FORMAT(1X,'RN: ',I12,1X,F12.0,1X,F12.8) + END +C +C --- main program --------------------------------------------------- +C PROGRAM MCPI + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + INTEGER I + INTEGER NTRY,NHIT,NGO + REAL*8 PI,PIEST,PIERR + REAL*8 X,Y,R + REAL*8 DUMMY + REAL*8 RANNUM + REAL*8 RTRY,RHIT + DATA PI /3.141592653589793D0/ + DATA NTRY /0/ + DATA NHIT /0/ +C + RR32 = 4294967296.D0 + RR32I = 1./RR32 + RDIV = 33554432.D0 + RDIVI = 1./RDIV +C + RSEED = 12345.D0 + RLAST = 0.D0 + RANINI = .FALSE. +C + READ(5,9000,ERR=910,END=900) IDBGRR,IDBGRN,IDBGMC +C + IF (IDBGRR.EQ.0 .AND. IDBGRN.EQ.0 .AND. IDBGMC.EQ.0) + X WRITE(6,9005) +C +100 READ(5,9010,ERR=910,END=900) NGO + IF (NGO .LE. 0) GOTO 900 +C + DO 200 I=1,NGO + X = 2.*RANNUM(DUMMY) - 1. + Y = 2.*RANNUM(DUMMY) - 1. + R = X*X + Y*Y + NTRY = NTRY + 1 + IF (R .LE. 1.) NHIT = NHIT + 1 + IF (IDBGMC .NE. 0) WRITE(6,9030) X,Y,R,NHIT +200 CONTINUE +C + RTRY = NTRY + RHIT = NHIT + PIEST = 4.* RHIT / RTRY + PIERR = PIEST - PI + IF (PIERR .LT. 0.) PIERR = -PIERR + WRITE(6,9020) NTRY, NHIT,PIEST,PIERR,RLAST + GOTO 100 +C +900 CONTINUE +C + STOP +C +910 WRITE(6,9040) + STOP +C +9000 FORMAT(3I10) +9005 FORMAT(1X,' ntry nhit pi-est', + X ' pi-err seed') +9010 FORMAT(I10) +9020 FORMAT(1X,'PI: ',I12,1X,I12,1X,F12.8,1X,F12.8,1X,F12.0) +9030 FORMAT(1X,'MC: ',F12.8,1X,F12.8,1X,F12.8,1X,I12) +9040 FORMAT(1X,'conversion error, abort') +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 1 1 1 + 10 + 0 +/* +// +./ ADD NAME=MCPIFOHF,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#FOH JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1440),PRTY=2 +//CLG EXEC FORTHCLG, +// PARM.FORT='OPT=2', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: mcpi_for.f 978 2017-12-28 21:32:18Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-28 978 1.1 use inverse to avoid divide by constant +C 2017-08-12 938 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- function ranraw ------------------------------------------------ +C +C Fortran IV(1966): function syntax is: 'type FUNCTION name*precision (args) +C however gfortran -std=legacy wants: 'type*precision FUNCTION name (args) + REAL FUNCTION RANRAW*8 (DUMMY) +C + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + REAL*8 DUMMY + REAL*8 RFAC,RNEW + INTEGER IFAC +C + RNEW = RSEED * 69069.D0 + RFAC = RNEW * RR32I + IFAC = RFAC + RFAC = IFAC + RNEW = RNEW - RFAC * RR32 + IF (IDBGRR .NE. 0) WRITE(6,9000) RSEED,RNEW + RSEED = RNEW + RANRAW = RNEW + RETURN +C +9000 FORMAT(1X,'RR: ',F12.0,1X,F12.0) + END +C +C --- function rannum ------------------------------------------------ +C + REAL FUNCTION RANNUM*8 (DUMMY) +C + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + REAL*8 DUMMY + REAL*8 RANRAW + INTEGER I +C + IF (RANINI) GOTO 1000 + DO 100 I=1,128 + RSHUF(I) = RANRAW(DUMMY) +100 CONTINUE + RANINI = .TRUE. +1000 CONTINUE +C + I = RLAST * RDIVI + RLAST = RSHUF(I+1) + RSHUF(I+1) = RANRAW(DUMMY) + RANNUM = RLAST * RR32I + IF (IDBGRN .NE. 0) WRITE(6,9000) I,RLAST,RANNUM + RETURN +C +9000 FORMAT(1X,'RN: ',I12,1X,F12.0,1X,F12.8) + END +C +C --- main program --------------------------------------------------- +C PROGRAM MCPI + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + INTEGER I + INTEGER NTRY,NHIT,NGO + REAL*8 PI,PIEST,PIERR + REAL*8 X,Y,R + REAL*8 DUMMY + REAL*8 RANNUM + REAL*8 RTRY,RHIT + DATA PI /3.141592653589793D0/ + DATA NTRY /0/ + DATA NHIT /0/ +C + RR32 = 4294967296.D0 + RR32I = 1./RR32 + RDIV = 33554432.D0 + RDIVI = 1./RDIV +C + RSEED = 12345.D0 + RLAST = 0.D0 + RANINI = .FALSE. +C + READ(5,9000,ERR=910,END=900) IDBGRR,IDBGRN,IDBGMC +C + IF (IDBGRR.EQ.0 .AND. IDBGRN.EQ.0 .AND. IDBGMC.EQ.0) + X WRITE(6,9005) +C +100 READ(5,9010,ERR=910,END=900) NGO + IF (NGO .LE. 0) GOTO 900 +C + DO 200 I=1,NGO + X = 2.*RANNUM(DUMMY) - 1. + Y = 2.*RANNUM(DUMMY) - 1. + R = X*X + Y*Y + NTRY = NTRY + 1 + IF (R .LE. 1.) NHIT = NHIT + 1 + IF (IDBGMC .NE. 0) WRITE(6,9030) X,Y,R,NHIT +200 CONTINUE +C + RTRY = NTRY + RHIT = NHIT + PIEST = 4.* RHIT / RTRY + PIERR = PIEST - PI + IF (PIERR .LT. 0.) PIERR = -PIERR + WRITE(6,9020) NTRY, NHIT,PIEST,PIERR,RLAST + GOTO 100 +C +900 CONTINUE +C + STOP +C +910 WRITE(6,9040) + STOP +C +9000 FORMAT(3I10) +9005 FORMAT(1X,' ntry nhit pi-est', + X ' pi-err seed') +9010 FORMAT(I10) +9020 FORMAT(1X,'PI: ',I12,1X,I12,1X,F12.8,1X,F12.8,1X,F12.0) +9030 FORMAT(1X,'MC: ',F12.8,1X,F12.8,1X,F12.8,1X,I12) +9040 FORMAT(1X,'conversion error, abort') +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 0 0 0 + 100 + 200 + 700 + 2000 + 7000 + 20000 + 70000 + 200000 + 700000 + 2000000 + 0 +/* +// +./ ADD NAME=MCPIFOHT,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#FOH JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC FORTHCLG, +// PARM.FORT='OPT=2', +// PARM.LKED='MAP,LIST,LET' +//FORT.SYSIN DD * +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: mcpi_for.f 978 2017-12-28 21:32:18Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-28 978 1.1 use inverse to avoid divide by constant +C 2017-08-12 938 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- function ranraw ------------------------------------------------ +C +C Fortran IV(1966): function syntax is: 'type FUNCTION name*precision (args) +C however gfortran -std=legacy wants: 'type*precision FUNCTION name (args) + REAL FUNCTION RANRAW*8 (DUMMY) +C + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + REAL*8 DUMMY + REAL*8 RFAC,RNEW + INTEGER IFAC +C + RNEW = RSEED * 69069.D0 + RFAC = RNEW * RR32I + IFAC = RFAC + RFAC = IFAC + RNEW = RNEW - RFAC * RR32 + IF (IDBGRR .NE. 0) WRITE(6,9000) RSEED,RNEW + RSEED = RNEW + RANRAW = RNEW + RETURN +C +9000 FORMAT(1X,'RR: ',F12.0,1X,F12.0) + END +C +C --- function rannum ------------------------------------------------ +C + REAL FUNCTION RANNUM*8 (DUMMY) +C + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + REAL*8 DUMMY + REAL*8 RANRAW + INTEGER I +C + IF (RANINI) GOTO 1000 + DO 100 I=1,128 + RSHUF(I) = RANRAW(DUMMY) +100 CONTINUE + RANINI = .TRUE. +1000 CONTINUE +C + I = RLAST * RDIVI + RLAST = RSHUF(I+1) + RSHUF(I+1) = RANRAW(DUMMY) + RANNUM = RLAST * RR32I + IF (IDBGRN .NE. 0) WRITE(6,9000) I,RLAST,RANNUM + RETURN +C +9000 FORMAT(1X,'RN: ',I12,1X,F12.0,1X,F12.8) + END +C +C --- main program --------------------------------------------------- +C PROGRAM MCPI + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + INTEGER I + INTEGER NTRY,NHIT,NGO + REAL*8 PI,PIEST,PIERR + REAL*8 X,Y,R + REAL*8 DUMMY + REAL*8 RANNUM + REAL*8 RTRY,RHIT + DATA PI /3.141592653589793D0/ + DATA NTRY /0/ + DATA NHIT /0/ +C + RR32 = 4294967296.D0 + RR32I = 1./RR32 + RDIV = 33554432.D0 + RDIVI = 1./RDIV +C + RSEED = 12345.D0 + RLAST = 0.D0 + RANINI = .FALSE. +C + READ(5,9000,ERR=910,END=900) IDBGRR,IDBGRN,IDBGMC +C + IF (IDBGRR.EQ.0 .AND. IDBGRN.EQ.0 .AND. IDBGMC.EQ.0) + X WRITE(6,9005) +C +100 READ(5,9010,ERR=910,END=900) NGO + IF (NGO .LE. 0) GOTO 900 +C + DO 200 I=1,NGO + X = 2.*RANNUM(DUMMY) - 1. + Y = 2.*RANNUM(DUMMY) - 1. + R = X*X + Y*Y + NTRY = NTRY + 1 + IF (R .LE. 1.) NHIT = NHIT + 1 + IF (IDBGMC .NE. 0) WRITE(6,9030) X,Y,R,NHIT +200 CONTINUE +C + RTRY = NTRY + RHIT = NHIT + PIEST = 4.* RHIT / RTRY + PIERR = PIEST - PI + IF (PIERR .LT. 0.) PIERR = -PIERR + WRITE(6,9020) NTRY, NHIT,PIEST,PIERR,RLAST + GOTO 100 +C +900 CONTINUE +C + STOP +C +910 WRITE(6,9040) + STOP +C +9000 FORMAT(3I10) +9005 FORMAT(1X,' ntry nhit pi-est', + X ' pi-err seed') +9010 FORMAT(I10) +9020 FORMAT(1X,'PI: ',I12,1X,I12,1X,F12.8,1X,F12.8,1X,F12.0) +9030 FORMAT(1X,'MC: ',F12.8,1X,F12.8,1X,F12.8,1X,I12) +9040 FORMAT(1X,'conversion error, abort') +C + END +/* +//GO.FT06F001 DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 1 1 1 + 10 + 0 +/* +// +./ ADD NAME=MCPIFOWF,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#FOW JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(20,0),PRTY=2 +//CLG EXEC WATFIV +//SYSIN DD * +$JOB MCPI#FOW,T=(20,0),P=100,NOCHECK +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: mcpi_for.f 978 2017-12-28 21:32:18Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-28 978 1.1 use inverse to avoid divide by constant +C 2017-08-12 938 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- function ranraw ------------------------------------------------ +C +C Fortran IV(1966): function syntax is: 'type FUNCTION name*precision (args) +C however gfortran -std=legacy wants: 'type*precision FUNCTION name (args) + REAL FUNCTION RANRAW*8 (DUMMY) +C + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + REAL*8 DUMMY + REAL*8 RFAC,RNEW + INTEGER IFAC +C + RNEW = RSEED * 69069.D0 + RFAC = RNEW * RR32I + IFAC = RFAC + RFAC = IFAC + RNEW = RNEW - RFAC * RR32 + IF (IDBGRR .NE. 0) WRITE(6,9000) RSEED,RNEW + RSEED = RNEW + RANRAW = RNEW + RETURN +C +9000 FORMAT(1X,'RR: ',F12.0,1X,F12.0) + END +C +C --- function rannum ------------------------------------------------ +C + REAL FUNCTION RANNUM*8 (DUMMY) +C + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + REAL*8 DUMMY + REAL*8 RANRAW + INTEGER I +C + IF (RANINI) GOTO 1000 + DO 100 I=1,128 + RSHUF(I) = RANRAW(DUMMY) +100 CONTINUE + RANINI = .TRUE. +1000 CONTINUE +C + I = RLAST * RDIVI + RLAST = RSHUF(I+1) + RSHUF(I+1) = RANRAW(DUMMY) + RANNUM = RLAST * RR32I + IF (IDBGRN .NE. 0) WRITE(6,9000) I,RLAST,RANNUM + RETURN +C +9000 FORMAT(1X,'RN: ',I12,1X,F12.0,1X,F12.8) + END +C +C --- main program --------------------------------------------------- +C PROGRAM MCPI + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + INTEGER I + INTEGER NTRY,NHIT,NGO + REAL*8 PI,PIEST,PIERR + REAL*8 X,Y,R + REAL*8 DUMMY + REAL*8 RANNUM + REAL*8 RTRY,RHIT + DATA PI /3.141592653589793D0/ + DATA NTRY /0/ + DATA NHIT /0/ +C + RR32 = 4294967296.D0 + RR32I = 1./RR32 + RDIV = 33554432.D0 + RDIVI = 1./RDIV +C + RSEED = 12345.D0 + RLAST = 0.D0 + RANINI = .FALSE. +C + READ(5,9000,ERR=910,END=900) IDBGRR,IDBGRN,IDBGMC +C + IF (IDBGRR.EQ.0 .AND. IDBGRN.EQ.0 .AND. IDBGMC.EQ.0) + X WRITE(6,9005) +C +100 READ(5,9010,ERR=910,END=900) NGO + IF (NGO .LE. 0) GOTO 900 +C + DO 200 I=1,NGO + X = 2.*RANNUM(DUMMY) - 1. + Y = 2.*RANNUM(DUMMY) - 1. + R = X*X + Y*Y + NTRY = NTRY + 1 + IF (R .LE. 1.) NHIT = NHIT + 1 + IF (IDBGMC .NE. 0) WRITE(6,9030) X,Y,R,NHIT +200 CONTINUE +C + RTRY = NTRY + RHIT = NHIT + PIEST = 4.* RHIT / RTRY + PIERR = PIEST - PI + IF (PIERR .LT. 0.) PIERR = -PIERR + WRITE(6,9020) NTRY, NHIT,PIEST,PIERR,RLAST + GOTO 100 +C +900 CONTINUE +C + STOP +C +910 WRITE(6,9040) + STOP +C +9000 FORMAT(3I10) +9005 FORMAT(1X,' ntry nhit pi-est', + X ' pi-err seed') +9010 FORMAT(I10) +9020 FORMAT(1X,'PI: ',I12,1X,I12,1X,F12.8,1X,F12.8,1X,F12.0) +9030 FORMAT(1X,'MC: ',F12.8,1X,F12.8,1X,F12.8,1X,I12) +9040 FORMAT(1X,'conversion error, abort') +C + END +$ENTRY + 0 0 0 + 100 + 200 + 700 + 2000 + 7000 + 20000 + 70000 + 200000 + 700000 + 2000000 + 0 +$STOP +/* +// +./ ADD NAME=MCPIFOWT,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#FOW JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC WATFIV +//SYSIN DD * +$JOB MCPI#FOW,T=(1,0),P=100,CHECK +C 1 2 3 4 5 6 712-------- +C2345*78901234567890123456789012345678901234567890123456789012345678901234567890 +C $Id: mcpi_for.f 978 2017-12-28 21:32:18Z mueller $ +C +C Copyright 2017- by Walter F.J. Mueller +C +C This program is free software; you may redistribute and/or modify +C it under the terms of the GNU General Public License version 3. +C See Licence.txt in distribition directory for further details. +C +C Revision History: +C Date Rev Version Comment +C 2017-12-28 978 1.1 use inverse to avoid divide by constant +C 2017-08-12 938 1.0 Initial version +C 2017-07-30 931 0.1 First draft +C +C --- function ranraw ------------------------------------------------ +C +C Fortran IV(1966): function syntax is: 'type FUNCTION name*precision (args) +C however gfortran -std=legacy wants: 'type*precision FUNCTION name (args) + REAL FUNCTION RANRAW*8 (DUMMY) +C + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + REAL*8 DUMMY + REAL*8 RFAC,RNEW + INTEGER IFAC +C + RNEW = RSEED * 69069.D0 + RFAC = RNEW * RR32I + IFAC = RFAC + RFAC = IFAC + RNEW = RNEW - RFAC * RR32 + IF (IDBGRR .NE. 0) WRITE(6,9000) RSEED,RNEW + RSEED = RNEW + RANRAW = RNEW + RETURN +C +9000 FORMAT(1X,'RR: ',F12.0,1X,F12.0) + END +C +C --- function rannum ------------------------------------------------ +C + REAL FUNCTION RANNUM*8 (DUMMY) +C + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + REAL*8 DUMMY + REAL*8 RANRAW + INTEGER I +C + IF (RANINI) GOTO 1000 + DO 100 I=1,128 + RSHUF(I) = RANRAW(DUMMY) +100 CONTINUE + RANINI = .TRUE. +1000 CONTINUE +C + I = RLAST * RDIVI + RLAST = RSHUF(I+1) + RSHUF(I+1) = RANRAW(DUMMY) + RANNUM = RLAST * RR32I + IF (IDBGRN .NE. 0) WRITE(6,9000) I,RLAST,RANNUM + RETURN +C +9000 FORMAT(1X,'RN: ',I12,1X,F12.0,1X,F12.8) + END +C +C --- main program --------------------------------------------------- +C PROGRAM MCPI + COMMON /DBG/IDBGRR,IDBGRN,IDBGMC + COMMON /RANFAC/RR32,RR32I,RDIV,RDIVI + COMMON /RAN/RLAST,RSEED,RSHUF(128),RANINI + REAL*8 RR32,RR32I,RDIV,RDIVI + REAL*8 RLAST,RSEED,RSHUF + LOGICAL RANINI +C + INTEGER I + INTEGER NTRY,NHIT,NGO + REAL*8 PI,PIEST,PIERR + REAL*8 X,Y,R + REAL*8 DUMMY + REAL*8 RANNUM + REAL*8 RTRY,RHIT + DATA PI /3.141592653589793D0/ + DATA NTRY /0/ + DATA NHIT /0/ +C + RR32 = 4294967296.D0 + RR32I = 1./RR32 + RDIV = 33554432.D0 + RDIVI = 1./RDIV +C + RSEED = 12345.D0 + RLAST = 0.D0 + RANINI = .FALSE. +C + READ(5,9000,ERR=910,END=900) IDBGRR,IDBGRN,IDBGMC +C + IF (IDBGRR.EQ.0 .AND. IDBGRN.EQ.0 .AND. IDBGMC.EQ.0) + X WRITE(6,9005) +C +100 READ(5,9010,ERR=910,END=900) NGO + IF (NGO .LE. 0) GOTO 900 +C + DO 200 I=1,NGO + X = 2.*RANNUM(DUMMY) - 1. + Y = 2.*RANNUM(DUMMY) - 1. + R = X*X + Y*Y + NTRY = NTRY + 1 + IF (R .LE. 1.) NHIT = NHIT + 1 + IF (IDBGMC .NE. 0) WRITE(6,9030) X,Y,R,NHIT +200 CONTINUE +C + RTRY = NTRY + RHIT = NHIT + PIEST = 4.* RHIT / RTRY + PIERR = PIEST - PI + IF (PIERR .LT. 0.) PIERR = -PIERR + WRITE(6,9020) NTRY, NHIT,PIEST,PIERR,RLAST + GOTO 100 +C +900 CONTINUE +C + STOP +C +910 WRITE(6,9040) + STOP +C +9000 FORMAT(3I10) +9005 FORMAT(1X,' ntry nhit pi-est', + X ' pi-err seed') +9010 FORMAT(I10) +9020 FORMAT(1X,'PI: ',I12,1X,I12,1X,F12.8,1X,F12.8,1X,F12.0) +9030 FORMAT(1X,'MC: ',F12.8,1X,F12.8,1X,F12.8,1X,I12) +9040 FORMAT(1X,'conversion error, abort') +C + END +$ENTRY + 1 1 1 + 10 + 0 +$STOP +/* +// +./ ADD NAME=MCPIPASF,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#PAS JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(10,0),PRTY=2 +//CLG EXEC PASCLG,GOTIME=3600,GOREG=1024K, +// OPT='M+,D-', +// GOPARM='/STACK=512k' +//COMPILE.SYSIN DD * +(* $Id: mcpi_pas.pas 978 2017-12-28 21:32:18Z mueller $ *) +(* +(* Copyright 2017- by Walter F.J. Mueller *) +(* +(* This program is free software; you may redistribute and/or modify *) +(* it under the terms of the GNU General Public License version 3. *) +(* See Licence.txt in distribition directory for further details. *) +(* *) +(* Revision History: *) +(* Date Rev Version Comment *) +(* 2017-12-28 978 1.1 use inverse to avoid divide by constant *) +(* 2017-09-17 951 1.0 Initial version *) +(* 2017-09-07 948 0.1 First draft *) + +program mcpi(input,output); +const + rr32 = 4294967296.0; + rdiv = 33554432.0; + pi = 3.141592653589793; +var + rseed,rlast : real; + ranini : boolean; + idbgrr,idbgrn,idbgmc : integer; + i,ntry,nhit,ngo : integer; + piest,pierr : real; + rhit,rtry : real; + x,y,r : real; + rr32i,rdivi : real; + rshuf : ARRAY[0 .. 127] of real; + +function ranraw(dummy :real) : real; +var + rfac,rnew : real; +begin + rnew := rseed * 69069.0; + rfac := rnew * rr32i; + rfac := trunc(rfac); + rnew := rnew - rfac * rr32; + if idbgrr > 0 then writeln(' ','RR: ',rseed:14:1,rnew:14:1); + rseed := rnew; + ranraw := rnew; +end; + +function rannum(dummy :real) : real; +var + rnew : real; + i : integer; +begin + if not ranini then begin + for i := 0 to 127 do rshuf[i] := ranraw(0.0); + ranini := TRUE; + end; + + i := trunc(rlast*rdivi); + rlast := rshuf[i]; + rshuf[i] := ranraw(0.0); + rnew := rlast * rr32i; + if idbgrn > 0 then writeln(' ','RN: ',i:12,rlast:14:1,rnew:14:8); + rannum := rnew; +end; + +begin + rseed := 12345.0; + ranini := FALSE; + + rr32i := 1.0/rr32; + rdivi := 1.0/rdiv; + + read(idbgrr); + read(idbgrn); + read(idbgmc); + + if (idbgrr=0) and (idbgrn=0) and (idbgmc=0) then + writeln(' ',' ntry nhit pi-est', + ' pi-err seed'); + + while TRUE do begin + read(ngo); + if ngo = 0 then exit(0); + for i := 1 to ngo do begin + x := 2.0 * rannum(0.0) - 1.0; + y := 2.0 * rannum(0.0) - 1.0; + r := x*x + y*y; + ntry := ntry + 1; + if r <= 1.0 then nhit := nhit + 1; + if idbgmc > 0 then writeln(' ','MC: ', + x:12:8,y:12:8,r:12:8,nhit:12); + end; + + rtry := ntry; + rhit := nhit; + + piest := 4.0 * (rhit / rtry); + pierr := piest - pi; + writeln(' ','PI: ',ntry:12,nhit:12,piest:12:8,pierr:12:8, + rlast:14:1); + end; + +end. +/* +//GO.OUTPUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 0 0 0 + 100 + 200 + 700 + 2000 + 7000 + 20000 + 70000 + 200000 + 700000 + 2000000 + 0 +/* +// +./ ADD NAME=MCPIPAST,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#PAS JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1024K,TIME=(1,0),PRTY=8 +//CLG EXEC PASCLG,GOTIME=3600,GOREG=1024K, +// OPT='M+', +// GOPARM='/STACK=512k' +//COMPILE.SYSIN DD * +(* $Id: mcpi_pas.pas 978 2017-12-28 21:32:18Z mueller $ *) +(* +(* Copyright 2017- by Walter F.J. Mueller *) +(* +(* This program is free software; you may redistribute and/or modify *) +(* it under the terms of the GNU General Public License version 3. *) +(* See Licence.txt in distribition directory for further details. *) +(* *) +(* Revision History: *) +(* Date Rev Version Comment *) +(* 2017-12-28 978 1.1 use inverse to avoid divide by constant *) +(* 2017-09-17 951 1.0 Initial version *) +(* 2017-09-07 948 0.1 First draft *) + +program mcpi(input,output); +const + rr32 = 4294967296.0; + rdiv = 33554432.0; + pi = 3.141592653589793; +var + rseed,rlast : real; + ranini : boolean; + idbgrr,idbgrn,idbgmc : integer; + i,ntry,nhit,ngo : integer; + piest,pierr : real; + rhit,rtry : real; + x,y,r : real; + rr32i,rdivi : real; + rshuf : ARRAY[0 .. 127] of real; + +function ranraw(dummy :real) : real; +var + rfac,rnew : real; +begin + rnew := rseed * 69069.0; + rfac := rnew * rr32i; + rfac := trunc(rfac); + rnew := rnew - rfac * rr32; + if idbgrr > 0 then writeln(' ','RR: ',rseed:14:1,rnew:14:1); + rseed := rnew; + ranraw := rnew; +end; + +function rannum(dummy :real) : real; +var + rnew : real; + i : integer; +begin + if not ranini then begin + for i := 0 to 127 do rshuf[i] := ranraw(0.0); + ranini := TRUE; + end; + + i := trunc(rlast*rdivi); + rlast := rshuf[i]; + rshuf[i] := ranraw(0.0); + rnew := rlast * rr32i; + if idbgrn > 0 then writeln(' ','RN: ',i:12,rlast:14:1,rnew:14:8); + rannum := rnew; +end; + +begin + rseed := 12345.0; + ranini := FALSE; + + rr32i := 1.0/rr32; + rdivi := 1.0/rdiv; + + read(idbgrr); + read(idbgrn); + read(idbgmc); + + if (idbgrr=0) and (idbgrn=0) and (idbgmc=0) then + writeln(' ',' ntry nhit pi-est', + ' pi-err seed'); + + while TRUE do begin + read(ngo); + if ngo = 0 then exit(0); + for i := 1 to ngo do begin + x := 2.0 * rannum(0.0) - 1.0; + y := 2.0 * rannum(0.0) - 1.0; + r := x*x + y*y; + ntry := ntry + 1; + if r <= 1.0 then nhit := nhit + 1; + if idbgmc > 0 then writeln(' ','MC: ', + x:12:8,y:12:8,r:12:8,nhit:12); + end; + + rtry := ntry; + rhit := nhit; + + piest := 4.0 * (rhit / rtry); + pierr := piest - pi; + writeln(' ','PI: ',ntry:12,nhit:12,piest:12:8,pierr:12:8, + rlast:14:1); + end; + +end. +/* +//GO.OUTPUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 1 1 1 + 10 + 0 +/* +// +./ ADD NAME=MCPIPLIF,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#PLI JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(10,0),PRTY=2 +//CLG EXEC PL1LFCLG, +// PARM.PL1L='LOAD,NODECK,OPT=2', +// PARM.LKED='MAP,LIST' +//PL1L.SYSLIN DD UNIT=SYSDA +//PL1L.SYSIN DD * +/* 1 2 3 4 5 6 7*/-------- +/*4567890123456789012345678901234567890123456789012345678901234567890*/-------- +/* $Id: mcpi_pli.pli 978 2017-12-28 21:32:18Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-28 978 1.1 use inverse to avoid divide by constant */ +/* 2017-09-07 947 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + + MCPI: PROC OPTIONS(MAIN) REORDER; + DCL RSEED DEC FLOAT(16) INIT(12345.); + DCL RLAST DEC FLOAT(16) INIT(0.); + DCL RSHUF(0:127) DEC FLOAT(16) INIT((128)0.); + DCL RR32 DEC FLOAT(16) INIT(4294967296.); + DCL RDIV DEC FLOAT(16) INIT(33554432.); + DCL RANINI BIN FIXED(31) INIT(0); + DCL (IDBGRR,IDBGRN,IDBGMC) BIN FIXED(31) INIT(0); + + DCL RANRAW ENTRY RETURNS(DEC FLOAT(16)); + DCL RANNUM ENTRY RETURNS(DEC FLOAT(16)); + + DCL (I,NTRY,NHIT,NGO) BIN FIXED(31) INIT(0); + DCL (PIEST,PIERR) DEC FLOAT(16); + DCL (RHIT,RTRY) DEC FLOAT(16); + DCL (RR32I,RDIVI) DEC FLOAT(16); + DCL (X,Y,R) DEC FLOAT(16); + DCL PI DEC FLOAT(16) INIT(3.141592653589793E0); + + ON ENDFILE(SYSIN) GOTO DONE; + ON CONVERSION GOTO ABORT; + + RR32I = 1./RR32; + RDIVI = 1./RDIV; + + GET EDIT(IDBGRR,IDBGRN,IDBGMC) (3(F(10))); + + IF IDBGRR=0 & IDBGRN=0 & IDBGMC=0 THEN + PUT SKIP EDIT(' ntry nhit pi-est', + ' pi-err seed')(A,A); + + DO WHILE('1'B); + GET SKIP EDIT(NGO) (F(10)); + IF NGO = 0 THEN GOTO DONE; + + DO I=1 TO NGO; + X = 2.*RANNUM - 1.; + Y = 2.*RANNUM - 1.; + R = X*X + Y*Y; + NTRY = NTRY + 1; + IF R <= 1. THEN NHIT = NHIT + 1; + IF IDBGMC > 0 THEN PUT SKIP EDIT('MC: ',X,Y,R,NHIT) + (A,3(F(12,8),X(1)),F(12)); + END; + + RTRY = NTRY; + RHIT = NHIT; + + PIEST = 4.E0 * (RHIT / RTRY); + PIERR = PIEST - PI; + IF PIERR < 0. THEN PIERR = -PIERR; + PUT SKIP EDIT('PI: ',NTRY,NHIT,PIEST,PIERR,RLAST) + (A,2(F(12),X(1)),2(F(12,8),X(1)),F(12)); + END; + GOTO DONE; + + ABORT: PUT SKIP EDIT('Conversion error, abort')(A); + DONE:; + + /* procedure RANRAW --------------------------------------------*/ + RANRAW: PROC RETURNS(DEC FLOAT(16)); + + DCL (RFAC,RNEW) DEC FLOAT(16); + DCL IFAC BIN FIXED(31); + + RNEW = RSEED * 69069.; + RFAC = RNEW * RR32I; + IFAC = RFAC; + RFAC = IFAC; + RNEW = RNEW - RFAC * RR32; + IF IDBGRR > 0 THEN PUT SKIP EDIT('RR: ',RSEED,RNEW) + (A,F(12,0),X(1),F(12,0)); + RSEED = RNEW; + RETURN(RNEW); + END RANRAW; + + /* procedure RANNUM --------------------------------------------*/ + RANNUM: PROC RETURNS(DEC FLOAT(16)); + DCL I BIN FIXED(31); + DCL RNEW DEC FLOAT(16); + + IF RANINI = 0 THEN DO; + DO I=0 TO 127; + RSHUF(I) = RANRAW; + END; + RANINI = 1; + END; + + I = RLAST * RDIVI; + RLAST = RSHUF(I); + RSHUF(I) = RANRAW; + RNEW = RLAST * RR32I; + IF IDBGRN > 0 THEN PUT SKIP EDIT('RN: ',I,RLAST,RNEW) + (A,F(12),X(1),F(12,0),X(1),F(12,8)); + RETURN(RNEW); + END RANNUM; + END MCPI; +/* +//LKED.SYSLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.STEPLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.SYSIN DD * + 0 0 0 + 100 + 200 + 700 + 2000 + 7000 + 20000 + 70000 + 200000 + 700000 + 2000000 + 0 +/* +// +./ ADD NAME=MCPIPLIT,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#PLI JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=256K,TIME=(1,0),PRTY=8 +//CLG EXEC PL1LFCLG, +// PARM.PL1L='LOAD,NODECK,OPT=2', +// PARM.LKED='MAP,LIST' +//PL1L.SYSLIN DD UNIT=SYSDA +//PL1L.SYSIN DD * +/* 1 2 3 4 5 6 7*/-------- +/*4567890123456789012345678901234567890123456789012345678901234567890*/-------- +/* $Id: mcpi_pli.pli 978 2017-12-28 21:32:18Z mueller $ */ +/* +/* Copyright 2017- by Walter F.J. Mueller */ +/* +/* This program is free software; you may redistribute and/or modify */ +/* it under the terms of the GNU General Public License version 3. */ +/* See Licence.txt in distribition directory for further details. */ +/* */ +/* Revision History: */ +/* Date Rev Version Comment */ +/* 2017-12-28 978 1.1 use inverse to avoid divide by constant */ +/* 2017-09-07 947 1.0 Initial version */ +/* 2017-07-30 931 0.1 First draft */ + + MCPI: PROC OPTIONS(MAIN) REORDER; + DCL RSEED DEC FLOAT(16) INIT(12345.); + DCL RLAST DEC FLOAT(16) INIT(0.); + DCL RSHUF(0:127) DEC FLOAT(16) INIT((128)0.); + DCL RR32 DEC FLOAT(16) INIT(4294967296.); + DCL RDIV DEC FLOAT(16) INIT(33554432.); + DCL RANINI BIN FIXED(31) INIT(0); + DCL (IDBGRR,IDBGRN,IDBGMC) BIN FIXED(31) INIT(0); + + DCL RANRAW ENTRY RETURNS(DEC FLOAT(16)); + DCL RANNUM ENTRY RETURNS(DEC FLOAT(16)); + + DCL (I,NTRY,NHIT,NGO) BIN FIXED(31) INIT(0); + DCL (PIEST,PIERR) DEC FLOAT(16); + DCL (RHIT,RTRY) DEC FLOAT(16); + DCL (RR32I,RDIVI) DEC FLOAT(16); + DCL (X,Y,R) DEC FLOAT(16); + DCL PI DEC FLOAT(16) INIT(3.141592653589793E0); + + ON ENDFILE(SYSIN) GOTO DONE; + ON CONVERSION GOTO ABORT; + + RR32I = 1./RR32; + RDIVI = 1./RDIV; + + GET EDIT(IDBGRR,IDBGRN,IDBGMC) (3(F(10))); + + IF IDBGRR=0 & IDBGRN=0 & IDBGMC=0 THEN + PUT SKIP EDIT(' ntry nhit pi-est', + ' pi-err seed')(A,A); + + DO WHILE('1'B); + GET SKIP EDIT(NGO) (F(10)); + IF NGO = 0 THEN GOTO DONE; + + DO I=1 TO NGO; + X = 2.*RANNUM - 1.; + Y = 2.*RANNUM - 1.; + R = X*X + Y*Y; + NTRY = NTRY + 1; + IF R <= 1. THEN NHIT = NHIT + 1; + IF IDBGMC > 0 THEN PUT SKIP EDIT('MC: ',X,Y,R,NHIT) + (A,3(F(12,8),X(1)),F(12)); + END; + + RTRY = NTRY; + RHIT = NHIT; + + PIEST = 4.E0 * (RHIT / RTRY); + PIERR = PIEST - PI; + IF PIERR < 0. THEN PIERR = -PIERR; + PUT SKIP EDIT('PI: ',NTRY,NHIT,PIEST,PIERR,RLAST) + (A,2(F(12),X(1)),2(F(12,8),X(1)),F(12)); + END; + GOTO DONE; + + ABORT: PUT SKIP EDIT('Conversion error, abort')(A); + DONE:; + + /* procedure RANRAW --------------------------------------------*/ + RANRAW: PROC RETURNS(DEC FLOAT(16)); + + DCL (RFAC,RNEW) DEC FLOAT(16); + DCL IFAC BIN FIXED(31); + + RNEW = RSEED * 69069.; + RFAC = RNEW * RR32I; + IFAC = RFAC; + RFAC = IFAC; + RNEW = RNEW - RFAC * RR32; + IF IDBGRR > 0 THEN PUT SKIP EDIT('RR: ',RSEED,RNEW) + (A,F(12,0),X(1),F(12,0)); + RSEED = RNEW; + RETURN(RNEW); + END RANRAW; + + /* procedure RANNUM --------------------------------------------*/ + RANNUM: PROC RETURNS(DEC FLOAT(16)); + DCL I BIN FIXED(31); + DCL RNEW DEC FLOAT(16); + + IF RANINI = 0 THEN DO; + DO I=0 TO 127; + RSHUF(I) = RANRAW; + END; + RANINI = 1; + END; + + I = RLAST * RDIVI; + RLAST = RSHUF(I); + RSHUF(I) = RANRAW; + RNEW = RLAST * RR32I; + IF IDBGRN > 0 THEN PUT SKIP EDIT('RN: ',I,RLAST,RNEW) + (A,F(12),X(1),F(12,0),X(1),F(12,8)); + RETURN(RNEW); + END RANNUM; + END MCPI; +/* +//LKED.SYSLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.STEPLIB DD DSN=SYS1.PL1LIB,DISP=SHR +//GO.SYSIN DD * + 1 1 1 + 10 + 0 +/* +// +./ ADD NAME=MCPISIMF,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#SIM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1000K,TIME=(10,0),PRTY=2 +//CLG EXEC SIMCLG, +// PARM.SIM=NOSUBCHK, +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='LINECNT=64' +//SIM.SYSIN DD * +COMMENT +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-28 978 1.1 use inverse to avoid divide by constant +* 2017-09-17 951 1.0 Initial version +* 2017-09-08 949 0.1 First draft +*; + +BEGIN + LONG REAL rr32,rr32i; + LONG REAL rdiv,rdivi; + LONG REAL pi; + LONG REAL rseed,rlast; + BOOLEAN ranini; + INTEGER idbgrr,idbgrn,idbgmc; + INTEGER i,ntry,nhit,ngo; + LONG REAL piest,pierr; + LONG REAL rhit,rtry; + LONG REAL x,y,r; + LONG REAL ARRAY rshuf(0:127); + + LONG REAL PROCEDURE ranraw; + BEGIN + LONG REAL rfac,rnew; + rnew := rseed * 69069.0; + rfac := rnew * rr32i; + rfac := Entier(rfac); + rnew := rnew - rfac * rr32; + IF idbgrr > 0 THEN BEGIN + OutText("RR: "); + OutFix(rseed,1,14); + OutFix(rnew,1,14); + OutImage; + END; + rseed := rnew; + ranraw := rnew; + END ** ranraw **; + + LONG REAL PROCEDURE rannum; + BEGIN + LONG REAL rnew; + INTEGER i; + IF NOT ranini THEN BEGIN + FOR i := 0 STEP 1 UNTIL 127 DO rshuf(i) := ranraw; + ranini := TRUE; + END; + i := Entier(rlast*rdivi); + rlast := rshuf(i); + rshuf(i) := ranraw; + rnew := rlast * rr32i; + IF idbgrn > 0 THEN BEGIN + OutText("RN: "); + OutInt(I,12); + OutFix(rlast,1,14); + OutFix(rnew,8,14); + OutImage; + END; + rannum := rnew; + END ** rannum **; + + rr32 := 4294967296.0; + rr32i := 1.0/rr32; + rdiv := 33554432.0; + rdivi := 1.0/rdiv; + pi := 3.141592653589793; + rseed := 12345.0; + ranini := FALSE; + + idbgrr := InInt; + idbgrn := InInt; + idbgmc := InInt; + + IF idbgrr=0 AND idbgrn=0 AND idbgmc=0 THEN BEGIN + OutText(" ntry nhit pi-est"); + OutText(" pi-err seed"); + OutImage; + END; + + WHILE TRUE DO BEGIN + ngo := InInt; + IF ngo = 0 THEN GOTO done; + FOR i := 1 STEP 1 UNTIL ngo DO BEGIN + x := 2.0 * rannum - 1.0; + y := 2.0 * rannum - 1.0; + r := x*x + y*y; + ntry := ntry + 1; + IF r <= 1.0 THEN nhit := nhit + 1; + IF idbgrr > 0 THEN BEGIN + OutText("MC: "); + OutFix(x,8,12); + OutFix(y,8,12); + OutFix(r,8,12); + OutInt(nhit,12); + OutImage; + END; + END; + rtry := ntry; + rhit := nhit; + + piest := 4.0 * (rhit / rtry); + pierr := piest - pi; + + OutText("PI: "); + OutInt(ntry,12); + OutInt(nhit,12); + OutFix(piest,8,12); + OutFix(pierr,8,12); + OutFix(rlast,1,14); + OutImage; + END; + + done: +END; +/* +//GO.SYSOUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 0 0 0 + 100 + 200 + 700 + 2000 + 7000 + 20000 + 70000 + 200000 + 700000 + 2000000 + 0 +/* +// +./ ADD NAME=MCPISIMT,LEVEL=00,SOURCE=0,LIST=ALL +//MCPI#SIM JOB 'S322-0C4','WFJM', +// CLASS=A,MSGCLASS=A,MSGLEVEL=(1,1), +// REGION=1000K,TIME=(1,0),PRTY=8 +//CLG EXEC SIMCLG, +// PARM.SIM='', +// PARM.LKED='MAP,LIST,LET', +// PARM.GO='LINECNT=64' +//SIM.SYSIN DD * +COMMENT +* +* Copyright 2017- by Walter F.J. Mueller +* +* This program is free software, you may redistribute and/or modify +* it under the terms of the GNU General Public License version 3. +* See Licence.txt in distribition directory for further details. +* +* Revision History: +* Date Rev Version Comment +* 2017-12-28 978 1.1 use inverse to avoid divide by constant +* 2017-09-17 951 1.0 Initial version +* 2017-09-08 949 0.1 First draft +*; + +BEGIN + LONG REAL rr32,rr32i; + LONG REAL rdiv,rdivi; + LONG REAL pi; + LONG REAL rseed,rlast; + BOOLEAN ranini; + INTEGER idbgrr,idbgrn,idbgmc; + INTEGER i,ntry,nhit,ngo; + LONG REAL piest,pierr; + LONG REAL rhit,rtry; + LONG REAL x,y,r; + LONG REAL ARRAY rshuf(0:127); + + LONG REAL PROCEDURE ranraw; + BEGIN + LONG REAL rfac,rnew; + rnew := rseed * 69069.0; + rfac := rnew * rr32i; + rfac := Entier(rfac); + rnew := rnew - rfac * rr32; + IF idbgrr > 0 THEN BEGIN + OutText("RR: "); + OutFix(rseed,1,14); + OutFix(rnew,1,14); + OutImage; + END; + rseed := rnew; + ranraw := rnew; + END ** ranraw **; + + LONG REAL PROCEDURE rannum; + BEGIN + LONG REAL rnew; + INTEGER i; + IF NOT ranini THEN BEGIN + FOR i := 0 STEP 1 UNTIL 127 DO rshuf(i) := ranraw; + ranini := TRUE; + END; + i := Entier(rlast*rdivi); + rlast := rshuf(i); + rshuf(i) := ranraw; + rnew := rlast * rr32i; + IF idbgrn > 0 THEN BEGIN + OutText("RN: "); + OutInt(I,12); + OutFix(rlast,1,14); + OutFix(rnew,8,14); + OutImage; + END; + rannum := rnew; + END ** rannum **; + + rr32 := 4294967296.0; + rr32i := 1.0/rr32; + rdiv := 33554432.0; + rdivi := 1.0/rdiv; + pi := 3.141592653589793; + rseed := 12345.0; + ranini := FALSE; + + idbgrr := InInt; + idbgrn := InInt; + idbgmc := InInt; + + IF idbgrr=0 AND idbgrn=0 AND idbgmc=0 THEN BEGIN + OutText(" ntry nhit pi-est"); + OutText(" pi-err seed"); + OutImage; + END; + + WHILE TRUE DO BEGIN + ngo := InInt; + IF ngo = 0 THEN GOTO done; + FOR i := 1 STEP 1 UNTIL ngo DO BEGIN + x := 2.0 * rannum - 1.0; + y := 2.0 * rannum - 1.0; + r := x*x + y*y; + ntry := ntry + 1; + IF r <= 1.0 THEN nhit := nhit + 1; + IF idbgrr > 0 THEN BEGIN + OutText("MC: "); + OutFix(x,8,12); + OutFix(y,8,12); + OutFix(r,8,12); + OutInt(nhit,12); + OutImage; + END; + END; + rtry := ntry; + rhit := nhit; + + piest := 4.0 * (rhit / rtry); + pierr := piest - pi; + + OutText("PI: "); + OutInt(ntry,12); + OutInt(nhit,12); + OutFix(piest,8,12); + OutFix(pierr,8,12); + OutFix(rlast,1,14); + OutImage; + END; + + done: +END; +/* +//GO.SYSOUT DD SYSOUT=*,OUTLIM=5000 +//GO.SYSIN DD * + 1 1 1 + 10 + 0 +/* +// +./ ENDUP +@@ +/* +//