Index: trunk/circe1/share/doc/noweb.sty =================================================================== --- trunk/circe1/share/doc/noweb.sty (revision 8914) +++ trunk/circe1/share/doc/noweb.sty (revision 8915) @@ -1,927 +1,976 @@ % noweb.sty -- LaTeX support for noweb % DON'T read or edit this file! Use ...noweb-source/tex/support.nw instead. {\obeyspaces\AtBeginDocument{\global\let =\ }} % from texbook, p 381 \def\nwopt@nomargintag{\let\nwmargintag=\@gobble} \def\nwopt@margintag{% \def\nwmargintag##1{\leavevmode\llap{##1\kern\nwmarginglue\kern\codemargin}}} \def\nwopt@margintag{% \def\nwmargintag##1{\leavevmode\kern-\codemargin\nwthemargintag{##1}\kern\codemargin}} \def\nwthemargintag#1{\llap{#1\kern\nwmarginglue}} \nwopt@margintag \newdimen\nwmarginglue \nwmarginglue=0.3in \def\nwtagstyle{\footnotesize\Rm} +\def\nwgitversion{|GITVERSION|} % make \hsize in code sufficient for 88 columns -\setbox0=\hbox{\tt m} +\ifx\ttfamily\undefined + \setbox0=\hbox{\tt m} +\else + \setbox0=\hbox{\ttfamily m} +\fi \newdimen\codehsize \codehsize=91\wd0 % 88 columns wasn't enough; I don't know why \newdimen\codemargin \codemargin=0pt \newdimen\nwdefspace \nwdefspace=\codehsize % need to use \textwidth in {\LaTeX} to handle styles with % non-standard margins (David Bruce). Don't know why we sometimes % wanted \hsize. 27 August 1997. %% \advance\nwdefspace by -\hsize\relax \ifx\textwidth\undefined \advance\nwdefspace by -\hsize\relax \else \advance\nwdefspace by -\textwidth\relax \fi \chardef\other=12 \def\setupcode{% \chardef\\=`\\ \chardef\{=`\{ \chardef\}=`\} \catcode`\$=\other \catcode`\&=\other \catcode`\#=\other \catcode`\%=\other \catcode`\~=\other \catcode`\_=\other \catcode`\^=\other \catcode`\"=\other % fixes problem with german.sty \obeyspaces\Tt } -\let\nwlbrace=\{ -\let\nwrbrace=\} \def\nwendquote{\relax\ifhmode\spacefactor=1000 \fi} {\catcode`\^^M=\active % make CR an active character \gdef\newlines{\catcode`\^^M=\active % make CR an active character \def^^M{\par\startline}}% \gdef\eatline#1^^M{\relax}% } %%% DON'T \gdef^^M{\par\startline}}% in case ^^M appears in a \write \def\startline{\noindent\hskip\parindent\ignorespaces} \def\nwnewline{\ifvmode\else\hfil\break\leavevmode\hbox{}\fi} \def\setupmodname{% \catcode`\$=3 \catcode`\&=4 \catcode`\#=6 \catcode`\%=14 \catcode`\~=13 \catcode`\_=8 \catcode`\^=7 \catcode`\ =10 \catcode`\^^M=5 - \let\{\nwlbrace - \let\}\nwrbrace + \let\{\lbrace + \let\}\rbrace % bad news --- don't know what catcode to give " \Rm} \def\LA{\begingroup\maybehbox\bgroup\setupmodname\It$\langle$} \def\RA{\/$\rangle$\egroup\endgroup} \def\code{\leavevmode\begingroup\setupcode\newlines} \def\edoc{\endgroup} \let\maybehbox\relax \newbox\equivbox \setbox\equivbox=\hbox{$\equiv$} \newbox\plusequivbox \setbox\plusequivbox=\hbox{$\mathord{+}\mathord{\equiv}$} % \moddef can't have an argument because there might be \code...\edoc \def\moddef{\leavevmode\kern-\codemargin\LA} \def\endmoddef{\RA\ifmmode\equiv\else\unhcopy\equivbox\fi \nobreak\hfill\nobreak} \def\plusendmoddef{\RA\ifmmode\mathord{+}\mathord{\equiv}\else\unhcopy\plusequivbox\fi \nobreak\hfill\nobreak} \def\chunklist{% \errhelp{I changed \chunklist to \nowebchunks. I'll try to avoid such incompatible changes in the future.}% \errmessage{Use \string\nowebchunks\space instead of \string\chunklist}} \def\nowebchunks{\message{}} \def\nowebindex{\message{}} % here is support for the new-style (capitalized) font-changing commands % thanks to Dave Love \ifx\documentstyle\undefined \let\Rm=\rm \let\It=\it \let\Tt=\tt % plain \else\ifx\selectfont\undefined \let\Rm=\rm \let\It=\it \let\Tt=\tt % LaTeX OFSS \else % LaTeX NFSS - \def\Rm{\reset@font\rm} - \def\It{\reset@font\it} - \def\Tt{\reset@font\tt} - \def\Bf{\reset@font\bf} + \def\Rm{\reset@font\rmfamily} + \def\It{\reset@font\itshape} + \def\Tt{\reset@font\ttfamily} + \def\Bf{\reset@font\bfseries} \fi\fi \ifx\reset@font\undefined \let\reset@font=\relax \fi +\def\nwbackslash{\char92} +\def\nwlbrace{\char123} +\def\nwrbrace{\char125} \def\noweboptions#1{% \def\@nwoptionlist{#1}% \@for\@nwoption:=\@nwoptionlist\do{% \@ifundefined{nwopt@\@nwoption}{% \@latexerr{There is no such noweb option as '\@nwoption'}\@eha}{% \csname nwopt@\@nwoption\endcsname}}} \codemargin=10pt \advance\codehsize by \codemargin % make room for indentation of code \advance\nwdefspace by \codemargin % and fix adjustment for def/use \def\setcodemargin#1{% \advance\codehsize by -\codemargin % make room for indentation of code \advance\nwdefspace by -\codemargin % and fix adjustment for def/use \codemargin=#1 \advance\codehsize by \codemargin % make room for indentation of code \advance\nwdefspace by \codemargin % and fix adjustment for % def/use } \def\nwopt@shift{% \dimen@=-0.8in \if@twoside % Values for two-sided printing: \advance\evensidemargin by \dimen@ \else % Values for one-sided printing: \advance\evensidemargin by \dimen@ \advance\oddsidemargin by \dimen@ \fi % \advance \marginparwidth -\dimen@ } \let\nwopt@noshift\@empty \def\nwbegincode#1{% \begingroup \topsep \nwcodetopsep \@beginparpenalty \@highpenalty \@endparpenalty -\@highpenalty \@begincode } \def\nwendcode{\endtrivlist \endgroup \filbreak} % keeps code on 1 page \newenvironment{webcode}{% \@begincode }{% \endtrivlist} +\newdimen\@nwbegincodelinewidth \def\@begincode{% + \@nwbegincodelinewidth=\linewidth \trivlist \item[]% \leftskip\@totalleftmargin \advance\leftskip\codemargin \rightskip\hsize \advance\rightskip -\codehsize \parskip\z@ \parindent\z@ \parfillskip\@flushglue \linewidth\codehsize \@@par \def\par{\leavevmode\null \@@par \penalty\nwcodepenalty}% \obeylines + \nowebsize \setupcode \@noligs \ifx\verbatim@nolig@list\undefined\else \let\do=\nw@makeother \verbatim@nolig@list \do@noligs\` \fi \setupcode \frenchspacing \@vobeyspaces - \nowebsize \setupcode \let\maybehbox\mbox } \newskip\nwcodetopsep \nwcodetopsep = 3pt plus 1.2pt minus 1pt \let\nowebsize=\normalsize \def\nwopt@tinycode{\let\nowebsize=\tiny} \def\nwopt@footnotesizecode{\let\nowebsize=\footnotesize} \def\nwopt@scriptsizecode{\let\nowebsize=\scriptsize} \def\nwopt@smallcode{\let\nowebsize=\small} \def\nwopt@normalsizecode{\let\nowebsize=\normalsize} \def\nwopt@largecode{\let\nowebsize=\large} \def\nwopt@Largecode{\let\nowebsize=\Large} \def\nwopt@LARGEcode{\let\nowebsize=\LARGE} \def\nwopt@hugecode{\let\nowebsize=\huge} \def\nwopt@Hugecode{\let\nowebsize=\Huge} \newcount\nwcodepenalty \nwcodepenalty=\@highpenalty \def\nw@makeother#1{\catcode`#1=12 } \def\nwbegindocs#1{\ifvmode\noindent\fi} \let\nwenddocs=\relax \let\nwdocspar=\filbreak \def\@nwsemifilbreak#1{\vskip0pt plus#1\penalty-200\vskip0pt plus -#1} \newdimen\nwbreakcodespace \nwbreakcodespace=0.2in % by default, leave no more than this on a page \def\nwopt@breakcode{% \def\nwdocspar{\@nwsemifilbreak{0.2in}}% \def\nwendcode{\endtrivlist\endgroup} % ditches filbreak } \raggedbottom \def\code{\leavevmode\begingroup\setupcode\@vobeyspaces\obeylines} \let\edoc=\endgroup \newdimen\@original@textwidth \def\ps@noweb{% \@original@textwidth=\textwidth \let\@mkboth\@gobbletwo \def\@oddfoot{}\def\@evenfoot{}% No feet. \if@twoside % If two-sided printing. \def\@evenhead{\hbox to \@original@textwidth{% \Rm \thepage\qquad{\Tt\leftmark}\hfil\today}}% Left heading. \def\@oddhead{\hbox to \@original@textwidth{% \Rm \today\hfil{\Tt\leftmark}\qquad\thepage}}% Right heading. \else % If one-sided printing. \def\@oddhead{\hbox to \@original@textwidth{% \Rm \today\hfil{\Tt\leftmark}\qquad\thepage}}% Right heading. \let\@evenhead\@oddhead \fi \let\chaptermark\@gobble \let\sectionmark\@gobble \let\subsectionmark\@gobble \let\subsubsectionmark\@gobble \let\paragraphmark\@gobble \let\subparagraphmark\@gobble \def\nwfilename{\begingroup\let\do\@makeother\dospecials \catcode`\{=1 \catcode`\}=2 \nw@filename} \def\nw@filename##1{\endgroup\markboth{##1}{##1}\let\nw@filename=\nw@laterfilename}% } \def\nw@laterfilename#1{\endgroup\clearpage \markboth{#1}{#1}} \let\nwfilename=\@gobble \def\nwcodecomment#1{\@@par\penalty\nwcodepenalty \if@firstnwcodecomment \vskip\nwcodecommentsep\penalty\nwcodepenalty\@firstnwcodecommentfalse \fi% \hspace{-\codemargin}{% \rightskip=0pt plus1in \interlinepenalty\nwcodepenalty \let\\\relax\footnotesize\Rm #1\@@par\penalty\nwcodepenalty}} \def\@nwalsodefined#1{\nwcodecomment{\@nwlangdepdef\ \nwpageprep\ \@pagesl{#1}.}} \def\@nwused#1{\nwcodecomment{\@nwlangdepcud\ \nwpageprep\ \@pagesl{#1}.}} \def\@nwnotused#1{\nwcodecomment{\@nwlangdeprtc.}} \def\nwoutput#1{\nwcodecomment{\@nwlangdepcwf\ {\Tt \@stripstar#1*\stripped}.}} \def\@stripstar#1*#2\stripped{#1} \newcommand{\nwprevdefptr}[1]{% \mbox{$\mathord{\triangleleft}\,\mathord{\mbox{\subpageref{#1}}}$}} \newcommand{\nwnextdefptr}[1]{% \mbox{$\mathord{\mbox{\subpageref{#1}}}\,\mathord{\triangleright}$}} \newcommand{\@nwprevnextdefs}[2]{% {\nwtagstyle \ifx\relax#1\else ~~\nwprevdefptr{#1}\fi \ifx\relax#2\else ~~\nwnextdefptr{#2}\fi}} \newcommand{\@nwusesondefline}[1]{{\nwtagstyle~~(\@pagenumsl{#1})}} \newcommand{\@nwstartdeflinemarkup}{\nobreak\hskip 1.5em plus 1fill\nobreak} \newcommand{\@nwenddeflinemarkup}{\nobreak\hskip \nwdefspace minus\nwdefspace\nobreak} \def\nwopt@longxref{% \let\nwalsodefined\@nwalsodefined \let\nwused\@nwused \let\nwnotused\@nwnotused \let\nwprevnextdefs\@gobbletwo \let\nwusesondefline\@gobble \let\nwstartdeflinemarkup\relax \let\nwenddeflinemarkup\relax } \def\nwopt@shortxref{% \let\nwalsodefined\@gobble \let\nwused\@gobble \let\nwnotused\@gobble \let\nwprevnextdefs\@nwprevnextdefs \let\nwusesondefline\@nwusesondefline \let\nwstartdeflinemarkup\@nwstartdeflinemarkup \let\nwenddeflinemarkup\@nwenddeflinemarkup } \def\nwopt@noxref{% \let\nwalsodefined\@gobble \let\nwused\@gobble \let\nwnotused\@gobble \let\nwprevnextdefs\@gobbletwo \let\nwusesondefline\@gobble \let\nwstartdeflinemarkup\relax \let\nwenddeflinemarkup\relax } \nwopt@shortxref % to hell with backward compatibility! \newskip\nwcodecommentsep \nwcodecommentsep=3pt plus 1pt minus 1pt \newif\if@firstnwcodecomment\@firstnwcodecommenttrue \newcount\@nwlopage\newcount\@nwhipage % range lo..hi-1 \newcount\@nwlosub % subpage of lo \newcount\@nwhisub % subpage of hi \def\@nwfirstpage#1#2#3{% subpage page xref-tag \@nwlopage=#2 \@nwlosub=#1 \def\@nwloxreftag{#3}% \advance\@nwpagecount by \@ne \@nwhipage=\@nwlopage\advance\@nwhipage by \@ne } \def\@nwnextpage#1#2#3{% subpage page xref-tag \ifnum\@nwhipage=#2 \advance\@nwhipage by \@ne \advance\@nwpagecount by \@ne \@nwhisub=#1 \def\@nwhixreftag{#3}\else \ifnum#2<\@nwlopage \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\@nwfirstpage{#1}{#2}{#3}\else \ifnum#2>\@nwhipage \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\@nwfirstpage{#1}{#2}{#3}\else \@nwlosub=0 \@nwhisub=0 \fi\fi\fi } \newcount\@nwpagetemp \newcount\@nwpagecount \def\@nwfirstpagel#1{% label \@ifundefined{r@#1}{\@warning{Reference `#1' on page \thepage \space undefined}% - \nwix@cons\nw@pages{\\{\bf ??}}}{% + \nwix@cons\nw@pages{\\{\bfseries ??}}}{% \edef\@tempa{\noexpand\@nwfirstpage\subpagepair{#1}{#1}}\@tempa}} \def\@nwnextpagel#1{% label \@ifundefined{r@#1}{\@warning{Reference `#1' on page \thepage \space undefined}% - \nwix@cons\nw@pages{\\{\bf ??}}}{% + \nwix@cons\nw@pages{\\{\bfseries ??}}}{% \edef\@tempa{\noexpand\@nwnextpage\subpagepair{#1}{#1}}\@tempa}} \def\@pagesl#1{% list of labels \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\@nwfirstpagel{##1}\let\\=\@nwnextpagel}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\def\\##1{\@nwhyperpagenum##1}% \ifnum\@nwpagecount=1 \nwpageword \else \nwpagesword\fi~\commafy{\nw@pages}} \def\@nwhyperpagenum#1#2{\nwhyperreference{#2}{#1}} \def\@pagenumsl#1{% list of labels -- doesn't include word `pages', commas, or `and' \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\@nwfirstpagel{##1}\let\\=\@nwnextpagel}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa% \def\\##1{\@nwhyperpagenum##1\let\\=\@nwpagenumslrest}\nw@pages} \def\@nwpagenumslrest#1{~\@nwhyperpagenum#1} \def\subpages#1{% list of {{subpage}{page}} \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\edef\@tempa{\noexpand\@nwfirstpage##1{}}\@tempa \def\\####1{\edef\@tempa{\noexpand\@nwnextpage####1}\@tempa}}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\def\\##1{\@firstoftwo##1}% \ifnum\@nwpagecount=1 \nwpageword \else \nwpagesword\fi~\commafy{\nw@pages}} \def\@nwaddrange{\advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa} \def\nwpageword{\@nwlangdepchk} % chunk, was page \def\nwpagesword{\@nwlangdepchks} % chunk, was page \def\nwpageprep{\@nwlangdepin} % in, was on \newcommand\nw@genericref[2]{% what to do, name of ref \expandafter\nw@g@nericref\csname r@#2\endcsname#1{#2}} \newcommand\nw@g@nericref[3]{% control sequence, what to do, name \ifx#1\relax \ref{#3}% trigger the standard `undefined ref' mechanisms \else \expandafter#2#1.\\% \fi} \def\nw@selectone#1#2#3\\{#1} \def\nw@selecttwo#1#2#3\\{#2} \def\nw@selectonetwo#1#2#3\\{{#1}{#2}} \newcommand{\subpageref}[1]{% \nwhyperreference{#1}{\nw@genericref\@subpageref{#1}}} \def\@subpageref#1#2#3\\{% \@ifundefined{2on#2}{#2}{\nwthepagenum{#1}{#2}}} \newcommand{\subpagepair}[1]{% % produces {subpage}{page} \@ifundefined{r@#1}% {{0}{0}}% {\nw@genericref\@subpagepair{#1}}} \def\@subpagepair#1#2#3\\{% \@ifundefined{2on#2}{{0}{#2}}{{#1}{#2}}} \newcommand{\sublabel}[1]{% + \leavevmode % needed to make \@bsphack work \@bsphack \nwblindhyperanchor{#1}% \if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newsublabel{#1}{{}{\thepage}}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand{\nosublabel}[1]{% \@bsphack\if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newlabel{#1}{{0}{\thepage}}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand\newsublabel{% \nw@settrailers \global\let\newsublabel\@newsublabel \@newsublabel} \newcommand{\@newsublabel}[2]{% \edef\this@page{\@cdr#2\@nil}% \ifx\this@page\last@page\else \sub@page=\z@ \fi \edef\last@page{\this@page} \advance\sub@page by \@ne \ifnum\sub@page=\tw@ \global\@namedef{2on\this@page}{}% \fi \pendingsublabel{#1}% \edef\@tempa##1{\noexpand\newlabel{##1}% {{\number\sub@page}{\this@page}\nw@labeltrailers}}% \pending@sublabels \def\pending@sublabels{}} \newcommand\nw@settrailers{% -- won't work on first run \@ifpackageloaded{nameref}% {\gdef\nw@labeltrailers{{}{}{}}}% {\gdef\nw@labeltrailers{}}} \renewcommand\nw@settrailers{% \@ifundefined{@secondoffive}% {\gdef\nw@labeltrailers{}}% {\gdef\nw@labeltrailers{{}{}{}}}} \newcommand{\nextchunklabel}[1]{% \nwblindhyperanchor{#1}% % looks slightly bogus --- nr \@bsphack\if@filesw {\let\thepage\relax \edef\@tempa{\write\@auxout{\string\pendingsublabel{#1}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand\pendingsublabel[1]{% \def\@tempa{\noexpand\@tempa}% \edef\pending@sublabels{\noexpand\@tempa{#1}\pending@sublabels}} \def\pending@sublabels{} \def\last@page{\relax} \newcount\sub@page \def\@alphasubpagenum#1#2{#2\ifnum#1=0 \else\@alph{#1}\fi} \def\@nosubpagenum#1#2{#2} \def\@numsubpagenum#1#2{#2\ifnum#1=0 \else.\@arabic{#1}\fi} \def\nwopt@nosubpage{\let\nwthepagenum=\@nosubpagenum\nwopt@nomargintag} \def\nwopt@numsubpage{\let\nwthepagenum=\@numsubpagenum} \def\nwopt@alphasubpage{\let\nwthepagenum=\@alphasubpagenum} \nwopt@alphasubpage \newcount\@nwalph@n \let\@nwalph@d\@tempcnta \let\@nwalph@bound\@tempcntb \def\@nwlongalph#1{{% \@nwalph@n=#1\advance\@nwalph@n by-1 \@nwalph@bound=26 \loop\ifnum\@nwalph@n<\@nwalph@bound\else \advance\@nwalph@n by -\@nwalph@bound \multiply\@nwalph@bound by 26 \repeat \loop\ifnum\@nwalph@bound>1 \divide\@nwalph@bound by 26 \@nwalph@d=\@nwalph@n\divide\@nwalph@d by \@nwalph@bound % d := d * bound ; n -:= d; d := d / bound --- saves a temporary \multiply\@nwalph@d by \@nwalph@bound \advance\@nwalph@n by -\@nwalph@d \divide\@nwalph@d by \@nwalph@bound \advance\@nwalph@d by 1 \@alph{\@nwalph@d}% \repeat }} \newcount\nw@chunkcount \nw@chunkcount=\@ne \newcommand{\weblabel}[1]{% \@bsphack \nwblindhyperanchor{#1}% \if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newsublabel{#1}{{}{\number\nw@chunkcount}}}}% \expandafter}\@tempa \global\advance\nw@chunkcount by \@ne \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \def\nwopt@webnumbering{% \let\sublabel=\weblabel \def\nwpageword{chunk}\def\nwpagesword{chunks}% \def\nwpageprep{in}} % \nwindexdefn{printable name}{identifying label}{label of chunk} % \nwindexuse{printable name}{identifying label}{label of chunk} \def\nwindexdefn#1#2#3{\@auxix{\protect\nwixd}{#2}{#3}} \def\nwindexuse#1#2#3{\@auxix{\protect\nwixu}{#2}{#3}} \def\@auxix#1#2#3{% {marker}{id label}{subpage label} \@bsphack\if@filesw {\let\nwixd\relax\let\nwixu\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string\nwixadd{#1}{#2}{#3}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} % \nwixadd{marker}{idlabel}{subpage label} \def\nwixadd#1#2#3{% \@ifundefined{nwixl@#2}% {\global\@namedef{nwixl@#2}{#1{#3}}}% {\expandafter\nwix@cons\csname nwixl@#2\endcsname{#1{#3}}}} \def\@nwsubscriptident#1#2{\mbox{$\mbox{#1}_{\mathrm{\subpageref{#2}}}$}} \def\@nwnosubscriptident#1#2{#1} \def\@nwhyperident#1#2{\leavevmode\nwhyperreference{#2}{#1}} \def\nwopt@subscriptidents{% \let\nwlinkedidentq\@nwsubscriptident \let\nwlinkedidentc\@nwsubscriptident } \def\nwopt@nosubscriptidents{% \let\nwlinkedidentq\@nwnosubscriptident \let\nwlinkedidentc\@nwnosubscriptident } \def\nwopt@hyperidents{% \let\nwlinkedidentq\@nwhyperident \let\nwlinkedidentc\@nwhyperident } \def\nwopt@nohyperidents{% \let\nwlinkedidentq\@nwnosubscriptident \let\nwlinkedidentc\@nwnosubscriptident } \def\nwopt@subscriptquotedidents{% \let\nwlinkedidentq\@nwsubscriptident } \def\nwopt@nosubscriptquotedidents{% \let\nwlinkedidentq\@nwnosubscriptident } \def\nwopt@hyperquotedidents{% \let\nwlinkedidentq\@nwhyperident } \def\nwopt@nohyperquotedidents{% \let\nwlinkedidentq\@nwnosubscriptident } \nwopt@hyperidents \newcount\@commacount \def\commafy#1{% {\nwix@listcount{#1}\@commacount=\nwix@counter \let\@comma@each=\\% \ifcase\@commacount\let\\=\@comma@each\or\let\\=\@comma@each\or \def\\{\def\\{ \@nwlangdepand\ \@comma@each}\@comma@each}\else \def\\{\def\\{, % \advance\@commacount by \m@ne \ifnum\@commacount=1 \@nwlangdepand~\fi\@comma@each}\@comma@each}\fi #1}} \def\nwix@cons#1#2{% {list}{\marker{element}} {\toks0=\expandafter{#1}\def\@tempa{#2}\toks2=\expandafter{\@tempa}% \xdef#1{\the\toks0 \the\toks2 }}} \def\nwix@uses#1{% {label} \def\nwixu{\\}\let\nwixd\@gobble\@nameuse{nwixl@#1}} \def\nwix@defs#1{% {label} \def\nwixd{\\}\let\nwixu\@gobble\@nameuse{nwixl@#1}} \newcount\nwix@counter \def\nwix@listcount#1{% {list with \\} {\count@=0 \def\\##1{\advance\count@ by \@ne }% #1\global\nwix@counter=\count@ }} \def\nwix@usecount#1{\nwix@listcount{\nwix@uses{#1}}} \def\nwix@defcount#1{\nwix@listcount{\nwix@defs{#1}}} \def\nwix@id@defs#1{% index pair {{\Tt \@car#1\@nil}% \def\\##1{\nwix@defs@space\subpageref{##1}}\nwix@defs{\@cdr#1\@nil}}} % useful above to change ~ into something that can break % this option is undocumented because I think breakdefs is always right \def\nwopt@breakdefs{\def\nwix@defs@space{\penalty200\ }} \def\nwopt@nobreakdefs{\def\nwix@defs@space{~}} % old code \nwopt@breakdefs \def\nwidentuses#1{% list of index pairs \nwcodecomment{\@nwlangdepuss\ \let\\=\nwix@id@defs\commafy{#1}.}} \def\nwix@totaluses#1{% list of index pairs {\count@=0 \def\\##1{\nwix@usecount{\@cdr##1\@nil}\advance\count@ by\nwix@counter}% #1\global\nwix@counter\count@ }} \def\nwix@id@uses#1#2{% {ident}{label} \nwix@usecount{#2}\ifnum\nwix@counter>0 {\advance\leftskip by \codemargin \nwcodecomment{{\Tt #1}, \@nwlangdepusd\ \nwpageprep\ \@pagesl{\nwix@uses{#2}}.}}% \else \ifnw@hideunuseddefs\else {\advance\leftskip by \codemargin \nwcodecomment{{\Tt #1}, \@nwlangdepnvu.}}% \fi \fi} \def\nwidentdefs#1{% list of index pairs \ifnw@hideunuseddefs\nwix@totaluses{#1}\else\nwix@listcount{#1}\fi \ifnum\nwix@counter>0 \nwcodecomment{\@nwlangdepdfs:}% {\def\\##1{\nwix@id@uses ##1}#1}% \fi} \newif\ifnw@hideunuseddefs\nw@hideunuseddefsfalse \def\nwopt@hideunuseddefs{\nw@hideunuseddefstrue} \def\nwopt@noidentxref{% \let\nwidentdefs\@gobble \let\nwidentuses\@gobble} \def\nw@underlinedefs{% {list with \nwixd, \nwixu} \let\\=\relax\def\nw@comma{, } \def\nwixd##1{\\\underline{\subpageref{##1}}\let\\\nw@comma}% \def\nwixu##1{\\\subpageref{##1}\let\\\nw@comma}} \def\nw@indexline#1#2{% {\indent {\Tt #1}: \nw@underlinedefs\@nameuse{nwixl@#2}\par}} \newenvironment{thenowebindex}{\parindent=-10pt \parskip=\z@ \advance\leftskip by 10pt \advance\rightskip by 0pt plus1in\par\@afterindenttrue \def\\##1{\nw@indexline##1}}{} \def\nowebindex{% \@ifundefined{nwixs@i}% {\@warning{The \string\nowebindex\space is empty}}% {\begin{thenowebindex}\@nameuse{nwixs@i}\end{thenowebindex}}} \def\nowebindex@external{% {\let\nwixadds@c=\@gobble \def\nwixadds@i##1{\nw@indexline##1}% \def\nwixaddsx##1##2{\@nameuse{nwixadds@##1}{##2}}% \begin{thenowebindex}\@input{\jobname.nwi}\end{thenowebindex}}} \def\nwixlogsorted#1#2{% list data \@bsphack\if@filesw \toks0={#2}\immediate\write\@auxout{\string\nwixadds{#1}{\the\toks0}} \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \def\nwixadds#1#2{% \@ifundefined{nwixs@#1}% {\global\@namedef{nwixs@#1}{\\{#2}}}% {\expandafter\nwix@cons\csname nwixs@#1\endcsname{\\{#2}}}} \let\nwixaddsx=\@gobbletwo \def\nwopt@externalindex{% \ifx\nwixadds\@gobbletwo % already called \else \let\nwixaddsx=\nwixadds \let\nwixadds=\@gobbletwo \let\nowebindex=\nowebindex@external \let\nowebchunks=\nowebchunks@external \fi} \def\nowebchunks{% \@ifundefined{nwixs@c}% {\@warning{The are no \string\nowebchunks}}% {\begin{thenowebchunks}\@nameuse{nwixs@c}\end{thenowebchunks}}} \def\nowebchunks@external{% {\let\nwixadds@i=\@gobble \def\nwixadds@c##1{\nw@onechunk##1}% \def\nwixaddsx##1##2{\@nameuse{nwixadds@##1}{##2}}% \begin{thenowebchunks}\@input{\jobname.nwi}\end{thenowebchunks}}} \@namedef{r@nw@notdef}{{0}{(\@nwlangdepnvd)}} \def\nw@chunkunderlinedefs{% {list of labels with \nwixd, \nwixu} \let\\=\relax\def\nw@comma{, } \def\nwixd##1{\\\underline{\subpageref{##1}}\let\\\nw@comma}% \def\nwixu##1{\\\subpageref{##1}\let\\\nw@comma}} \def\nw@onechunk#1#2#3{% {name}{label of first definition}{list with \nwixd, \nwixu} \@ifundefined{r@#2}{}{% \indent\LA #1~{\nwtagstyle\subpageref{#2}}\RA \if@nwlongchunks{~\nw@chunkunderlinedefs#3}\fi\par}} \newenvironment{thenowebchunks}{\vskip3pt \parskip=\z@\parindent=-10pt \advance\leftskip by 10pt \advance\rightskip by 0pt plus10pt \@afterindenttrue \def\\##1{\nw@onechunk##1}}{} \newif\if@nwlongchunks \@nwlongchunksfalse \let\nwopt@longchunks\@nwlongchunkstrue \newcommand\@nw@hyper@ref{\hyperreference} % naras \newcommand\@nw@hyper@anc{\blindhyperanchor} % naras \newcommand\@nw@hyperref@ref[2]{\hyperlink{noweb.#1}{#2}} % nr \newcommand\@nw@hyperref@anc[1]{\hypertarget{noweb.#1}{\relax}} % nr %%\renewcommand\@nw@hyperref@ref[2]{{#2}} % nr %%\renewcommand\@nw@hyperref@anc[1]{} % nr \newcommand\nwhyperreference{% \@ifundefined{hyperlink} {\@ifundefined{hyperreference} {\global\let\nwhyperreference\@gobble} {\global\let\nwhyperreference\@nw@hyper@ref}} {\global\let\nwhyperreference\@nw@hyperref@ref}% \nwhyperreference } \newcommand\nwblindhyperanchor{% \@ifundefined{hyperlink} {\@ifundefined{hyperreference} {\global\let\nwblindhyperanchor\@gobble} {\global\let\nwblindhyperanchor\@nw@hyper@anc}} {\global\let\nwblindhyperanchor\@nw@hyperref@anc}% \nwblindhyperanchor } \newcommand\nwanchorto{% \begingroup\let\do\@makeother\dospecials \catcode`\{=1 \catcode`\}=2 \nw@anchorto} \newcommand\nw@anchorto[1]{\endgroup\def\nw@next{#1}\nw@anchortofin} \newcommand\nw@anchortofin[1]{#1\footnote{See URL \texttt{\nw@next}.}} \let\nwanchorname\@gobble \newif\ifhtml \htmlfalse \let\nwixident=\relax -\def\nwbackslash{\char92} -\def\nwlbrace{\char123} -\def\nwrbrace{\char125} \def\nwopt@english{% \def\@nwlangdepdef{This definition is continued}% \def\@nwlangdepcud{This code is used}% \def\@nwlangdeprtc{Root chunk (not used in this document)}% \def\@nwlangdepcwf{This code is written to file}% \def\@nwlangdepchk{chunk}% \def\@nwlangdepchks{chunks}% \def\@nwlangdepin{in}% \def\@nwlangdepand{and}% \def\@nwlangdepuss{Uses}% \def\@nwlangdepusd{used}% \def\@nwlangdepnvu{never used}% \def\@nwlangdepdfs{Defines}% \def\@nwlangdepnvd{never defined}% } \let\nwopt@american\nwopt@english +\def\nwopt@icelandic{% + \def\@nwlangdepdef{This definition is continued}% + \def\@nwlangdepcud{This code is used}% + \def\@nwlangdeprtc{Root chunk (not used in this document)}% + \def\@nwlangdepcwf{This code is written to file}% + \def\@nwlangdepchk{kóða}% + \def\@nwlangdepchks{kóðum}% + \def\@nwlangdepin{í}% + \def\@nwlangdepand{og}% + \def\@nwlangdepuss{Notar}% + \def\@nwlangdepusd{notað}% + \def\@nwlangdepnvu{hvergi notað}% + \def\@nwlangdepdfs{Skilgreinir}% + \def\@nwlangdepnvd{hvergi skilgreint}% +} \def\nwopt@portuges{% \def\@nwlangdepdef{Defini\c{c}\~ao continuada em}% % This definition is continued \def\@nwlangdepcud{C\'odigo usado em}% % This code is used \def\@nwlangdeprtc{Fragmento de topo (sem uso no documento)}% % Root chunk (not used in this document) \def\@nwlangdepcwf{Este c\'odigo foi escrito no ficheiro}% % This code is written to file \def\@nwlangdepchk{fragmento}% % chunk \def\@nwlangdepchks{fragmentos}% % chunks \def\@nwlangdepin{no(s)}% % in \def\@nwlangdepand{e}% % and \def\@nwlangdepuss{Usa}% % Uses \def\@nwlangdepusd{usado}% % used \def\@nwlangdepnvu{nunca usado}% % never used \def\@nwlangdepdfs{Define}% % Defines \def\@nwlangdepnvd{nunca definido}% % never defined } \def\nwopt@frenchb{% - \def\@nwlangdepdef{Cette d\'efinition suit}% + \def\@nwlangdepdef{Suite de la d\'efinition}% % This definition is continued \def\@nwlangdepcud{Ce code est employ\'e}% % This code is used \def\@nwlangdeprtc{Morceau racine (pas employ\'e dans ce document)}% % Root chunk (not used in this document) - \def\@nwlangdepcwf{Ce code est \'ecrit aux fichier}% + \def\@nwlangdepcwf{Ce code est \'ecrit dans le fichier}% % This code is written to file \def\@nwlangdepchk{le morceau}% % chunk \def\@nwlangdepchks{les morceaux}% % chunks \def\@nwlangdepin{dans}% % in \def\@nwlangdepand{et}% % and - \def\@nwlangdepuss{Il emploie}% + \def\@nwlangdepuss{Utilise}% % Uses - \def\@nwlangdepusd{employ\'{e}}% + \def\@nwlangdepusd{utilis\'{e}}% % used \def\@nwlangdepnvu{jamais employ\'{e}}% % never used - \def\@nwlangdepdfs{Il d\'{e}fine}% + \def\@nwlangdepdfs{D\'{e}finit}% % Defines % Cannot use the accent here: \def\@nwlangdepnvd{jamais d\'{e}fini}% \def\@nwlangdepnvd{jamais defini}% % never defined } \let\nwopt@french\nwopt@frenchb \def\nwopt@german{% \def\@nwlangdepdef{Diese Definition wird fortgesetzt}% % This definition is continued \def\@nwlangdepcud{Dieser Code wird benutzt}% % This code is used \def\@nwlangdeprtc{Hauptteil (nicht in diesem Dokument benutzt)}% % Root chunk (not used in this document) - \def\@nwlangdepcwf{Dieser Code schreibt man zum File}% + \def\@nwlangdepcwf{Geh\"ort in die Datei}% % This code is written to file + \def\@nwlangdepchk{Abschnitt}% + % chunk + \def\@nwlangdepchks{den Abschnitten}% + % chunks + \def\@nwlangdepin{in}% + % in + \def\@nwlangdepand{und}% + % and + \def\@nwlangdepuss{Benutzt}% + % Uses + \def\@nwlangdepusd{benutzt}% + % used + \def\@nwlangdepnvu{nicht benutzt}% + % never used + \def\@nwlangdepdfs{Definiert}% + % Defines + \def\@nwlangdepnvd{nicht definiert}% + % never defined +} +\def\nwopt@german{% + \def\@nwlangdepdef{Diese Definition wird fortgesetzt}% + % This definition is continued + \def\@nwlangdepcud{Dieser Code wird benutzt}% + % This code is used + \def\@nwlangdeprtc{Hauptteil (nicht in diesem Dokument benutzt)}% + % Root chunk (not used in this document) + \def\@nwlangdepcwf{Dieser Code erzeugt die Datei} + % This code generates the file \def\@nwlangdepchk{Teil}% % chunk \def\@nwlangdepchks{Teils}% % chunks \def\@nwlangdepin{im}% % in \def\@nwlangdepand{und}% % and \def\@nwlangdepuss{Benutzt}% % Uses \def\@nwlangdepusd{benutzt}% % used \def\@nwlangdepnvu{nicht benutzt}% % never used \def\@nwlangdepdfs{Definiert}% % Defines \def\@nwlangdepnvd{nicht definiert}% % never defined } \let\nwopt@ngerman\nwopt@german \ifx\languagename\undefined % default is English \noweboptions{english} \else \@ifundefined{nwopt@\languagename} {\noweboptions{english}} {\expandafter\noweboptions\expandafter{\languagename}} \fi Index: trunk/circe2/src/circe2.nw =================================================================== --- trunk/circe2/src/circe2.nw (revision 8914) +++ trunk/circe2/src/circe2.nw (revision 8915) @@ -1,1959 +1,1959 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % circe2/circe2.nw -- @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Implementation of [[circe2]]} <>= 'Version 3.1.4.1' @ <<[[implicit none]]>>= implicit none @ <<[[circe2.f90]]>>= ! circe2.f90 -- correlated beam spectra for linear colliders <> <> module circe2 use kinds implicit none private <<[[circe2]] parameters>> <<[[circe2]] declarations>> contains <<[[circe2]] implementation>> end module circe2 @ <>= !----------------------------------------------------------------------- @ The following is usually not needed for scientific programs. Nobody is going to hijack such code. But let us include it anyway to spread the gospel of free software: <>= ! Copyright (C) 2001-2023 by Thorsten Ohl ! ! Circe2 is free software; you can redistribute it and/or modify it ! under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2, or (at your option) ! any later version. ! ! Circe2 is distributed in the hope that it will be useful, but ! WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Data} <<[[circe2]] declarations>>= type circe2_division <<[[circe2_division]] members>> end type circe2_division @ <<[[circe2]] declarations>>= type circe2_channel <<[[circe2_channel]] members>> end type circe2_channel @ <<[[circe2]] declarations>>= type circe2_state <<[[circe2_state]] members>> end type circe2_state public :: circe2_state @ \begin{figure} \begin{center} \begin{empgraph}(110,60) setrange (0, 0, 1, 1); autogrid (,); pickup pencircle scaled 0.5pt; for i = 2 step 2 until 8: x := i / 10; gdraw (0,x) -- (1,x); gdraw (x,0) -- (x,1); endfor glabel (btex $x_{1}^{\min}$ etex, (0.0,-0.1)); glabel (btex $x_{1}^{\max}$ etex, (1.0,-0.1)); glabel (btex $x_{2}^{\min}$ etex, (-0.1,0.0)); glabel (btex $x_{3}^{\max}$ etex, (-0.1,1.0)); glabel (btex $i_1=1$ etex, (0.1,-0.1)); glabel (btex $2$ etex, (0.3,-0.1)); glabel (btex $3$ etex, (0.5,-0.1)); glabel (btex $\ldots$ etex, (0.7,-0.1)); glabel (btex $n_1$ etex, (0.9,-0.1)); glabel (btex $1$ etex, (-0.1,0.1)); glabel (btex $2$ etex, (-0.1,0.3)); glabel (btex $3$ etex, (-0.1,0.5)); glabel (btex $\ldots$ etex, (-0.1,0.7)); glabel (btex $i_2=n_2$ etex, (-0.1,0.9)); glabel (btex $1$ etex, (0.1,0.1)); glabel (btex $2$ etex, (0.3,0.1)); glabel (btex $3$ etex, (0.5,0.1)); glabel (btex $\ldots$ etex, (0.7,0.1)); glabel (btex $n_1$ etex, (0.9,0.1)); glabel (btex $n_1+1$ etex, (0.1,0.3)); glabel (btex $n_1+2$ etex, (0.3,0.3)); glabel (btex $\ldots$ etex, (0.5,0.3)); glabel (btex $\ldots$ etex, (0.7,0.3)); glabel (btex $2n_1$ etex, (0.9,0.3)); glabel (btex $2n_1+1$ etex, (0.1,0.5)); glabel (btex $\ldots$ etex, (0.3,0.5)); glabel (btex $\ldots$ etex, (0.5,0.5)); glabel (btex $\ldots$ etex, (0.7,0.5)); glabel (btex $\ldots$ etex, (0.9,0.5)); glabel (btex $\ldots$ etex, (0.1,0.7)); glabel (btex $\ldots$ etex, (0.3,0.7)); glabel (btex $\ldots$ etex, (0.5,0.7)); glabel (btex $\ldots$ etex, (0.7,0.7)); glabel (btex $n_1(n_2-1)$ etex, (0.9,0.7)); glabel (btex $\displaystyle {n_1(n_2-1)\atop\mbox{}+1}$ etex, (0.1,0.9)); glabel (btex $\displaystyle {n_1(n_2-1)\atop\mbox{}+2}$ etex, (0.3,0.9)); glabel (btex $\ldots$ etex, (0.5,0.9)); glabel (btex $n_1n_2-1$ etex, (0.7,0.9)); glabel (btex $n_1n_2$ etex, (0.9,0.9)); pickup pencircle scaled 1.0pt; \end{empgraph} \end{center} \caption{\label{fig:linear-enumeration}% Enumerating the bins linearly, starting from 1 (Fortran style). Probability distribution functions will have a sentinel at~0 that's always~0.} \end{figure} We store the probability distribution function as a one-dimensional array~[[wgt]]\footnote{The second ``dimension'' is just an index for the channel.}, since this simplifies the binary search used for inverting the distribution. [wgt(0,ic)] is always 0 and serves as a convenient sentinel for the binary search. It is \emph{not} written in the file, which contains the normalized weight of the bins. <<[[circe2_state]] members>>= type(circe2_channel), dimension(:), allocatable :: ch @ <<[[circe2_channel]] members>>= real(kind=default), dimension(:), allocatable :: wgt @ <<[[circe2_channel]] members>>= type(circe2_division), dimension(2) :: d @ Using figure~\ref{fig:linear-enumeration}, calculating the index of a bin from the two-dimensional coordinates is straightforward, of course: \begin{equation} i = i_1 + (i_2 - 1) n_1\,. \end{equation} The inverse \begin{subequations} \begin{align} i_1 &= 1 + ((i - 1) \mod n_1) \\ i_2 &= 1 + \lfloor (i - 1) / n_1 \rfloor \end{align} \end{subequations} can also be written \begin{subequations} \begin{align} i_2 &= 1 + \lfloor (i - 1) / n_1 \rfloor \\ i_1 &= i - (i_2 - 1) n_1 \end{align} \end{subequations} because \begin{subequations} \begin{multline} 1 + \lfloor (i - 1) / n_1 \rfloor = 1 + \lfloor i_2 - 1 + (i_1 - 1) / n_1 \rfloor \\ = 1 + \lfloor (i_1 + (i_2 - 1) n_1 - 1) / n_1 \rfloor = 1 + i_2 - 1 + \underbrace{\lfloor (i_1 - 1) / n_1 \rfloor}_{=0} = i_2 \end{multline} and trivially \begin{equation} i - (i_2 - 1) n_1 = i_1 + (i_2 - 1) n_1 - (i_2 - 1) n_1 = i_1 \end{equation} \end{subequations} -<<$([[i1]],[[i2]]) \leftarrow [[i]]$>>= +<<$(\text{[[i1]]},\text{[[i2]]}) \leftarrow \text{[[i]]}$>>= i2 = 1 + (i - 1) / ubound (ch%d(1)%x, dim=1) i1 = i - (i2 - 1) * ubound (ch%d(1)%x, dim=1) @ -<<$[[ib]] \leftarrow [[i]]$>>= +<<$\text{[[ib]]} \leftarrow \text{[[i]]}$>>= ib(2) = 1 + (i - 1) / ubound (ch%d(1)%x, dim=1) ib(1) = i - (ib(2) - 1) * ubound (ch%d(1)%x, dim=1) @ The density normalized to the bin size \begin{equation*} v = \frac{w}{\Delta x_1 \Delta x_2} \end{equation*} such that \begin{equation*} \int\!\mathrm{d}x_1\mathrm{d}x_2\; v = \sum w = 1 \end{equation*} For mapped distributions, on the level of bins, we can either use the area of the domain and apply a jacobian or the area of the codomain directly \begin{equation} \label{eq:jacobian-Delta_x-Delta_y} \frac{\mathrm{d}x}{\mathrm{d}y}\cdot\frac{1}{\Delta x} \approx \frac{1}{\Delta y} \end{equation} We elect to use the former, because this reflects the distribution of the events generated by~[[circe2_generate]] \emph{inside} the bins as well. This quantity is more conveniently stored as a true two-dimensional array: <<[[circe2_channel]] members>>= real(kind=default), dimension(:,:), allocatable :: val @ \begin{figure} \begin{center} \begin{empgraph}(50,50) pickup pencircle scaled 1.0pt; setrange (0, 0, 1, 1); autogrid (,); for i = 1 upto 15: xi := i / 16; x := 1 - xi * xi * xi; gdraw (0,x) -- (1,x); gdraw (x,0) -- (x,1); endfor \end{empgraph} \end{center} \caption{% Almost factorizable distributions, like $\mathrm{e}^+\mathrm{e}^-$.} \end{figure} <<[[circe2_division]] members>>= real(kind=default), dimension(:), allocatable :: x @ \begin{figure} \begin{center} \begin{empgraph}(50,50) setrange (0, 0, 1, 1); autogrid (,); for i = 1 upto 15: xi := i / 16; x := 1 - xi * xi * xi; pickup pencircle scaled 1.0pt; gdraw (0,0) -- (1,x); pickup pencircle scaled 0.5pt; gdraw (0,0) -- (x,1); endfor for i = 1 upto 15: xi := i / 16; x := 0.8 * (1 - xi * xi * xi); pickup pencircle scaled 1.0pt; gdraw (x,0) -- (x,x); pickup pencircle scaled 0.5pt; gdraw (0,x) -- (x,x); endfor pickup pencircle scaled 1.0pt; gdraw (0,0) -- (1,1); \end{empgraph} \end{center} \caption{% Symmetrical, strongly correlated distributions, e.\,g.~with a ridge on the diagonal, like $\gamma\gamma$ at a $\gamma$-collider.} \end{figure} <<[[circe2_channel]] members>>= logical :: triang @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Channels} The number of available channels $\gamma\gamma$, $\mathrm{e}^-\gamma$, $\mathrm{e}^-\mathrm{e}^+$, etc. can be found with [[size (circe2_state%ch)]]. @ The particles that are described by this channel and their polarizations: <<[[circe2_channel]] members>>= integer, dimension(2) :: pid, pol @ The integrated luminosity of the channel <<[[circe2_channel]] members>>= real(kind=default) :: lumi @ The integrated luminosity of the channel <<[[circe2_state]] members>>= real(kind=default), dimension(:), allocatable :: cwgt @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Maps} <<[[circe2_division]] members>>= integer, dimension(:), allocatable :: map @ <<[[circe2_division]] members>>= real(kind=default), dimension(:), allocatable :: y @ <<[[circe2_division]] members>>= real(kind=default), dimension(:), allocatable :: alpha, xi, eta, a, b @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Random Number Generation} We use the new WHIZARD interface. <<[[circe2]] declarations>>= public :: rng_type type, abstract :: rng_type contains procedure(rng_generate), deferred :: generate end type rng_type @ <<[[circe2]] declarations>>= abstract interface subroutine rng_generate (rng_obj, u) import :: rng_type, default class(rng_type), intent(inout) :: rng_obj real(kind=default), intent(out) :: u end subroutine rng_generate end interface @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Event Generation} -Generate a two-dimensional distribution for~$([[x1]],[[x2]])$ +Generate a two-dimensional distribution for~$(\text{[[x1]]},\text{[[x2]]})$ according to the histogram for channel [[ic]]. @ <<[[circe2]] declarations>>= public :: circe2_generate interface circe2_generate module procedure circe2_generate_ph end interface circe2_generate @ <<[[circe2]] implementation>>= subroutine circe2_generate_ph (c2s, rng, y, p, h) type(circe2_state), intent(in) :: c2s class(rng_type), intent(inout) :: rng real(kind=default), dimension(:), intent(out) :: y integer, dimension(:), intent(in) :: p integer, dimension(:), intent(in) :: h integer :: i, ic <> - <> + <> call circe2_generate_channel (c2s%ch(ic), rng, y) end subroutine circe2_generate_ph <> @ <<[[circe2]] declarations>>= interface circe2_generate module procedure circe2_generate_channel end interface circe2_generate @ <<[[circe2]] implementation>>= subroutine circe2_generate_channel (ch, rng, y) type(circe2_channel), intent(in) :: ch class(rng_type), intent(inout) :: rng real(kind=default), dimension(:), intent(out) :: y integer :: i, d, ibot, itop integer, dimension(2) :: ib real(kind=default), dimension(2) :: x, v real(kind=default) :: u, tmp call rng%generate (u) - <> - <<$[[ib]] \leftarrow [[i]]$>> - <<$[[x]]\in[ [[x(ib-1)]], [[x(ib)]] ]$>> + <> + <<$\text{[[ib]]} \leftarrow \text{[[i]]}$>> + <<$\text{[[x]]}\in[ \text{[[x(ib-1)]]}, \text{[[x(ib)]]} ]$>> y = circe2_map (ch%d, x, ib) <> end subroutine circe2_generate_channel <> @ <<[[circe2_state]] members>>= integer :: polspt @ <<[[circe2]] parameters>>= integer, parameter :: POLAVG = 1, POLHEL = 2, POLGEN = 3 @ A linear search for a matching channel should suffice, because the number if channels~[[nc]] will always be a small number. The most popular channels should be first in the list, anyway. <>= ic = 0 if ((c2s%polspt == POLAVG .or. c2s%polspt == POLGEN) .and. any (h /= 0)) then write (*, '(2A)') 'circe2: current beam description ', & 'supports only polarization averages' else if (c2s%polspt == POLHEL .and. any (h == 0)) then write (*, '(2A)') 'circe2: polarization averages ', & 'not supported by current beam description' else do i = 1, size (c2s%ch) if (all (p == c2s%ch(i)%pid .and. h == c2s%ch(i)%pol)) then ic = i end if end do end if @ -<>= +<>= if (ic <= 0) then write (*, '(A,2I4,A,2I3)') & 'circe2: no channel for particles', p, & ' and polarizations', h y = - huge (y) return end if @ The number of bins is typically \emph{much} larger and we must use a binary search to get a reasonable performance. -<>= +<>= ibot = 0 itop = ubound (ch%wgt, dim=1) do if (itop <= ibot + 1) then i = ibot + 1 exit else i = (ibot + itop) / 2 if (u < ch%wgt(i)) then itop = i else ibot = i end if end if end do @ -<<$[[x]]\in[ [[x(ib-1)]], [[x(ib)]] ]$>>= +<<$\text{[[x]]}\in[ \text{[[x(ib-1)]]}, \text{[[x(ib)]]} ]$>>= call rng%generate (v(1)) call rng%generate (v(2)) do d = 1, 2 x(d) = ch%d(d)%x(ib(d))*v(d) + ch%d(d)%x(ib(d)-1)*(1-v(d)) end do @ The NAG compiler is picky and doesn't like $(-0)^\alpha$ at all. <<$y\leftarrow(a(x-\xi))^\alpha/b + \eta$>>= z = d%a(b) * (x - d%xi(b)) if (abs (z) <= tiny (z)) then z = abs (z) end if y = z**d%alpha(b) / d%b(b) + d%eta(b) @ <<[[circe2]] implementation>>= elemental function circe2_map (d, x, b) result (y) type(circe2_division), intent(in) :: d real(kind=default), intent(in) :: x integer, intent(in) :: b real(kind=default) :: y real(kind=default) :: z select case (d%map(b)) case (0) y = x case (1) <<$y\leftarrow(a(x-\xi))^\alpha/b + \eta$>> case (2) y = d%a(b) * tan (d%a(b)*(x-d%xi(b)) / d%b(b)**2) + d%eta(b) case default y = - huge (y) end select end function circe2_map @ cf.~(\ref{eq:jacobian-Delta_x-Delta_y}) <<[[circe2]] implementation>>= elemental function circe2_jacobian (d, y, b) result (j) type(circe2_division), intent(in) :: d real(kind=default), intent(in) :: y integer, intent(in) :: b real(kind=default) :: j select case (d%map(b)) case (0) j = 1 case (1) j = d%b(b) / (d%a(b)*d%alpha(b)) & * (d%b(b)*(y-d%eta(b)))**(1/d%alpha(b)-1) case (2) j = d%b(b)**2 / ((y-d%eta(b))**2 + d%a(b)**2) case default j = - huge (j) end select end function circe2_jacobian @ \begin{dubious} There's still something wrong with \emph{unweighted} events for the case that there is a triangle map \emph{together} with a - non-trivial $[[x(2)]]\to[[y(2)]]$ map. \emph{Fix this!!!} + non-trivial $\text{[[x(2)]]}\to\text{[[y(2)]]}$ map. \emph{Fix this!!!} \end{dubious} <>= if (ch%triang) then y(2) = y(1) * y(2) <> end if @ <>= call rng%generate (u) if (2*u >= 1) then tmp = y(1) y(1) = y(2) y(2) = tmp end if @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Channel selection} We could call [[circe2_generate]] immediately, but then [[circe2_generate]] and [[cir2_choose_channel]] would have the same calling conventions and might have caused a lot of confusion. <<[[circe2]] declarations>>= public :: circe2_choose_channel interface circe2_choose_channel module procedure circe2_choose_channel end interface circe2_choose_channel @ <<[[circe2]] implementation>>= subroutine circe2_choose_channel (c2s, rng, p, h) type(circe2_state), intent(in) :: c2s class(rng_type), intent(inout) :: rng integer, dimension(:), intent(out) :: p, h integer :: ic, ibot, itop real(kind=default) :: u call rng%generate (u) ibot = 0 itop = size (c2s%ch) do if (itop <= ibot + 1) then ic = ibot + 1 p = c2s%ch(ic)%pid h = c2s%ch(ic)%pol return else ic = (ibot + itop) / 2 if (u < c2s%cwgt(ic)) then itop = ic else ibot = ic end if end if end do write (*, '(A)') 'circe2: internal error' stop end subroutine circe2_choose_channel -@ Below, we will always have $[[h]]=0$. but we don't have to +@ Below, we will always have $\text{[[h]]}=0$. but we don't have to check this explicitely, because [[circe2_density_matrix]] will do it anyway. The procedure could be made more efficient, since most of [[circe2_density_matrix]] is undoing parts of [[circe2_generate]]. <<[[circe2]] declarations>>= public :: circe2_generate_polarized interface circe2_generate_polarized module procedure circe2_generate_polarized end interface circe2_generate_polarized @ <<[[circe2]] implementation>>= subroutine circe2_generate_polarized (c2s, rng, p, pol, x) type(circe2_state), intent(in) :: c2s class(rng_type), intent(inout) :: rng integer, dimension(:), intent(out) :: p real(kind=default), intent(out) :: pol(0:3,0:3) real(kind=default), dimension(:), intent(out) :: x integer, dimension(2) :: h integer :: i1, i2 real(kind=default) :: pol00 call circe2_choose_channel (c2s, rng, p, h) call circe2_generate (c2s, rng, x, p, h) call circe2_density_matrix (c2s, pol, p, x) pol00 = pol(0,0) do i1 = 0, 3 do i2 = 0, 3 pol(i1,i2) = pol(i1,i2) / pol00 end do end do end subroutine circe2_generate_polarized @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Luminosity} <<[[circe2]] declarations>>= public :: circe2_luminosity @ <<[[circe2]] implementation>>= function circe2_luminosity (c2s, p, h) type(circe2_state), intent(in) :: c2s integer, dimension(:), intent(in) :: p integer, dimension(:), intent(in) :: h real(kind=default) :: circe2_luminosity integer :: ic circe2_luminosity = 0 do ic = 1, size (c2s%ch) if ( all (p == c2s%ch(ic)%pid .or. p == 0) & .and. all (h == c2s%ch(ic)%pol .or. h == 0)) then circe2_luminosity = circe2_luminosity + c2s%ch(ic)%lumi end if end do end function circe2_luminosity <> @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{2D-Distribution} <<[[circe2]] declarations>>= public :: circe2_distribution interface circe2_distribution module procedure circe2_distribution_ph end interface circe2_distribution @ <<[[circe2]] implementation>>= function circe2_distribution_ph (c2s, p, h, yy) type(circe2_state), intent(in) :: c2s integer, dimension(:), intent(in) :: p real(kind=default), dimension(:), intent(in) :: yy integer, dimension(:), intent(in) :: h real(kind=default) :: circe2_distribution_ph integer :: i, ic <> if (ic <= 0) then circe2_distribution_ph = 0 else circe2_distribution_ph = circe2_distribution_channel (c2s%ch(ic), yy) end if end function circe2_distribution_ph <> @ <<[[circe2]] declarations>>= interface circe2_distribution module procedure circe2_distribution_channel end interface circe2_distribution @ <<[[circe2]] implementation>>= function circe2_distribution_channel (ch, yy) type(circe2_channel), intent(in) :: ch real(kind=default), dimension(:), intent(in) :: yy real(kind=default) :: circe2_distribution_channel real(kind=default), dimension(2) :: y integer :: d, ibot, itop integer, dimension(2) :: ib - <<$[[y]])\leftarrow[[yy]]$>> + <<$\text{[[y]]}\leftarrow\text{[[yy]]}$>> if ( y(1) < ch%d(1)%y(0) & .or. y(1) > ch%d(1)%y(ubound (ch%d(1)%y, dim=1)) & .or. y(2) < ch%d(2)%y(0) & .or. y(2) > ch%d(2)%y(ubound (ch%d(2)%y, dim=1))) then circe2_distribution_channel = 0 return end if - <> + <> circe2_distribution_channel = & ch%val(ib(1),ib(2)) * product (circe2_jacobian (ch%d, y, ib)) <> end function circe2_distribution_channel <> @ The triangle map \begin{equation} \begin{aligned} \tau : \{(x_{1},x_{2}) \in [0,1]\times[0,1] : x_{2} \le x_{1} \} &\to [0,1]\times[0,1] \\ (x_{1},x_{2}) &\mapsto (y_{1},y_{2}) = (x_{1},x_{1}x_{2}) \end{aligned} \end{equation} and its inverse \begin{equation} \begin{aligned} \tau^{-1} : [0,1]\times[0,1] &\to \{(x_{1},x_{2}) \in [0,1]\times[0,1] : x_{2} \le x_{1} \} \\ (y_{1},y_{2}) &\mapsto (x_{1},x_{2}) = (y_{1},y_{2}/y_{1}) \end{aligned} \end{equation} -<<$[[y]])\leftarrow[[yy]]$>>= +<<$\text{[[y]]}\leftarrow\text{[[yy]]}$>>= if (ch%triang) then y(1) = maxval (yy) y(2) = minval (yy) / y(1) else y = yy end if @ with the jacobian~$J^*(y_{1},y_{2})=1/y_{2}$ from \begin{equation} \mathrm{d}x_{1}\wedge\mathrm{d}x_{2} = \frac{1}{y_{2}} \cdot \mathrm{d}y_{1}\wedge\mathrm{d}y_{2} \end{equation} <>= if (ch%triang) then circe2_distribution_channel = circe2_distribution_channel / y(1) end if @ Careful: the loop over [[d]] \emph{must} be executed sequentially, because of the shared local variables [[ibot]] and [[itop]]. -<>= +<>= do d = 1, 2 ibot = 0 itop = ubound (ch%d(d)%x, dim=1) search: do if (itop <= ibot + 1) then ib(d) = ibot + 1 exit search else ib(d) = (ibot + itop) / 2 if (y(d) < ch%d(d)%y(ib(d))) then itop = ib(d) else ibot = ib(d) end if end if end do search end do @ <<[[circe2]] declarations>>= public :: circe2_density_matrix @ <<[[circe2]] implementation>>= subroutine circe2_density_matrix (c2s, pol, p, x) type(circe2_state), intent(in) :: c2s real(kind=default), dimension(0:,0:), intent(out) :: pol integer, dimension(:), intent(in) :: p real(kind=default), dimension(:), intent(in) :: x <> print *, 'circe2: circe2_density_matrix not implemented yet!' if (p(1) < p(2) .and. x(1) < x(2)) then ! nonsense test to suppress warning end if pol = 0 end subroutine circe2_density_matrix <> @ <>= if (c2s%polspt /= POLGEN) then write (*, '(2A)') 'circe2: current beam ', & 'description supports no density matrices' return end if @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Reading Files} <<[[circe2]] declarations>>= public :: circe2_load <> @ <>= integer, parameter, public :: & EOK = 0, EFILE = -1, EMATCH = -2, EFORMT = -3, ESIZE = -4 @ <<[[circe2]] implementation>>= subroutine circe2_load (c2s, file, design, roots, ierror) type(circe2_state), intent(out) :: c2s character(len=*), intent(in) :: file, design real(kind=default), intent(in) :: roots integer, intent(out) :: ierror character(len=72) :: buffer, fdesgn, fpolsp real(kind=default) :: froots integer :: lun, loaded, prefix logical match <> <> if (lun < 0) then write (*, '(A)') 'circe2_load: no free unit' ierror = ESIZE return end if loaded = 0 <> if (ierror .gt. 0) then write (*, '(2A)') 'circe2_load: ', <> end if prefix = index (design, '*') - 1 do <> if (buffer(8:15) == 'FORMAT#1') then read (lun, *) read (lun, *) fdesgn, froots <> if (match .and. abs (froots - roots) <= 1) then <> loaded = loaded + 1 else <> cycle end if else write (*, '(2A)') 'circe2_load: invalid format: ', buffer(8:72) ierror = EFORMT return end if <> end do end subroutine circe2_load <> @ <>= match = .false. if (fdesgn == design) then match = .true. else if (prefix == 0) then match = .true. else if (prefix .gt. 0) then if (fdesgn(1:min(prefix,len(fdesgn))) & == design(1:min(prefix,len(design)))) then match = .true. end if end if @ <>= read (lun, *) read (lun, *) nc, fpolsp allocate (c2s%ch(nc), c2s%cwgt(0:nc)) <> c2s%cwgt(0) = 0 do ic = 1, nc call circe2_load_channel (c2s%ch(ic), c2s%polspt, lun, ierror) c2s%cwgt(ic) = c2s%cwgt(ic-1) + c2s%ch(ic)%lumi end do c2s%cwgt = c2s%cwgt / c2s%cwgt(nc) @ <<[[circe2]] implementation>>= subroutine circe2_load_channel (ch, polspt, lun, ierror) type(circe2_channel), intent(out) :: ch integer, intent(in) :: polspt, lun integer, intent(out) :: ierror integer :: d, i, ib integer :: i1, i2 integer, dimension(2) :: nb real(kind=default) :: w <> <> <> <> end subroutine circe2_load_channel @ @ <>= if (fpolsp(1:1)=='a' .or. fpolsp(1:1)=='A') then c2s%polspt = POLAVG else if (fpolsp(1:1)=='h' .or. fpolsp(1:1)=='H') then c2s%polspt = POLHEL else if (fpolsp(1:1)=='d' .or. fpolsp(1:1)=='D') then c2s%polspt = POLGEN else write (*, '(A,I5)') 'circe2_load: invalid polarization support: ', fpolsp ierror = EFORMT return end if @ <>= integer :: ic, nc @ <>= read (lun, *) read (lun, *) ch%pid(1), ch%pol(1), ch%pid(2), ch%pol(2), ch%lumi <> @ <>= if (polspt == POLAVG .and. any (ch%pol /= 0)) then write (*, '(A)') 'circe2_load: expecting averaged polarization' ierror = EFORMT return else if (polspt == POLHEL .and. any (ch%pol == 0)) then write (*, '(A)') 'circe2_load: expecting helicities' ierror = EFORMT return else if (polspt == POLGEN) then write (*, '(A)') 'circe2_load: general polarizations not supported yet' ierror = EFORMT return else if (polspt == POLGEN .and. any (ch%pol /= 0)) then write (*, '(A)') 'circe2_load: expecting pol = 0' ierror = EFORMT return end if @ <>= read (lun, *) read (lun, *) nb, ch%triang @ <>= do d = 1, 2 read (lun, *) allocate (ch%d(d)%x(0:nb(d)), ch%d(d)%y(0:nb(d))) allocate (ch%d(d)%map(nb(d)), ch%d(d)%alpha(nb(d))) allocate (ch%d(d)%xi(nb(d)), ch%d(d)%eta(nb(d))) allocate (ch%d(d)%a(nb(d)), ch%d(d)%b(nb(d))) read (lun, *) ch%d(d)%x(0) do ib = 1, nb(d) read (lun, *) ch%d(d)%x(ib), ch%d(d)%map(ib), & ch%d(d)%alpha(ib), ch%d(d)%xi(ib), ch%d(d)%eta(ib), & ch%d(d)%a(ib), ch%d(d)%b(ib) if (ch%d(d)%map(ib) < 0 .or. ch%d(d)%map(ib) > 2) then write (*, '(A,I3)') 'circe2_load: invalid map: ', ch%d(d)%map(ib) ierror = EFORMT return end if end do end do @ The boundaries are guaranteed to be fixed points of the maps only if the boundaries are not allowed to float. This doesn't affect the unweighted events, because they never see the codomain grid, but distribution would be distorted significantly. In the following sums [[i1]] and [[i2]] run over the maps, while [[i]] runs over the boundaries. \begin{dubious} An alternative would be to introduce sentinels [[alpha(1,0,:)]], [[xi(1,0,:)]], etc. \end{dubious} <>= do d = 1, 2 do i = 0, ubound (ch%d(d)%x, dim=1) ch%d(d)%y(i) = circe2_map (ch%d(d), ch%d(d)%x(i), max (i, 1)) end do end do @ cf.~(\ref{eq:jacobian-Delta_x-Delta_y}) <>= read (lun, *) allocate (ch%wgt(0:product(nb)), ch%val(nb(1),nb(2))) ch%wgt(0) = 0 do i = 1, ubound (ch%wgt, dim=1) read (lun, *) w ch%wgt(i) = ch%wgt(i-1) + w - <<$([[i1]],[[i2]]) \leftarrow [[i]]$>> + <<$(\text{[[i1]]},\text{[[i2]]}) \leftarrow \text{[[i]]}$>> ch%val(i1,i2) = w & / ( (ch%d(1)%x(i1) - ch%d(1)%x(i1-1)) & * (ch%d(2)%x(i2) - ch%d(2)%x(i2-1))) end do ch%wgt(ubound (ch%wgt, dim=1)) = 1 @ <>= @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Auxiliary Code For Reading Files} <>= open (unit = lun, file = file, status = 'old', iostat = status) if (status /= 0) then write (*, '(2A)') 'circe2_load: can''t open ', file ierror = EFILE return end if @ <>= integer :: status @ The outer [[do]] loop is never repeated! <>= find_circe2: do skip_comments: do read (lun, '(A)', iostat = status) buffer if (status /= 0) then close (unit = lun) if (loaded > 0) then ierror = EOK else ierror = EMATCH end if return else if (buffer(1:6) == 'CIRCE2') then exit find_circe2 else if (buffer(1:1) == '!') then if (ierror > 0) then write (*, '(A)') buffer end if else exit skip_comments end if end if end do skip_comments write (*, '(A)') 'circe2_load: invalid file' ierror = EFORMT return end do find_circe2 @ <>= skip_data: do read (lun, *) buffer if (buffer(1:6) == 'ECRIC2') then exit skip_data end if end do skip_data @ <>= read (lun, '(A)') buffer if (buffer(1:6) /= 'ECRIC2') then write (*, '(A)') 'circe2_load: invalid file' ierror = EFORMT return end if @ <>= scan: do lun = 10, 99 inquire (unit = lun, exist = exists, opened = isopen, iostat = status) if (status == 0 .and. exists .and. .not.isopen) exit scan end do scan if (lun > 99) lun = -1 @ <>= logical exists, isopen @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \appendix \section{Tests and Examples} \subsection{Object-Oriented interface to [[tao_random_numbers]]} We need the object oriented interface to [[tao_random_numbers]] to be able to talk to the WHIZARD <<[[tao_random_objects.f90]]>>= module tao_random_objects use kinds use tao_random_numbers use circe2 implicit none private <<[[tao_random_objects]] declarations>> contains <<[[tao_random_objects]] implementation>> end module tao_random_objects @ <<[[tao_random_objects]] declarations>>= public :: rng_tao type, extends (rng_type) :: rng_tao integer :: seed = 0 integer :: n_calls = 0 type(tao_random_state) :: state contains procedure :: generate => rng_tao_generate procedure :: init => rng_tao_init end type rng_tao @ <<[[tao_random_objects]] implementation>>= subroutine rng_tao_generate (rng_obj, u) class(rng_tao), intent(inout) :: rng_obj real(default), intent(out) :: u call tao_random_number (rng_obj%state, u) rng_obj%n_calls = rng_obj%n_calls + 1 end subroutine rng_tao_generate @ <<[[tao_random_objects]] implementation>>= subroutine rng_tao_init (rng_obj, seed) class(rng_tao), intent(inout) :: rng_obj integer, intent(in) :: seed rng_obj%seed = seed call tao_random_create (rng_obj%state, seed) end subroutine rng_tao_init @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{[[circe2_generate]]: Standalone Generation of Samples} <<[[circe2_generate.f90]]>>= program circe2_generate_program use kinds use circe2 use tao_random_objects implicit none type(circe2_state) :: c2s type(rng_tao), save :: rng character(len=1024) :: filename, design, buffer integer :: status, nevents, seed real(kind=default) :: roots real(kind=default), dimension(2) :: x integer :: p1, p2, i, ierror <> call circe2_load (c2s, trim(filename), trim(design), roots, ierror) if (ierror /= 0) then print *, "circe2_generate: failed to load design ", trim(design), & " for ", real (roots, kind=single), & " GeV from ", trim(filename) stop end if do i = 1, nevents call circe2_generate (c2s, rng, x, [p1, p2], [0, 0]) write (*, '(F12.10,1X,F12.10,1X,F3.1)') x, 1.0_default end do contains <> end program circe2_generate_program @ <>= call get_command_argument (1, value = filename, status = status) if (status /= 0) filename = "" @ <>= call get_command_argument (2, value = design, status = status) if (status /= 0) design = "" if (filename == "" .or. design == "") then print *, "usage: circe2_generate filename design [roots] [p1] [p2] [#events] [seed]" stop end if @ <>= call get_command_argument (3, value = buffer, status = status) if (status == 0) then read (buffer, *, iostat = status) roots if (status /= 0) roots = 500 else roots = 500 end if @ <>= call get_command_argument (4, value = buffer, status = status) if (status == 0) then read (buffer, *, iostat = status) p1 if (status /= 0) nevents = 1000 else p1 = 11 end if @ <>= call get_command_argument (5, value = buffer, status = status) if (status == 0) then read (buffer, *, iostat = status) p2 if (status /= 0) nevents = 1000 else p2 = -11 end if @ <>= call get_command_argument (6, value = buffer, status = status) if (status == 0) then read (buffer, *, iostat = status) nevents if (status /= 0) nevents = 1000 else nevents = 1000 end if @ <>= call get_command_argument (7, value = buffer, status = status) if (status == 0) then read (buffer, *, iostat = status) seed if (status == 0) then call random2_seed (rng, seed) else call random2_seed (rng) end if else call random2_seed (rng) end if @ <>= subroutine random2_seed (rng, seed) class(rng_tao), intent(inout) :: rng integer, intent(in), optional:: seed integer, dimension(8) :: date_time integer :: seed_value if (present (seed)) then seed_value = seed else call date_and_time (values = date_time) seed_value = product (date_time) endif call rng%init (seed_value) end subroutine random2_seed @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{[[circe2_ls]]: Listing File Contents} Here's a small utility program for listing the contents of \KirkeTwo/ data files. It performs \emph{no} verification and assumes that the file is in the correct format (cf.~table~\ref{tab:fileformat}). <<[[circe2_ls.f90]]>>= ! circe2_ls.f90 -- beam spectra for linear colliders and photon colliders <> <> program circe2_ls use circe2 use kinds implicit none integer :: i, lun character(len=132) :: buffer character(len=60) :: design, polspt integer :: pid1, hel1, pid2, hel2, nc real(kind=default) :: roots, lumi integer :: status logical :: exists, isopen character(len=1024) :: filename <> if (lun < 0) then write (*, '(A)') 'circe2_ls: no free unit' stop end if files: do i = 1, command_argument_count () call get_command_argument (i, value = filename, status = status) if (status /= 0) then exit files else open (unit = lun, file = filename, status = 'old', iostat = status) if (status /= 0) then write (*, "(A,1X,A)") "circe2: can't open", trim(filename) else write (*, "(A,1X,A)") "file:", trim(filename) lines: do read (lun, '(A)', iostat = status) buffer if (status /= 0) exit lines if (buffer(1:7) == 'design,') then read (lun, *) design, roots read (lun, *) read (lun, *) nc, polspt <> <> else if (buffer(1:5) == 'pid1,') then read (lun, *) pid1, hel1, pid2, hel2, lumi <> end if end do lines end if close (unit = lun) end if end do files end program circe2_ls <> @ <>= write (*, '(A,1X,A)') ' design:', trim(design) write (*, '(A,1X,F7.1)') ' sqrt(s):', roots write (*, '(A,1X,I3)') ' #channels:', nc write (*, '(A,1X,A)') ' polarization:', trim(polspt) @ <>= write (*, '(4X,4(A5,2X),A)') & 'pid#1', 'hel#1', 'pid#2', 'hel#2', 'luminosity / (10^32cm^-2sec^-1)' @ <>= write (*, '(4X,4(I5,2X),F10.2)') pid1, hel1, pid2, hel2, lumi @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ \subsection{$\beta$-distribitions} @ We need a fast generator of $\beta$-distribitions: \begin{equation} \beta_{x_{\text{min}},x_{\text{max}}}^{a,b}(x) = x^{a-1}(1-x)^{b-1}\cdot \frac{\Theta(x_{\text{max}}-x)\Theta(x-x_{\text{min}})}% {I(x_{\text{min}},a,b)-I(x_{\text{max}},a,b)} \end{equation} with the \emph{incomplete Beta-function~$I$:} \begin{align} I(x,a,b) & = \int_x^1\!d\xi\, \xi^{a-1}(1-\xi)^{b-1} \\ I(0,a,b) & = B(a,b) = \frac{\Gamma(a)\Gamma(b)}{\Gamma(a+b)} \end{align} This problem has been studied extensively~\cite{Devroye:1986:random_deviates} and we can use an algorithm~\cite{Atkinson/Whittaker:1979:beta_distribution} that is very fast for~$0>= public :: generate_beta @ <<[[circe2_moments_library]] implementation>>= subroutine generate_beta (rng, x, xmin, xmax, a, b) class(rng_type), intent(inout) :: rng real(kind=default), intent(out) :: x real(kind=default), intent(in) :: xmin, xmax, a, b real(kind=default) :: t, p, u, umin, umax, w <> <> do <> call rng%generate (u) if (w > u) exit end do end subroutine generate_beta @ %def generate_beta @ In fact, this algorithm works for~$0>= if (a >= 1 .or. b <= 1) then x = -1 print *, 'ERROR: beta-distribution expects a<1>= <> p = b*t / (b*t + a * (1 - t)**b) @ The dominating distributions can be generated by simple mappings \begin{align} \phi: [0,1] & \to [0,1] \\ u & \mapsto \begin{cases} t\left(\frac{u}{p}\right)^\frac{1}{a} &t\;\text{for}\;u>p \end{cases} \end{align} The beauty of the algorithm is that we can use a single uniform deviate~$u$ for both intervals: <>= call rng%generate (u) u = umin + (umax - umin) * u if (u <= p) then x = t * (u/p)**(1/a) w = (1 - x)**(b-1) else x = 1 - (1 - t) * ((1 - u)/(1 - p))**(1/b) w = (x/t)**(a-1) end if @ The weights that are derived by dividing the distribution by the dominating distributions are already normalized correctly: \begin{align} w: [0,1] & \to [0,1] \\ x & \mapsto \begin{cases} (1-x)^{b-1} &\in[(1-t)^{b-1},1]\;\text{for}\;x\le t\\ \left(\frac{x}{t}\right)^{a-1} &\in[t^{1-a},1] \;\text{for}\;x\ge t \end{cases} \end{align} @ To derive~$u_{\text{min},\text{max}}$ from~$x_{\text{min},\text{max}}$ we can use~$\phi^{-1}$: \begin{align} \phi^{-1}: [0,1] & \to [0,1] \\ x & \mapsto \begin{cases} p\left(\frac{x}{t}\right)^a &p\;\text{for}\;x>t \end{cases} \end{align} We start with~$u_{\text{min}}$. For efficiency, we handle the most common cases (small~$x_{\text{min}}$) first: <>= if (xmin <= 0) then umin = 0 elseif (xmin < t) then umin = p * (xmin/t)**a elseif (xmin == t) then umin = p elseif (xmin < 1) then umin = 1 - (1 - p) * ((1 - xmin)/(1 - t))**b else umin = 1 endif @ Same procedure for~$u_{\text{max}}$; again, handle the most common cases (large~$x_{\text{max}}$) first: <>= if (xmax >= 1) then umax = 1 elseif (xmax > t) then umax = 1 - (1 - p) * ((1 - xmax)/(1 - t))**b elseif (xmax == t) then umax = p elseif (xmax > 0) then umax = p * (xmax/t)**a else umax = 0 endif @ Check for absurd cases. <>= if (umax < umin) then x = -1 return endif @ It remains to choose he best value for~$t$. The rejection efficiency~$\epsilon$ of the algorithm is given by the ratio of the dominating distribution and the distribution \begin{equation} \frac{1}{\epsilon(t)} = \frac{B(a,b)}{ab} \left(bt^{a} + at^{a-1}(1-t)^b\right). \end{equation} It is maximized for \begin{equation} bt - bt(1-t)^{b-1} + (a-1)(1-t)^b = 0 \end{equation} This equation has a solution which can be determined numerically. While this determination is far too expensive compared to a moderate loss in efficiency, we could perform it once after fitting the coefficients~$a$, $b$. Nevertheless, it has been shown,\cite{Atkinson/Whittaker:1979:beta_distribution} that \begin{equation} t = \frac{1-a}{b+1-a} \end{equation} results in non-vanishing efficiency for all values~$1>= t = (1 - a) / (b + 1 - a) @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ \subsection{Sampling} <<[[circe2_moments.f90]]>>= module sampling use kinds implicit none private <<[[sampling]] declarations>> contains <<[[sampling]] implementation>> end module sampling @ <<[[sampling]] declarations>>= type sample integer :: n = 0 real(kind=default) :: w = 0 real(kind=default) :: w2 = 0 end type sample public :: sample @ <<[[sampling]] declarations>>= public :: reset, record @ <<[[sampling]] implementation>>= elemental subroutine reset (s) type(sample), intent(inout) :: s s%n = 0 s%w = 0 s%w2 = 0 end subroutine reset @ <<[[sampling]] implementation>>= elemental subroutine record (s, w) type(sample), intent(inout) :: s real(kind=default), intent(in), optional :: w s%n = s%n + 1 if (present (w)) then s%w = s%w + w s%w2 = s%w2 + w*w else s%w = s%w + 1 s%w2 = s%w2 + 1 endif end subroutine record @ <<[[sampling]] declarations>>= public :: mean, variance @ <<[[sampling]] implementation>>= elemental function mean (s) type(sample), intent(in) :: s real(kind=default) :: mean mean = s%w / s%n end function mean @ <<[[sampling]] implementation>>= elemental function variance (s) type(sample), intent(in) :: s real(kind=default) :: variance variance = (s%w2 / s%n - mean(s)**2) / s%n variance = max (variance, epsilon (variance)) end function variance @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ \subsection{Moments} This would probably be a good place for inheritance <<[[circe2_moments_library]] declarations>>= type moment integer, dimension(2) :: n, m type(sample) :: sample = sample (0, 0.0_default, 0.0_default) end type moment public :: moment @ <<[[circe2_moments_library]] declarations>>= public :: init_moments @ <<[[circe2_moments_library]] implementation>>= subroutine init_moments (moments) type(moment), dimension(0:,0:,0:,0:), intent(inout) :: moments integer :: nx, mx, ny, my do nx = lbound(moments,1), ubound(moments,1) do mx = lbound(moments,2), ubound(moments,2) do ny = lbound(moments,3), ubound(moments,3) do my = lbound(moments,4), ubound(moments,4) moments(nx,mx,ny,my) = moment([nx,ny],[mx,my]) end do end do end do end do call reset_moment (moments) end subroutine init_moments @ <<[[circe2_moments_library]] declarations>>= public :: reset_moment, record_moment @ <<[[circe2_moments_library]] implementation>>= elemental subroutine reset_moment (m) type(moment), intent(inout) :: m call reset (m%sample) end subroutine reset_moment @ If we were pressed for time, we would compute the moments by iterative multiplications instead by powers, of course. In any case, we would like to combine [[x1]] and [[x2]] into an array. Unfortunately this is not possible for [[elemental]] procedures. NB: the NAG compiler appears to want a more careful evaluation of the powers. We enforce [[0.0**0 == 0]]. <<[[circe2_moments_library]] implementation>>= elemental subroutine record_moment (m, x1, x2, w) type(moment), intent(inout) :: m real(kind=default), intent(in) :: x1, x2 real(kind=default), intent(in), optional :: w real(kind=default) :: p p = pwr (x1, m%n(1)) * pwr (1-x1, m%m(1)) & * pwr (x2, m%n(2)) * pwr (1-x2, m%m(2)) if (present (w)) p = p*w call record (m%sample, p) contains pure function pwr (x, n) real(kind=default), intent(in) :: x integer, intent(in) :: n real(kind=default) :: pwr if (n == 0) then pwr = 1 else pwr = x**n end if end function pwr end subroutine record_moment @ <<[[circe2_moments_library]] declarations>>= public :: mean_moment, variance_moment @ <<[[circe2_moments_library]] implementation>>= elemental function mean_moment (m) type(moment), intent(in) :: m real(kind=default) :: mean_moment mean_moment = mean (m%sample) end function mean_moment @ <<[[circe2_moments_library]] implementation>>= elemental function variance_moment (m) type(moment), intent(in) :: m real(kind=default) :: variance_moment variance_moment = variance (m%sample) end function variance_moment @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ \subsubsection{Moments of $\beta$-distributions} <<[[circe2_moments_library]] declarations>>= public :: beta_moment @ \begin{multline} M_{n,m}(a,b) = \int_0^1\!\dd x\, x^n(1-x)^m \beta_{0,1}^{a,b}(x) = \int_0^1\!\dd x\, x^n(1-x)^m \frac{x^{a-1}(1-x)^{b-1}}{B(a,b)} \\ = \frac{1}{B(a,b)} \int_0^1\!\dd x\, x^{n+a-1}(1-x)^{m+b-1} = \frac{B(n+a,m+b)}{B(a,b)} \\ = \frac{\Gamma(n+a)\Gamma(m+b)\Gamma(a+b)}% {\Gamma(n+a+m+b)\Gamma(a)\Gamma(b)} = \frac{\Gamma(n+a)}{\Gamma(a)} \frac{\Gamma(m+b)}{\Gamma(b)} \frac{\Gamma(n+m+a+b)}{\Gamma(a+b)} \\ = \frac{(a+n)(a+n-1)\cdots(a+1)a(b+m)(b+m-1)\cdots(b+1)b}% {(a+b+n+m)(a+b+n+m-1)\cdots(a+b+1)(a+b)} \end{multline} <<[[circe2_moments_library]] implementation>>= elemental function beta_moment (n, m, a, b) integer, intent(in) :: n, m real(kind=default), intent(in) :: a, b real(kind=default) :: beta_moment beta_moment = & gamma_ratio (a, n) * gamma_ratio (b, m) / gamma_ratio (a+b, n+m) end function beta_moment @ \begin{equation} \frac{\Gamma(x+n)}{\Gamma(x)} = (x+n)(x+n-1)\cdots(x+1)x \end{equation} <<[[circe2_moments_library]] implementation>>= elemental function gamma_ratio (x, n) real(kind=default), intent(in) :: x integer, intent(in) :: n real(kind=default) :: gamma_ratio integer :: i gamma_ratio = 1 do i = 0, n - 1 gamma_ratio = gamma_ratio * (x + i) end do end function gamma_ratio @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ \subsubsection{Channels} <<[[circe2_moments_library]] declarations>>= type channel real(kind=default) :: w = 1 real(kind=default), dimension(2) :: a = 1, b = 1 logical, dimension(2) :: delta = .false. end type channel public :: channel @ <<[[circe2_moments_library]] declarations>>= public :: generate_beta_multi, beta_moments_multi @ <<[[circe2_moments_library]] implementation>>= subroutine generate_beta_multi (rng, x, channels) class(rng_type), intent(inout) :: rng real(kind=default), dimension(:), intent(out) :: x type(channel), dimension(:), intent(in) :: channels real(kind=default) :: u, accum integer :: i, n <>= call rng%generate (u) u = u * sum (channels%w) accum = 0 scan: do n = 1, size (channels) - 1 accum = accum + channels(n)%w if (accum >= u) exit scan end do scan @ <<[[circe2_moments_library]] implementation>>= pure function beta_moments_multi (n, m, channels) integer, intent(in), dimension(2) :: n, m type(channel), dimension(:), intent(in) :: channels real(kind=default) :: beta_moments_multi real(kind=default) :: w integer :: c, i beta_moments_multi = 0 do c = 1, size (channels) w = channels(c)%w do i = 1, 2 if (channels(c)%delta(i)) then if (m(i) > 0) w = 0 else w = w * beta_moment (n(i), m(i), channels(c)%a(i), channels(c)%b(i)) end if end do beta_moments_multi = beta_moments_multi + w end do beta_moments_multi = beta_moments_multi / sum (channels%w) end function beta_moments_multi @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ \subsubsection{Selftest} @ <<[[circe2_moments_library]] declarations>>= public :: selftest @ <<[[circe2_moments_library]] implementation>>= subroutine selftest (rng, nevents) class(rng_type), intent(inout) :: rng integer, intent(in) :: nevents integer, parameter :: N = 1 type(moment), dimension(0:N,0:N,0:N,0:N) :: moments integer :: i real(kind=default), dimension(2) :: x type(channel), dimension(:), allocatable :: channels call read_channels (channels) call init_moments (moments) do i = 1, nevents call generate_beta_multi (rng, x, channels) call record_moment (moments, x(1), x(2)) end do call report_results (moments, channels) end subroutine selftest @ <<[[circe2_moments_library]] declarations>>= public :: random2_seed @ <<[[circe2_moments_library]] implementation>>= subroutine random2_seed (rng, seed) class(rng_tao), intent(inout) :: rng integer, intent(in), optional:: seed integer, dimension(8) :: date_time integer :: seed_value if (present (seed)) then seed_value = seed else call date_and_time (values = date_time) seed_value = product (date_time) endif call rng%init (seed_value) end subroutine random2_seed @ <<[[circe2_moments_library]] declarations>>= public :: read_channels @ <<[[circe2_moments_library]] implementation>>= subroutine read_channels (channels) type(channel), dimension(:), allocatable, intent(out) :: channels type(channel), dimension(100) :: buffer real(kind=default) :: w real(kind=default), dimension(2) :: a, b logical, dimension(2) :: delta integer :: n, status do n = 1, size (buffer) read (*, *, iostat = status) w, a(1), b(1), a(2), b(2), delta if (status == 0) then buffer(n) = channel (w, a, b, delta) else exit end if end do allocate (channels(n-1)) channels = buffer(1:n-1) end subroutine read_channels @ <<[[circe2_moments_library]] declarations>>= public :: report_results @ <<[[circe2_moments_library]] implementation>>= subroutine report_results (moments, channels) type(moment), dimension(0:,0:,0:,0:), intent(in) :: moments type(channel), dimension(:), intent(in) :: channels integer :: nx, mx, ny, my real(kind=default) :: truth, estimate, sigma, pull, eps do nx = lbound(moments,1), ubound(moments,1) do mx = lbound(moments,2), ubound(moments,2) do ny = lbound(moments,3), ubound(moments,3) do my = lbound(moments,4), ubound(moments,4) truth = beta_moments_multi ([nx, ny], [mx, my], channels) estimate = mean_moment (moments(nx,mx,ny,my)) sigma = sqrt (variance_moment (moments(nx,mx,ny,my))) pull = estimate - truth eps = pull / max (epsilon (1.0_default), epsilon (1.0_double)) if (sigma /= 0.0_default) pull = pull / sigma write (*, "(' x^', I1, ' (1-x)^', I1, & &' y^', I1, ' (1-y)^', I1, & &': ', F8.5, ': est = ', F8.5, & &' +/- ', F8.5,& &', pull = ', F8.2,& &', eps = ', F8.2)") & nx, mx, ny, my, truth, estimate, sigma, pull, eps end do end do end do end do end subroutine report_results @ <<[[circe2_moments_library]] declarations>>= public :: results_ok @ <<[[circe2_moments_library]] implementation>>= function results_ok (moments, channels, threshold, fraction) ! use, intrinsic :: ieee_arithmetic type(moment), dimension(0:,0:,0:,0:), intent(in) :: moments type(channel), dimension(:), intent(in) :: channels real(kind=default), intent(in), optional :: threshold, fraction logical :: results_ok integer :: nx, mx, ny, my, failures real(kind=default) :: thr, frac, eps real(kind=default) :: truth, estimate, sigma ! we mut not expect to measure zero better than the ! double precision used in the ocaml code: eps = 200 * max (epsilon (1.0_default), epsilon (1.0_double)) if (present(threshold)) then thr = threshold else thr = 5 end if if (present(fraction)) then frac = fraction else frac = 0.01_default end if failures = 0 do nx = lbound(moments,1), ubound(moments,1) do mx = lbound(moments,2), ubound(moments,2) do ny = lbound(moments,3), ubound(moments,3) do my = lbound(moments,4), ubound(moments,4) truth = beta_moments_multi ([nx, ny], [mx, my], channels) estimate = mean_moment (moments(nx,mx,ny,my)) sigma = sqrt (variance_moment (moments(nx,mx,ny,my))) if (.not. ( ieee_is_normal (truth) & .and. ieee_is_normal (estimate) & .and. ieee_is_normal (sigma)) & .or. abs (estimate - truth) > max (thr * sigma, eps)) then failures = failures + 1 end if end do end do end do end do if (failures >= frac * size (moments)) then results_ok = .false. else results_ok = .true. end if contains <> end function results_ok @ gfortran doesn't have the intrinsic [[ieee_arithmetic]] module yet \ldots <>= function ieee_is_normal (x) real(kind=default), intent(in) :: x logical :: ieee_is_normal ieee_is_normal = .not. (x /= x) end function ieee_is_normal @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ \subsubsection{Generate Sample} @ <<[[circe2_moments_library]] declarations>>= public :: generate @ <<[[circe2_moments_library]] implementation>>= subroutine generate (rng, nevents) class(rng_type), intent(inout) :: rng integer, intent(in) :: nevents type(channel), dimension(:), allocatable :: channels real(kind=default), dimension(2) :: x integer :: i call read_channels (channels) do i = 1, nevents call generate_beta_multi (rng, x, channels) write (*, "(3(5x,F19.17))") x, 1.0_default end do end subroutine generate @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ \subsubsection{List Moments} @ <<[[circe2_moments_library]] declarations>>= public :: compare @ <<[[circe2_moments_library]] implementation>>= subroutine compare (rng, nevents, file) class(rng_type), intent(inout) :: rng integer, intent(in) :: nevents character(len=*), intent(in) :: file type(channel), dimension(:), allocatable :: channels integer, parameter :: N = 1 type(moment), dimension(0:N,0:N,0:N,0:N) :: moments real(kind=default), dimension(2) :: x character(len=128) :: design real(kind=default) :: roots integer :: ierror integer, dimension(2) :: p, h integer :: i type(circe2_state) :: c2s call read_channels (channels) call init_moments (moments) design = "CIRCE2/TEST" roots = 42 p = [11, -11] h = 0 call circe2_load (c2s, trim(file), trim(design), roots, ierror) do i = 1, nevents call circe2_generate (c2s, rng, x, p, h) call record_moment (moments, x(1), x(2)) end do call report_results (moments, channels) end subroutine compare @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ \subsubsection{Check Generator} @ <<[[circe2_moments_library]] declarations>>= public :: check @ <<[[circe2_moments_library]] implementation>>= subroutine check (rng, nevents, file, distributions, fail) class(rng_type), intent(inout) :: rng integer, intent(in) :: nevents character(len=*), intent(in) :: file logical, intent(in), optional :: distributions, fail type(channel), dimension(:), allocatable :: channels type(channel), dimension(1) :: unit_channel integer, parameter :: N = 1 type(moment), dimension(0:N,0:N,0:N,0:N) :: moments, unit_moments real(kind=default), dimension(2) :: x character(len=128) :: design real(kind=default) :: roots, weight integer :: ierror integer, dimension(2) :: p, h integer :: i logical :: generation_ok, distributions_ok logical :: check_distributions, expect_failure type(circe2_state) :: c2s if (present (distributions)) then check_distributions = distributions else check_distributions = .true. end if if (present (fail)) then expect_failure = fail else expect_failure = .false. end if call read_channels (channels) call init_moments (moments) if (check_distributions) call init_moments (unit_moments) design = "CIRCE2/TEST" roots = 42 p = [11, -11] h = 0 call circe2_load (c2s, trim(file), trim(design), roots, ierror) do i = 1, nevents call circe2_generate (c2s, rng, x, p, h) call record_moment (moments, x(1), x(2)) if (check_distributions) then weight = circe2_distribution (c2s, p, h, x) call record_moment (unit_moments, x(1), x(2), w = 1 / weight) end if end do generation_ok = results_ok (moments, channels) if (check_distributions) then distributions_ok = results_ok (unit_moments, unit_channel) else distributions_ok = .not. expect_failure end if if (expect_failure) then if (generation_ok .and. distributions_ok) then print *, "FAIL: unexpected success" else if (.not. generation_ok) then print *, "OK: expected failure in generation" end if if (.not. distributions_ok) then print *, "OK: expected failure in distributions" end if end if call report_results (moments, channels) else if (generation_ok .and. distributions_ok) then print *, "OK" else if (.not. generation_ok) then print *, "FAIL: generation" call report_results (moments, channels) end if if (.not. distributions_ok) then print *, "FAIL: distributions" call report_results (unit_moments, unit_channel) end if end if end if end subroutine check @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @ \subsection{[[circe2_moments]]: Compare Moments of distributions} <
>= program circe2_moments use circe2 use circe2_moments_library !NODEP! use tao_random_objects !NODEP! implicit none type(rng_tao), save :: rng character(len=1024) :: mode, filename, buffer integer :: status, nevents, seed call get_command_argument (1, value = mode, status = status) if (status /= 0) mode = "" call get_command_argument (2, value = filename, status = status) if (status /= 0) filename = "" call get_command_argument (3, value = buffer, status = status) if (status == 0) then read (buffer, *, iostat = status) nevents if (status /= 0) nevents = 1000 else nevents = 1000 end if call get_command_argument (4, value = buffer, status = status) if (status == 0) then read (buffer, *, iostat = status) seed if (status == 0) then call random2_seed (rng, seed) else call random2_seed (rng) end if else call random2_seed (rng) end if select case (trim (mode)) case ("check") call check (rng, nevents, trim (filename)) case ("!check") call check (rng, nevents, trim (filename), fail = .true.) case ("check_generation") call check (rng, nevents, trim (filename), distributions = .false.) case ("!check_generation") call check (rng, nevents, trim (filename), fail = .true., & distributions = .false.) case ("compare") call compare (rng, nevents, trim (filename)) case ("generate") call generate (rng, nevents) case ("selftest") call selftest (rng, nevents) case default print *, & "usage: circe2_moments " // & "[check|check_generation|generate|selftest] " // & "filename [events] [seed]" end select end program circe2_moments @ <<[[circe2_moments.f90]]>>= module circe2_moments_library use kinds use tao_random_objects !NODEP! use sampling !NODEP! use circe2 implicit none private <<[[circe2_moments_library]] declarations>> contains <<[[circe2_moments_library]] implementation>> end module circe2_moments_library @ <<[[circe2_moments.f90]]>>= <
> @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{thebibliography}{10} \bibitem{Atkinson/Whittaker:1979:beta_distribution} A. Atkinson and J. Whittaker, Appl.\ Stat.\ {\bf 28}, 90 (1979). \bibitem{Devroye:1986:random_deviates} L. Devroye, {\em Non-uniform Random Variate Generation}, Springer, 1986. \end{thebibliography} Index: trunk/circe2/share/doc/noweb.sty =================================================================== --- trunk/circe2/share/doc/noweb.sty (revision 8914) +++ trunk/circe2/share/doc/noweb.sty (revision 8915) @@ -1,927 +1,976 @@ % noweb.sty -- LaTeX support for noweb % DON'T read or edit this file! Use ...noweb-source/tex/support.nw instead. {\obeyspaces\AtBeginDocument{\global\let =\ }} % from texbook, p 381 \def\nwopt@nomargintag{\let\nwmargintag=\@gobble} \def\nwopt@margintag{% \def\nwmargintag##1{\leavevmode\llap{##1\kern\nwmarginglue\kern\codemargin}}} \def\nwopt@margintag{% \def\nwmargintag##1{\leavevmode\kern-\codemargin\nwthemargintag{##1}\kern\codemargin}} \def\nwthemargintag#1{\llap{#1\kern\nwmarginglue}} \nwopt@margintag \newdimen\nwmarginglue \nwmarginglue=0.3in \def\nwtagstyle{\footnotesize\Rm} +\def\nwgitversion{|GITVERSION|} % make \hsize in code sufficient for 88 columns -\setbox0=\hbox{\tt m} +\ifx\ttfamily\undefined + \setbox0=\hbox{\tt m} +\else + \setbox0=\hbox{\ttfamily m} +\fi \newdimen\codehsize \codehsize=91\wd0 % 88 columns wasn't enough; I don't know why \newdimen\codemargin \codemargin=0pt \newdimen\nwdefspace \nwdefspace=\codehsize % need to use \textwidth in {\LaTeX} to handle styles with % non-standard margins (David Bruce). Don't know why we sometimes % wanted \hsize. 27 August 1997. %% \advance\nwdefspace by -\hsize\relax \ifx\textwidth\undefined \advance\nwdefspace by -\hsize\relax \else \advance\nwdefspace by -\textwidth\relax \fi \chardef\other=12 \def\setupcode{% \chardef\\=`\\ \chardef\{=`\{ \chardef\}=`\} \catcode`\$=\other \catcode`\&=\other \catcode`\#=\other \catcode`\%=\other \catcode`\~=\other \catcode`\_=\other \catcode`\^=\other \catcode`\"=\other % fixes problem with german.sty \obeyspaces\Tt } -\let\nwlbrace=\{ -\let\nwrbrace=\} \def\nwendquote{\relax\ifhmode\spacefactor=1000 \fi} {\catcode`\^^M=\active % make CR an active character \gdef\newlines{\catcode`\^^M=\active % make CR an active character \def^^M{\par\startline}}% \gdef\eatline#1^^M{\relax}% } %%% DON'T \gdef^^M{\par\startline}}% in case ^^M appears in a \write \def\startline{\noindent\hskip\parindent\ignorespaces} \def\nwnewline{\ifvmode\else\hfil\break\leavevmode\hbox{}\fi} \def\setupmodname{% \catcode`\$=3 \catcode`\&=4 \catcode`\#=6 \catcode`\%=14 \catcode`\~=13 \catcode`\_=8 \catcode`\^=7 \catcode`\ =10 \catcode`\^^M=5 - \let\{\nwlbrace - \let\}\nwrbrace + \let\{\lbrace + \let\}\rbrace % bad news --- don't know what catcode to give " \Rm} \def\LA{\begingroup\maybehbox\bgroup\setupmodname\It$\langle$} \def\RA{\/$\rangle$\egroup\endgroup} \def\code{\leavevmode\begingroup\setupcode\newlines} \def\edoc{\endgroup} \let\maybehbox\relax \newbox\equivbox \setbox\equivbox=\hbox{$\equiv$} \newbox\plusequivbox \setbox\plusequivbox=\hbox{$\mathord{+}\mathord{\equiv}$} % \moddef can't have an argument because there might be \code...\edoc \def\moddef{\leavevmode\kern-\codemargin\LA} \def\endmoddef{\RA\ifmmode\equiv\else\unhcopy\equivbox\fi \nobreak\hfill\nobreak} \def\plusendmoddef{\RA\ifmmode\mathord{+}\mathord{\equiv}\else\unhcopy\plusequivbox\fi \nobreak\hfill\nobreak} \def\chunklist{% \errhelp{I changed \chunklist to \nowebchunks. I'll try to avoid such incompatible changes in the future.}% \errmessage{Use \string\nowebchunks\space instead of \string\chunklist}} \def\nowebchunks{\message{}} \def\nowebindex{\message{}} % here is support for the new-style (capitalized) font-changing commands % thanks to Dave Love \ifx\documentstyle\undefined \let\Rm=\rm \let\It=\it \let\Tt=\tt % plain \else\ifx\selectfont\undefined \let\Rm=\rm \let\It=\it \let\Tt=\tt % LaTeX OFSS \else % LaTeX NFSS - \def\Rm{\reset@font\rm} - \def\It{\reset@font\it} - \def\Tt{\reset@font\tt} - \def\Bf{\reset@font\bf} + \def\Rm{\reset@font\rmfamily} + \def\It{\reset@font\itshape} + \def\Tt{\reset@font\ttfamily} + \def\Bf{\reset@font\bfseries} \fi\fi \ifx\reset@font\undefined \let\reset@font=\relax \fi +\def\nwbackslash{\char92} +\def\nwlbrace{\char123} +\def\nwrbrace{\char125} \def\noweboptions#1{% \def\@nwoptionlist{#1}% \@for\@nwoption:=\@nwoptionlist\do{% \@ifundefined{nwopt@\@nwoption}{% \@latexerr{There is no such noweb option as '\@nwoption'}\@eha}{% \csname nwopt@\@nwoption\endcsname}}} \codemargin=10pt \advance\codehsize by \codemargin % make room for indentation of code \advance\nwdefspace by \codemargin % and fix adjustment for def/use \def\setcodemargin#1{% \advance\codehsize by -\codemargin % make room for indentation of code \advance\nwdefspace by -\codemargin % and fix adjustment for def/use \codemargin=#1 \advance\codehsize by \codemargin % make room for indentation of code \advance\nwdefspace by \codemargin % and fix adjustment for % def/use } \def\nwopt@shift{% \dimen@=-0.8in \if@twoside % Values for two-sided printing: \advance\evensidemargin by \dimen@ \else % Values for one-sided printing: \advance\evensidemargin by \dimen@ \advance\oddsidemargin by \dimen@ \fi % \advance \marginparwidth -\dimen@ } \let\nwopt@noshift\@empty \def\nwbegincode#1{% \begingroup \topsep \nwcodetopsep \@beginparpenalty \@highpenalty \@endparpenalty -\@highpenalty \@begincode } \def\nwendcode{\endtrivlist \endgroup \filbreak} % keeps code on 1 page \newenvironment{webcode}{% \@begincode }{% \endtrivlist} +\newdimen\@nwbegincodelinewidth \def\@begincode{% + \@nwbegincodelinewidth=\linewidth \trivlist \item[]% \leftskip\@totalleftmargin \advance\leftskip\codemargin \rightskip\hsize \advance\rightskip -\codehsize \parskip\z@ \parindent\z@ \parfillskip\@flushglue \linewidth\codehsize \@@par \def\par{\leavevmode\null \@@par \penalty\nwcodepenalty}% \obeylines + \nowebsize \setupcode \@noligs \ifx\verbatim@nolig@list\undefined\else \let\do=\nw@makeother \verbatim@nolig@list \do@noligs\` \fi \setupcode \frenchspacing \@vobeyspaces - \nowebsize \setupcode \let\maybehbox\mbox } \newskip\nwcodetopsep \nwcodetopsep = 3pt plus 1.2pt minus 1pt \let\nowebsize=\normalsize \def\nwopt@tinycode{\let\nowebsize=\tiny} \def\nwopt@footnotesizecode{\let\nowebsize=\footnotesize} \def\nwopt@scriptsizecode{\let\nowebsize=\scriptsize} \def\nwopt@smallcode{\let\nowebsize=\small} \def\nwopt@normalsizecode{\let\nowebsize=\normalsize} \def\nwopt@largecode{\let\nowebsize=\large} \def\nwopt@Largecode{\let\nowebsize=\Large} \def\nwopt@LARGEcode{\let\nowebsize=\LARGE} \def\nwopt@hugecode{\let\nowebsize=\huge} \def\nwopt@Hugecode{\let\nowebsize=\Huge} \newcount\nwcodepenalty \nwcodepenalty=\@highpenalty \def\nw@makeother#1{\catcode`#1=12 } \def\nwbegindocs#1{\ifvmode\noindent\fi} \let\nwenddocs=\relax \let\nwdocspar=\filbreak \def\@nwsemifilbreak#1{\vskip0pt plus#1\penalty-200\vskip0pt plus -#1} \newdimen\nwbreakcodespace \nwbreakcodespace=0.2in % by default, leave no more than this on a page \def\nwopt@breakcode{% \def\nwdocspar{\@nwsemifilbreak{0.2in}}% \def\nwendcode{\endtrivlist\endgroup} % ditches filbreak } \raggedbottom \def\code{\leavevmode\begingroup\setupcode\@vobeyspaces\obeylines} \let\edoc=\endgroup \newdimen\@original@textwidth \def\ps@noweb{% \@original@textwidth=\textwidth \let\@mkboth\@gobbletwo \def\@oddfoot{}\def\@evenfoot{}% No feet. \if@twoside % If two-sided printing. \def\@evenhead{\hbox to \@original@textwidth{% \Rm \thepage\qquad{\Tt\leftmark}\hfil\today}}% Left heading. \def\@oddhead{\hbox to \@original@textwidth{% \Rm \today\hfil{\Tt\leftmark}\qquad\thepage}}% Right heading. \else % If one-sided printing. \def\@oddhead{\hbox to \@original@textwidth{% \Rm \today\hfil{\Tt\leftmark}\qquad\thepage}}% Right heading. \let\@evenhead\@oddhead \fi \let\chaptermark\@gobble \let\sectionmark\@gobble \let\subsectionmark\@gobble \let\subsubsectionmark\@gobble \let\paragraphmark\@gobble \let\subparagraphmark\@gobble \def\nwfilename{\begingroup\let\do\@makeother\dospecials \catcode`\{=1 \catcode`\}=2 \nw@filename} \def\nw@filename##1{\endgroup\markboth{##1}{##1}\let\nw@filename=\nw@laterfilename}% } \def\nw@laterfilename#1{\endgroup\clearpage \markboth{#1}{#1}} \let\nwfilename=\@gobble \def\nwcodecomment#1{\@@par\penalty\nwcodepenalty \if@firstnwcodecomment \vskip\nwcodecommentsep\penalty\nwcodepenalty\@firstnwcodecommentfalse \fi% \hspace{-\codemargin}{% \rightskip=0pt plus1in \interlinepenalty\nwcodepenalty \let\\\relax\footnotesize\Rm #1\@@par\penalty\nwcodepenalty}} \def\@nwalsodefined#1{\nwcodecomment{\@nwlangdepdef\ \nwpageprep\ \@pagesl{#1}.}} \def\@nwused#1{\nwcodecomment{\@nwlangdepcud\ \nwpageprep\ \@pagesl{#1}.}} \def\@nwnotused#1{\nwcodecomment{\@nwlangdeprtc.}} \def\nwoutput#1{\nwcodecomment{\@nwlangdepcwf\ {\Tt \@stripstar#1*\stripped}.}} \def\@stripstar#1*#2\stripped{#1} \newcommand{\nwprevdefptr}[1]{% \mbox{$\mathord{\triangleleft}\,\mathord{\mbox{\subpageref{#1}}}$}} \newcommand{\nwnextdefptr}[1]{% \mbox{$\mathord{\mbox{\subpageref{#1}}}\,\mathord{\triangleright}$}} \newcommand{\@nwprevnextdefs}[2]{% {\nwtagstyle \ifx\relax#1\else ~~\nwprevdefptr{#1}\fi \ifx\relax#2\else ~~\nwnextdefptr{#2}\fi}} \newcommand{\@nwusesondefline}[1]{{\nwtagstyle~~(\@pagenumsl{#1})}} \newcommand{\@nwstartdeflinemarkup}{\nobreak\hskip 1.5em plus 1fill\nobreak} \newcommand{\@nwenddeflinemarkup}{\nobreak\hskip \nwdefspace minus\nwdefspace\nobreak} \def\nwopt@longxref{% \let\nwalsodefined\@nwalsodefined \let\nwused\@nwused \let\nwnotused\@nwnotused \let\nwprevnextdefs\@gobbletwo \let\nwusesondefline\@gobble \let\nwstartdeflinemarkup\relax \let\nwenddeflinemarkup\relax } \def\nwopt@shortxref{% \let\nwalsodefined\@gobble \let\nwused\@gobble \let\nwnotused\@gobble \let\nwprevnextdefs\@nwprevnextdefs \let\nwusesondefline\@nwusesondefline \let\nwstartdeflinemarkup\@nwstartdeflinemarkup \let\nwenddeflinemarkup\@nwenddeflinemarkup } \def\nwopt@noxref{% \let\nwalsodefined\@gobble \let\nwused\@gobble \let\nwnotused\@gobble \let\nwprevnextdefs\@gobbletwo \let\nwusesondefline\@gobble \let\nwstartdeflinemarkup\relax \let\nwenddeflinemarkup\relax } \nwopt@shortxref % to hell with backward compatibility! \newskip\nwcodecommentsep \nwcodecommentsep=3pt plus 1pt minus 1pt \newif\if@firstnwcodecomment\@firstnwcodecommenttrue \newcount\@nwlopage\newcount\@nwhipage % range lo..hi-1 \newcount\@nwlosub % subpage of lo \newcount\@nwhisub % subpage of hi \def\@nwfirstpage#1#2#3{% subpage page xref-tag \@nwlopage=#2 \@nwlosub=#1 \def\@nwloxreftag{#3}% \advance\@nwpagecount by \@ne \@nwhipage=\@nwlopage\advance\@nwhipage by \@ne } \def\@nwnextpage#1#2#3{% subpage page xref-tag \ifnum\@nwhipage=#2 \advance\@nwhipage by \@ne \advance\@nwpagecount by \@ne \@nwhisub=#1 \def\@nwhixreftag{#3}\else \ifnum#2<\@nwlopage \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\@nwfirstpage{#1}{#2}{#3}\else \ifnum#2>\@nwhipage \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\@nwfirstpage{#1}{#2}{#3}\else \@nwlosub=0 \@nwhisub=0 \fi\fi\fi } \newcount\@nwpagetemp \newcount\@nwpagecount \def\@nwfirstpagel#1{% label \@ifundefined{r@#1}{\@warning{Reference `#1' on page \thepage \space undefined}% - \nwix@cons\nw@pages{\\{\bf ??}}}{% + \nwix@cons\nw@pages{\\{\bfseries ??}}}{% \edef\@tempa{\noexpand\@nwfirstpage\subpagepair{#1}{#1}}\@tempa}} \def\@nwnextpagel#1{% label \@ifundefined{r@#1}{\@warning{Reference `#1' on page \thepage \space undefined}% - \nwix@cons\nw@pages{\\{\bf ??}}}{% + \nwix@cons\nw@pages{\\{\bfseries ??}}}{% \edef\@tempa{\noexpand\@nwnextpage\subpagepair{#1}{#1}}\@tempa}} \def\@pagesl#1{% list of labels \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\@nwfirstpagel{##1}\let\\=\@nwnextpagel}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\def\\##1{\@nwhyperpagenum##1}% \ifnum\@nwpagecount=1 \nwpageword \else \nwpagesword\fi~\commafy{\nw@pages}} \def\@nwhyperpagenum#1#2{\nwhyperreference{#2}{#1}} \def\@pagenumsl#1{% list of labels -- doesn't include word `pages', commas, or `and' \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\@nwfirstpagel{##1}\let\\=\@nwnextpagel}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa% \def\\##1{\@nwhyperpagenum##1\let\\=\@nwpagenumslrest}\nw@pages} \def\@nwpagenumslrest#1{~\@nwhyperpagenum#1} \def\subpages#1{% list of {{subpage}{page}} \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\edef\@tempa{\noexpand\@nwfirstpage##1{}}\@tempa \def\\####1{\edef\@tempa{\noexpand\@nwnextpage####1}\@tempa}}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\def\\##1{\@firstoftwo##1}% \ifnum\@nwpagecount=1 \nwpageword \else \nwpagesword\fi~\commafy{\nw@pages}} \def\@nwaddrange{\advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa} \def\nwpageword{\@nwlangdepchk} % chunk, was page \def\nwpagesword{\@nwlangdepchks} % chunk, was page \def\nwpageprep{\@nwlangdepin} % in, was on \newcommand\nw@genericref[2]{% what to do, name of ref \expandafter\nw@g@nericref\csname r@#2\endcsname#1{#2}} \newcommand\nw@g@nericref[3]{% control sequence, what to do, name \ifx#1\relax \ref{#3}% trigger the standard `undefined ref' mechanisms \else \expandafter#2#1.\\% \fi} \def\nw@selectone#1#2#3\\{#1} \def\nw@selecttwo#1#2#3\\{#2} \def\nw@selectonetwo#1#2#3\\{{#1}{#2}} \newcommand{\subpageref}[1]{% \nwhyperreference{#1}{\nw@genericref\@subpageref{#1}}} \def\@subpageref#1#2#3\\{% \@ifundefined{2on#2}{#2}{\nwthepagenum{#1}{#2}}} \newcommand{\subpagepair}[1]{% % produces {subpage}{page} \@ifundefined{r@#1}% {{0}{0}}% {\nw@genericref\@subpagepair{#1}}} \def\@subpagepair#1#2#3\\{% \@ifundefined{2on#2}{{0}{#2}}{{#1}{#2}}} \newcommand{\sublabel}[1]{% + \leavevmode % needed to make \@bsphack work \@bsphack \nwblindhyperanchor{#1}% \if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newsublabel{#1}{{}{\thepage}}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand{\nosublabel}[1]{% \@bsphack\if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newlabel{#1}{{0}{\thepage}}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand\newsublabel{% \nw@settrailers \global\let\newsublabel\@newsublabel \@newsublabel} \newcommand{\@newsublabel}[2]{% \edef\this@page{\@cdr#2\@nil}% \ifx\this@page\last@page\else \sub@page=\z@ \fi \edef\last@page{\this@page} \advance\sub@page by \@ne \ifnum\sub@page=\tw@ \global\@namedef{2on\this@page}{}% \fi \pendingsublabel{#1}% \edef\@tempa##1{\noexpand\newlabel{##1}% {{\number\sub@page}{\this@page}\nw@labeltrailers}}% \pending@sublabels \def\pending@sublabels{}} \newcommand\nw@settrailers{% -- won't work on first run \@ifpackageloaded{nameref}% {\gdef\nw@labeltrailers{{}{}{}}}% {\gdef\nw@labeltrailers{}}} \renewcommand\nw@settrailers{% \@ifundefined{@secondoffive}% {\gdef\nw@labeltrailers{}}% {\gdef\nw@labeltrailers{{}{}{}}}} \newcommand{\nextchunklabel}[1]{% \nwblindhyperanchor{#1}% % looks slightly bogus --- nr \@bsphack\if@filesw {\let\thepage\relax \edef\@tempa{\write\@auxout{\string\pendingsublabel{#1}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand\pendingsublabel[1]{% \def\@tempa{\noexpand\@tempa}% \edef\pending@sublabels{\noexpand\@tempa{#1}\pending@sublabels}} \def\pending@sublabels{} \def\last@page{\relax} \newcount\sub@page \def\@alphasubpagenum#1#2{#2\ifnum#1=0 \else\@alph{#1}\fi} \def\@nosubpagenum#1#2{#2} \def\@numsubpagenum#1#2{#2\ifnum#1=0 \else.\@arabic{#1}\fi} \def\nwopt@nosubpage{\let\nwthepagenum=\@nosubpagenum\nwopt@nomargintag} \def\nwopt@numsubpage{\let\nwthepagenum=\@numsubpagenum} \def\nwopt@alphasubpage{\let\nwthepagenum=\@alphasubpagenum} \nwopt@alphasubpage \newcount\@nwalph@n \let\@nwalph@d\@tempcnta \let\@nwalph@bound\@tempcntb \def\@nwlongalph#1{{% \@nwalph@n=#1\advance\@nwalph@n by-1 \@nwalph@bound=26 \loop\ifnum\@nwalph@n<\@nwalph@bound\else \advance\@nwalph@n by -\@nwalph@bound \multiply\@nwalph@bound by 26 \repeat \loop\ifnum\@nwalph@bound>1 \divide\@nwalph@bound by 26 \@nwalph@d=\@nwalph@n\divide\@nwalph@d by \@nwalph@bound % d := d * bound ; n -:= d; d := d / bound --- saves a temporary \multiply\@nwalph@d by \@nwalph@bound \advance\@nwalph@n by -\@nwalph@d \divide\@nwalph@d by \@nwalph@bound \advance\@nwalph@d by 1 \@alph{\@nwalph@d}% \repeat }} \newcount\nw@chunkcount \nw@chunkcount=\@ne \newcommand{\weblabel}[1]{% \@bsphack \nwblindhyperanchor{#1}% \if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newsublabel{#1}{{}{\number\nw@chunkcount}}}}% \expandafter}\@tempa \global\advance\nw@chunkcount by \@ne \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \def\nwopt@webnumbering{% \let\sublabel=\weblabel \def\nwpageword{chunk}\def\nwpagesword{chunks}% \def\nwpageprep{in}} % \nwindexdefn{printable name}{identifying label}{label of chunk} % \nwindexuse{printable name}{identifying label}{label of chunk} \def\nwindexdefn#1#2#3{\@auxix{\protect\nwixd}{#2}{#3}} \def\nwindexuse#1#2#3{\@auxix{\protect\nwixu}{#2}{#3}} \def\@auxix#1#2#3{% {marker}{id label}{subpage label} \@bsphack\if@filesw {\let\nwixd\relax\let\nwixu\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string\nwixadd{#1}{#2}{#3}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} % \nwixadd{marker}{idlabel}{subpage label} \def\nwixadd#1#2#3{% \@ifundefined{nwixl@#2}% {\global\@namedef{nwixl@#2}{#1{#3}}}% {\expandafter\nwix@cons\csname nwixl@#2\endcsname{#1{#3}}}} \def\@nwsubscriptident#1#2{\mbox{$\mbox{#1}_{\mathrm{\subpageref{#2}}}$}} \def\@nwnosubscriptident#1#2{#1} \def\@nwhyperident#1#2{\leavevmode\nwhyperreference{#2}{#1}} \def\nwopt@subscriptidents{% \let\nwlinkedidentq\@nwsubscriptident \let\nwlinkedidentc\@nwsubscriptident } \def\nwopt@nosubscriptidents{% \let\nwlinkedidentq\@nwnosubscriptident \let\nwlinkedidentc\@nwnosubscriptident } \def\nwopt@hyperidents{% \let\nwlinkedidentq\@nwhyperident \let\nwlinkedidentc\@nwhyperident } \def\nwopt@nohyperidents{% \let\nwlinkedidentq\@nwnosubscriptident \let\nwlinkedidentc\@nwnosubscriptident } \def\nwopt@subscriptquotedidents{% \let\nwlinkedidentq\@nwsubscriptident } \def\nwopt@nosubscriptquotedidents{% \let\nwlinkedidentq\@nwnosubscriptident } \def\nwopt@hyperquotedidents{% \let\nwlinkedidentq\@nwhyperident } \def\nwopt@nohyperquotedidents{% \let\nwlinkedidentq\@nwnosubscriptident } \nwopt@hyperidents \newcount\@commacount \def\commafy#1{% {\nwix@listcount{#1}\@commacount=\nwix@counter \let\@comma@each=\\% \ifcase\@commacount\let\\=\@comma@each\or\let\\=\@comma@each\or \def\\{\def\\{ \@nwlangdepand\ \@comma@each}\@comma@each}\else \def\\{\def\\{, % \advance\@commacount by \m@ne \ifnum\@commacount=1 \@nwlangdepand~\fi\@comma@each}\@comma@each}\fi #1}} \def\nwix@cons#1#2{% {list}{\marker{element}} {\toks0=\expandafter{#1}\def\@tempa{#2}\toks2=\expandafter{\@tempa}% \xdef#1{\the\toks0 \the\toks2 }}} \def\nwix@uses#1{% {label} \def\nwixu{\\}\let\nwixd\@gobble\@nameuse{nwixl@#1}} \def\nwix@defs#1{% {label} \def\nwixd{\\}\let\nwixu\@gobble\@nameuse{nwixl@#1}} \newcount\nwix@counter \def\nwix@listcount#1{% {list with \\} {\count@=0 \def\\##1{\advance\count@ by \@ne }% #1\global\nwix@counter=\count@ }} \def\nwix@usecount#1{\nwix@listcount{\nwix@uses{#1}}} \def\nwix@defcount#1{\nwix@listcount{\nwix@defs{#1}}} \def\nwix@id@defs#1{% index pair {{\Tt \@car#1\@nil}% \def\\##1{\nwix@defs@space\subpageref{##1}}\nwix@defs{\@cdr#1\@nil}}} % useful above to change ~ into something that can break % this option is undocumented because I think breakdefs is always right \def\nwopt@breakdefs{\def\nwix@defs@space{\penalty200\ }} \def\nwopt@nobreakdefs{\def\nwix@defs@space{~}} % old code \nwopt@breakdefs \def\nwidentuses#1{% list of index pairs \nwcodecomment{\@nwlangdepuss\ \let\\=\nwix@id@defs\commafy{#1}.}} \def\nwix@totaluses#1{% list of index pairs {\count@=0 \def\\##1{\nwix@usecount{\@cdr##1\@nil}\advance\count@ by\nwix@counter}% #1\global\nwix@counter\count@ }} \def\nwix@id@uses#1#2{% {ident}{label} \nwix@usecount{#2}\ifnum\nwix@counter>0 {\advance\leftskip by \codemargin \nwcodecomment{{\Tt #1}, \@nwlangdepusd\ \nwpageprep\ \@pagesl{\nwix@uses{#2}}.}}% \else \ifnw@hideunuseddefs\else {\advance\leftskip by \codemargin \nwcodecomment{{\Tt #1}, \@nwlangdepnvu.}}% \fi \fi} \def\nwidentdefs#1{% list of index pairs \ifnw@hideunuseddefs\nwix@totaluses{#1}\else\nwix@listcount{#1}\fi \ifnum\nwix@counter>0 \nwcodecomment{\@nwlangdepdfs:}% {\def\\##1{\nwix@id@uses ##1}#1}% \fi} \newif\ifnw@hideunuseddefs\nw@hideunuseddefsfalse \def\nwopt@hideunuseddefs{\nw@hideunuseddefstrue} \def\nwopt@noidentxref{% \let\nwidentdefs\@gobble \let\nwidentuses\@gobble} \def\nw@underlinedefs{% {list with \nwixd, \nwixu} \let\\=\relax\def\nw@comma{, } \def\nwixd##1{\\\underline{\subpageref{##1}}\let\\\nw@comma}% \def\nwixu##1{\\\subpageref{##1}\let\\\nw@comma}} \def\nw@indexline#1#2{% {\indent {\Tt #1}: \nw@underlinedefs\@nameuse{nwixl@#2}\par}} \newenvironment{thenowebindex}{\parindent=-10pt \parskip=\z@ \advance\leftskip by 10pt \advance\rightskip by 0pt plus1in\par\@afterindenttrue \def\\##1{\nw@indexline##1}}{} \def\nowebindex{% \@ifundefined{nwixs@i}% {\@warning{The \string\nowebindex\space is empty}}% {\begin{thenowebindex}\@nameuse{nwixs@i}\end{thenowebindex}}} \def\nowebindex@external{% {\let\nwixadds@c=\@gobble \def\nwixadds@i##1{\nw@indexline##1}% \def\nwixaddsx##1##2{\@nameuse{nwixadds@##1}{##2}}% \begin{thenowebindex}\@input{\jobname.nwi}\end{thenowebindex}}} \def\nwixlogsorted#1#2{% list data \@bsphack\if@filesw \toks0={#2}\immediate\write\@auxout{\string\nwixadds{#1}{\the\toks0}} \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \def\nwixadds#1#2{% \@ifundefined{nwixs@#1}% {\global\@namedef{nwixs@#1}{\\{#2}}}% {\expandafter\nwix@cons\csname nwixs@#1\endcsname{\\{#2}}}} \let\nwixaddsx=\@gobbletwo \def\nwopt@externalindex{% \ifx\nwixadds\@gobbletwo % already called \else \let\nwixaddsx=\nwixadds \let\nwixadds=\@gobbletwo \let\nowebindex=\nowebindex@external \let\nowebchunks=\nowebchunks@external \fi} \def\nowebchunks{% \@ifundefined{nwixs@c}% {\@warning{The are no \string\nowebchunks}}% {\begin{thenowebchunks}\@nameuse{nwixs@c}\end{thenowebchunks}}} \def\nowebchunks@external{% {\let\nwixadds@i=\@gobble \def\nwixadds@c##1{\nw@onechunk##1}% \def\nwixaddsx##1##2{\@nameuse{nwixadds@##1}{##2}}% \begin{thenowebchunks}\@input{\jobname.nwi}\end{thenowebchunks}}} \@namedef{r@nw@notdef}{{0}{(\@nwlangdepnvd)}} \def\nw@chunkunderlinedefs{% {list of labels with \nwixd, \nwixu} \let\\=\relax\def\nw@comma{, } \def\nwixd##1{\\\underline{\subpageref{##1}}\let\\\nw@comma}% \def\nwixu##1{\\\subpageref{##1}\let\\\nw@comma}} \def\nw@onechunk#1#2#3{% {name}{label of first definition}{list with \nwixd, \nwixu} \@ifundefined{r@#2}{}{% \indent\LA #1~{\nwtagstyle\subpageref{#2}}\RA \if@nwlongchunks{~\nw@chunkunderlinedefs#3}\fi\par}} \newenvironment{thenowebchunks}{\vskip3pt \parskip=\z@\parindent=-10pt \advance\leftskip by 10pt \advance\rightskip by 0pt plus10pt \@afterindenttrue \def\\##1{\nw@onechunk##1}}{} \newif\if@nwlongchunks \@nwlongchunksfalse \let\nwopt@longchunks\@nwlongchunkstrue \newcommand\@nw@hyper@ref{\hyperreference} % naras \newcommand\@nw@hyper@anc{\blindhyperanchor} % naras \newcommand\@nw@hyperref@ref[2]{\hyperlink{noweb.#1}{#2}} % nr \newcommand\@nw@hyperref@anc[1]{\hypertarget{noweb.#1}{\relax}} % nr %%\renewcommand\@nw@hyperref@ref[2]{{#2}} % nr %%\renewcommand\@nw@hyperref@anc[1]{} % nr \newcommand\nwhyperreference{% \@ifundefined{hyperlink} {\@ifundefined{hyperreference} {\global\let\nwhyperreference\@gobble} {\global\let\nwhyperreference\@nw@hyper@ref}} {\global\let\nwhyperreference\@nw@hyperref@ref}% \nwhyperreference } \newcommand\nwblindhyperanchor{% \@ifundefined{hyperlink} {\@ifundefined{hyperreference} {\global\let\nwblindhyperanchor\@gobble} {\global\let\nwblindhyperanchor\@nw@hyper@anc}} {\global\let\nwblindhyperanchor\@nw@hyperref@anc}% \nwblindhyperanchor } \newcommand\nwanchorto{% \begingroup\let\do\@makeother\dospecials \catcode`\{=1 \catcode`\}=2 \nw@anchorto} \newcommand\nw@anchorto[1]{\endgroup\def\nw@next{#1}\nw@anchortofin} \newcommand\nw@anchortofin[1]{#1\footnote{See URL \texttt{\nw@next}.}} \let\nwanchorname\@gobble \newif\ifhtml \htmlfalse \let\nwixident=\relax -\def\nwbackslash{\char92} -\def\nwlbrace{\char123} -\def\nwrbrace{\char125} \def\nwopt@english{% \def\@nwlangdepdef{This definition is continued}% \def\@nwlangdepcud{This code is used}% \def\@nwlangdeprtc{Root chunk (not used in this document)}% \def\@nwlangdepcwf{This code is written to file}% \def\@nwlangdepchk{chunk}% \def\@nwlangdepchks{chunks}% \def\@nwlangdepin{in}% \def\@nwlangdepand{and}% \def\@nwlangdepuss{Uses}% \def\@nwlangdepusd{used}% \def\@nwlangdepnvu{never used}% \def\@nwlangdepdfs{Defines}% \def\@nwlangdepnvd{never defined}% } \let\nwopt@american\nwopt@english +\def\nwopt@icelandic{% + \def\@nwlangdepdef{This definition is continued}% + \def\@nwlangdepcud{This code is used}% + \def\@nwlangdeprtc{Root chunk (not used in this document)}% + \def\@nwlangdepcwf{This code is written to file}% + \def\@nwlangdepchk{kóða}% + \def\@nwlangdepchks{kóðum}% + \def\@nwlangdepin{í}% + \def\@nwlangdepand{og}% + \def\@nwlangdepuss{Notar}% + \def\@nwlangdepusd{notað}% + \def\@nwlangdepnvu{hvergi notað}% + \def\@nwlangdepdfs{Skilgreinir}% + \def\@nwlangdepnvd{hvergi skilgreint}% +} \def\nwopt@portuges{% \def\@nwlangdepdef{Defini\c{c}\~ao continuada em}% % This definition is continued \def\@nwlangdepcud{C\'odigo usado em}% % This code is used \def\@nwlangdeprtc{Fragmento de topo (sem uso no documento)}% % Root chunk (not used in this document) \def\@nwlangdepcwf{Este c\'odigo foi escrito no ficheiro}% % This code is written to file \def\@nwlangdepchk{fragmento}% % chunk \def\@nwlangdepchks{fragmentos}% % chunks \def\@nwlangdepin{no(s)}% % in \def\@nwlangdepand{e}% % and \def\@nwlangdepuss{Usa}% % Uses \def\@nwlangdepusd{usado}% % used \def\@nwlangdepnvu{nunca usado}% % never used \def\@nwlangdepdfs{Define}% % Defines \def\@nwlangdepnvd{nunca definido}% % never defined } \def\nwopt@frenchb{% - \def\@nwlangdepdef{Cette d\'efinition suit}% + \def\@nwlangdepdef{Suite de la d\'efinition}% % This definition is continued \def\@nwlangdepcud{Ce code est employ\'e}% % This code is used \def\@nwlangdeprtc{Morceau racine (pas employ\'e dans ce document)}% % Root chunk (not used in this document) - \def\@nwlangdepcwf{Ce code est \'ecrit aux fichier}% + \def\@nwlangdepcwf{Ce code est \'ecrit dans le fichier}% % This code is written to file \def\@nwlangdepchk{le morceau}% % chunk \def\@nwlangdepchks{les morceaux}% % chunks \def\@nwlangdepin{dans}% % in \def\@nwlangdepand{et}% % and - \def\@nwlangdepuss{Il emploie}% + \def\@nwlangdepuss{Utilise}% % Uses - \def\@nwlangdepusd{employ\'{e}}% + \def\@nwlangdepusd{utilis\'{e}}% % used \def\@nwlangdepnvu{jamais employ\'{e}}% % never used - \def\@nwlangdepdfs{Il d\'{e}fine}% + \def\@nwlangdepdfs{D\'{e}finit}% % Defines % Cannot use the accent here: \def\@nwlangdepnvd{jamais d\'{e}fini}% \def\@nwlangdepnvd{jamais defini}% % never defined } \let\nwopt@french\nwopt@frenchb \def\nwopt@german{% \def\@nwlangdepdef{Diese Definition wird fortgesetzt}% % This definition is continued \def\@nwlangdepcud{Dieser Code wird benutzt}% % This code is used \def\@nwlangdeprtc{Hauptteil (nicht in diesem Dokument benutzt)}% % Root chunk (not used in this document) - \def\@nwlangdepcwf{Dieser Code schreibt man zum File}% + \def\@nwlangdepcwf{Geh\"ort in die Datei}% % This code is written to file + \def\@nwlangdepchk{Abschnitt}% + % chunk + \def\@nwlangdepchks{den Abschnitten}% + % chunks + \def\@nwlangdepin{in}% + % in + \def\@nwlangdepand{und}% + % and + \def\@nwlangdepuss{Benutzt}% + % Uses + \def\@nwlangdepusd{benutzt}% + % used + \def\@nwlangdepnvu{nicht benutzt}% + % never used + \def\@nwlangdepdfs{Definiert}% + % Defines + \def\@nwlangdepnvd{nicht definiert}% + % never defined +} +\def\nwopt@german{% + \def\@nwlangdepdef{Diese Definition wird fortgesetzt}% + % This definition is continued + \def\@nwlangdepcud{Dieser Code wird benutzt}% + % This code is used + \def\@nwlangdeprtc{Hauptteil (nicht in diesem Dokument benutzt)}% + % Root chunk (not used in this document) + \def\@nwlangdepcwf{Dieser Code erzeugt die Datei} + % This code generates the file \def\@nwlangdepchk{Teil}% % chunk \def\@nwlangdepchks{Teils}% % chunks \def\@nwlangdepin{im}% % in \def\@nwlangdepand{und}% % and \def\@nwlangdepuss{Benutzt}% % Uses \def\@nwlangdepusd{benutzt}% % used \def\@nwlangdepnvu{nicht benutzt}% % never used \def\@nwlangdepdfs{Definiert}% % Defines \def\@nwlangdepnvd{nicht definiert}% % never defined } \let\nwopt@ngerman\nwopt@german \ifx\languagename\undefined % default is English \noweboptions{english} \else \@ifundefined{nwopt@\languagename} {\noweboptions{english}} {\expandafter\noweboptions\expandafter{\languagename}} \fi Index: trunk/src/events/events.nw =================================================================== --- trunk/src/events/events.nw (revision 8914) +++ trunk/src/events/events.nw (revision 8915) @@ -1,19881 +1,19881 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: event handling objects %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Generic Event Handling} \includemodulegraph{events} Event records allow the MC to communicate with the outside world. The event record should exhibit the observable contents of a physical event. We should be able to read and write events. The actual implementation of the event need not be defined yet, for that purpose. We have the following basic modules: \begin{description} \item[event\_base] Abstract base type for event records. The base type contains a reference to a [[particle_set_t]] object as the event core, and it holds some data that we should always expect, such as the squared matrix element and event weight. \item[eio\_data] Transparent container for the metadata of an event sample. \item[eio\_base] Abstract base type for event-record input and output. The implementations of this base type represent specific event I/O formats. \end{description} These are the implementation modules: \begin{description} \item[eio\_checkpoints] Auxiliary output format. The only purpose is to provide screen diagnostics during event output. \item[eio\_callback] Auxiliary output format. The only purpose is to execute a callback procedure, so we have a hook for external access during event output. \item[eio\_weights] Print some event summary data, no details. The main use is for testing purposes. \item[eio\_dump] Dump the contents of WHIZARD's [[particle_set]] internal record, using the [[write]] method of that record as-is. The main use if for testing purposes. \item[hep\_common] Implements traditional HEP common blocks that are (still) used by some of the event I/O formats below. \item[hepmc\_interface] Access particle objects of the HepMC package. Functional only if this package is linked. The interface is working both for HepMC2 and HepMC3. \item[lcio\_interface] Access objects of the LCIO package. Functional only if this package is linked. \item[hep\_events] Interface between the event record and the common blocks. \item[eio\_ascii] Collection of event output formats that write ASCII files. \item[eio\_lhef] LHEF for input and output. \item[eio\_stdhep] Support for the StdHEP format (binary, machine-independent). \item[eio\_hepmc] Support for the HepMC format (C++). \item[eio\_lcio] Support for the LCIO format (C++). \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Generic Event Handling} We introduce events first in form of an abstract type, together with some utilities. Abstract events can be used by other modules, in particular event I/O, without introducing an explicit dependency on the event implementation. <<[[event_base.f90]]>>= <> module event_base <> use kinds, only: i64 <> use model_data use particles <> <> <> <> <> interface <> end interface end module event_base @ %def event_base @ <<[[event_base_sub.f90]]>>= <> submodule (event_base) event_base_s use io_units use string_utils, only: lower_case use diagnostics implicit none contains <> end submodule event_base_s @ %def event_base_s @ \subsection{generic event type} <>= public :: generic_event_t <>= type, abstract :: generic_event_t !private logical :: particle_set_is_valid = .false. type(particle_set_t), pointer :: particle_set => null () logical :: sqme_ref_known = .false. real(default) :: sqme_ref = 0 logical :: sqme_prc_known = .false. real(default) :: sqme_prc = 0 logical :: weight_ref_known = .false. real(default) :: weight_ref = 0 logical :: weight_prc_known = .false. real(default) :: weight_prc = 0 logical :: excess_prc_known = .false. real(default) :: excess_prc = 0 logical :: n_dropped_known = .false. integer :: n_dropped = 0 integer :: n_alt = 0 logical :: sqme_alt_known = .false. real(default), dimension(:), allocatable :: sqme_alt logical :: weight_alt_known = .false. real(default), dimension(:), allocatable :: weight_alt contains <> end type generic_event_t @ %def generic_event_t @ \subsection{Initialization} This determines the number of alternate weights and sqme values. <>= procedure :: base_init => generic_event_init <>= module subroutine generic_event_init (event, n_alt) class(generic_event_t), intent(out) :: event integer, intent(in) :: n_alt end subroutine generic_event_init <>= module subroutine generic_event_init (event, n_alt) class(generic_event_t), intent(out) :: event integer, intent(in) :: n_alt event%n_alt = n_alt allocate (event%sqme_alt (n_alt)) allocate (event%weight_alt (n_alt)) end subroutine generic_event_init @ %def generic_event_init @ \subsection{Access particle set} The particle set is the core of the event. We allow access to it via a pointer, and we maintain the information whether the particle set is valid, i.e., has been filled with meaningful data. <>= procedure :: has_valid_particle_set => generic_event_has_valid_particle_set procedure :: accept_particle_set => generic_event_accept_particle_set procedure :: discard_particle_set => generic_event_discard_particle_set <>= module function generic_event_has_valid_particle_set (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag end function generic_event_has_valid_particle_set module subroutine generic_event_accept_particle_set (event) class(generic_event_t), intent(inout) :: event end subroutine generic_event_accept_particle_set module subroutine generic_event_discard_particle_set (event) class(generic_event_t), intent(inout) :: event end subroutine generic_event_discard_particle_set <>= module function generic_event_has_valid_particle_set (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag flag = event%particle_set_is_valid end function generic_event_has_valid_particle_set module subroutine generic_event_accept_particle_set (event) class(generic_event_t), intent(inout) :: event event%particle_set_is_valid = .true. end subroutine generic_event_accept_particle_set module subroutine generic_event_discard_particle_set (event) class(generic_event_t), intent(inout) :: event event%particle_set_is_valid = .false. end subroutine generic_event_discard_particle_set @ %def generic_event_has_valid_particle_set @ %def generic_event_accept_particle_set @ %def generic_event_discard_particle_set @ These procedures deal with the particle set directly. Return the pointer: <>= procedure :: get_particle_set_ptr => generic_event_get_particle_set_ptr <>= module function generic_event_get_particle_set_ptr (event) result (ptr) class(generic_event_t), intent(in) :: event type(particle_set_t), pointer :: ptr end function generic_event_get_particle_set_ptr <>= module function generic_event_get_particle_set_ptr (event) result (ptr) class(generic_event_t), intent(in) :: event type(particle_set_t), pointer :: ptr ptr => event%particle_set end function generic_event_get_particle_set_ptr @ %def generic_event_get_particle_set_ptr @ Let it point to some existing particle set: <>= procedure :: link_particle_set => generic_event_link_particle_set <>= module subroutine generic_event_link_particle_set (event, particle_set) class(generic_event_t), intent(inout) :: event type(particle_set_t), intent(in), target :: particle_set end subroutine generic_event_link_particle_set <>= module subroutine generic_event_link_particle_set (event, particle_set) class(generic_event_t), intent(inout) :: event type(particle_set_t), intent(in), target :: particle_set event%particle_set => particle_set call event%accept_particle_set () end subroutine generic_event_link_particle_set @ %def generic_event_link_particle_set @ \subsection{Access sqme and weight} There are several incarnations: the current value, a reference value, alternate values. <>= procedure :: sqme_prc_is_known => generic_event_sqme_prc_is_known procedure :: sqme_ref_is_known => generic_event_sqme_ref_is_known procedure :: sqme_alt_is_known => generic_event_sqme_alt_is_known procedure :: weight_prc_is_known => generic_event_weight_prc_is_known procedure :: weight_ref_is_known => generic_event_weight_ref_is_known procedure :: weight_alt_is_known => generic_event_weight_alt_is_known procedure :: excess_prc_is_known => generic_event_excess_prc_is_known <>= module function generic_event_sqme_prc_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag end function generic_event_sqme_prc_is_known module function generic_event_sqme_ref_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag end function generic_event_sqme_ref_is_known module function generic_event_sqme_alt_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag end function generic_event_sqme_alt_is_known module function generic_event_weight_prc_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag end function generic_event_weight_prc_is_known module function generic_event_weight_ref_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag end function generic_event_weight_ref_is_known module function generic_event_weight_alt_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag end function generic_event_weight_alt_is_known module function generic_event_excess_prc_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag end function generic_event_excess_prc_is_known <>= module function generic_event_sqme_prc_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag flag = event%sqme_prc_known end function generic_event_sqme_prc_is_known module function generic_event_sqme_ref_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag flag = event%sqme_ref_known end function generic_event_sqme_ref_is_known module function generic_event_sqme_alt_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag flag = event%sqme_alt_known end function generic_event_sqme_alt_is_known module function generic_event_weight_prc_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag flag = event%weight_prc_known end function generic_event_weight_prc_is_known module function generic_event_weight_ref_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag flag = event%weight_ref_known end function generic_event_weight_ref_is_known module function generic_event_weight_alt_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag flag = event%weight_alt_known end function generic_event_weight_alt_is_known module function generic_event_excess_prc_is_known (event) result (flag) class(generic_event_t), intent(in) :: event logical :: flag flag = event%excess_prc_known end function generic_event_excess_prc_is_known @ %def generic_event_sqme_prc_is_known @ %def generic_event_sqme_ref_is_known @ %def generic_event_sqme_alt_is_known @ %def generic_event_weight_prc_is_known @ %def generic_event_weight_ref_is_known @ %def generic_event_weight_alt_is_known @ %def generic_event_excess_prc_is_known @ <>= procedure :: get_n_alt => generic_event_get_n_alt <>= module function generic_event_get_n_alt (event) result (n) class(generic_event_t), intent(in) :: event integer :: n end function generic_event_get_n_alt <>= module function generic_event_get_n_alt (event) result (n) class(generic_event_t), intent(in) :: event integer :: n n = event%n_alt end function generic_event_get_n_alt @ %def generic_event_get_n_alt @ <>= procedure :: get_sqme_prc => generic_event_get_sqme_prc procedure :: get_sqme_ref => generic_event_get_sqme_ref generic :: get_sqme_alt => & generic_event_get_sqme_alt_0, generic_event_get_sqme_alt_1 procedure :: generic_event_get_sqme_alt_0 procedure :: generic_event_get_sqme_alt_1 procedure :: get_weight_prc => generic_event_get_weight_prc procedure :: get_weight_ref => generic_event_get_weight_ref generic :: get_weight_alt => & generic_event_get_weight_alt_0, generic_event_get_weight_alt_1 procedure :: generic_event_get_weight_alt_0 procedure :: generic_event_get_weight_alt_1 procedure :: get_n_dropped => generic_event_get_n_dropped procedure :: get_excess_prc => generic_event_get_excess_prc <>= module function generic_event_get_sqme_prc (event) result (sqme) class(generic_event_t), intent(in) :: event real(default) :: sqme end function generic_event_get_sqme_prc module function generic_event_get_sqme_ref (event) result (sqme) class(generic_event_t), intent(in) :: event real(default) :: sqme end function generic_event_get_sqme_ref module function generic_event_get_sqme_alt_0 (event, i) result (sqme) class(generic_event_t), intent(in) :: event integer, intent(in) :: i real(default) :: sqme end function generic_event_get_sqme_alt_0 module function generic_event_get_sqme_alt_1 (event) result (sqme) class(generic_event_t), intent(in) :: event real(default), dimension(event%n_alt) :: sqme end function generic_event_get_sqme_alt_1 module function generic_event_get_weight_prc (event) result (weight) class(generic_event_t), intent(in) :: event real(default) :: weight end function generic_event_get_weight_prc module function generic_event_get_weight_ref (event) result (weight) class(generic_event_t), intent(in) :: event real(default) :: weight end function generic_event_get_weight_ref module function generic_event_get_weight_alt_0 (event, i) result (weight) class(generic_event_t), intent(in) :: event integer, intent(in) :: i real(default) :: weight end function generic_event_get_weight_alt_0 module function generic_event_get_weight_alt_1 (event) result (weight) class(generic_event_t), intent(in) :: event real(default), dimension(event%n_alt) :: weight end function generic_event_get_weight_alt_1 module function generic_event_get_excess_prc (event) result (excess) class(generic_event_t), intent(in) :: event real(default) :: excess end function generic_event_get_excess_prc module function generic_event_get_n_dropped (event) result (n_dropped) class(generic_event_t), intent(in) :: event integer :: n_dropped end function generic_event_get_n_dropped <>= module function generic_event_get_sqme_prc (event) result (sqme) class(generic_event_t), intent(in) :: event real(default) :: sqme if (event%sqme_prc_known) then sqme = event%sqme_prc else sqme = 0 end if end function generic_event_get_sqme_prc module function generic_event_get_sqme_ref (event) result (sqme) class(generic_event_t), intent(in) :: event real(default) :: sqme if (event%sqme_ref_known) then sqme = event%sqme_ref else sqme = 0 end if end function generic_event_get_sqme_ref module function generic_event_get_sqme_alt_0 (event, i) result (sqme) class(generic_event_t), intent(in) :: event integer, intent(in) :: i real(default) :: sqme if (event%sqme_alt_known) then sqme = event%sqme_alt(i) else sqme = 0 end if end function generic_event_get_sqme_alt_0 module function generic_event_get_sqme_alt_1 (event) result (sqme) class(generic_event_t), intent(in) :: event real(default), dimension(event%n_alt) :: sqme sqme = event%sqme_alt end function generic_event_get_sqme_alt_1 module function generic_event_get_weight_prc (event) result (weight) class(generic_event_t), intent(in) :: event real(default) :: weight if (event%weight_prc_known) then weight = event%weight_prc else weight = 0 end if end function generic_event_get_weight_prc module function generic_event_get_weight_ref (event) result (weight) class(generic_event_t), intent(in) :: event real(default) :: weight if (event%weight_ref_known) then weight = event%weight_ref else weight = 0 end if end function generic_event_get_weight_ref module function generic_event_get_weight_alt_0 (event, i) result (weight) class(generic_event_t), intent(in) :: event integer, intent(in) :: i real(default) :: weight if (event%weight_alt_known) then weight = event%weight_alt(i) else weight = 0 end if end function generic_event_get_weight_alt_0 module function generic_event_get_weight_alt_1 (event) result (weight) class(generic_event_t), intent(in) :: event real(default), dimension(event%n_alt) :: weight weight = event%weight_alt end function generic_event_get_weight_alt_1 module function generic_event_get_excess_prc (event) result (excess) class(generic_event_t), intent(in) :: event real(default) :: excess if (event%excess_prc_known) then excess = event%excess_prc else excess = 0 end if end function generic_event_get_excess_prc module function generic_event_get_n_dropped (event) result (n_dropped) class(generic_event_t), intent(in) :: event integer :: n_dropped if (event%n_dropped_known) then n_dropped = event%n_dropped else n_dropped = 0 end if end function generic_event_get_n_dropped @ %def generic_event_get_sqme_prc @ %def generic_event_get_sqme_ref @ %def generic_event_get_sqme_alt @ %def generic_event_get_weight_prc @ %def generic_event_get_weight_ref @ %def generic_event_get_weight_alt @ %def generic_event_get_n_dropped @ %def generic_event_get_excess_prc @ <>= procedure :: set_sqme_prc => generic_event_set_sqme_prc procedure :: set_sqme_ref => generic_event_set_sqme_ref procedure :: set_sqme_alt => generic_event_set_sqme_alt procedure :: set_weight_prc => generic_event_set_weight_prc procedure :: set_weight_ref => generic_event_set_weight_ref procedure :: set_weight_alt => generic_event_set_weight_alt procedure :: set_excess_prc => generic_event_set_excess_prc procedure :: set_n_dropped => generic_event_set_n_dropped <>= module subroutine generic_event_set_sqme_prc (event, sqme) class(generic_event_t), intent(inout) :: event real(default), intent(in) :: sqme end subroutine generic_event_set_sqme_prc module subroutine generic_event_set_sqme_ref (event, sqme) class(generic_event_t), intent(inout) :: event real(default), intent(in) :: sqme end subroutine generic_event_set_sqme_ref module subroutine generic_event_set_sqme_alt (event, sqme) class(generic_event_t), intent(inout) :: event real(default), dimension(:), intent(in) :: sqme end subroutine generic_event_set_sqme_alt module subroutine generic_event_set_weight_prc (event, weight) class(generic_event_t), intent(inout) :: event real(default), intent(in) :: weight end subroutine generic_event_set_weight_prc module subroutine generic_event_set_weight_ref (event, weight) class(generic_event_t), intent(inout) :: event real(default), intent(in) :: weight end subroutine generic_event_set_weight_ref module subroutine generic_event_set_weight_alt (event, weight) class(generic_event_t), intent(inout) :: event real(default), dimension(:), intent(in) :: weight end subroutine generic_event_set_weight_alt module subroutine generic_event_set_excess_prc (event, excess) class(generic_event_t), intent(inout) :: event real(default), intent(in) :: excess end subroutine generic_event_set_excess_prc module subroutine generic_event_set_n_dropped (event, n_dropped) class(generic_event_t), intent(inout) :: event integer, intent(in) :: n_dropped end subroutine generic_event_set_n_dropped <>= module subroutine generic_event_set_sqme_prc (event, sqme) class(generic_event_t), intent(inout) :: event real(default), intent(in) :: sqme event%sqme_prc = sqme event%sqme_prc_known = .true. end subroutine generic_event_set_sqme_prc module subroutine generic_event_set_sqme_ref (event, sqme) class(generic_event_t), intent(inout) :: event real(default), intent(in) :: sqme event%sqme_ref = sqme event%sqme_ref_known = .true. end subroutine generic_event_set_sqme_ref module subroutine generic_event_set_sqme_alt (event, sqme) class(generic_event_t), intent(inout) :: event real(default), dimension(:), intent(in) :: sqme event%sqme_alt = sqme event%sqme_alt_known = .true. end subroutine generic_event_set_sqme_alt module subroutine generic_event_set_weight_prc (event, weight) class(generic_event_t), intent(inout) :: event real(default), intent(in) :: weight event%weight_prc = weight event%weight_prc_known = .true. end subroutine generic_event_set_weight_prc module subroutine generic_event_set_weight_ref (event, weight) class(generic_event_t), intent(inout) :: event real(default), intent(in) :: weight event%weight_ref = weight event%weight_ref_known = .true. end subroutine generic_event_set_weight_ref module subroutine generic_event_set_weight_alt (event, weight) class(generic_event_t), intent(inout) :: event real(default), dimension(:), intent(in) :: weight event%weight_alt = weight event%weight_alt_known = .true. end subroutine generic_event_set_weight_alt module subroutine generic_event_set_excess_prc (event, excess) class(generic_event_t), intent(inout) :: event real(default), intent(in) :: excess event%excess_prc = excess event%excess_prc_known = .true. end subroutine generic_event_set_excess_prc module subroutine generic_event_set_n_dropped (event, n_dropped) class(generic_event_t), intent(inout) :: event integer, intent(in) :: n_dropped event%n_dropped = n_dropped event%n_dropped_known = .true. end subroutine generic_event_set_n_dropped @ %def generic_event_set_sqme_prc @ %def generic_event_set_sqme_ref @ %def generic_event_set_sqme_alt @ %def generic_event_set_weight_prc @ %def generic_event_set_weight_ref @ %def generic_event_set_weight_alt @ %def generic_event_set_n_dropped @ Set the appropriate entry directly. <>= procedure :: set => generic_event_set <>= module subroutine generic_event_set (event, & weight_ref, weight_prc, weight_alt, & excess_prc, n_dropped, & sqme_ref, sqme_prc, sqme_alt) class(generic_event_t), intent(inout) :: event real(default), intent(in), optional :: weight_ref, weight_prc real(default), intent(in), optional :: sqme_ref, sqme_prc real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt real(default), intent(in), optional :: excess_prc integer, intent(in), optional :: n_dropped end subroutine generic_event_set <>= module subroutine generic_event_set (event, & weight_ref, weight_prc, weight_alt, & excess_prc, n_dropped, & sqme_ref, sqme_prc, sqme_alt) class(generic_event_t), intent(inout) :: event real(default), intent(in), optional :: weight_ref, weight_prc real(default), intent(in), optional :: sqme_ref, sqme_prc real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt real(default), intent(in), optional :: excess_prc integer, intent(in), optional :: n_dropped if (present (sqme_prc)) then call event%set_sqme_prc (sqme_prc) end if if (present (sqme_ref)) then call event%set_sqme_ref (sqme_ref) end if if (present (sqme_alt)) then call event%set_sqme_alt (sqme_alt) end if if (present (weight_prc)) then call event%set_weight_prc (weight_prc) end if if (present (weight_ref)) then call event%set_weight_ref (weight_ref) end if if (present (weight_alt)) then call event%set_weight_alt (weight_alt) end if if (present (excess_prc)) then call event%set_excess_prc (excess_prc) end if if (present (n_dropped)) then call event%set_n_dropped (n_dropped) end if end subroutine generic_event_set @ %def generic_event_set @ \subsection{Pure Virtual Methods} These procedures can only implemented in the concrete implementation. Output (verbose, depending on parameters). <>= procedure (generic_event_write), deferred :: write <>= abstract interface subroutine generic_event_write (object, unit, & show_process, show_transforms, & show_decay, verbose, testflag) import class(generic_event_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: show_process logical, intent(in), optional :: show_transforms logical, intent(in), optional :: show_decay logical, intent(in), optional :: verbose logical, intent(in), optional :: testflag end subroutine generic_event_write end interface @ %def generic_event_write @ Generate an event, based on a selector index [[i_mci]], and optionally on an extra set of random numbers [[r]]. For the main bunch of random numbers that the generator needs, the event object should contain its own generator. <>= procedure (generic_event_generate), deferred :: generate <>= abstract interface subroutine generic_event_generate (event, i_mci, r, i_nlo) import class(generic_event_t), intent(inout) :: event integer, intent(in) :: i_mci real(default), dimension(:), intent(in), optional :: r integer, intent(in), optional :: i_nlo end subroutine generic_event_generate end interface @ %def event_generate @ Alternative : inject a particle set that is supposed to represent the hard process. How this determines the event, is dependent on the event structure, therefore this is a deferred method. <>= procedure (generic_event_set_hard_particle_set), deferred :: & set_hard_particle_set <>= abstract interface subroutine generic_event_set_hard_particle_set (event, particle_set) import class(generic_event_t), intent(inout) :: event type(particle_set_t), intent(in) :: particle_set end subroutine generic_event_set_hard_particle_set end interface @ %def generic_event_set_hard_particle_set @ Event index handlers. <>= procedure (generic_event_set_index), deferred :: set_index procedure (generic_event_handler), deferred :: reset_index procedure (generic_event_increment_index), deferred :: increment_index @ <>= abstract interface subroutine generic_event_set_index (event, index) import class(generic_event_t), intent(inout) :: event integer, intent(in) :: index end subroutine generic_event_set_index end interface abstract interface subroutine generic_event_handler (event) import class(generic_event_t), intent(inout) :: event end subroutine generic_event_handler end interface abstract interface subroutine generic_event_increment_index (event, offset) import class(generic_event_t), intent(inout) :: event integer, intent(in), optional :: offset end subroutine generic_event_increment_index end interface @ %def generic_event_set_index @ %def generic_event_increment_index @ %def generic_event_handler @ Evaluate any expressions associated with the event. No argument needed. <>= procedure (generic_event_handler), deferred :: evaluate_expressions @ Select internal parameters <>= procedure (generic_event_select), deferred :: select <>= abstract interface subroutine generic_event_select (event, i_mci, i_term, channel) import class(generic_event_t), intent(inout) :: event integer, intent(in) :: i_mci, i_term, channel end subroutine generic_event_select end interface @ %def generic_event_select @ Return a pointer to the model for the currently active process. <>= procedure (generic_event_get_model_ptr), deferred :: get_model_ptr <>= abstract interface function generic_event_get_model_ptr (event) result (model) import class(generic_event_t), intent(in) :: event class(model_data_t), pointer :: model end function generic_event_get_model_ptr end interface @ %def generic_event_get_model_ptr @ Return data used by external event formats. <>= procedure (generic_event_has_index), deferred :: has_index procedure (generic_event_get_index), deferred :: get_index procedure (generic_event_get_fac_scale), deferred :: get_fac_scale procedure (generic_event_get_alpha_s), deferred :: get_alpha_s procedure (generic_event_get_sqrts), deferred :: get_sqrts procedure (generic_event_get_polarization), deferred :: get_polarization procedure (generic_event_get_beam_file), deferred :: get_beam_file procedure (generic_event_get_process_name), deferred :: & get_process_name <>= abstract interface function generic_event_has_index (event) result (flag) import class(generic_event_t), intent(in) :: event logical :: flag end function generic_event_has_index end interface abstract interface function generic_event_get_index (event) result (index) import class(generic_event_t), intent(in) :: event integer :: index end function generic_event_get_index end interface abstract interface function generic_event_get_fac_scale (event) result (fac_scale) import class(generic_event_t), intent(in) :: event real(default) :: fac_scale end function generic_event_get_fac_scale end interface abstract interface function generic_event_get_alpha_s (event) result (alpha_s) import class(generic_event_t), intent(in) :: event real(default) :: alpha_s end function generic_event_get_alpha_s end interface abstract interface function generic_event_get_sqrts (event) result (sqrts) import class(generic_event_t), intent(in) :: event real(default) :: sqrts end function generic_event_get_sqrts end interface abstract interface function generic_event_get_polarization (event) result (pol) import class(generic_event_t), intent(in) :: event real(default), dimension(:), allocatable :: pol end function generic_event_get_polarization end interface abstract interface function generic_event_get_beam_file (event) result (file) import class(generic_event_t), intent(in) :: event type(string_t) :: file end function generic_event_get_beam_file end interface abstract interface function generic_event_get_process_name (event) result (name) import class(generic_event_t), intent(in) :: event type(string_t) :: name end function generic_event_get_process_name end interface @ %def generic_event_get_index @ %def generic_event_get_fac_scale @ %def generic_event_get_alpha_s @ %def generic_event_get_sqrts @ %def generic_event_get_polarization @ %def generic_event_get_beam_file @ %def generic_event_get_process_name @ Set data used by external event formats. <>= procedure (generic_event_set_alpha_qcd_forced), deferred :: & set_alpha_qcd_forced procedure (generic_event_set_scale_forced), deferred :: & set_scale_forced <>= abstract interface subroutine generic_event_set_alpha_qcd_forced (event, alpha_qcd) import class(generic_event_t), intent(inout) :: event real(default), intent(in) :: alpha_qcd end subroutine generic_event_set_alpha_qcd_forced end interface abstract interface subroutine generic_event_set_scale_forced (event, scale) import class(generic_event_t), intent(inout) :: event real(default), intent(in) :: scale end subroutine generic_event_set_scale_forced end interface @ %def generic_event_set_alpha_qcd_forced @ %def generic_event_set_scale_forced @ \subsection{Utilities} Applying this, current event contents are marked as incomplete but are not deleted. In particular, the initialization is kept. <>= procedure :: reset_contents => generic_event_reset_contents procedure :: base_reset_contents => generic_event_reset_contents <>= module subroutine generic_event_reset_contents (event) class(generic_event_t), intent(inout) :: event end subroutine generic_event_reset_contents <>= module subroutine generic_event_reset_contents (event) class(generic_event_t), intent(inout) :: event call event%discard_particle_set () event%sqme_ref_known = .false. event%sqme_prc_known = .false. event%sqme_alt_known = .false. event%weight_ref_known = .false. event%weight_prc_known = .false. event%weight_alt_known = .false. event%excess_prc_known = .false. end subroutine generic_event_reset_contents @ %def generic_event_reset_contents @ Pacify particle set. <>= procedure :: pacify_particle_set => generic_event_pacify_particle_set <>= module subroutine generic_event_pacify_particle_set (event) class(generic_event_t), intent(inout) :: event end subroutine generic_event_pacify_particle_set <>= module subroutine generic_event_pacify_particle_set (event) class(generic_event_t), intent(inout) :: event if (event%has_valid_particle_set ()) call pacify (event%particle_set) end subroutine generic_event_pacify_particle_set @ %def generic_event_pacify_particle_set @ \subsection{Event normalization} The parameters for event normalization. For unweighted events, [[NORM_UNIT]] is intended as default, while for weighted events, it is [[NORM_SIGMA]]. Note: the unit test for this is in [[eio_data_2]] below. <>= integer, parameter, public :: NORM_UNDEFINED = 0 integer, parameter, public :: NORM_UNIT = 1 integer, parameter, public :: NORM_N_EVT = 2 integer, parameter, public :: NORM_SIGMA = 3 integer, parameter, public :: NORM_S_N = 4 @ %def NORM_UNDEFINED NORM_UNIT NORM_N_EVT NORM_SIGMA NORM_S_N @ These functions translate between the user representation and the internal one. <>= public :: event_normalization_mode public :: event_normalization_string <>= module function event_normalization_mode (string, unweighted) result (mode) integer :: mode type(string_t), intent(in) :: string logical, intent(in) :: unweighted end function event_normalization_mode module function event_normalization_string (norm_mode) result (string) integer, intent(in) :: norm_mode type(string_t) :: string end function event_normalization_string <>= module function event_normalization_mode (string, unweighted) result (mode) integer :: mode type(string_t), intent(in) :: string logical, intent(in) :: unweighted select case (lower_case (char (string))) case ("auto") if (unweighted) then mode = NORM_UNIT else mode = NORM_SIGMA end if case ("1") mode = NORM_UNIT case ("1/n") mode = NORM_N_EVT case ("sigma") mode = NORM_SIGMA case ("sigma/n") mode = NORM_S_N case default call msg_fatal ("Event normalization: unknown value '" & // char (string) // "'") end select end function event_normalization_mode module function event_normalization_string (norm_mode) result (string) integer, intent(in) :: norm_mode type(string_t) :: string select case (norm_mode) case (NORM_UNDEFINED); string = "[undefined]" case (NORM_UNIT); string = "'1'" case (NORM_N_EVT); string = "'1/n'" case (NORM_SIGMA); string = "'sigma'" case (NORM_S_N); string = "'sigma/n'" case default; string = "???" end select end function event_normalization_string @ %def event_normalization_mode @ %def event_normalization_string @ We place this here as a generic helper, so we can update event weights whenever we need, not just in connection with an event sample data object. <>= public :: event_normalization_update <>= module subroutine event_normalization_update & (weight, sigma, n, mode_new, mode_old) real(default), intent(inout) :: weight real(default), intent(in) :: sigma integer, intent(in) :: n integer, intent(in) :: mode_new, mode_old end subroutine event_normalization_update <>= module subroutine event_normalization_update & (weight, sigma, n, mode_new, mode_old) real(default), intent(inout) :: weight real(default), intent(in) :: sigma integer, intent(in) :: n integer, intent(in) :: mode_new, mode_old if (mode_new /= mode_old) then if (sigma > 0 .and. n > 0) then weight = weight / factor (mode_old) * factor (mode_new) else call msg_fatal ("Event normalization update: null sample") end if end if contains function factor (mode) real(default) :: factor integer, intent(in) :: mode select case (mode) case (NORM_UNIT); factor = 1._default case (NORM_N_EVT); factor = 1._default / n case (NORM_SIGMA); factor = sigma case (NORM_S_N); factor = sigma / n case default call msg_fatal ("Event normalization update: undefined mode") end select end function factor end subroutine event_normalization_update @ %def event_normalization_update @ \subsection{Callback container} This derived type contains a callback procedure that can be executed during event I/O. The callback procedure is given the event object (with class [[generic_event]]) and an event index. This is a simple wrapper. The object is abstract, so the the actual procedure is introduced by overriding the deferred one. We use the PASS attribute, so we may supplement runtime data in the callback object if desired. <>= public :: event_callback_t <>= type, abstract :: event_callback_t private contains procedure(event_callback_write), deferred :: write procedure(event_callback_proc), deferred :: proc end type event_callback_t @ %def event_callback_t @ Identify the callback procedure in output <>= abstract interface subroutine event_callback_write (event_callback, unit) import class(event_callback_t), intent(in) :: event_callback integer, intent(in), optional :: unit end subroutine event_callback_write end interface @ %def event_callback_write @ This is the procedure interface. <>= abstract interface subroutine event_callback_proc (event_callback, i, event) import class(event_callback_t), intent(in) :: event_callback integer(i64), intent(in) :: i class(generic_event_t), intent(in) :: event end subroutine event_callback_proc end interface @ %def event_callback_proc @ A dummy implementation for testing and fallback. <>= public :: event_callback_nop_t <>= type, extends (event_callback_t) :: event_callback_nop_t private contains procedure :: write => event_callback_nop_write procedure :: proc => event_callback_nop end type event_callback_nop_t @ %def event_callback_t <>= module subroutine event_callback_nop_write (event_callback, unit) class(event_callback_nop_t), intent(in) :: event_callback integer, intent(in), optional :: unit end subroutine event_callback_nop_write module subroutine event_callback_nop (event_callback, i, event) class(event_callback_nop_t), intent(in) :: event_callback integer(i64), intent(in) :: i class(generic_event_t), intent(in) :: event end subroutine event_callback_nop <>= module subroutine event_callback_nop_write (event_callback, unit) class(event_callback_nop_t), intent(in) :: event_callback integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "NOP" end subroutine event_callback_nop_write module subroutine event_callback_nop (event_callback, i, event) class(event_callback_nop_t), intent(in) :: event_callback integer(i64), intent(in) :: i class(generic_event_t), intent(in) :: event end subroutine event_callback_nop @ %def event_callback_nop_write @ %def event_callback_nop @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Event Handle} This module defines an abstract base type that allows us to communicate any type of event record within the program. The concrete extensions are expected to consist of pointers, such as the C pointers for HepMC or LCIO events, so the communication object is a very light-weight one. <<[[event_handles.f90]]>>= <> module event_handles <> <> <> end module event_handles @ %def event_handles @ There is only one abstract type. <>= public :: event_handle_t <>= type, abstract :: event_handle_t end type event_handle_t @ %def event_handle_t @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Event Sample Data} We define a simple and transparent container for (meta)data that are associated with an event sample. <<[[eio_data.f90]]>>= <> module eio_data <> <> use event_base <> <> <> interface <> end interface end module eio_data @ %def eio_data @ <<[[eio_data_sub.f90]]>>= <> submodule (eio_data) eio_data_s use io_units use numeric_utils use diagnostics implicit none contains <> end submodule eio_data_s @ %def eio_data_s @ \subsection{Event Sample Data} These are data that apply to an event sample as a whole. They are given in an easily portable form (no fancy structure) and are used for initializing event formats. There are two MD5 sums here. [[md5sum_proc]] depends only on the definition of the contributing processes. A sample with matching checksum can be rescanned with modified model parameters, beam structure etc, to recalculate observables. [[md5sum_config]] includes all relevant data. Rescanning a sample with matching checksum will produce identical observables. (A third checksum might be added which depends on the event sample itself. This is not needed, so far.) If alternate weights are part of the event sample ([[n_alt]] nonzero), there is a configuration MD5 sum for each of them. <>= public :: event_sample_data_t <>= type :: event_sample_data_t character(32) :: md5sum_prc = "" character(32) :: md5sum_cfg = "" logical :: unweighted = .true. logical :: negative_weights = .false. integer :: norm_mode = NORM_UNDEFINED integer :: n_beam = 0 integer, dimension(2) :: pdg_beam = 0 real(default), dimension(2) :: energy_beam = 0 integer :: n_proc = 0 integer :: n_evt = 0 integer :: nlo_multiplier = 1 integer :: split_n_evt = 0 integer :: split_n_kbytes = 0 integer :: split_index = 0 real(default) :: total_cross_section = 0 integer, dimension(:), allocatable :: proc_num_id integer :: n_alt = 0 character(32), dimension(:), allocatable :: md5sum_alt real(default), dimension(:), allocatable :: cross_section real(default), dimension(:), allocatable :: error contains <> end type event_sample_data_t @ %def event_sample_data_t @ Initialize: allocate for the number of processes <>= procedure :: init => event_sample_data_init <>= module subroutine event_sample_data_init (data, n_proc, n_alt) class(event_sample_data_t), intent(out) :: data integer, intent(in) :: n_proc integer, intent(in), optional :: n_alt end subroutine event_sample_data_init <>= module subroutine event_sample_data_init (data, n_proc, n_alt) class(event_sample_data_t), intent(out) :: data integer, intent(in) :: n_proc integer, intent(in), optional :: n_alt data%n_proc = n_proc allocate (data%proc_num_id (n_proc), source = 0) allocate (data%cross_section (n_proc), source = 0._default) allocate (data%error (n_proc), source = 0._default) if (present (n_alt)) then data%n_alt = n_alt allocate (data%md5sum_alt (n_alt)) data%md5sum_alt = "" end if end subroutine event_sample_data_init @ %def event_sample_data_init @ Output. <>= procedure :: write => event_sample_data_write <>= module subroutine event_sample_data_write (data, unit) class(event_sample_data_t), intent(in) :: data integer, intent(in), optional :: unit end subroutine event_sample_data_write <>= module subroutine event_sample_data_write (data, unit) class(event_sample_data_t), intent(in) :: data integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Event sample properties:" write (u, "(3x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'" write (u, "(3x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'" write (u, "(3x,A,L1)") "unweighted = ", data%unweighted write (u, "(3x,A,L1)") "negative weights = ", data%negative_weights write (u, "(3x,A,A)") "normalization = ", & char (event_normalization_string (data%norm_mode)) write (u, "(3x,A,I0)") "number of beams = ", data%n_beam write (u, "(5x,A,2(1x,I19))") "PDG = ", & data%pdg_beam(:data%n_beam) write (u, "(5x,A,2(1x,ES19.12))") "Energy = ", & data%energy_beam(:data%n_beam) if (data%n_evt > 0) then write (u, "(3x,A,I0)") "number of events = ", data%n_evt end if if (.not. vanishes (data%total_cross_section)) then write (u, "(3x,A,ES19.12)") "total cross sec. = ", & data%total_cross_section end if write (u, "(3x,A,I0)") "num of processes = ", data%n_proc do i = 1, data%n_proc write (u, "(3x,A,I0)") "Process #", data%proc_num_id (i) select case (data%n_beam) case (1) write (u, "(5x,A,ES19.12)") "Width = ", data%cross_section(i) case (2) write (u, "(5x,A,ES19.12)") "CSec = ", data%cross_section(i) end select write (u, "(5x,A,ES19.12)") "Error = ", data%error(i) end do if (data%n_alt > 0) then write (u, "(3x,A,I0)") "num of alt wgt = ", data%n_alt do i = 1, data%n_alt write (u, "(5x,A,A,A,1x,I0)") "MD5 sum (cfg) = '", & data%md5sum_alt(i), "'", i end do end if end subroutine event_sample_data_write @ %def event_sample_data_write @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_data_ut.f90]]>>= <> module eio_data_ut use unit_tests use eio_data_uti <> <> contains <> end module eio_data_ut @ %def eio_data_ut @ <<[[eio_data_uti.f90]]>>= <> module eio_data_uti <> <> use event_base use eio_data <> <> contains <> end module eio_data_uti @ %def eio_data_ut @ API: driver for the unit tests below. <>= public :: eio_data_test <>= subroutine eio_data_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_data_test @ %def eio_data_test @ \subsubsection{Event Sample Data} Print the contents of a sample data block. <>= call test (eio_data_1, "eio_data_1", & "event sample data", & u, results) <>= public :: eio_data_1 <>= subroutine eio_data_1 (u) integer, intent(in) :: u type(event_sample_data_t) :: data write (u, "(A)") "* Test output: eio_data_1" write (u, "(A)") "* Purpose: display event sample data" write (u, "(A)") write (u, "(A)") "* Decay process, one component" write (u, "(A)") call data%init (1, 1) data%n_beam = 1 data%pdg_beam(1) = 25 data%energy_beam(1) = 125 data%norm_mode = NORM_UNIT data%proc_num_id = [42] data%cross_section = [1.23e-4_default] data%error = 5e-6_default data%md5sum_prc = "abcdefghijklmnopabcdefghijklmnop" data%md5sum_cfg = "12345678901234561234567890123456" data%md5sum_alt(1) = "uuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuu" call data%write (u) write (u, "(A)") write (u, "(A)") "* Scattering process, two components" write (u, "(A)") call data%init (2) data%n_beam = 2 data%pdg_beam = [2212, -2212] data%energy_beam = [8._default, 10._default] data%norm_mode = NORM_SIGMA data%proc_num_id = [12, 34] data%cross_section = [100._default, 88._default] data%error = [1._default, 0.1_default] call data%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: eio_data_1" end subroutine eio_data_1 @ %def eio_data_1 @ \subsubsection{Event Normalization} Check the functions for translating modes and updating weights. <>= call test (eio_data_2, "eio_data_2", & "event normalization", & u, results) <>= public :: eio_data_2 <>= subroutine eio_data_2 (u) integer, intent(in) :: u type(string_t) :: s logical :: unweighted real(default) :: w, w0, sigma integer :: n write (u, "(A)") "* Test output: eio_data_2" write (u, "(A)") "* Purpose: handle event normalization" write (u, "(A)") write (u, "(A)") "* Normalization strings" write (u, "(A)") s = "auto" unweighted = .true. write (u, "(1x,A,1x,L1,1x,A)") char (s), unweighted, & char (event_normalization_string & (event_normalization_mode (s, unweighted))) s = "AUTO" unweighted = .false. write (u, "(1x,A,1x,L1,1x,A)") char (s), unweighted, & char (event_normalization_string & (event_normalization_mode (s, unweighted))) unweighted = .true. s = "1" write (u, "(2(1x,A))") char (s), char (event_normalization_string & (event_normalization_mode (s, unweighted))) s = "1/n" write (u, "(2(1x,A))") char (s), char (event_normalization_string & (event_normalization_mode (s, unweighted))) s = "Sigma" write (u, "(2(1x,A))") char (s), char (event_normalization_string & (event_normalization_mode (s, unweighted))) s = "sigma/N" write (u, "(2(1x,A))") char (s), char (event_normalization_string & (event_normalization_mode (s, unweighted))) write (u, "(A)") write (u, "(A)") "* Normalization update" write (u, "(A)") sigma = 5 n = 2 w0 = 1 w = w0 call event_normalization_update (w, sigma, n, NORM_UNIT, NORM_UNIT) write (u, "(2(F6.3))") w0, w w = w0 call event_normalization_update (w, sigma, n, NORM_N_EVT, NORM_UNIT) write (u, "(2(F6.3))") w0, w w = w0 call event_normalization_update (w, sigma, n, NORM_SIGMA, NORM_UNIT) write (u, "(2(F6.3))") w0, w w = w0 call event_normalization_update (w, sigma, n, NORM_S_N, NORM_UNIT) write (u, "(2(F6.3))") w0, w write (u, *) w0 = 0.5 w = w0 call event_normalization_update (w, sigma, n, NORM_UNIT, NORM_N_EVT) write (u, "(2(F6.3))") w0, w w = w0 call event_normalization_update (w, sigma, n, NORM_N_EVT, NORM_N_EVT) write (u, "(2(F6.3))") w0, w w = w0 call event_normalization_update (w, sigma, n, NORM_SIGMA, NORM_N_EVT) write (u, "(2(F6.3))") w0, w w = w0 call event_normalization_update (w, sigma, n, NORM_S_N, NORM_N_EVT) write (u, "(2(F6.3))") w0, w write (u, *) w0 = 5.0 w = w0 call event_normalization_update (w, sigma, n, NORM_UNIT, NORM_SIGMA) write (u, "(2(F6.3))") w0, w w = w0 call event_normalization_update (w, sigma, n, NORM_N_EVT, NORM_SIGMA) write (u, "(2(F6.3))") w0, w w = w0 call event_normalization_update (w, sigma, n, NORM_SIGMA, NORM_SIGMA) write (u, "(2(F6.3))") w0, w w = w0 call event_normalization_update (w, sigma, n, NORM_S_N, NORM_SIGMA) write (u, "(2(F6.3))") w0, w write (u, *) w0 = 2.5 w = w0 call event_normalization_update (w, sigma, n, NORM_UNIT, NORM_S_N) write (u, "(2(F6.3))") w0, w w = w0 call event_normalization_update (w, sigma, n, NORM_N_EVT, NORM_S_N) write (u, "(2(F6.3))") w0, w w = w0 call event_normalization_update (w, sigma, n, NORM_SIGMA, NORM_S_N) write (u, "(2(F6.3))") w0, w w = w0 call event_normalization_update (w, sigma, n, NORM_S_N, NORM_S_N) write (u, "(2(F6.3))") w0, w write (u, "(A)") write (u, "(A)") "* Test output end: eio_data_2" end subroutine eio_data_2 @ %def eio_data_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Abstract I/O Handler} This module defines an abstract object for event I/O and the associated methods. There are [[output]] and [[input]] methods which write or read a single event from/to the I/O stream, respectively. The I/O stream itself may be a file, a common block, or an externally linked structure, depending on the concrete implementation. A [[write]] method prints the current content of the implementation-dependent event record in human-readable form. The [[init_in]]/[[init_out]] and [[final]] prepare and finalize the I/O stream, respectively. There is also a [[switch_inout]] method which turns an input stream into an output stream where events can be appended. Optionally, output files can be split in chunks of well-defined size. The [[split_out]] method takes care of this. <<[[eio_base.f90]]>>= <> module eio_base use kinds, only: i64 <> use model_data use event_base use event_handles, only: event_handle_t use eio_data <> <> <> <> interface <> end interface end module eio_base @ %def eio_base @ <<[[eio_base_sub.f90]]>>= <> submodule (eio_base) eio_base_s use io_units use diagnostics implicit none contains <> end submodule eio_base_s @ %def eio_base_s @ \subsection{Type} We can assume that most implementations will need the file extension as a fixed string and, if they support file splitting, the current file index. The fallback model is useful for implementations that are able to read unknown files which may contain hadrons etc., not in the current hard-interaction model. <>= public :: eio_t <>= type, abstract :: eio_t type(string_t) :: sample type(string_t) :: extension type(string_t) :: filename logical :: has_file = .false. logical :: split = .false. integer :: split_n_evt = 0 integer :: split_n_kbytes = 0 integer :: split_index = 0 integer :: split_count = 0 class(model_data_t), pointer :: fallback_model => null () contains <> end type eio_t @ %def eio_t @ Write to screen. If possible, this should display the contents of the current event, i.e., the last one that was written or read. <>= procedure (eio_write), deferred :: write <>= abstract interface subroutine eio_write (object, unit) import class(eio_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine eio_write end interface @ %def eio_write @ Finalize. This should write/read footer data and close input/output channels. <>= procedure (eio_final), deferred :: final <>= abstract interface subroutine eio_final (object) import class(eio_t), intent(inout) :: object end subroutine eio_final end interface @ %def eio_final @ Determine splitting parameters from the event sample data. <>= procedure :: set_splitting => eio_set_splitting <>= module subroutine eio_set_splitting (eio, data) class(eio_t), intent(inout) :: eio type(event_sample_data_t), intent(in) :: data end subroutine eio_set_splitting <>= module subroutine eio_set_splitting (eio, data) class(eio_t), intent(inout) :: eio type(event_sample_data_t), intent(in) :: data eio%split = data%split_n_evt > 0 .or. data%split_n_kbytes > 0 if (eio%split) then eio%split_n_evt = data%split_n_evt eio%split_n_kbytes = data%split_n_kbytes eio%split_index = data%split_index eio%split_count = 0 end if end subroutine eio_set_splitting @ %def eio_set_splitting @ Update the byte count and check if it has increased. We use integer division to determine the number of [[n_kbytes]] blocks that are in the event file. <>= procedure :: update_split_count => eio_update_split_count <>= module subroutine eio_update_split_count (eio, increased) class(eio_t), intent(inout) :: eio logical, intent(out) :: increased end subroutine eio_update_split_count <>= module subroutine eio_update_split_count (eio, increased) class(eio_t), intent(inout) :: eio logical, intent(out) :: increased integer :: split_count_old if (eio%split_n_kbytes > 0) then split_count_old = eio%split_count eio%split_count = eio%file_size_kbytes () / eio%split_n_kbytes increased = eio%split_count > split_count_old end if end subroutine eio_update_split_count @ %def eio_update_split_count @ Generate a filename, taking a possible split index into account. <>= procedure :: set_filename => eio_set_filename <>= module subroutine eio_set_filename (eio) class(eio_t), intent(inout) :: eio end subroutine eio_set_filename <>= module subroutine eio_set_filename (eio) class(eio_t), intent(inout) :: eio character(32) :: buffer if (eio%split) then write (buffer, "(I0,'.')") eio%split_index eio%filename = eio%sample // "." // trim (buffer) // eio%extension eio%has_file = .true. else eio%filename = eio%sample // "." // eio%extension eio%has_file = .true. end if end subroutine eio_set_filename @ %def eio_set_filename @ Set the fallback model. <>= procedure :: set_fallback_model => eio_set_fallback_model <>= module subroutine eio_set_fallback_model (eio, model) class(eio_t), intent(inout) :: eio class(model_data_t), intent(in), target :: model end subroutine eio_set_fallback_model <>= module subroutine eio_set_fallback_model (eio, model) class(eio_t), intent(inout) :: eio class(model_data_t), intent(in), target :: model eio%fallback_model => model end subroutine eio_set_fallback_model @ %def eio_set_fallback_model @ Initialize for output. We provide process names. This should open an event file if appropriate and write header data. Some methods may require event sample data. <>= procedure (eio_init_out), deferred :: init_out <>= abstract interface subroutine eio_init_out (eio, sample, data, success, extension) import class(eio_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success type(string_t), intent(in), optional :: extension end subroutine eio_init_out end interface @ %def eio_init_out @ Initialize for input. We provide process names. This should open an event file if appropriate and read header data. The [[md5sum]] can be used to check the integrity of the configuration, it it provides a checksum to compare with. In case the extension has changed the extension is also given as an argument. The [[data]] argument is [[intent(inout)]]: we may read part of it and keep other parts and/or check them against the data in the file. <>= procedure (eio_init_in), deferred :: init_in <>= abstract interface subroutine eio_init_in (eio, sample, data, success, extension) import class(eio_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success type(string_t), intent(in), optional :: extension end subroutine eio_init_in end interface @ %def eio_init_in @ Re-initialize for output. This should change the status of any event file from input to output and position it for appending new events. <>= procedure (eio_switch_inout), deferred :: switch_inout <>= abstract interface subroutine eio_switch_inout (eio, success) import class(eio_t), intent(inout) :: eio logical, intent(out), optional :: success end subroutine eio_switch_inout end interface @ %def eio_switch_inout @ This is similar: split the output, i.e., close the current file and open a new one. The default implementation does nothing. For the feature to work, an implementation must override this. <>= procedure :: split_out => eio_split_out <>= module subroutine eio_split_out (eio) class(eio_t), intent(inout) :: eio end subroutine eio_split_out <>= module subroutine eio_split_out (eio) class(eio_t), intent(inout) :: eio end subroutine eio_split_out @ %def eio_split_out @ Determine the file size in kilobytes. More exactly, determine the size in units of 1024 storage units, as returned by the INQUIRE statement. The implementation returns zero if there is no file. The [[has_file]] flag is set by the [[set_filename]] method, so we can be confident that the [[inquire]] call is meaningful. If this algorithm doesn't apply for a particular format, we still can override the procedure. <>= procedure :: file_size_kbytes => eio_file_size_kbytes <>= module function eio_file_size_kbytes (eio) result (kbytes) class(eio_t), intent(in) :: eio integer :: kbytes end function eio_file_size_kbytes <>= module function eio_file_size_kbytes (eio) result (kbytes) class(eio_t), intent(in) :: eio integer :: kbytes integer(i64) :: bytes if (eio%has_file) then inquire (file = char (eio%filename), size = bytes) if (bytes > 0) then kbytes = bytes / 1024 else kbytes = 0 end if else kbytes = 0 end if end function eio_file_size_kbytes @ %def eio_file_size_kbytes @ Output an event. All data can be taken from the [[event]] record. The index [[i_prc]] identifies the process among the processes that are contained in the current sample. The [[reading]] flag, if present, indicates that the event was read from file, not generated. The [[passed]] flag tells us that this event has passed the selection criteria. Depending on the event format, we may choose to skip events that have not passed. <>= procedure (eio_output), deferred :: output <>= abstract interface subroutine eio_output & (eio, event, i_prc, reading, passed, pacify, event_handle) import class(eio_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_output end interface @ %def eio_output @ Input an event. This should fill all event data that cannot be inferred from the associated process. The input is broken down into two parts. First we read the [[i_prc]] index. So we know which process to expect in the subsequent event. If we have reached end of file, we also will know. Then, we read the event itself. The parameter [[iostat]] is supposed to be set as the Fortran standard requires, negative for EOF and positive for error. <>= procedure (eio_input_i_prc), deferred :: input_i_prc procedure (eio_input_event), deferred :: input_event <>= abstract interface subroutine eio_input_i_prc (eio, i_prc, iostat) import class(eio_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat end subroutine eio_input_i_prc end interface abstract interface subroutine eio_input_event (eio, event, iostat, event_handle) import class(eio_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_input_event end interface @ %def eio_input @ <>= procedure (eio_skip), deferred :: skip <>= abstract interface subroutine eio_skip (eio, iostat) import class(eio_t), intent(inout) :: eio integer, intent(out) :: iostat end subroutine eio_skip end interface @ %def eio_skip @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_base_ut.f90]]>>= <> module eio_base_ut use unit_tests use eio_base_uti <> <> <> contains <> end module eio_base_ut @ %def eio_base_ut @ <<[[eio_base_uti.f90]]>>= <> module eio_base_uti <> <> use io_units use lorentz use model_data use particles use event_base use event_handles, only: event_handle_t use eio_data use eio_base <> <> <> <> <> contains <> <> end module eio_base_uti @ %def eio_base_ut @ API: driver for the unit tests below. <>= public :: eio_base_test <>= subroutine eio_base_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_base_test @ %def eio_base_test @ The caller has to provide procedures that prepare and cleanup the test environment. They depend on modules that are not available here. <>= abstract interface subroutine eio_prepare_event (event, unweighted, n_alt, sample_norm) import class(generic_event_t), intent(inout), pointer :: event logical, intent(in), optional :: unweighted integer, intent(in), optional :: n_alt type(string_t), intent(in), optional :: sample_norm end subroutine eio_prepare_event end interface abstract interface subroutine eio_cleanup_event (event) import class(generic_event_t), intent(inout), pointer :: event end subroutine eio_cleanup_event end interface @ We store pointers to the test-environment handlers as module variables. This allows us to call them from the test routines themselves, which don't allow for extra arguments. <>= public :: eio_prepare_test, eio_cleanup_test <>= procedure(eio_prepare_event), pointer :: eio_prepare_test => null () procedure(eio_cleanup_event), pointer :: eio_cleanup_test => null () @ %def eio_prepare_test eio_cleanup_test @ Similarly, for the fallback (hadron) model that some eio tests require: <>= abstract interface subroutine eio_prepare_model (model) import class(model_data_t), intent(inout), pointer :: model end subroutine eio_prepare_model end interface abstract interface subroutine eio_cleanup_model (model) import class(model_data_t), intent(inout), target :: model end subroutine eio_cleanup_model end interface <>= public :: eio_prepare_fallback_model, eio_cleanup_fallback_model <>= procedure(eio_prepare_model), pointer :: eio_prepare_fallback_model => null () procedure(eio_cleanup_model), pointer :: eio_cleanup_fallback_model => null () @ %def eio_prepare_fallback_model eio_cleanup_fallback_model @ \subsubsection{Test type for event I/O} The contents simulate the contents of an external file. We have the [[sample]] string as the file name and the array of momenta [[event_p]] as the list of events. The second index is the event index. The [[event_i]] component is the pointer to the current event, [[event_n]] is the total number of stored events. <>= type, extends (eio_t) :: eio_test_t integer :: event_n = 0 integer :: event_i = 0 integer :: i_prc = 0 type(vector4_t), dimension(:,:), allocatable :: event_p contains <> end type eio_test_t @ %def eio_test_t @ Write to screen. Pretend that this is an actual event format. <>= procedure :: write => eio_test_write <>= subroutine eio_test_write (object, unit) class(eio_test_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "Test event stream" if (object%event_i /= 0) then write (u, "(1x,A,I0,A)") "Event #", object%event_i, ":" do i = 1, size (object%event_p, 1) call vector4_write (object%event_p(i, object%event_i), u) end do end if end subroutine eio_test_write @ %def eio_test_write @ Finalizer. For the test case, we just reset the event count, but keep the stored ``events''. For the real implementations, the events would be stored on an external medium, so we would delete the object contents. <>= procedure :: final => eio_test_final <>= subroutine eio_test_final (object) class(eio_test_t), intent(inout) :: object object%event_i = 0 end subroutine eio_test_final @ %def eio_test_final @ Initialization: We store the process IDs and the energy from the beam-data object. We also allocate the momenta (i.e., the simulated event record) for a fixed maximum size of 10 events, 2 momenta each. There is only a single process. <>= procedure :: init_out => eio_test_init_out <>= subroutine eio_test_init_out (eio, sample, data, success, extension) class(eio_test_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success type(string_t), intent(in), optional :: extension eio%sample = sample eio%event_n = 0 eio%event_i = 0 allocate (eio%event_p (2, 10)) if (present (success)) success = .true. end subroutine eio_test_init_out @ %def eio_test_init_out @ Initialization for input. Nothing to do for the test type. <>= procedure :: init_in => eio_test_init_in <>= subroutine eio_test_init_in (eio, sample, data, success, extension) class(eio_test_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success type(string_t), intent(in), optional :: extension if (present (success)) success = .true. end subroutine eio_test_init_in @ %def eio_test_init_in @ Switch from output to input. Again, nothing to do for the test type. <>= procedure :: switch_inout => eio_test_switch_inout <>= subroutine eio_test_switch_inout (eio, success) class(eio_test_t), intent(inout) :: eio logical, intent(out), optional :: success if (present (success)) success = .true. end subroutine eio_test_switch_inout @ %def eio_test_switch_inout @ Output. Increment the event counter and store the momenta of the current event. <>= procedure :: output => eio_test_output <>= subroutine eio_test_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_test_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle integer, intent(in) :: i_prc type(particle_set_t), pointer :: pset type(particle_t) :: prt eio%event_n = eio%event_n + 1 eio%event_i = eio%event_n eio%i_prc = i_prc pset => event%get_particle_set_ptr () prt = pset%get_particle (3) eio%event_p(1, eio%event_i) = prt%get_momentum () prt = pset%get_particle (4) eio%event_p(2, eio%event_i) = prt%get_momentum () end subroutine eio_test_output @ %def eio_test_output @ Input. Increment the event counter and retrieve the momenta of the current event. For the test case, we do not actually modify the current event. <>= procedure :: input_i_prc => eio_test_input_i_prc procedure :: input_event => eio_test_input_event <>= subroutine eio_test_input_i_prc (eio, i_prc, iostat) class(eio_test_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat i_prc = eio%i_prc iostat = 0 end subroutine eio_test_input_i_prc subroutine eio_test_input_event (eio, event, iostat, event_handle) class(eio_test_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle eio%event_i = eio%event_i + 1 iostat = 0 end subroutine eio_test_input_event @ %def eio_test_input_i_prc @ %def eio_test_input_event @ <>= procedure :: skip => eio_test_skip <>= subroutine eio_test_skip (eio, iostat) class(eio_test_t), intent(inout) :: eio integer, intent(out) :: iostat iostat = 0 end subroutine eio_test_skip @ %def eio_test_skip @ \subsubsection{Test I/O methods} <>= call test (eio_base_1, "eio_base_1", & "read and write event contents", & u, results) <>= public :: eio_base_1 <>= subroutine eio_base_1 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event class(eio_t), allocatable :: eio integer :: i_prc, iostat type(string_t) :: sample write (u, "(A)") "* Test output: eio_base_1" write (u, "(A)") "* Purpose: generate and read/write an event" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_test1" allocate (eio_test_t :: eio) call eio%init_out (sample) call event%generate (1, [0._default, 0._default]) call eio%output (event, 42) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* Re-read the event" write (u, "(A)") call eio%init_in (sample) call eio%input_i_prc (i_prc, iostat) call eio%input_event (event, iostat) call eio%write (u) write (u, "(A)") write (u, "(1x,A,I0)") "i = ", i_prc write (u, "(A)") write (u, "(A)") "* Generate and append another event" write (u, "(A)") call eio%switch_inout () call event%generate (1, [0._default, 0._default]) call eio%output (event, 5) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* Re-read both events" write (u, "(A)") call eio%init_in (sample) call eio%input_i_prc (i_prc, iostat) call eio%input_event (event, iostat) call eio%input_i_prc (i_prc, iostat) call eio%input_event (event, iostat) call eio%write (u) write (u, "(A)") write (u, "(1x,A,I0)") "i = ", i_prc write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () deallocate (eio) call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_base_1" end subroutine eio_base_1 @ %def eio_base_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Direct Event Access} As a convenient application of the base type, we construct an event handler that allows us of setting and retrieving events just in the same way as an file I/O format, but directly dealing with particle data and momenta. This is an input and output format, but we do not care about counting events. <<[[eio_direct.f90]]>>= <> module eio_direct <> <> use lorentz, only: vector4_t use particles, only: particle_set_t use model_data, only: model_data_t use event_base use event_handles, only: event_handle_t use eio_data use eio_base <> <> <> interface <> end interface end module eio_direct @ %def eio_direct @ <<[[eio_direct_sub.f90]]>>= <> submodule (eio_direct) eio_direct_s use io_units use diagnostics use cputime implicit none contains <> end submodule eio_direct_s @ %def eio_direct_s @ \subsection{Type} <>= public :: eio_direct_t <>= type, extends (eio_t) :: eio_direct_t private logical :: i_evt_set = .false. integer :: i_evt = 0 integer :: i_prc = 0 integer :: i_mci = 0 integer :: i_term = 0 integer :: channel = 0 logical :: passed_set = .false. logical :: passed = .true. type(particle_set_t) :: pset contains <> end type eio_direct_t @ %def eio_direct_t @ \subsection{Common Methods} Output. <>= procedure :: write => eio_direct_write <>= module subroutine eio_direct_write (object, unit) class(eio_direct_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine eio_direct_write <>= module subroutine eio_direct_write (object, unit) class(eio_direct_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event direct access:" if (object%i_evt_set) then write (u, "(3x,A,1x,I0)") "i_evt =", object%i_evt else write (u, "(3x,A)") "i_evt = [undefined]" end if write (u, "(3x,A,1x,I0)") "i_prc =", object%i_prc write (u, "(3x,A,1x,I0)") "i_mci =", object%i_prc write (u, "(3x,A,1x,I0)") "i_term =", object%i_prc write (u, "(3x,A,1x,I0)") "channel =", object%i_prc if (object%passed_set) then write (u, "(3x,A,1x,L1)") "passed =", object%passed else write (u, "(3x,A)") "passed = [N/A]" end if call object%pset%write (u) end subroutine eio_direct_write @ %def eio_direct_write @ Finalizer: trivial. <>= procedure :: final => eio_direct_final <>= module subroutine eio_direct_final (object) class(eio_direct_t), intent(inout) :: object end subroutine eio_direct_final <>= module subroutine eio_direct_final (object) class(eio_direct_t), intent(inout) :: object call object%pset%final () end subroutine eio_direct_final @ %def eio_direct_final @ Initialize for input and/or output, both are identical <>= procedure :: init_out => eio_direct_init_out <>= module subroutine eio_direct_init_out & (eio, sample, data, success, extension) class(eio_direct_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success end subroutine eio_direct_init_out <>= module subroutine eio_direct_init_out & (eio, sample, data, success, extension) class(eio_direct_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success if (present (success)) success = .true. end subroutine eio_direct_init_out @ %def eio_direct_init_out @ <>= procedure :: init_in => eio_direct_init_in <>= module subroutine eio_direct_init_in & (eio, sample, data, success, extension) class(eio_direct_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success end subroutine eio_direct_init_in <>= module subroutine eio_direct_init_in & (eio, sample, data, success, extension) class(eio_direct_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success if (present (success)) success = .true. end subroutine eio_direct_init_in @ %def eio_direct_init_in @ Switch from input to output: no-op <>= procedure :: switch_inout => eio_direct_switch_inout <>= module subroutine eio_direct_switch_inout (eio, success) class(eio_direct_t), intent(inout) :: eio logical, intent(out), optional :: success end subroutine eio_direct_switch_inout <>= module subroutine eio_direct_switch_inout (eio, success) class(eio_direct_t), intent(inout) :: eio logical, intent(out), optional :: success if (present (success)) success = .true. end subroutine eio_direct_switch_inout @ %def eio_direct_switch_inout @ Output: transfer event contents from the [[event]] object to the [[eio]] object. Note that finalization of the particle set is not (yet) automatic. <>= procedure :: output => eio_direct_output <>= module subroutine eio_direct_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_direct_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_direct_output <>= module subroutine eio_direct_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_direct_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle type(particle_set_t), pointer :: pset_ptr call eio%pset%final () if (event%has_index ()) then call eio%set_event_index (event%get_index ()) else call eio%reset_event_index () end if if (present (passed)) then eio%passed = passed eio%passed_set = .true. else eio%passed_set = .false. end if pset_ptr => event%get_particle_set_ptr () if (associated (pset_ptr)) then eio%i_prc = i_prc eio%pset = pset_ptr end if end subroutine eio_direct_output @ %def eio_direct_output @ Input: transfer event contents from the [[eio]] object to the [[event]] object. The [[i_prc]] parameter has been stored inside the [[eio]] record before. <>= procedure :: input_i_prc => eio_direct_input_i_prc procedure :: input_event => eio_direct_input_event <>= module subroutine eio_direct_input_i_prc (eio, i_prc, iostat) class(eio_direct_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat end subroutine eio_direct_input_i_prc module subroutine eio_direct_input_event (eio, event, iostat, event_handle) class(eio_direct_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_direct_input_event <>= module subroutine eio_direct_input_i_prc (eio, i_prc, iostat) class(eio_direct_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat i_prc = eio%i_prc iostat = 0 end subroutine eio_direct_input_i_prc module subroutine eio_direct_input_event (eio, event, iostat, event_handle) class(eio_direct_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle call event%select (eio%i_mci, eio%i_term, eio%channel) if (eio%has_event_index ()) then call event%set_index (eio%get_event_index ()) else call event%reset_index () end if call event%set_hard_particle_set (eio%pset) end subroutine eio_direct_input_event @ %def eio_direct_input_i_prc @ %def eio_direct_input_event @ No-op. <>= procedure :: skip => eio_direct_skip <>= module subroutine eio_direct_skip (eio, iostat) class(eio_direct_t), intent(inout) :: eio integer, intent(out) :: iostat end subroutine eio_direct_skip <>= module subroutine eio_direct_skip (eio, iostat) class(eio_direct_t), intent(inout) :: eio integer, intent(out) :: iostat iostat = 0 end subroutine eio_direct_skip @ %def eio_direct_skip @ \subsection{Retrieve individual contents} <>= procedure :: has_event_index => eio_direct_has_event_index procedure :: get_event_index => eio_direct_get_event_index procedure :: passed_known => eio_direct_passed_known procedure :: has_passed => eio_direct_has_passed procedure :: get_n_in => eio_direct_get_n_in procedure :: get_n_out => eio_direct_get_n_out procedure :: get_n_tot => eio_direct_get_n_tot <>= module function eio_direct_has_event_index (eio) result (flag) class(eio_direct_t), intent(in) :: eio logical :: flag end function eio_direct_has_event_index module function eio_direct_get_event_index (eio) result (index) class(eio_direct_t), intent(in) :: eio integer :: index end function eio_direct_get_event_index module function eio_direct_passed_known (eio) result (flag) class(eio_direct_t), intent(in) :: eio logical :: flag end function eio_direct_passed_known module function eio_direct_has_passed (eio) result (flag) class(eio_direct_t), intent(in) :: eio logical :: flag end function eio_direct_has_passed module function eio_direct_get_n_in (eio) result (n_in) class(eio_direct_t), intent(in) :: eio integer :: n_in end function eio_direct_get_n_in module function eio_direct_get_n_out (eio) result (n_out) class(eio_direct_t), intent(in) :: eio integer :: n_out end function eio_direct_get_n_out module function eio_direct_get_n_tot (eio) result (n_tot) class(eio_direct_t), intent(in) :: eio integer :: n_tot end function eio_direct_get_n_tot <>= module function eio_direct_has_event_index (eio) result (flag) class(eio_direct_t), intent(in) :: eio logical :: flag flag = eio%i_evt_set end function eio_direct_has_event_index module function eio_direct_get_event_index (eio) result (index) class(eio_direct_t), intent(in) :: eio integer :: index if (eio%has_event_index ()) then index = eio%i_evt else index = 0 end if end function eio_direct_get_event_index module function eio_direct_passed_known (eio) result (flag) class(eio_direct_t), intent(in) :: eio logical :: flag flag = eio%passed_set end function eio_direct_passed_known module function eio_direct_has_passed (eio) result (flag) class(eio_direct_t), intent(in) :: eio logical :: flag if (eio%passed_known ()) then flag = eio%passed else flag = .true. end if end function eio_direct_has_passed module function eio_direct_get_n_in (eio) result (n_in) class(eio_direct_t), intent(in) :: eio integer :: n_in n_in = eio%pset%get_n_in () end function eio_direct_get_n_in module function eio_direct_get_n_out (eio) result (n_out) class(eio_direct_t), intent(in) :: eio integer :: n_out n_out = eio%pset%get_n_out () end function eio_direct_get_n_out module function eio_direct_get_n_tot (eio) result (n_tot) class(eio_direct_t), intent(in) :: eio integer :: n_tot n_tot = eio%pset%get_n_tot () end function eio_direct_get_n_tot @ %def eio_direct_has_event_index @ %def eio_direct_get_event_index @ %def eio_direct_passed_known @ %def eio_direct_has_passed @ %def eio_direct_get_n_in @ %def eio_direct_get_n_out @ %def eio_direct_get_n_tot @ All momenta as a single allocatable array. <>= procedure :: get_momentum_array => eio_direct_get_momentum_array <>= module subroutine eio_direct_get_momentum_array (eio, p) class(eio_direct_t), intent(in) :: eio type(vector4_t), dimension(:), allocatable, intent(out) :: p end subroutine eio_direct_get_momentum_array <>= module subroutine eio_direct_get_momentum_array (eio, p) class(eio_direct_t), intent(in) :: eio type(vector4_t), dimension(:), allocatable, intent(out) :: p integer :: n n = eio%get_n_tot () allocate (p (n)) p(:) = eio%pset%get_momenta () end subroutine eio_direct_get_momentum_array @ %def eio_direct_get_momentum_array @ \subsection{Manual access} Build the contained particle set from scratch. <>= procedure :: init_direct => eio_direct_init_direct <>= module subroutine eio_direct_init_direct & (eio, n_beam, n_in, n_rem, n_vir, n_out, pdg, model) class(eio_direct_t), intent(out) :: eio integer, intent(in) :: n_beam integer, intent(in) :: n_in integer, intent(in) :: n_rem integer, intent(in) :: n_vir integer, intent(in) :: n_out integer, dimension(:), intent(in) :: pdg class(model_data_t), intent(in), target :: model end subroutine eio_direct_init_direct <>= module subroutine eio_direct_init_direct & (eio, n_beam, n_in, n_rem, n_vir, n_out, pdg, model) class(eio_direct_t), intent(out) :: eio integer, intent(in) :: n_beam integer, intent(in) :: n_in integer, intent(in) :: n_rem integer, intent(in) :: n_vir integer, intent(in) :: n_out integer, dimension(:), intent(in) :: pdg class(model_data_t), intent(in), target :: model call eio%pset%init_direct (n_beam, n_in, n_rem, n_vir, n_out, pdg, model) end subroutine eio_direct_init_direct @ %def eio_direct_init_direct @ Set/reset the event index, which is optional. <>= procedure :: set_event_index => eio_direct_set_event_index procedure :: reset_event_index => eio_direct_reset_event_index <>= module subroutine eio_direct_set_event_index (eio, index) class(eio_direct_t), intent(inout) :: eio integer, intent(in) :: index end subroutine eio_direct_set_event_index module subroutine eio_direct_reset_event_index (eio) class(eio_direct_t), intent(inout) :: eio end subroutine eio_direct_reset_event_index <>= module subroutine eio_direct_set_event_index (eio, index) class(eio_direct_t), intent(inout) :: eio integer, intent(in) :: index eio%i_evt = index eio%i_evt_set = .true. end subroutine eio_direct_set_event_index module subroutine eio_direct_reset_event_index (eio) class(eio_direct_t), intent(inout) :: eio eio%i_evt_set = .false. end subroutine eio_direct_reset_event_index @ %def eio_direct_set_event_index @ %def eio_direct_reset_event_index @ Set the selection indices. This is supposed to select the [[i_prc]], [[i_mci]], [[i_term]], and [[channel]] entries of the event where the momentum set has to be stored, respectively. The selection indices determine the process, MCI set, calculation term, and phase-space channel is to be used for recalculation. The index values must not be zero, even if the do not apply. <>= procedure :: set_selection_indices => eio_direct_set_selection_indices <>= module subroutine eio_direct_set_selection_indices & (eio, i_prc, i_mci, i_term, channel) class(eio_direct_t), intent(inout) :: eio integer, intent(in) :: i_prc integer, intent(in) :: i_mci integer, intent(in) :: i_term integer, intent(in) :: channel end subroutine eio_direct_set_selection_indices <>= module subroutine eio_direct_set_selection_indices & (eio, i_prc, i_mci, i_term, channel) class(eio_direct_t), intent(inout) :: eio integer, intent(in) :: i_prc integer, intent(in) :: i_mci integer, intent(in) :: i_term integer, intent(in) :: channel eio%i_prc = i_prc eio%i_mci = i_mci eio%i_term = i_term eio%channel = channel end subroutine eio_direct_set_selection_indices @ %def eio_direct_set_i_prc @ Set momentum (or momenta -- elemental). <>= generic :: set_momentum => set_momentum_single generic :: set_momentum => set_momentum_all procedure :: set_momentum_single => eio_direct_set_momentum_single procedure :: set_momentum_all => eio_direct_set_momentum_all <>= module subroutine eio_direct_set_momentum_single (eio, i, p, p2, on_shell) class(eio_direct_t), intent(inout) :: eio integer, intent(in) :: i type(vector4_t), intent(in) :: p real(default), intent(in), optional :: p2 logical, intent(in), optional :: on_shell end subroutine eio_direct_set_momentum_single module subroutine eio_direct_set_momentum_all (eio, p, p2, on_shell) class(eio_direct_t), intent(inout) :: eio type(vector4_t), dimension(:), intent(in) :: p real(default), dimension(:), intent(in), optional :: p2 logical, intent(in), optional :: on_shell end subroutine eio_direct_set_momentum_all <>= module subroutine eio_direct_set_momentum_single (eio, i, p, p2, on_shell) class(eio_direct_t), intent(inout) :: eio integer, intent(in) :: i type(vector4_t), intent(in) :: p real(default), intent(in), optional :: p2 logical, intent(in), optional :: on_shell call eio%pset%set_momentum (i, p, p2, on_shell) end subroutine eio_direct_set_momentum_single module subroutine eio_direct_set_momentum_all (eio, p, p2, on_shell) class(eio_direct_t), intent(inout) :: eio type(vector4_t), dimension(:), intent(in) :: p real(default), dimension(:), intent(in), optional :: p2 logical, intent(in), optional :: on_shell call eio%pset%set_momentum (p, p2, on_shell) end subroutine eio_direct_set_momentum_all @ %def eio_direct_set_momentum @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_direct_ut.f90]]>>= <> module eio_direct_ut use unit_tests use eio_direct_uti <> <> contains <> end module eio_direct_ut @ %def eio_direct_ut @ <<[[eio_direct_uti.f90]]>>= <> module eio_direct_uti <> <> use lorentz, only: vector4_t use model_data, only: model_data_t use event_base use eio_data use eio_base use eio_direct use eio_base_ut, only: eio_prepare_test, eio_cleanup_test <> <> contains <> end module eio_direct_uti @ %def eio_direct_ut @ API: driver for the unit tests below. <>= public :: eio_direct_test <>= subroutine eio_direct_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_direct_test @ %def eio_direct_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_direct_1, "eio_direct_1", & "read and write event contents", & u, results) <>= public :: eio_direct_1 <>= subroutine eio_direct_1 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event class(eio_t), allocatable :: eio type(event_sample_data_t) :: data type(string_t) :: sample type(vector4_t), dimension(:), allocatable :: p class(model_data_t), pointer :: model integer :: i, n_events, iostat, i_prc write (u, "(A)") "* Test output: eio_direct_1" write (u, "(A)") "* Purpose: generate and read/write an event" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) write (u, "(A)") write (u, "(A)") "* Initial state" write (u, "(A)") allocate (eio_direct_t :: eio) call eio%write (u) write (u, "(A)") write (u, "(A)") "* Extract an empty event" write (u, "(A)") call eio%output (event, 1) call eio%write (u) write (u, "(A)") write (u, "(A)") "* Retrieve contents" write (u, "(A)") select type (eio) class is (eio_direct_t) if (eio%has_event_index ()) write (u, "(A,1x,I0)") "index =", eio%get_event_index () if (eio%passed_known ()) write (u, "(A,1x,L1)") "passed =", eio%has_passed () write (u, "(A,1x,I0)") "n_in =", eio%get_n_in () write (u, "(A,1x,I0)") "n_out =", eio%get_n_out () end select write (u, "(A)") write (u, "(A)") "* Generate and extract an event" write (u, "(A)") call event%generate (1, [0._default, 0._default]) call event%set_index (42) model => event%get_model_ptr () sample = "" call eio%init_out (sample) call eio%output (event, 1, passed = .true.) call eio%write (u) write (u, "(A)") write (u, "(A)") "* Retrieve contents" write (u, "(A)") select type (eio) class is (eio_direct_t) if (eio%has_event_index ()) write (u, "(A,1x,I0)") "index =", eio%get_event_index () if (eio%passed_known ()) write (u, "(A,1x,L1)") "passed =", eio%has_passed () write (u, "(A,1x,I0)") "n_in =", eio%get_n_in () write (u, "(A,1x,I0)") "n_out =", eio%get_n_out () end select select type (eio) class is (eio_direct_t) call eio%get_momentum_array (p) if (allocated (p)) then write (u, "(A)") "p[3] =" call p(3)%write (u) end if end select write (u, "(A)") write (u, "(A)") "* Re-create an eio event record: initialization" write (u, "(A)") call eio%final () select type (eio) class is (eio_direct_t) call eio%init_direct ( & n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 2, & pdg = [25, 25, 25, 25], model = model) call eio%set_event_index (42) call eio%set_selection_indices (1, 1, 1, 1) call eio%write (u) end select write (u, "(A)") write (u, "(A)") "* Re-create an eio event record: & &set momenta, interchanged" write (u, "(A)") select type (eio) class is (eio_direct_t) call eio%set_momentum (p([1,2,4,3]), on_shell=.true.) call eio%write (u) end select write (u, "(A)") write (u, "(A)") "* 'read' i_prc" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) write (u, "(1x,A,1x,I0)") "i_prc =", i_prc write (u, "(1x,A,1x,I0)") "iostat =", iostat write (u, "(A)") write (u, "(A)") "* 'read' (fill) event" write (u, "(A)") call eio%input_event (event, iostat) write (u, "(1x,A,1x,I0)") "iostat =", iostat write (u, "(A)") call event%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () deallocate (eio) call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_direct_1" end subroutine eio_direct_1 @ %def eio_direct_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Event Generation Checkpoints} This is an output-only format. Its only use is to write screen messages every $n$ events, to inform the user about progress. <<[[eio_checkpoints.f90]]>>= <> module eio_checkpoints <> use cputime use event_base use event_handles, only: event_handle_t use eio_data use eio_base <> <> <> interface <> end interface end module eio_checkpoints @ %def eio_checkpoints @ <<[[eio_checkpoints_sub.f90]]>>= <> submodule (eio_checkpoints) eio_checkpoints_s use io_units use diagnostics implicit none <> contains <> end submodule eio_checkpoints_s @ %def eio_checkpoints_s @ \subsection{Type} <>= public :: eio_checkpoints_t <>= type, extends (eio_t) :: eio_checkpoints_t logical :: active = .false. logical :: running = .false. integer :: val = 0 integer :: n_events = 0 integer :: n_read = 0 integer :: i_evt = 0 logical :: blank = .false. type(timer_t) :: timer contains <> end type eio_checkpoints_t @ %def eio_checkpoints_t @ \subsection{Specific Methods} Set parameters that are specifically used for checkpointing. <>= procedure :: set_parameters => eio_checkpoints_set_parameters <>= module subroutine eio_checkpoints_set_parameters (eio, checkpoint, blank) class(eio_checkpoints_t), intent(inout) :: eio integer, intent(in) :: checkpoint logical, intent(in), optional :: blank end subroutine eio_checkpoints_set_parameters <>= module subroutine eio_checkpoints_set_parameters (eio, checkpoint, blank) class(eio_checkpoints_t), intent(inout) :: eio integer, intent(in) :: checkpoint logical, intent(in), optional :: blank eio%val = checkpoint if (present (blank)) eio%blank = blank end subroutine eio_checkpoints_set_parameters @ %def eio_checkpoints_set_parameters @ \subsection{Common Methods} Output. This is not the actual event format, but a readable account of the current status. <>= procedure :: write => eio_checkpoints_write <>= module subroutine eio_checkpoints_write (object, unit) class(eio_checkpoints_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine eio_checkpoints_write <>= module subroutine eio_checkpoints_write (object, unit) class(eio_checkpoints_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (object%active) then write (u, "(1x,A)") "Event-sample checkpoints: active" write (u, "(3x,A,I0)") "interval = ", object%val write (u, "(3x,A,I0)") "n_events = ", object%n_events write (u, "(3x,A,I0)") "n_read = ", object%n_read write (u, "(3x,A,I0)") "n_current = ", object%i_evt write (u, "(3x,A,L1)") "blanking = ", object%blank call object%timer%write (u) else write (u, "(1x,A)") "Event-sample checkpoints: off" end if end subroutine eio_checkpoints_write @ %def eio_checkpoints_write @ Finalizer: trivial. <>= procedure :: final => eio_checkpoints_final <>= module subroutine eio_checkpoints_final (object) class(eio_checkpoints_t), intent(inout) :: object end subroutine eio_checkpoints_final <>= module subroutine eio_checkpoints_final (object) class(eio_checkpoints_t), intent(inout) :: object object%active = .false. end subroutine eio_checkpoints_final @ %def eio_checkpoints_final @ Activate checkpointing for event generation or writing. <>= procedure :: init_out => eio_checkpoints_init_out <>= module subroutine eio_checkpoints_init_out & (eio, sample, data, success, extension) class(eio_checkpoints_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success end subroutine eio_checkpoints_init_out <>= module subroutine eio_checkpoints_init_out & (eio, sample, data, success, extension) class(eio_checkpoints_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success if (present (data)) then if (eio%val > 0) then eio%active = .true. eio%i_evt = 0 eio%n_read = 0 eio%n_events = data%n_evt * data%nlo_multiplier end if end if if (present (success)) success = .true. end subroutine eio_checkpoints_init_out @ %def eio_checkpoints_init_out @ No checkpointing for event reading. <>= procedure :: init_in => eio_checkpoints_init_in <>= module subroutine eio_checkpoints_init_in & (eio, sample, data, success, extension) class(eio_checkpoints_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success end subroutine eio_checkpoints_init_in <>= module subroutine eio_checkpoints_init_in & (eio, sample, data, success, extension) class(eio_checkpoints_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success call msg_bug ("Event checkpoints: event input not supported") if (present (success)) success = .false. end subroutine eio_checkpoints_init_in @ %def eio_checkpoints_init_in @ Switch from input to output: also not supported. <>= procedure :: switch_inout => eio_checkpoints_switch_inout <>= module subroutine eio_checkpoints_switch_inout (eio, success) class(eio_checkpoints_t), intent(inout) :: eio logical, intent(out), optional :: success end subroutine eio_checkpoints_switch_inout <>= module subroutine eio_checkpoints_switch_inout (eio, success) class(eio_checkpoints_t), intent(inout) :: eio logical, intent(out), optional :: success call msg_bug ("Event checkpoints: in-out switch not supported") if (present (success)) success = .false. end subroutine eio_checkpoints_switch_inout @ %def eio_checkpoints_switch_inout @ Checkpoints: display progress for the current event, if applicable. <>= procedure :: output => eio_checkpoints_output <>= module subroutine eio_checkpoints_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_checkpoints_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_checkpoints_output <>= module subroutine eio_checkpoints_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_checkpoints_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle logical :: rd rd = .false.; if (present (reading)) rd = reading if (eio%active) then if (.not. eio%running) call eio%startup () if (eio%running) then eio%i_evt = eio%i_evt + 1 if (rd) then eio%n_read = eio%n_read + 1 else if (mod (eio%i_evt, eio%val) == 0) then call eio%message (eio%blank) end if if (eio%i_evt == eio%n_events) call eio%shutdown () end if end if end subroutine eio_checkpoints_output @ %def eio_checkpoints_output @ When the first event is called, we have to initialize the screen output. <>= procedure :: startup => eio_checkpoints_startup <>= module subroutine eio_checkpoints_startup (eio) class(eio_checkpoints_t), intent(inout) :: eio end subroutine eio_checkpoints_startup <>= module subroutine eio_checkpoints_startup (eio) class(eio_checkpoints_t), intent(inout) :: eio if (eio%active .and. eio%i_evt < eio%n_events) then call msg_message ("") call msg_message (checkpoint_bar) call msg_message (checkpoint_head) call msg_message (checkpoint_bar) write (msg_buffer, checkpoint_fmt) 0., 0, eio%n_events - eio%i_evt, "???" call msg_message () eio%running = .true. call eio%timer%start () end if end subroutine eio_checkpoints_startup @ %def eio_checkpoints_startup @ This message is printed at every checkpoint. <>= procedure :: message => eio_checkpoints_message <>= module subroutine eio_checkpoints_message (eio, testflag) class(eio_checkpoints_t), intent(inout) :: eio logical, intent(in), optional :: testflag end subroutine eio_checkpoints_message <>= module subroutine eio_checkpoints_message (eio, testflag) class(eio_checkpoints_t), intent(inout) :: eio logical, intent(in), optional :: testflag real :: t type(time_t) :: time_remaining type(string_t) :: time_string call eio%timer%stop () t = eio%timer call eio%timer%restart () time_remaining = & nint (t / (eio%i_evt - eio%n_read) * (eio%n_events - eio%i_evt)) time_string = time_remaining%to_string_ms (blank = testflag) write (msg_buffer, checkpoint_fmt) & 100 * ((eio%i_evt - eio%n_read) / real (eio%n_events - eio%n_read)), & eio%i_evt - eio%n_read, & eio%n_events - eio%i_evt, & char (time_string) call msg_message () end subroutine eio_checkpoints_message @ %def eio_checkpoints_message @ When the last event is called, wrap up. <>= procedure :: shutdown => eio_checkpoints_shutdown <>= module subroutine eio_checkpoints_shutdown (eio) class(eio_checkpoints_t), intent(inout) :: eio end subroutine eio_checkpoints_shutdown <>= module subroutine eio_checkpoints_shutdown (eio) class(eio_checkpoints_t), intent(inout) :: eio if (mod (eio%i_evt, eio%val) /= 0) then write (msg_buffer, checkpoint_fmt) & 100., eio%i_evt - eio%n_read, 0, "0m:00s" call msg_message () end if call msg_message (checkpoint_bar) call msg_message ("") eio%running = .false. end subroutine eio_checkpoints_shutdown @ %def eio_checkpoints_shutdown <>= procedure :: input_i_prc => eio_checkpoints_input_i_prc procedure :: input_event => eio_checkpoints_input_event <>= module subroutine eio_checkpoints_input_i_prc (eio, i_prc, iostat) class(eio_checkpoints_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat end subroutine eio_checkpoints_input_i_prc module subroutine eio_checkpoints_input_event & (eio, event, iostat, event_handle) class(eio_checkpoints_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_checkpoints_input_event <>= module subroutine eio_checkpoints_input_i_prc (eio, i_prc, iostat) class(eio_checkpoints_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat call msg_bug ("Event checkpoints: event input not supported") i_prc = 0 iostat = 1 end subroutine eio_checkpoints_input_i_prc module subroutine eio_checkpoints_input_event & (eio, event, iostat, event_handle) class(eio_checkpoints_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle call msg_bug ("Event checkpoints: event input not supported") iostat = 1 end subroutine eio_checkpoints_input_event @ %def eio_checkpoints_input_i_prc @ %def eio_checkpoints_input_event @ <>= procedure :: skip => eio_checkpoints_skip <>= module subroutine eio_checkpoints_skip (eio, iostat) class(eio_checkpoints_t), intent(inout) :: eio integer, intent(out) :: iostat end subroutine eio_checkpoints_skip <>= module subroutine eio_checkpoints_skip (eio, iostat) class(eio_checkpoints_t), intent(inout) :: eio integer, intent(out) :: iostat iostat = 0 end subroutine eio_checkpoints_skip @ %def eio_checkpoints_skip @ \subsection{Message header} <>= character(*), parameter :: & checkpoint_head = "| % complete | events generated | events remaining & &| time remaining" character(*), parameter :: & checkpoint_bar = "|==================================================& &=================|" character(*), parameter :: & checkpoint_fmt = "(' ',F5.1,T16,I9,T35,I9,T58,A)" @ %def checkpoint_head @ %def checkpoint_bar @ %def checkpoint_fmt @ %def checkpointing_t @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_checkpoints_ut.f90]]>>= <> module eio_checkpoints_ut use unit_tests use eio_checkpoints_uti <> <> contains <> end module eio_checkpoints_ut @ %def eio_checkpoints_ut @ <<[[eio_checkpoints_uti.f90]]>>= <> module eio_checkpoints_uti <> <> use event_base use eio_data use eio_base use eio_checkpoints use eio_base_ut, only: eio_prepare_test, eio_cleanup_test <> <> contains <> end module eio_checkpoints_uti @ %def eio_checkpoints_ut @ API: driver for the unit tests below. <>= public :: eio_checkpoints_test <>= subroutine eio_checkpoints_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_checkpoints_test @ %def eio_checkpoints_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_checkpoints_1, "eio_checkpoints_1", & "read and write event contents", & u, results) <>= public :: eio_checkpoints_1 <>= subroutine eio_checkpoints_1 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event class(eio_t), allocatable :: eio type(event_sample_data_t) :: data type(string_t) :: sample integer :: i, n_events write (u, "(A)") "* Test output: eio_checkpoints_1" write (u, "(A)") "* Purpose: generate a number of events & &with screen output" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event) write (u, "(A)") write (u, "(A)") "* Generate events" write (u, "(A)") sample = "eio_checkpoints_1" allocate (eio_checkpoints_t :: eio) n_events = 10 call data%init (1, 0) data%n_evt = n_events select type (eio) type is (eio_checkpoints_t) call eio%set_parameters (checkpoint = 4) end select call eio%init_out (sample, data) do i = 1, n_events call event%generate (1, [0._default, 0._default]) call eio%output (event, i_prc = 0) end do write (u, "(A)") "* Checkpointing status" write (u, "(A)") call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_checkpoints_1" end subroutine eio_checkpoints_1 @ %def eio_checkpoints_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Event Generation Callback} This is an output-only format. Its only use is to write screen messages every $n$ events, to inform the user about progress. <<[[eio_callback.f90]]>>= <> module eio_callback use kinds, only: i64 <> use cputime use event_base use event_handles, only: event_handle_t use eio_data use eio_base <> <> <> interface <> end interface end module eio_callback @ %def eio_callback @ <<[[eio_callback_sub.f90]]>>= <> submodule (eio_callback) eio_callback_s use io_units use diagnostics implicit none contains <> end submodule eio_callback_s @ %def eio_callback_s @ \subsection{Type} <>= public :: eio_callback_t <>= type, extends (eio_t) :: eio_callback_t class(event_callback_t), allocatable :: callback integer(i64) :: i_evt = 0 integer :: i_interval = 0 integer :: n_interval = 0 ! type(timer_t) :: timer contains <> end type eio_callback_t @ %def eio_callback_t @ \subsection{Specific Methods} Set parameters that are specifically used for callback: the procedure and the number of events to wait until the procedure is called (again). <>= procedure :: set_parameters => eio_callback_set_parameters <>= module subroutine eio_callback_set_parameters & (eio, callback, count_interval) class(eio_callback_t), intent(inout) :: eio class(event_callback_t), intent(in) :: callback integer, intent(in) :: count_interval end subroutine eio_callback_set_parameters <>= module subroutine eio_callback_set_parameters & (eio, callback, count_interval) class(eio_callback_t), intent(inout) :: eio class(event_callback_t), intent(in) :: callback integer, intent(in) :: count_interval allocate (eio%callback, source = callback) eio%n_interval = count_interval end subroutine eio_callback_set_parameters @ %def eio_callback_set_parameters @ \subsection{Common Methods} Output. This is not the actual event format, but a readable account of the current status. <>= procedure :: write => eio_callback_write <>= module subroutine eio_callback_write (object, unit) class(eio_callback_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine eio_callback_write <>= module subroutine eio_callback_write (object, unit) class(eio_callback_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Event-sample callback:" write (u, "(3x,A,I0)") "interval = ", object%n_interval write (u, "(3x,A,I0)") "evt count = ", object%i_evt ! call object%timer%write (u) end subroutine eio_callback_write @ %def eio_callback_write @ Finalizer: trivial. <>= procedure :: final => eio_callback_final <>= module subroutine eio_callback_final (object) class(eio_callback_t), intent(inout) :: object end subroutine eio_callback_final <>= module subroutine eio_callback_final (object) class(eio_callback_t), intent(inout) :: object end subroutine eio_callback_final @ %def eio_callback_final @ Activate checkpointing for event generation or writing. <>= procedure :: init_out => eio_callback_init_out <>= module subroutine eio_callback_init_out & (eio, sample, data, success, extension) class(eio_callback_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success end subroutine eio_callback_init_out <>= module subroutine eio_callback_init_out & (eio, sample, data, success, extension) class(eio_callback_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success eio%i_evt = 0 eio%i_interval = 0 if (present (success)) success = .true. end subroutine eio_callback_init_out @ %def eio_callback_init_out @ No callback for event reading. <>= procedure :: init_in => eio_callback_init_in <>= module subroutine eio_callback_init_in & (eio, sample, data, success, extension) class(eio_callback_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success end subroutine eio_callback_init_in <>= module subroutine eio_callback_init_in & (eio, sample, data, success, extension) class(eio_callback_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success call msg_bug ("Event callback: event input not supported") if (present (success)) success = .false. end subroutine eio_callback_init_in @ %def eio_callback_init_in @ Switch from input to output: also not supported. <>= procedure :: switch_inout => eio_callback_switch_inout <>= module subroutine eio_callback_switch_inout (eio, success) class(eio_callback_t), intent(inout) :: eio logical, intent(out), optional :: success end subroutine eio_callback_switch_inout <>= module subroutine eio_callback_switch_inout (eio, success) class(eio_callback_t), intent(inout) :: eio logical, intent(out), optional :: success call msg_bug ("Event callback: in-out switch not supported") if (present (success)) success = .false. end subroutine eio_callback_switch_inout @ %def eio_callback_switch_inout @ The actual callback. First increment counters, then call the procedure if the counter hits the interval. <>= procedure :: output => eio_callback_output <>= module subroutine eio_callback_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_callback_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_callback_output <>= module subroutine eio_callback_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_callback_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle eio%i_evt = eio%i_evt + 1 if (eio%n_interval > 0) then eio%i_interval = eio%i_interval + 1 if (eio%i_interval >= eio%n_interval) then call eio%callback%proc (eio%i_evt, event) eio%i_interval = 0 end if end if end subroutine eio_callback_output @ %def eio_callback_output @ No input. <>= procedure :: input_i_prc => eio_callback_input_i_prc procedure :: input_event => eio_callback_input_event <>= module subroutine eio_callback_input_i_prc (eio, i_prc, iostat) class(eio_callback_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat end subroutine eio_callback_input_i_prc module subroutine eio_callback_input_event & (eio, event, iostat, event_handle) class(eio_callback_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_callback_input_event <>= module subroutine eio_callback_input_i_prc (eio, i_prc, iostat) class(eio_callback_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat call msg_bug ("Event callback: event input not supported") i_prc = 0 iostat = 1 end subroutine eio_callback_input_i_prc module subroutine eio_callback_input_event & (eio, event, iostat, event_handle) class(eio_callback_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle call msg_bug ("Event callback: event input not supported") iostat = 1 end subroutine eio_callback_input_event @ %def eio_callback_input_i_prc @ %def eio_callback_input_event @ <>= procedure :: skip => eio_callback_skip <>= module subroutine eio_callback_skip (eio, iostat) class(eio_callback_t), intent(inout) :: eio integer, intent(out) :: iostat end subroutine eio_callback_skip <>= module subroutine eio_callback_skip (eio, iostat) class(eio_callback_t), intent(inout) :: eio integer, intent(out) :: iostat iostat = 0 end subroutine eio_callback_skip @ %def eio_callback_skip @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Event Weight Output} This is an output-only format. For each event, we print the indices that identify process, process part (MCI group), and term. As numerical information we print the squared matrix element (trace) and the event weight. <<[[eio_weights.f90]]>>= <> module eio_weights <> <> use event_base use event_handles, only: event_handle_t use eio_data use eio_base <> <> <> interface <> end interface end module eio_weights @ %def eio_weights @ <<[[eio_weights_sub.f90]]>>= <> submodule (eio_weights) eio_weights_s use io_units use diagnostics implicit none contains <> end submodule eio_weights_s @ %def eio_weights_s @ \subsection{Type} <>= public :: eio_weights_t <>= type, extends (eio_t) :: eio_weights_t logical :: writing = .false. integer :: unit = 0 logical :: pacify = .false. contains <> end type eio_weights_t @ %def eio_weights_t @ \subsection{Specific Methods} Set pacify flags. <>= procedure :: set_parameters => eio_weights_set_parameters <>= module subroutine eio_weights_set_parameters (eio, pacify) class(eio_weights_t), intent(inout) :: eio logical, intent(in), optional :: pacify end subroutine eio_weights_set_parameters <>= module subroutine eio_weights_set_parameters (eio, pacify) class(eio_weights_t), intent(inout) :: eio logical, intent(in), optional :: pacify if (present (pacify)) eio%pacify = pacify eio%extension = "weights.dat" end subroutine eio_weights_set_parameters @ %def eio_weights_set_parameters @ \subsection{Common Methods} @ Output. This is not the actual event format, but a readable account of the current object status. <>= procedure :: write => eio_weights_write <>= module subroutine eio_weights_write (object, unit) class(eio_weights_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine eio_weights_write <>= module subroutine eio_weights_write (object, unit) class(eio_weights_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Weight stream:" if (object%writing) then write (u, "(3x,A,A)") "Writing to file = ", char (object%filename) write (u, "(3x,A,L1)") "Reduced I/O prec. = ", object%pacify else write (u, "(3x,A)") "[closed]" end if end subroutine eio_weights_write @ %def eio_weights_write @ Finalizer: close any open file. <>= procedure :: final => eio_weights_final <>= module subroutine eio_weights_final (object) class(eio_weights_t), intent(inout) :: object end subroutine eio_weights_final <>= module subroutine eio_weights_final (object) class(eio_weights_t), intent(inout) :: object if (object%writing) then write (msg_buffer, "(A,A,A)") "Events: closing weight stream file '", & char (object%filename), "'" call msg_message () close (object%unit) object%writing = .false. end if end subroutine eio_weights_final @ %def eio_weights_final @ Initialize event writing. <>= procedure :: init_out => eio_weights_init_out <>= module subroutine eio_weights_init_out & (eio, sample, data, success, extension) class(eio_weights_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success end subroutine eio_weights_init_out <>= module subroutine eio_weights_init_out & (eio, sample, data, success, extension) class(eio_weights_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success if (present(extension)) then eio%extension = extension else eio%extension = "weights.dat" end if eio%filename = sample // "." // eio%extension eio%unit = free_unit () write (msg_buffer, "(A,A,A)") "Events: writing to weight stream file '", & char (eio%filename), "'" call msg_message () eio%writing = .true. open (eio%unit, file = char (eio%filename), & action = "write", status = "replace") if (present (success)) success = .true. end subroutine eio_weights_init_out @ %def eio_weights_init_out @ Initialize event reading. <>= procedure :: init_in => eio_weights_init_in <>= module subroutine eio_weights_init_in & (eio, sample, data, success, extension) class(eio_weights_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success end subroutine eio_weights_init_in <>= module subroutine eio_weights_init_in & (eio, sample, data, success, extension) class(eio_weights_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success call msg_bug ("Weight stream: event input not supported") if (present (success)) success = .false. end subroutine eio_weights_init_in @ %def eio_weights_init_in @ Switch from input to output: reopen the file for reading. <>= procedure :: switch_inout => eio_weights_switch_inout <>= module subroutine eio_weights_switch_inout (eio, success) class(eio_weights_t), intent(inout) :: eio logical, intent(out), optional :: success end subroutine eio_weights_switch_inout <>= module subroutine eio_weights_switch_inout (eio, success) class(eio_weights_t), intent(inout) :: eio logical, intent(out), optional :: success call msg_bug ("Weight stream: in-out switch not supported") if (present (success)) success = .false. end subroutine eio_weights_switch_inout @ %def eio_weights_switch_inout @ Output an event. Write first the event indices, then weight and two values of the squared matrix element: [[sqme_ref]] is the value stored in the event record, and [[sqme_prc]] is the one stored in the process instance. (They can differ: when recalculating, the former is read from file and the latter is the result of the new calculation.) For the alternative entries, the [[sqme]] value is always obtained by a new calculation, and thus qualifies as [[sqme_prc]]. Don't write the file if the [[passed]] flag is set and false. <>= procedure :: output => eio_weights_output <>= module subroutine eio_weights_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_weights_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_weights_output <>= module subroutine eio_weights_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_weights_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle integer :: n_alt, i real(default) :: weight, sqme_ref, sqme_prc logical :: evt_pacify, evt_passed evt_pacify = eio%pacify; if (present (pacify)) evt_pacify = pacify evt_passed = .true.; if (present (passed)) evt_passed = passed if (eio%writing) then if (evt_passed) then weight = event%get_weight_prc () sqme_ref = event%get_sqme_ref () sqme_prc = event%get_sqme_prc () n_alt = event%get_n_alt () 1 format (I0,3(1x,ES17.10),3(1x,I0)) 2 format (I0,3(1x,ES15.8),3(1x,I0)) if (evt_pacify) then write (eio%unit, 2) 0, weight, sqme_prc, sqme_ref, & i_prc else write (eio%unit, 1) 0, weight, sqme_prc, sqme_ref, & i_prc end if do i = 1, n_alt weight = event%get_weight_alt(i) sqme_prc = event%get_sqme_alt(i) if (evt_pacify) then write (eio%unit, 2) i, weight, sqme_prc else write (eio%unit, 1) i, weight, sqme_prc end if end do end if else call eio%write () call msg_fatal ("Weight stream file is not open for writing") end if end subroutine eio_weights_output @ %def eio_weights_output @ Input an event. <>= procedure :: input_i_prc => eio_weights_input_i_prc procedure :: input_event => eio_weights_input_event <>= module subroutine eio_weights_input_i_prc (eio, i_prc, iostat) class(eio_weights_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat end subroutine eio_weights_input_i_prc module subroutine eio_weights_input_event & (eio, event, iostat, event_handle) class(eio_weights_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_weights_input_event <>= module subroutine eio_weights_input_i_prc (eio, i_prc, iostat) class(eio_weights_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat call msg_bug ("Weight stream: event input not supported") i_prc = 0 iostat = 1 end subroutine eio_weights_input_i_prc module subroutine eio_weights_input_event & (eio, event, iostat, event_handle) class(eio_weights_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle call msg_bug ("Weight stream: event input not supported") iostat = 1 end subroutine eio_weights_input_event @ %def eio_weights_input_i_prc @ %def eio_weights_input_event @ <>= procedure :: skip => eio_weights_skip <>= module subroutine eio_weights_skip (eio, iostat) class(eio_weights_t), intent(inout) :: eio integer, intent(out) :: iostat end subroutine eio_weights_skip <>= module subroutine eio_weights_skip (eio, iostat) class(eio_weights_t), intent(inout) :: eio integer, intent(out) :: iostat iostat = 0 end subroutine eio_weights_skip @ %def eio_weights_skip @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_weights_ut.f90]]>>= <> module eio_weights_ut use unit_tests use eio_weights_uti <> <> contains <> end module eio_weights_ut @ %def eio_weights_ut @ <<[[eio_weights_uti.f90]]>>= <> module eio_weights_uti <> <> use io_units use event_base use eio_data use eio_base use eio_weights use eio_base_ut, only: eio_prepare_test, eio_cleanup_test <> <> contains <> end module eio_weights_uti @ %def eio_weights_ut @ API: driver for the unit tests below. <>= public :: eio_weights_test <>= subroutine eio_weights_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_weights_test @ %def eio_weights_test @ \subsubsection{Simple event} We test the implementation of all I/O methods. <>= call test (eio_weights_1, "eio_weights_1", & "read and write event contents", & u, results) <>= public :: eio_weights_1 <>= subroutine eio_weights_1 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file character(80) :: buffer write (u, "(A)") "* Test output: eio_weights_1" write (u, "(A)") "* Purpose: generate an event and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_weights_1" allocate (eio_weights_t :: eio) call eio%init_out (sample) call event%generate (1, [0._default, 0._default]) call eio%output (event, i_prc = 42) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents: & &(weight, sqme(evt), sqme(prc), i_prc)" write (u, "(A)") u_file = free_unit () open (u_file, file = "eio_weights_1.weights.dat", & action = "read", status = "old") read (u_file, "(A)") buffer write (u, "(A)") trim (buffer) close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_weights_1" end subroutine eio_weights_1 @ %def eio_weights_1 @ \subsubsection{Multiple weights} Event with several weight entries set. <>= call test (eio_weights_2, "eio_weights_2", & "multiple weights", & u, results) <>= public :: eio_weights_2 <>= subroutine eio_weights_2 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, i character(80) :: buffer write (u, "(A)") "* Test output: eio_weights_2" write (u, "(A)") "* Purpose: generate an event and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false., n_alt = 2) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_weights_2" allocate (eio_weights_t :: eio) call eio%init_out (sample) select type (eio) type is (eio_weights_t) call eio%set_parameters (pacify = .true.) end select call event%generate (1, [0._default, 0._default]) call event%set (sqme_alt = [2._default, 3._default]) call event%set (weight_alt = & [2 * event%get_weight_prc (), 3 * event%get_weight_prc ()]) call eio%output (event, i_prc = 42) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents: & &(weight, sqme(evt), sqme(prc), i_prc)" write (u, "(A)") u_file = free_unit () open (u_file, file = "eio_weights_2.weights.dat", & action = "read", status = "old") do i = 1, 3 read (u_file, "(A)") buffer write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_weights_2" end subroutine eio_weights_2 @ %def eio_weights_2 @ \subsubsection{Multiple events} Events with [[passed]] flag switched on/off. <>= call test (eio_weights_3, "eio_weights_3", & "check passed-flag", & u, results) <>= public :: eio_weights_3 <>= subroutine eio_weights_3 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_weights_3" write (u, "(A)") "* Purpose: generate three events and write to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) write (u, "(A)") write (u, "(A)") "* Generate and write events" write (u, "(A)") sample = "eio_weights_3" allocate (eio_weights_t :: eio) select type (eio) type is (eio_weights_t) call eio%set_parameters (pacify = .true.) end select call eio%init_out (sample) call event%generate (1, [0._default, 0._default]) call eio%output (event, i_prc = 1) call event%generate (1, [0.1_default, 0._default]) call eio%output (event, i_prc = 1, passed = .false.) call event%generate (1, [0.2_default, 0._default]) call eio%output (event, i_prc = 1, passed = .true.) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents: & &(weight, sqme(evt), sqme(prc), i_prc), should be just two entries" write (u, "(A)") u_file = free_unit () open (u_file, file = "eio_weights_3.weights.dat", & action = "read", status = "old") do read (u_file, "(A)", iostat=iostat) buffer if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_weights_3" end subroutine eio_weights_3 @ %def eio_weights_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Event Dump Output} This is an output-only format. We simply dump the contents of the [[particle_set]], using the [[write]] method of that type. The event-format options are the options of that procedure. <<[[eio_dump.f90]]>>= <> module eio_dump use, intrinsic :: iso_fortran_env, only: output_unit use kinds, only: i64 <> use event_base use event_handles, only: event_handle_t use eio_data use eio_base <> <> <> interface <> end interface end module eio_dump @ %def eio_dump @ <<[[eio_dump_sub.f90]]>>= <> submodule (eio_dump) eio_dump_s use io_units use diagnostics use format_utils, only: write_separator use format_utils, only: pac_fmt use format_defs, only: FMT_16, FMT_19 implicit none contains <> end submodule eio_dump_s @ %def eio_dump_s @ \subsection{Type} <>= public :: eio_dump_t <>= type, extends (eio_t) :: eio_dump_t integer(i64) :: count = 0 integer :: unit = 0 logical :: writing = .false. logical :: screen = .false. logical :: pacify = .false. logical :: weights = .false. logical :: compressed = .false. logical :: summary = .false. contains <> end type eio_dump_t @ %def eio_dump_t @ \subsection{Specific Methods} Set control parameters. We may provide a [[unit]] for input or output; this will be taken if the sample file name is empty. In that case, the unit is assumed to be open and will be kept open; no messages will be issued. <>= procedure :: set_parameters => eio_dump_set_parameters <>= module subroutine eio_dump_set_parameters (eio, extension, & pacify, weights, compressed, summary, screen, unit) class(eio_dump_t), intent(inout) :: eio type(string_t), intent(in), optional :: extension logical, intent(in), optional :: pacify logical, intent(in), optional :: weights logical, intent(in), optional :: compressed logical, intent(in), optional :: summary logical, intent(in), optional :: screen integer, intent(in), optional :: unit end subroutine eio_dump_set_parameters <>= module subroutine eio_dump_set_parameters (eio, extension, & pacify, weights, compressed, summary, screen, unit) class(eio_dump_t), intent(inout) :: eio type(string_t), intent(in), optional :: extension logical, intent(in), optional :: pacify logical, intent(in), optional :: weights logical, intent(in), optional :: compressed logical, intent(in), optional :: summary logical, intent(in), optional :: screen integer, intent(in), optional :: unit if (present (pacify)) eio%pacify = pacify if (present (weights)) eio%weights = weights if (present (compressed)) eio%compressed = compressed if (present (summary)) eio%summary = summary if (present (screen)) eio%screen = screen if (present (unit)) eio%unit = unit eio%extension = "pset.dat" if (present (extension)) eio%extension = extension end subroutine eio_dump_set_parameters @ %def eio_dump_set_parameters @ \subsection{Common Methods} @ Output. This is not the actual event format, but a readable account of the current object status. <>= procedure :: write => eio_dump_write <>= module subroutine eio_dump_write (object, unit) class(eio_dump_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine eio_dump_write <>= module subroutine eio_dump_write (object, unit) class(eio_dump_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Dump event stream:" if (object%writing) then write (u, "(3x,A,L1)") "Screen output = ", object%screen write (u, "(3x,A,A,A)") "Writing to file = '", char (object%filename), "'" write (u, "(3x,A,L1)") "Reduced I/O prec. = ", object%pacify write (u, "(3x,A,L1)") "Show weights/sqme = ", object%weights write (u, "(3x,A,L1)") "Compressed = ", object%compressed write (u, "(3x,A,L1)") "Summary = ", object%summary else write (u, "(3x,A)") "[closed]" end if end subroutine eio_dump_write @ %def eio_dump_write @ Finalizer: close any open file. <>= procedure :: final => eio_dump_final <>= module subroutine eio_dump_final (object) class(eio_dump_t), intent(inout) :: object end subroutine eio_dump_final <>= module subroutine eio_dump_final (object) class(eio_dump_t), intent(inout) :: object if (object%screen) then write (msg_buffer, "(A,A,A)") "Events: display complete" call msg_message () object%screen = .false. end if if (object%writing) then if (object%filename /= "") then write (msg_buffer, "(A,A,A)") "Events: closing event dump file '", & char (object%filename), "'" call msg_message () close (object%unit) end if object%writing = .false. end if end subroutine eio_dump_final @ %def eio_dump_final @ Initialize event writing. <>= procedure :: init_out => eio_dump_init_out <>= module subroutine eio_dump_init_out & (eio, sample, data, success, extension) class(eio_dump_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success end subroutine eio_dump_init_out <>= module subroutine eio_dump_init_out & (eio, sample, data, success, extension) class(eio_dump_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success if (present(extension)) then eio%extension = extension else eio%extension = "pset.dat" end if if (sample == "" .and. eio%unit /= 0) then eio%filename = "" eio%writing = .true. else if (sample /= "") then eio%filename = sample // "." // eio%extension eio%unit = free_unit () write (msg_buffer, "(A,A,A)") "Events: writing to event dump file '", & char (eio%filename), "'" call msg_message () eio%writing = .true. open (eio%unit, file = char (eio%filename), & action = "write", status = "replace") end if if (eio%screen) then write (msg_buffer, "(A,A,A)") "Events: display on standard output" call msg_message () end if eio%count = 0 if (present (success)) success = .true. end subroutine eio_dump_init_out @ %def eio_dump_init_out @ Initialize event reading. <>= procedure :: init_in => eio_dump_init_in <>= module subroutine eio_dump_init_in & (eio, sample, data, success, extension) class(eio_dump_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success end subroutine eio_dump_init_in <>= module subroutine eio_dump_init_in & (eio, sample, data, success, extension) class(eio_dump_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success call msg_bug ("Event dump: event input not supported") if (present (success)) success = .false. end subroutine eio_dump_init_in @ %def eio_dump_init_in @ Switch from input to output: reopen the file for reading. <>= procedure :: switch_inout => eio_dump_switch_inout <>= module subroutine eio_dump_switch_inout (eio, success) class(eio_dump_t), intent(inout) :: eio logical, intent(out), optional :: success end subroutine eio_dump_switch_inout <>= module subroutine eio_dump_switch_inout (eio, success) class(eio_dump_t), intent(inout) :: eio logical, intent(out), optional :: success call msg_bug ("Event dump: in-out switch not supported") if (present (success)) success = .false. end subroutine eio_dump_switch_inout @ %def eio_dump_switch_inout @ Output an event. Delegate the output call to the [[write]] method of the current particle set, if valid. Output both to file (if defined) and to screen (if requested). <>= procedure :: output => eio_dump_output <>= module subroutine eio_dump_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_dump_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_dump_output <>= module subroutine eio_dump_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_dump_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle character(len=7) :: fmt eio%count = eio%count + 1 if (present (pacify)) then call pac_fmt (fmt, FMT_19, FMT_16, pacify) else call pac_fmt (fmt, FMT_19, FMT_16, eio%pacify) end if if (eio%writing) call dump (eio%unit) if (eio%screen) then call dump (output_unit) if (logfile_unit () > 0) call dump (logfile_unit ()) end if contains subroutine dump (u) integer, intent(in) :: u integer :: i call write_separator (u, 2) write (u, "(1x,A,I0)", advance="no") "Event" if (event%has_index ()) then write (u, "(1x,'#',I0)") event%get_index () else write (u, *) end if call write_separator (u, 2) write (u, "(1x,A,1x,I0)") "count =", eio%count if (present (passed)) then write (u, "(1x,A,1x,L1)") "passed =", passed else write (u, "(1x,A)") "passed = [N/A]" end if write (u, "(1x,A,1x,I0)") "prc id =", i_prc if (eio%weights) then call write_separator (u) if (event%sqme_ref_known) then write (u, "(1x,A," // fmt // ")") "sqme (ref) = ", & event%sqme_ref else write (u, "(1x,A)") "sqme (ref) = [undefined]" end if if (event%sqme_prc_known) then write (u, "(1x,A," // fmt // ")") "sqme (prc) = ", & event%sqme_prc else write (u, "(1x,A)") "sqme (prc) = [undefined]" end if if (event%weight_ref_known) then write (u, "(1x,A," // fmt // ")") "weight (ref) = ", & event%weight_ref else write (u, "(1x,A)") "weight (ref) = [undefined]" end if if (event%weight_prc_known) then write (u, "(1x,A," // fmt // ")") "weight (prc) = ", & event%weight_prc else write (u, "(1x,A)") "weight (prc) = [undefined]" end if if (event%excess_prc_known) then write (u, "(1x,A," // fmt // ")") "excess (prc) = ", & event%excess_prc else write (u, "(1x,A)") "excess (prc) = [undefined]" end if do i = 1, event%n_alt if (event%sqme_ref_known) then write (u, "(1x,A,I0,A," // fmt // ")") "sqme (", i, ") = ",& event%sqme_prc else write (u, "(1x,A,I0,A)") "sqme (", i, ") = [undefined]" end if if (event%weight_prc_known) then write (u, "(1x,A,I0,A," // fmt // ")") "weight (", i, ") = ",& event%weight_prc else write (u, "(1x,A,I0,A)") "weight (", i, ") = [undefined]" end if end do end if call write_separator (u) if (event%particle_set_is_valid) then call event%particle_set%write (unit = u, & summary = eio%summary, compressed = eio%compressed, & testflag = eio%pacify) else write (u, "(1x,A)") "Particle set: [invalid]" end if end subroutine dump end subroutine eio_dump_output @ %def eio_dump_output @ Input an event. <>= procedure :: input_i_prc => eio_dump_input_i_prc procedure :: input_event => eio_dump_input_event <>= module subroutine eio_dump_input_i_prc (eio, i_prc, iostat) class(eio_dump_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat end subroutine eio_dump_input_i_prc module subroutine eio_dump_input_event & (eio, event, iostat, event_handle) class(eio_dump_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_dump_input_event <>= module subroutine eio_dump_input_i_prc (eio, i_prc, iostat) class(eio_dump_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat call msg_bug ("Dump stream: event input not supported") i_prc = 0 iostat = 1 end subroutine eio_dump_input_i_prc module subroutine eio_dump_input_event & (eio, event, iostat, event_handle) class(eio_dump_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle call msg_bug ("Dump stream: event input not supported") iostat = 1 end subroutine eio_dump_input_event @ %def eio_dump_input_i_prc @ %def eio_dump_input_event @ <>= procedure :: skip => eio_dump_skip <>= module subroutine eio_dump_skip (eio, iostat) class(eio_dump_t), intent(inout) :: eio integer, intent(out) :: iostat end subroutine eio_dump_skip <>= module subroutine eio_dump_skip (eio, iostat) class(eio_dump_t), intent(inout) :: eio integer, intent(out) :: iostat iostat = 0 end subroutine eio_dump_skip @ %def eio_dump_skip @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_dump_ut.f90]]>>= <> module eio_dump_ut use unit_tests use eio_dump_uti <> <> contains <> end module eio_dump_ut @ %def eio_dump_ut @ <<[[eio_dump_uti.f90]]>>= <> module eio_dump_uti <> <> use io_units use event_base use eio_data use eio_base use eio_dump use eio_base_ut, only: eio_prepare_test, eio_cleanup_test <> <> contains <> end module eio_dump_uti @ %def eio_dump_ut @ API: driver for the unit tests below. <>= public :: eio_dump_test <>= subroutine eio_dump_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_dump_test @ %def eio_dump_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_dump_1, "eio_dump_1", & "write event contents", & u, results) <>= public :: eio_dump_1 <>= subroutine eio_dump_1 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event class(eio_t), allocatable :: eio integer :: i_prc integer :: u_file write (u, "(A)") "* Test output: eio_dump_1" write (u, "(A)") "* Purpose: generate events and write essentials to output" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) write (u, "(A)") write (u, "(A)") "* Generate and write three events (two passed)" write (u, "(A)") allocate (eio_dump_t :: eio) select type (eio) type is (eio_dump_t) call eio%set_parameters (unit = u, weights = .true., pacify = .true.) end select i_prc = 42 call eio%init_out (var_str ("")) call event%generate (1, [0._default, 0._default]) call eio%output (event, i_prc = i_prc) call event%generate (1, [0.1_default, 0._default]) call event%set_index (99) call eio%output (event, i_prc = i_prc, passed = .false.) call event%generate (1, [0.2_default, 0._default]) call event%increment_index () call eio%output (event, i_prc = i_prc, passed = .true.) write (u, "(A)") write (u, "(A)") "* Contents of eio_dump object" write (u, "(A)") call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" select type (eio) type is (eio_dump_t) eio%writing = .false. end select call eio%final () call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_dump_1" end subroutine eio_dump_1 @ %def eio_dump_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{ASCII File Formats} Here, we implement several ASCII file formats. It is possible to switch between them using flags. <<[[eio_ascii.f90]]>>= <> module eio_ascii <> use event_base use event_handles, only: event_handle_t use eio_data use eio_base <> <> <> interface <> end interface end module eio_ascii @ %def eio_ascii @ <<[[eio_ascii_sub.f90]]>>= <> submodule (eio_ascii) eio_ascii_s use io_units use diagnostics use hep_common use hep_events implicit none contains <> end submodule eio_ascii_s @ %def eio_ascii_s @ \subsection{Type} <>= public :: eio_ascii_t <>= type, abstract, extends (eio_t) :: eio_ascii_t logical :: writing = .false. integer :: unit = 0 logical :: keep_beams = .false. logical :: keep_remnants = .true. logical :: ensure_order = .false. contains <> end type eio_ascii_t @ %def eio_ascii_t @ <>= public :: eio_ascii_ascii_t <>= type, extends (eio_ascii_t) :: eio_ascii_ascii_t end type eio_ascii_ascii_t @ %def eio_ascii_ascii_t @ <>= public :: eio_ascii_athena_t <>= type, extends (eio_ascii_t) :: eio_ascii_athena_t end type eio_ascii_athena_t @ %def eio_ascii_athena_t @ The debug format has a few options that can be controlled by Sindarin variables. <>= public :: eio_ascii_debug_t <>= type, extends (eio_ascii_t) :: eio_ascii_debug_t logical :: show_process = .true. logical :: show_transforms = .true. logical :: show_decay = .true. logical :: verbose = .true. end type eio_ascii_debug_t @ %def eio_ascii_debug_t @ <>= public :: eio_ascii_hepevt_t <>= type, extends (eio_ascii_t) :: eio_ascii_hepevt_t end type eio_ascii_hepevt_t @ %def eio_ascii_hepevt_t @ <>= public :: eio_ascii_hepevt_verb_t <>= type, extends (eio_ascii_t) :: eio_ascii_hepevt_verb_t end type eio_ascii_hepevt_verb_t @ %def eio_ascii_hepevt_verb_t @ <>= public :: eio_ascii_lha_t <>= type, extends (eio_ascii_t) :: eio_ascii_lha_t end type eio_ascii_lha_t @ %def eio_ascii_lha_t @ <>= public :: eio_ascii_lha_verb_t <>= type, extends (eio_ascii_t) :: eio_ascii_lha_verb_t end type eio_ascii_lha_verb_t @ %def eio_ascii_lha_verb_t @ <>= public :: eio_ascii_long_t <>= type, extends (eio_ascii_t) :: eio_ascii_long_t end type eio_ascii_long_t @ %def eio_ascii_long_t @ <>= public :: eio_ascii_mokka_t <>= type, extends (eio_ascii_t) :: eio_ascii_mokka_t end type eio_ascii_mokka_t @ %def eio_ascii_mokka_t @ <>= public :: eio_ascii_short_t <>= type, extends (eio_ascii_t) :: eio_ascii_short_t end type eio_ascii_short_t @ %def eio_ascii_short_t @ \subsection{Specific Methods} Set parameters that are specifically used with ASCII file formats. In particular, this is the file extension. <>= procedure :: set_parameters => eio_ascii_set_parameters <>= module subroutine eio_ascii_set_parameters (eio, & keep_beams, keep_remnants, ensure_order, extension, & show_process, show_transforms, show_decay, verbose) class(eio_ascii_t), intent(inout) :: eio logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants logical, intent(in), optional :: ensure_order type(string_t), intent(in), optional :: extension logical, intent(in), optional :: show_process, show_transforms, show_decay logical, intent(in), optional :: verbose end subroutine eio_ascii_set_parameters <>= module subroutine eio_ascii_set_parameters (eio, & keep_beams, keep_remnants, ensure_order, extension, & show_process, show_transforms, show_decay, verbose) class(eio_ascii_t), intent(inout) :: eio logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants logical, intent(in), optional :: ensure_order type(string_t), intent(in), optional :: extension logical, intent(in), optional :: show_process, show_transforms, show_decay logical, intent(in), optional :: verbose if (present (keep_beams)) eio%keep_beams = keep_beams if (present (keep_remnants)) eio%keep_remnants = keep_remnants if (present (ensure_order)) eio%ensure_order = ensure_order if (present (extension)) then eio%extension = extension else select type (eio) type is (eio_ascii_ascii_t) eio%extension = "evt" type is (eio_ascii_athena_t) eio%extension = "athena.evt" type is (eio_ascii_debug_t) eio%extension = "debug" type is (eio_ascii_hepevt_t) eio%extension = "hepevt" type is (eio_ascii_hepevt_verb_t) eio%extension = "hepevt.verb" type is (eio_ascii_lha_t) eio%extension = "lha" type is (eio_ascii_lha_verb_t) eio%extension = "lha.verb" type is (eio_ascii_long_t) eio%extension = "long.evt" type is (eio_ascii_mokka_t) eio%extension = "mokka.evt" type is (eio_ascii_short_t) eio%extension = "short.evt" end select end if select type (eio) type is (eio_ascii_debug_t) if (present (show_process)) eio%show_process = show_process if (present (show_transforms)) eio%show_transforms = show_transforms if (present (show_decay)) eio%show_decay = show_decay if (present (verbose)) eio%verbose = verbose end select end subroutine eio_ascii_set_parameters @ %def eio_ascii_set_parameters @ \subsection{Common Methods} Output. This is not the actual event format, but a readable account of the current object status. <>= procedure :: write => eio_ascii_write <>= module subroutine eio_ascii_write (object, unit) class(eio_ascii_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine eio_ascii_write <>= module subroutine eio_ascii_write (object, unit) class(eio_ascii_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) select type (object) type is (eio_ascii_ascii_t) write (u, "(1x,A)") "ASCII event stream (default format):" type is (eio_ascii_athena_t) write (u, "(1x,A)") "ASCII event stream (ATHENA format):" type is (eio_ascii_debug_t) write (u, "(1x,A)") "ASCII event stream (Debugging format):" type is (eio_ascii_hepevt_t) write (u, "(1x,A)") "ASCII event stream (HEPEVT format):" type is (eio_ascii_hepevt_verb_t) write (u, "(1x,A)") "ASCII event stream (verbose HEPEVT format):" type is (eio_ascii_lha_t) write (u, "(1x,A)") "ASCII event stream (LHA format):" type is (eio_ascii_lha_verb_t) write (u, "(1x,A)") "ASCII event stream (verbose LHA format):" type is (eio_ascii_long_t) write (u, "(1x,A)") "ASCII event stream (long format):" type is (eio_ascii_mokka_t) write (u, "(1x,A)") "ASCII event stream (MOKKA format):" type is (eio_ascii_short_t) write (u, "(1x,A)") "ASCII event stream (short format):" end select if (object%writing) then write (u, "(3x,A,A)") "Writing to file = ", char (object%filename) else write (u, "(3x,A)") "[closed]" end if write (u, "(3x,A,L1)") "Keep beams = ", object%keep_beams write (u, "(3x,A,L1)") "Keep remnants = ", object%keep_remnants select type (object) type is (eio_ascii_debug_t) write (u, "(3x,A,L1)") "Show process = ", object%show_process write (u, "(3x,A,L1)") "Show transforms = ", object%show_transforms write (u, "(3x,A,L1)") "Show decay tree = ", object%show_decay write (u, "(3x,A,L1)") "Verbose output = ", object%verbose end select end subroutine eio_ascii_write @ %def eio_ascii_write @ Finalizer: close any open file. <>= procedure :: final => eio_ascii_final <>= module subroutine eio_ascii_final (object) class(eio_ascii_t), intent(inout) :: object end subroutine eio_ascii_final <>= module subroutine eio_ascii_final (object) class(eio_ascii_t), intent(inout) :: object if (object%writing) then write (msg_buffer, "(A,A,A)") "Events: closing ASCII file '", & char (object%filename), "'" call msg_message () close (object%unit) object%writing = .false. end if end subroutine eio_ascii_final @ %def eio_ascii_final @ Initialize event writing. Check weight normalization. This applies to all ASCII-type files that use the HEPRUP common block. We can't allow normalization conventions that are not covered by the HEPRUP definition. <>= procedure :: init_out => eio_ascii_init_out <>= module subroutine eio_ascii_init_out & (eio, sample, data, success, extension) class(eio_ascii_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success end subroutine eio_ascii_init_out <>= module subroutine eio_ascii_init_out & (eio, sample, data, success, extension) class(eio_ascii_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success logical :: is_width integer :: i if (.not. present (data)) & call msg_bug ("ASCII initialization: missing data") is_width = data%n_beam == 1 eio%sample = sample call eio%check_normalization (data) call eio%set_splitting (data) call eio%set_filename () eio%unit = free_unit () write (msg_buffer, "(A,A,A)") "Events: writing to ASCII file '", & char (eio%filename), "'" call msg_message () eio%writing = .true. open (eio%unit, file = char (eio%filename), & action = "write", status = "replace") select type (eio) type is (eio_ascii_lha_t) call heprup_init( & data%pdg_beam, & data%energy_beam, & n_processes = data%n_proc, & unweighted = data%unweighted, & negative_weights = data%negative_weights) do i = 1, data%n_proc call heprup_set_process_parameters (i = i, & process_id = data%proc_num_id(i), & cross_section = data%cross_section(i), & error = data%error(i), & is_width = is_width) end do call heprup_write_ascii (eio%unit) type is (eio_ascii_lha_verb_t) call heprup_init( & data%pdg_beam, & data%energy_beam, & n_processes = data%n_proc, & unweighted = data%unweighted, & negative_weights = data%negative_weights) do i = 1, data%n_proc call heprup_set_process_parameters (i = i, & process_id = data%proc_num_id(i), & cross_section = data%cross_section(i), & error = data%error(i), & is_width = is_width) end do call heprup_write_verbose (eio%unit) end select if (present (success)) success = .true. end subroutine eio_ascii_init_out @ %def eio_ascii_init_out @ Some event properties do not go well with some output formats. In particular, many formats require unweighted events. <>= procedure :: check_normalization => eio_ascii_check_normalization <>= module subroutine eio_ascii_check_normalization (eio, data) class(eio_ascii_t), intent(in) :: eio type(event_sample_data_t), intent(in) :: data end subroutine eio_ascii_check_normalization <>= module subroutine eio_ascii_check_normalization (eio, data) class(eio_ascii_t), intent(in) :: eio type(event_sample_data_t), intent(in) :: data if (data%unweighted) then else select type (eio) type is (eio_ascii_athena_t); call msg_fatal & ("Event output (Athena format): events must be unweighted.") type is (eio_ascii_hepevt_t); call msg_fatal & ("Event output (HEPEVT format): events must be unweighted.") type is (eio_ascii_hepevt_verb_t); call msg_fatal & ("Event output (HEPEVT format): events must be unweighted.") end select select case (data%norm_mode) case (NORM_SIGMA) case default select type (eio) type is (eio_ascii_lha_t) call msg_fatal & ("Event output (LHA): normalization for weighted events & &must be 'sigma'") type is (eio_ascii_lha_verb_t) call msg_fatal & ("Event output (LHA): normalization for weighted events & &must be 'sigma'") end select end select end if end subroutine eio_ascii_check_normalization @ %def check_normalization @ Initialize event reading. <>= procedure :: init_in => eio_ascii_init_in <>= module subroutine eio_ascii_init_in & (eio, sample, data, success, extension) class(eio_ascii_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success end subroutine eio_ascii_init_in <>= module subroutine eio_ascii_init_in & (eio, sample, data, success, extension) class(eio_ascii_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success call msg_bug ("ASCII: event input not supported") if (present (success)) success = .false. end subroutine eio_ascii_init_in @ %def eio_ascii_init_in @ Switch from input to output: reopen the file for reading. <>= procedure :: switch_inout => eio_ascii_switch_inout <>= module subroutine eio_ascii_switch_inout (eio, success) class(eio_ascii_t), intent(inout) :: eio logical, intent(out), optional :: success end subroutine eio_ascii_switch_inout <>= module subroutine eio_ascii_switch_inout (eio, success) class(eio_ascii_t), intent(inout) :: eio logical, intent(out), optional :: success call msg_bug ("ASCII: in-out switch not supported") if (present (success)) success = .false. end subroutine eio_ascii_switch_inout @ %def eio_ascii_switch_inout @ Split event file: increment the counter, close the current file, open a new one. If the file needs a header, repeat it for the new file. (We assume that the common block contents are still intact.) <>= procedure :: split_out => eio_ascii_split_out <>= module subroutine eio_ascii_split_out (eio) class(eio_ascii_t), intent(inout) :: eio end subroutine eio_ascii_split_out <>= module subroutine eio_ascii_split_out (eio) class(eio_ascii_t), intent(inout) :: eio if (eio%split) then eio%split_index = eio%split_index + 1 call eio%set_filename () write (msg_buffer, "(A,A,A)") "Events: writing to ASCII file '", & char (eio%filename), "'" call msg_message () close (eio%unit) open (eio%unit, file = char (eio%filename), & action = "write", status = "replace") select type (eio) type is (eio_ascii_lha_t) call heprup_write_ascii (eio%unit) type is (eio_ascii_lha_verb_t) call heprup_write_verbose (eio%unit) end select end if end subroutine eio_ascii_split_out @ %def eio_ascii_split_out @ Output an event. Write first the event indices, then weight and squared matrix element, then the particle set. Events that did not pass the selection are skipped. The exceptions are the [[ascii]] and [[debug]] formats. These are the formats that contain the [[passed]] flag in their output, and should be most useful for debugging purposes. <>= procedure :: output => eio_ascii_output <>= module subroutine eio_ascii_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_ascii_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_ascii_output <>= module subroutine eio_ascii_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_ascii_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle if (present (passed)) then if (.not. passed) then select type (eio) type is (eio_ascii_debug_t) type is (eio_ascii_ascii_t) class default return end select end if end if if (eio%writing) then select type (eio) type is (eio_ascii_lha_t) call hepeup_from_event (event, & process_index = i_prc, & keep_beams = eio%keep_beams, & keep_remnants = eio%keep_remnants) call hepeup_write_lha (eio%unit) type is (eio_ascii_lha_verb_t) call hepeup_from_event (event, & process_index = i_prc, & keep_beams = eio%keep_beams, & keep_remnants = eio%keep_remnants) call hepeup_write_verbose (eio%unit) type is (eio_ascii_ascii_t) call event%write (eio%unit, & show_process = .false., & show_transforms = .false., & show_decay = .false., & verbose = .false., testflag = pacify) type is (eio_ascii_athena_t) call hepevt_from_event (event, & keep_beams = eio%keep_beams, & keep_remnants = eio%keep_remnants, & ensure_order = eio%ensure_order) call hepevt_write_athena (eio%unit) type is (eio_ascii_debug_t) call event%write (eio%unit, & show_process = eio%show_process, & show_transforms = eio%show_transforms, & show_decay = eio%show_decay, & verbose = eio%verbose, & testflag = pacify) type is (eio_ascii_hepevt_t) call hepevt_from_event (event, & keep_beams = eio%keep_beams, & keep_remnants = eio%keep_remnants, & ensure_order = eio%ensure_order) call hepevt_write_hepevt (eio%unit) type is (eio_ascii_hepevt_verb_t) call hepevt_from_event (event, & keep_beams = eio%keep_beams, & keep_remnants = eio%keep_remnants, & ensure_order = eio%ensure_order) call hepevt_write_verbose (eio%unit) type is (eio_ascii_long_t) call hepevt_from_event (event, & keep_beams = eio%keep_beams, & keep_remnants = eio%keep_remnants, & ensure_order = eio%ensure_order) call hepevt_write_ascii (eio%unit, .true.) type is (eio_ascii_mokka_t) call hepevt_from_event (event, & keep_beams = eio%keep_beams, & keep_remnants = eio%keep_remnants, & ensure_order = eio%ensure_order) call hepevt_write_mokka (eio%unit) type is (eio_ascii_short_t) call hepevt_from_event (event, & keep_beams = eio%keep_beams, & keep_remnants = eio%keep_remnants, & ensure_order = eio%ensure_order) call hepevt_write_ascii (eio%unit, .false.) end select else call eio%write () call msg_fatal ("ASCII file is not open for writing") end if end subroutine eio_ascii_output @ %def eio_ascii_output @ Input an event. <>= procedure :: input_i_prc => eio_ascii_input_i_prc procedure :: input_event => eio_ascii_input_event <>= module subroutine eio_ascii_input_i_prc (eio, i_prc, iostat) class(eio_ascii_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat end subroutine eio_ascii_input_i_prc module subroutine eio_ascii_input_event & (eio, event, iostat, event_handle) class(eio_ascii_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_ascii_input_event <>= module subroutine eio_ascii_input_i_prc (eio, i_prc, iostat) class(eio_ascii_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat call msg_bug ("ASCII: event input not supported") i_prc = 0 iostat = 1 end subroutine eio_ascii_input_i_prc module subroutine eio_ascii_input_event & (eio, event, iostat, event_handle) class(eio_ascii_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle call msg_bug ("ASCII: event input not supported") iostat = 1 end subroutine eio_ascii_input_event @ %def eio_ascii_input_i_prc @ %def eio_ascii_input_event @ <>= procedure :: skip => eio_ascii_skip <>= module subroutine eio_ascii_skip (eio, iostat) class(eio_ascii_t), intent(inout) :: eio integer, intent(out) :: iostat end subroutine eio_ascii_skip <>= module subroutine eio_ascii_skip (eio, iostat) class(eio_ascii_t), intent(inout) :: eio integer, intent(out) :: iostat iostat = 0 end subroutine eio_ascii_skip @ %def eio_asciii_skip @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_ascii_ut.f90]]>>= <> module eio_ascii_ut use unit_tests use eio_ascii_uti <> <> contains <> end module eio_ascii_ut @ %def eio_ascii_ut @ <<[[eio_ascii_uti.f90]]>>= <> module eio_ascii_uti <> <> use io_units use lorentz use model_data use event_base use particles use eio_data use eio_base use eio_ascii use eio_base_ut, only: eio_prepare_test, eio_cleanup_test <> <> contains <> end module eio_ascii_uti @ %def eio_ascii_uti @ API: driver for the unit tests below. <>= public :: eio_ascii_test <>= subroutine eio_ascii_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_ascii_test @ %def eio_ascii_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods, method [[ascii]]: <>= call test (eio_ascii_1, "eio_ascii_1", & "read and write event contents, format [ascii]", & u, results) <>= public :: eio_ascii_1 <>= subroutine eio_ascii_1 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_ascii_1" write (u, "(A)") "* Purpose: generate an event in ASCII ascii format" write (u, "(A)") "* and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_ascii_1" allocate (eio_ascii_ascii_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%set_index (42) call event%evaluate_expressions () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".evt"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:21) == " ") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_ascii_ascii_t :: eio) select type (eio) type is (eio_ascii_ascii_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_ascii_1" end subroutine eio_ascii_1 @ %def eio_ascii_1 @ We test the implementation of all I/O methods, method [[athena]]: <>= call test (eio_ascii_2, "eio_ascii_2", & "read and write event contents, format [athena]", & u, results) <>= public :: eio_ascii_2 <>= subroutine eio_ascii_2 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_ascii_2" write (u, "(A)") "* Purpose: generate an event in ASCII athena format" write (u, "(A)") "* and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_ascii_2" allocate (eio_ascii_athena_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%set_index (42) call event%evaluate_expressions () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char(sample // ".athena.evt"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:21) == " ") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_ascii_athena_t :: eio) select type (eio) type is (eio_ascii_athena_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_ascii_2" end subroutine eio_ascii_2 @ %def eio_ascii_2 @ We test the implementation of all I/O methods, method [[debug]]: <>= call test (eio_ascii_3, "eio_ascii_3", & "read and write event contents, format [debug]", & u, results) <>= public :: eio_ascii_3 <>= subroutine eio_ascii_3 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_ascii_3" write (u, "(A)") "* Purpose: generate an event in ASCII debug format" write (u, "(A)") "* and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_ascii_3" allocate (eio_ascii_debug_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".debug"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:21) == " ") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_ascii_debug_t :: eio) select type (eio) type is (eio_ascii_debug_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_ascii_3" end subroutine eio_ascii_3 @ %def eio_ascii_3 @ We test the implementation of all I/O methods, method [[hepevt]]: <>= call test (eio_ascii_4, "eio_ascii_4", & "read and write event contents, format [hepevt]", & u, results) <>= public :: eio_ascii_4 <>= subroutine eio_ascii_4 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_ascii_4" write (u, "(A)") "* Purpose: generate an event in ASCII hepevt format" write (u, "(A)") "* and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_ascii_4" allocate (eio_ascii_hepevt_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".hepevt"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:21) == " ") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_ascii_hepevt_t :: eio) select type (eio) type is (eio_ascii_hepevt_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_ascii_4" end subroutine eio_ascii_4 @ %def eio_ascii_4 @ We test the implementation of all I/O methods, method [[lha]] (old LHA): <>= call test (eio_ascii_5, "eio_ascii_5", & "read and write event contents, format [lha]", & u, results) <>= public :: eio_ascii_5 <>= subroutine eio_ascii_5 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_ascii_5" write (u, "(A)") "* Purpose: generate an event in ASCII LHA format" write (u, "(A)") "* and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_ascii_5" allocate (eio_ascii_lha_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".lha"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:21) == " ") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_ascii_lha_t :: eio) select type (eio) type is (eio_ascii_lha_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_ascii_5" end subroutine eio_ascii_5 @ %def eio_ascii_5 @ We test the implementation of all I/O methods, method [[long]]: <>= call test (eio_ascii_6, "eio_ascii_6", & "read and write event contents, format [long]", & u, results) <>= public :: eio_ascii_6 <>= subroutine eio_ascii_6 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_ascii_6" write (u, "(A)") "* Purpose: generate an event in ASCII long format" write (u, "(A)") "* and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_ascii_6" allocate (eio_ascii_long_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".long.evt"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:21) == " ") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_ascii_long_t :: eio) select type (eio) type is (eio_ascii_long_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_ascii_6" end subroutine eio_ascii_6 @ %def eio_ascii_6 @ We test the implementation of all I/O methods, method [[mokka]]: <>= call test (eio_ascii_7, "eio_ascii_7", & "read and write event contents, format [mokka]", & u, results) <>= public :: eio_ascii_7 <>= subroutine eio_ascii_7 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_ascii_7" write (u, "(A)") "* Purpose: generate an event in ASCII mokka format" write (u, "(A)") "* and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_ascii_7" allocate (eio_ascii_mokka_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".mokka.evt"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:21) == " ") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_ascii_mokka_t :: eio) select type (eio) type is (eio_ascii_mokka_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_ascii_7" end subroutine eio_ascii_7 @ %def eio_ascii_7 @ We test the implementation of all I/O methods, method [[short]]: <>= call test (eio_ascii_8, "eio_ascii_8", & "read and write event contents, format [short]", & u, results) <>= public :: eio_ascii_8 <>= subroutine eio_ascii_8 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_ascii_8" write (u, "(A)") "* Purpose: generate an event in ASCII short format" write (u, "(A)") "* and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_ascii_8" allocate (eio_ascii_short_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".short.evt"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:21) == " ") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_ascii_short_t :: eio) select type (eio) type is (eio_ascii_short_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_ascii_8" end subroutine eio_ascii_8 @ %def eio_ascii_8 @ We test the implementation of all I/O methods, method [[lha]] (old LHA) in verbose version: <>= call test (eio_ascii_9, "eio_ascii_9", & "read and write event contents, format [lha_verb]", & u, results) <>= public :: eio_ascii_9 <>= subroutine eio_ascii_9 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_ascii_9" write (u, "(A)") "* Purpose: generate an event in ASCII LHA verbose format" write (u, "(A)") "* and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_ascii_9" allocate (eio_ascii_lha_verb_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".lha.verb"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:21) == " ") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_ascii_lha_verb_t :: eio) select type (eio) type is (eio_ascii_lha_verb_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_ascii_9" end subroutine eio_ascii_9 @ %def eio_ascii_9 @ We test the implementation of all I/O methods, method [[hepevt_verb]]: <>= call test (eio_ascii_10, "eio_ascii_10", & "read and write event contents, format [hepevt_verb]", & u, results) <>= public :: eio_ascii_10 <>= subroutine eio_ascii_10 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_ascii_10" write (u, "(A)") "* Purpose: generate an event in ASCII hepevt verbose format" write (u, "(A)") "* and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_ascii_10" allocate (eio_ascii_hepevt_verb_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".hepevt.verb"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:21) == " ") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_ascii_hepevt_verb_t :: eio) select type (eio) type is (eio_ascii_hepevt_verb_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_ascii_10" end subroutine eio_ascii_10 @ %def eio_ascii_10 @ We test the implementation of all I/O methods, method [[mokka]]: <>= call test (eio_ascii_11, "eio_ascii_11", & "read and write event contents, format [mokka], tiny value", & u, results) <>= public :: eio_ascii_11 <>= subroutine eio_ascii_11 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(particle_set_t), pointer :: pset type(vector4_t) :: pnew type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(128) :: buffer real(default), parameter :: tval = 1.e-111_default write (u, "(A)") "* Test output: eio_ascii_11" write (u, "(A)") "* Purpose: generate an event in ASCII mokka format" write (u, "(A)") "* and write weight to file" write (u, "(A)") "* with low-value cutoff" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_ascii_11" allocate (eio_ascii_mokka_t :: eio) select type (eio) class is (eio_ascii_t); call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%increment_index () call event%evaluate_expressions () ! Manipulate values in the event record pset => event%get_particle_set_ptr () call pset%set_momentum (3, & vector4_moving (-tval, vector3_moving ([-tval, -tval, -tval])), & -tval**2) call pset%set_momentum (4, & vector4_moving (tval, vector3_moving ([tval, tval, tval])), & tval**2) call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".mokka.evt"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:21) == " ") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_ascii_11" end subroutine eio_ascii_11 @ %def eio_ascii_11 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{HEP Common Blocks} Long ago, to transfer data between programs one had to set up a common block and link both programs as libraries to the main executable. The HEP community standardizes several of those common blocks. The modern way of data exchange uses data files with standard formats. However, the LHEF standard data format derives from a common block (actually, two). \whizard\ used to support those common blocks, and LHEF was implemented via writing/reading blocks. We still keep this convention, but intend to eliminate common blocks (or any other static storage) from the workflow in the future. This will gain flexibility towards concurrent running of program images. We encapsulate everything here in a module. The module holds the variables which are part of the common block. To access the common block variables, we just have to [[use]] this module. (They are nevertheless in the common block, since external software may access it in this way.) Note: This code is taken essentially unchanged from \whizard\ 2.1 and does not (yet) provide unit tests. <<[[hep_common.f90]]>>= <> module hep_common <> use kinds, only: double use constants <> <> use lorentz use polarizations use model_data use particles <> <> <> <> <> <> interface <> end interface end module hep_common @ %def hep_common @ <<[[hep_common_sub.f90]]>>= <> submodule (hep_common) hep_common_s use io_units use diagnostics use numeric_utils use format_utils, only: refmt_tiny use physics_defs, only: pb_per_fb use physics_defs, only: HADRON_REMNANT use physics_defs, only: HADRON_REMNANT_SINGLET use physics_defs, only: HADRON_REMNANT_TRIPLET use physics_defs, only: HADRON_REMNANT_OCTET use xml use flavors use colors use subevents, only: PRT_BEAM, PRT_INCOMING, PRT_OUTGOING use subevents, only: PRT_UNDEFINED use subevents, only: PRT_VIRTUAL, PRT_RESONANT, PRT_BEAM_REMNANT implicit none contains <> end submodule hep_common_s @ %def hep_common_s @ \subsection{Event characteristics} The maximal number of particles in an event record. <>= integer, parameter, public :: MAXNUP = 500 @ %def MAXNUP @ The number of particles in this event. <>= integer, public :: NUP @ %def NUP @ The process ID for this event. <>= integer, public :: IDPRUP @ %def IDPRUP @ The weight of this event ($\pm 1$ for unweighted events). <>= double precision, public :: XWGTUP @ %def XWGTUP @ The factorization scale that is used for PDF calculation ($-1$ if undefined). <>= double precision, public :: SCALUP @ %def SCALUP @ The QED and QCD couplings $\alpha$ used for this event ($-1$ if undefined). <>= double precision, public :: AQEDUP double precision, public :: AQCDUP @ %def AQEDUP AQCDUP @ \subsection{Particle characteristics} The PDG code: <>= integer, dimension(MAXNUP), public :: IDUP @ %def IDUP @ The status code. Incoming: $-1$, outgoing: $+1$. Intermediate t-channel propagator: $-2$ (currently not used by WHIZARD). Intermediate resonance whose mass should be preserved: $2$. Intermediate resonance for documentation: $3$ (currently not used). Beam particles: $-9$. <>= integer, dimension(MAXNUP), public :: ISTUP @ %def ISTUP @ Index of first and last mother. <>= integer, dimension(2,MAXNUP), public :: MOTHUP @ %def MOTHUP @ Color line index of the color and anticolor entry for the particle. The standard recommends using large numbers; we start from MAXNUP+1. <>= integer, dimension(2,MAXNUP), public :: ICOLUP @ %def ICOLUP @ Momentum, energy, and invariant mass: $(p_x,p_y,p_z,E,M)$. For space-like particles, $M$ is the negative square root of the absolute value of the invariant mass. <>= double precision, dimension(5,MAXNUP), public :: PUP @ %def PUP @ Invariant lifetime (distance) from production to decay in mm. <>= double precision, dimension(MAXNUP), public :: VTIMUP @ %def VTIMUP @ Cosine of the angle between the spin-vector and a particle and the 3-momentum of its mother, given in the lab frame. If undefined/unpolarized: $9$. <>= double precision, dimension(MAXNUP), public :: SPINUP @ %def SPINUP @ \subsection{The HEPRUP common block} This common block is filled once per run. \subsubsection{Run characteristics} The maximal number of different processes. <>= integer, parameter, public :: MAXPUP = 100 @ %def MAXPUP @ The beam PDG codes. <>= integer, dimension(2), public :: IDBMUP @ %def IDBMUP @ The beam energies in GeV. <>= double precision, dimension(2), public :: EBMUP @ %def EBMUP @ The PDF group and set for the two beams. (Undefined: use $-1$; LHAPDF: use group = $0$). <>= integer, dimension(2), public :: PDFGUP integer, dimension(2), public :: PDFSUP @ %def PDFGUP PDFSUP @ The (re)weighting model. 1: events are weighted, the shower generator (SHG) selects processes according to the maximum weight (in pb) and unweights events. 2: events are weighted, the SHG selects processes according to their cross section (in pb) and unweights events. 3: events are unweighted and simply run through the SHG. 4: events are weighted, and the SHG keeps the weight. Negative numbers: negative weights are allowed (and are reweighted to $\pm 1$ by the SHG, if allowed). \whizard\ only supports modes 3 and 4, as the SHG is not given control over process selection. This is consistent with writing events to file, for offline showering. <>= integer, public :: IDWTUP @ %def IDWTUP @ The number of different processes. <>= integer, public :: NPRUP @ %def NPRUP @ \subsubsection{Process characteristics} Cross section and error in pb. (Cross section is needed only for -$[[IDWTUP]] = 2$, so here both values are given for informational +$\text{[[IDWTUP]]} = 2$, so here both values are given for informational purposes only.) <>= double precision, dimension(MAXPUP), public :: XSECUP double precision, dimension(MAXPUP), public :: XERRUP @ %def XSECUP XERRUP @ Maximum weight, i.e., the maximum value that [[XWGTUP]] can take. Also unused for the supported weighting models. It is $\pm 1$ for unweighted events. <>= double precision, dimension(MAXPUP), public :: XMAXUP @ %def XMAXUP @ Internal ID of the selected process, matches [[IDPRUP]] below. <>= integer, dimension(MAXPUP), public :: LPRUP @ %def LPRUP @ \subsubsection{The common block} <>= common /HEPRUP/ & IDBMUP, EBMUP, PDFGUP, PDFSUP, IDWTUP, NPRUP, & XSECUP, XERRUP, XMAXUP, LPRUP save /HEPRUP/ @ %def HEPRUP @ Fill the run characteristics of the common block. The initialization sets the beam properties, number of processes, and weighting model. <>= public :: heprup_init <>= module subroutine heprup_init & (beam_pdg, beam_energy, n_processes, unweighted, negative_weights) integer, dimension(2), intent(in) :: beam_pdg real(default), dimension(2), intent(in) :: beam_energy integer, intent(in) :: n_processes logical, intent(in) :: unweighted logical, intent(in) :: negative_weights end subroutine heprup_init <>= module subroutine heprup_init & (beam_pdg, beam_energy, n_processes, unweighted, negative_weights) integer, dimension(2), intent(in) :: beam_pdg real(default), dimension(2), intent(in) :: beam_energy integer, intent(in) :: n_processes logical, intent(in) :: unweighted logical, intent(in) :: negative_weights IDBMUP = beam_pdg EBMUP = beam_energy PDFGUP = -1 PDFSUP = -1 if (unweighted) then IDWTUP = 3 else IDWTUP = 4 end if if (negative_weights) IDWTUP = - IDWTUP NPRUP = n_processes end subroutine heprup_init @ %def heprup_init The HEPRUP (event) common block is needed for the interface to the shower. Filling of it is triggered by some output file formats. If these are not present, the common block is filled with some dummy information. Be generous with the number of processes in HEPRUP so that PYTHIA only rarely needs to be reinitialized in case events with higher process ids are generated. <>= public :: assure_heprup <>= module subroutine assure_heprup (pset) type(particle_set_t), intent(in) :: pset end subroutine assure_heprup <>= module subroutine assure_heprup (pset) type(particle_set_t), intent(in) :: pset integer :: i, num_id integer, parameter :: min_processes = 10 num_id = 1 if (LPRUP (num_id) /= 0) return call heprup_init ( & [pset%prt(1)%get_pdg (), pset%prt(2)%get_pdg ()] , & [pset%prt(1)%p%p(0), pset%prt(2)%p%p(0)], & num_id, .false., .false.) do i = 1, (num_id / min_processes + 1) * min_processes call heprup_set_process_parameters (i = i, process_id = & i, cross_section = 1._default, error = 1._default) end do end subroutine assure_heprup @ %def assure_heprup @ Read in the LHE file opened in unit [[u]] and add the final particles to the [[particle_set]], the outgoing particles of the existing [[particle_set]] are compared to the particles that are read in. When they are equal in flavor and momenta, they are erased and their mother-daughter relations are transferred to the existing particles. <>= public :: combine_lhef_with_particle_set <>= module subroutine combine_lhef_with_particle_set & (particle_set, u, model_in, model_hadrons) type(particle_set_t), intent(inout) :: particle_set integer, intent(in) :: u class(model_data_t), intent(in), target :: model_in class(model_data_t), intent(in), target :: model_hadrons end subroutine combine_lhef_with_particle_set <>= module subroutine combine_lhef_with_particle_set & (particle_set, u, model_in, model_hadrons) type(particle_set_t), intent(inout) :: particle_set integer, intent(in) :: u class(model_data_t), intent(in), target :: model_in class(model_data_t), intent(in), target :: model_hadrons type(flavor_t) :: flv type(color_t) :: col class(model_data_t), pointer :: model type(particle_t), dimension(:), allocatable :: prt_tmp, prt integer :: i, j type(vector4_t) :: mom, d_mom integer, PARAMETER :: MAXLEN=200 character(len=maxlen) :: string integer :: ibeg, n_tot, n_entries integer, dimension(:), allocatable :: relations, mothers, tbd INTEGER :: NUP,IDPRUP,IDUP,ISTUP real(kind=double) :: XWGTUP,SCALUP,AQEDUP,AQCDUP,VTIMUP,SPINUP integer :: MOTHUP(1:2), ICOLUP(1:2) real(kind=double) :: PUP(1:5) real(kind=default) :: pup_dum(1:5) character(len=5) :: buffer character(len=6) :: strfmt logical :: not_found logical :: debug_lhef = .false. STRFMT='(A000)' WRITE (STRFMT(3:5),'(I3)') MAXLEN if (debug_lhef) call particle_set%write () rewind (u) do read (u,*, END=501, ERR=502) STRING IBEG = 0 do if (signal_is_pending ()) return IBEG = IBEG + 1 ! Allow indentation. IF (STRING (IBEG:IBEG) .EQ. ' ' .and. IBEG < MAXLEN-6) cycle exit end do IF (string(IBEG:IBEG+6) /= '' .and. & string(IBEG:IBEG+6) /= ' number of entries read (u, *, END=503, ERR=504) NUP, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP n_tot = particle_set%get_n_tot () allocate (prt_tmp (1:n_tot+NUP)) allocate (relations (1:NUP), mothers (1:NUP), tbd(1:NUP)) do i = 1, n_tot if (signal_is_pending ()) return prt_tmp (i) = particle_set%get_particle (i) end do !!! transfer particles from lhef to particle_set !!!...Read NUP subsequent lines with information on each particle. n_entries = 1 mothers = 0 relations = 0 PARTICLE_LOOP: do I = 1, NUP read (u,*, END=200, ERR=505) IDUP, ISTUP, MOTHUP(1), MOTHUP(2), & ICOLUP(1), ICOLUP(2), (PUP (J),J=1,5), VTIMUP, SPINUP if (model_in%test_field (IDUP)) then model => model_in else if (model_hadrons%test_field (IDUP)) then model => model_hadrons else write (buffer, "(I5)") IDUP call msg_error ("Parton " // buffer // & " found neither in given model file nor in SM_hadrons") return end if if (debug_lhef) then print *, "IDUP, ISTUP, MOTHUP, PUP = ", IDUP, ISTUP, MOTHUP(1), & MOTHUP(2), PUP end if call flv%init (IDUP, model) if (IABS(IDUP) == 2212 .or. IABS(IDUP) == 2112) then ! PYTHIA sometimes sets color indices for protons and neutrons (?) ICOLUP (1) = 0 ICOLUP (2) = 0 end if call col%init_col_acl (ICOLUP (1), ICOLUP (2)) !!! Settings for unpolarized particles ! particle_set%prt (oldsize+i)%hel = ?? ! particle_set%prt (oldsize+i)%pol = ?? if (MOTHUP(1) /= 0) then mothers(i) = MOTHUP(1) end if pup_dum = PUP if (pup_dum(4) < 1E-10_default) cycle mom = vector4_moving (pup_dum (4), & vector3_moving ([pup_dum (1), pup_dum (2), pup_dum (3)])) not_found = .true. SCAN_PARTICLES: do j = 1, n_tot d_mom = prt_tmp(j)%get_momentum () if (all (nearly_equal & (mom%p, d_mom%p, abs_smallness = 1.E-4_default)) .and. & (prt_tmp(j)%get_pdg () == IDUP)) then if (.not. prt_tmp(j)%get_status () == PRT_BEAM .or. & .not. prt_tmp(j)%get_status () == PRT_BEAM_REMNANT) & relations(i) = j not_found = .false. end if end do SCAN_PARTICLES if (not_found) then if (debug_lhef) & print *, "Not found: adding particle" call prt_tmp(n_tot+n_entries)%set_flavor (flv) call prt_tmp(n_tot+n_entries)%set_color (col) call prt_tmp(n_tot+n_entries)%set_momentum (mom) if (MOTHUP(1) /= 0) then if (relations(MOTHUP(1)) /= 0) then call prt_tmp(n_tot+n_entries)%set_parents & ([relations(MOTHUP(1))]) call prt_tmp(relations(MOTHUP(1)))%add_child (n_tot+n_entries) if (prt_tmp(relations(MOTHUP(1)))%get_status () & == PRT_OUTGOING) & call prt_tmp(relations(MOTHUP(1)))%reset_status & (PRT_VIRTUAL) end if end if call prt_tmp(n_tot+n_entries)%set_status (PRT_OUTGOING) if (debug_lhef) call prt_tmp(n_tot+n_entries)%write () n_entries = n_entries + 1 end if end do PARTICLE_LOOP do i = 1, n_tot if (prt_tmp(i)%get_status () == PRT_OUTGOING .and. & prt_tmp(i)%get_n_children () /= 0) then call prt_tmp(i)%reset_status (PRT_VIRTUAL) end if end do allocate (prt (1:n_tot+n_entries-1)) prt = prt_tmp (1:n_tot+n_entries-1) ! transfer to particle_set call particle_set%replace (prt) deallocate (prt, prt_tmp) if (debug_lhef) then call particle_set%write () print *, "combine_lhef_with_particle_set" ! stop end if 200 continue return 501 write(*,*) "READING LHEF failed 501" return 502 write(*,*) "READING LHEF failed 502" return 503 write(*,*) "READING LHEF failed 503" return 504 write(*,*) "READING LHEF failed 504" return 505 write(*,*) "READING LHEF failed 505" return end subroutine combine_lhef_with_particle_set @ %def combine_lhef_with_particle_set @ <>= public :: w2p_write_lhef_event <>= module subroutine w2p_write_lhef_event (unit) integer, intent(in) :: unit end subroutine w2p_write_lhef_event <>= module subroutine w2p_write_lhef_event (unit) integer, intent(in) :: unit type(xml_tag_t), allocatable :: tag_lhef, tag_head, tag_init, & tag_event, tag_gen_n, tag_gen_v if (debug_on) call msg_debug (D_EVENTS, "w2p_write_lhef_event") allocate (tag_lhef, tag_head, tag_init, tag_event, & tag_gen_n, tag_gen_v) call tag_lhef%init (var_str ("LesHouchesEvents"), & [xml_attribute (var_str ("version"), var_str ("1.0"))], .true.) call tag_head%init (var_str ("header"), .true.) call tag_init%init (var_str ("init"), .true.) call tag_event%init (var_str ("event"), .true.) call tag_gen_n%init (var_str ("generator_name"), .true.) call tag_gen_v%init (var_str ("generator_version"), .true.) call tag_lhef%write (unit); write (unit, *) call tag_head%write (unit); write (unit, *) write (unit, "(2x)", advance = "no") call tag_gen_n%write (var_str ("WHIZARD"), unit) write (unit, *) write (unit, "(2x)", advance = "no") call tag_gen_v%write (var_str ("<>"), unit) write (unit, *) call tag_head%close (unit); write (unit, *) call tag_init%write (unit); write (unit, *) call heprup_write_lhef (unit) call tag_init%close (unit); write (unit, *) call tag_event%write (unit); write (unit, *) call hepeup_write_lhef (unit) call tag_event%close (unit); write (unit, *) call tag_lhef%close (unit); write (unit, *) deallocate (tag_lhef, tag_head, tag_init, tag_event, & tag_gen_n, tag_gen_v) end subroutine w2p_write_lhef_event @ %def w2p_write_lhef_event @ Extract parameters from the common block. We leave it to the caller to specify which parameters it actually needs. [[PDFGUP]] and [[PDFSUP]] are not extracted. [[IDWTUP=1,2]] are not supported by \whizard, but correspond to weighted events. <>= public :: heprup_get_run_parameters <>= module subroutine heprup_get_run_parameters & (beam_pdg, beam_energy, n_processes, unweighted, negative_weights) integer, dimension(2), intent(out), optional :: beam_pdg real(default), dimension(2), intent(out), optional :: beam_energy integer, intent(out), optional :: n_processes logical, intent(out), optional :: unweighted logical, intent(out), optional :: negative_weights end subroutine heprup_get_run_parameters <>= module subroutine heprup_get_run_parameters & (beam_pdg, beam_energy, n_processes, unweighted, negative_weights) integer, dimension(2), intent(out), optional :: beam_pdg real(default), dimension(2), intent(out), optional :: beam_energy integer, intent(out), optional :: n_processes logical, intent(out), optional :: unweighted logical, intent(out), optional :: negative_weights if (present (beam_pdg)) beam_pdg = IDBMUP if (present (beam_energy)) beam_energy = EBMUP if (present (n_processes)) n_processes = NPRUP if (present (unweighted)) then select case (abs (IDWTUP)) case (3) unweighted = .true. case (4) unweighted = .false. case (1,2) !!! not supported by WHIZARD unweighted = .false. case default call msg_fatal ("HEPRUP: unsupported IDWTUP value") end select end if if (present (negative_weights)) then negative_weights = IDWTUP < 0 end if end subroutine heprup_get_run_parameters @ %def heprup_get_run_parameters @ Specify PDF set info. Since we support only LHAPDF, the group entry is zero. <>= public :: heprup_set_lhapdf_id <>= module subroutine heprup_set_lhapdf_id (i_beam, pdf_id) integer, intent(in) :: i_beam, pdf_id end subroutine heprup_set_lhapdf_id <>= module subroutine heprup_set_lhapdf_id (i_beam, pdf_id) integer, intent(in) :: i_beam, pdf_id PDFGUP(i_beam) = 0 PDFSUP(i_beam) = pdf_id end subroutine heprup_set_lhapdf_id @ %def heprup_set_lhapdf_id @ Fill the characteristics for a particular process. Only the process ID is mandatory. Note that \whizard\ computes cross sections in fb, so we have to rescale to pb. The maximum weight is meaningless for unweighted events. <>= public :: heprup_set_process_parameters <>= module subroutine heprup_set_process_parameters & (i, process_id, cross_section, error, max_weight, is_width) integer, intent(in) :: i, process_id real(default), intent(in), optional :: cross_section, error, max_weight logical, intent(in), optional :: is_width end subroutine heprup_set_process_parameters <>= module subroutine heprup_set_process_parameters & (i, process_id, cross_section, error, max_weight, is_width) integer, intent(in) :: i, process_id real(default), intent(in), optional :: cross_section, error, max_weight logical, intent(in), optional :: is_width logical :: is_w is_w = .false. if (present (is_width)) is_w = is_width LPRUP(i) = process_id if (present (cross_section)) then if (is_w) then XSECUP(i) = cross_section else XSECUP(i) = cross_section * pb_per_fb end if else XSECUP(i) = 0 end if if (present (error)) then if (is_w) then XERRUP(i) = error else XERRUP(i) = error * pb_per_fb end if else XERRUP(i) = 0 end if select case (IDWTUP) case (3); XMAXUP(i) = 1 case (4) if (present (max_weight)) then if (is_w) then XMAXUP(i) = max_weight else XMAXUP(i) = max_weight * pb_per_fb end if else XMAXUP(i) = 0 end if end select end subroutine heprup_set_process_parameters @ %def heprup_set_process_parameters @ Extract the process parameters, as far as needed. <>= public :: heprup_get_process_parameters <>= module subroutine heprup_get_process_parameters & (i, process_id, cross_section, error, max_weight, is_width) integer, intent(in) :: i integer, intent(out), optional :: process_id real(default), intent(out), optional :: cross_section, error, max_weight logical, intent(in), optional :: is_width end subroutine heprup_get_process_parameters <>= module subroutine heprup_get_process_parameters & (i, process_id, cross_section, error, max_weight, is_width) integer, intent(in) :: i integer, intent(out), optional :: process_id real(default), intent(out), optional :: cross_section, error, max_weight logical, intent(in), optional :: is_width logical :: is_w is_w = .false. if (present (is_width)) is_w = is_width if (present (process_id)) process_id = LPRUP(i) if (present (cross_section)) then if (is_w) then cross_section = XSECUP(i) else cross_section = XSECUP(i) / pb_per_fb end if end if if (present (error)) then if (is_w) then error = XERRUP(i) else error = XERRUP(i) / pb_per_fb end if end if if (present (max_weight)) then select case (IDWTUP) case (3) max_weight = 1 case (4) max_weight = XMAXUP(i) / pb_per_fb case (1,2) !!! not supported by WHIZARD max_weight = 0 case default call msg_fatal ("HEPRUP: unsupported IDWTUP value") end select end if end subroutine heprup_get_process_parameters @ %def heprup_get_process_parameters @ \subsection{Run parameter output (verbose)} This is a verbose output of the HEPRUP block. <>= public :: heprup_write_verbose <>= module subroutine heprup_write_verbose (unit) integer, intent(in), optional :: unit end subroutine heprup_write_verbose <>= module subroutine heprup_write_verbose (unit) integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "HEPRUP Common Block" write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "IDBMUP", IDBMUP, & "PDG code of beams" write (u, "(3x,A6,' = ',G12.5,1x,G12.5,8x,A)") "EBMUP ", EBMUP, & "Energy of beams in GeV" write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "PDFGUP", PDFGUP, & "PDF author group [-1 = undefined]" write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "PDFSUP", PDFSUP, & "PDF set ID [-1 = undefined]" write (u, "(3x,A6,' = ',I9,3x,1x,9x,3x,8x,A)") "IDWTUP", IDWTUP, & "LHA code for event weight mode" write (u, "(3x,A6,' = ',I9,3x,1x,9x,3x,8x,A)") "NPRUP ", NPRUP, & "Number of user subprocesses" do i = 1, NPRUP write (u, "(1x,A,I0)") "Subprocess #", i write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "XSECUP", XSECUP(i), & "Cross section in pb" write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "XERRUP", XERRUP(i), & "Cross section error in pb" write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "XMAXUP", XMAXUP(i), & "Maximum event weight (cf. IDWTUP)" write (u, "(3x,A6,' = ',I9,3x,1x,12x,8x,A)") "LPRUP ", LPRUP(i), & "Subprocess ID" end do end subroutine heprup_write_verbose @ %def heprup_write_verbose @ \subsection{Run parameter output (other formats)} This routine writes the initialization block according to the LHEF standard. It uses the current contents of the HEPRUP block. <>= public :: heprup_write_lhef <>= module subroutine heprup_write_lhef (unit) integer, intent(in), optional :: unit end subroutine heprup_write_lhef <>= module subroutine heprup_write_lhef (unit) integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(2(1x,I0),2(1x,ES17.10),6(1x,I0))") & IDBMUP, EBMUP, PDFGUP, PDFSUP, IDWTUP, NPRUP do i = 1, NPRUP write (u, "(3(1x,ES17.10),1x,I0)") & XSECUP(i), XERRUP(i), XMAXUP(i), LPRUP(i) end do end subroutine heprup_write_lhef @ %def heprup_write_lhef @ This routine is a complete dummy at the moment. It uses the current contents of the HEPRUP block. At the end, it should depend on certain input flags for the different ASCII event formats. <>= public :: heprup_write_ascii <>= module subroutine heprup_write_ascii (unit) integer, intent(in), optional :: unit end subroutine heprup_write_ascii <>= module subroutine heprup_write_ascii (unit) integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(2(1x,I0),2(1x,ES17.10),6(1x,I0))") & IDBMUP, EBMUP, PDFGUP, PDFSUP, IDWTUP, NPRUP do i = 1, NPRUP write (u, "(3(1x,ES17.10),1x,I0)") & XSECUP(i), XERRUP(i), XMAXUP(i), LPRUP(i) end do end subroutine heprup_write_ascii @ %def heprup_write_ascii @ \subsubsection{Run parameter input (LHEF)} In a LHEF file, the parameters are written in correct order on separate lines, but we should not count on the precise format. List-directed input should just work. <>= public :: heprup_read_lhef <>= module subroutine heprup_read_lhef (u) integer, intent(in) :: u end subroutine heprup_read_lhef <>= module subroutine heprup_read_lhef (u) integer, intent(in) :: u integer :: i read (u, *) & IDBMUP, EBMUP, PDFGUP, PDFSUP, IDWTUP, NPRUP do i = 1, NPRUP read (u, *) & XSECUP(i), XERRUP(i), XMAXUP(i), LPRUP(i) end do end subroutine heprup_read_lhef @ %def heprup_read_lhef @ \subsection{The HEPEUP common block} <>= common /HEPEUP/ & NUP, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP, & IDUP, ISTUP, MOTHUP, ICOLUP, PUP, VTIMUP, SPINUP save /HEPEUP/ @ %def HEPEUP @ \subsubsection{Initialization} Fill the event characteristics of the common block. The initialization sets only the number of particles and initializes the rest with default values. The other routine sets the optional parameters. <>= public :: hepeup_init public :: hepeup_set_event_parameters <>= module subroutine hepeup_init (n_tot) integer, intent(in) :: n_tot end subroutine hepeup_init module subroutine hepeup_set_event_parameters & (proc_id, weight, scale, alpha_qed, alpha_qcd) integer, intent(in), optional :: proc_id real(default), intent(in), optional :: & weight, scale, alpha_qed, alpha_qcd end subroutine hepeup_set_event_parameters <>= module subroutine hepeup_init (n_tot) integer, intent(in) :: n_tot NUP = n_tot IDPRUP = 0 XWGTUP = 1 SCALUP = -1 AQEDUP = -1 AQCDUP = -1 end subroutine hepeup_init module subroutine hepeup_set_event_parameters & (proc_id, weight, scale, alpha_qed, alpha_qcd) integer, intent(in), optional :: proc_id real(default), intent(in), optional :: & weight, scale, alpha_qed, alpha_qcd if (present (proc_id)) IDPRUP = proc_id if (present (weight)) XWGTUP = weight if (present (scale)) SCALUP = scale if (present (alpha_qed)) AQEDUP = alpha_qed if (present (alpha_qcd)) AQCDUP = alpha_qcd end subroutine hepeup_set_event_parameters @ %def hepeup_init hepeup_set_event_parameters @ Extract event information. The caller determines the parameters. <>= public :: hepeup_get_event_parameters <>= module subroutine hepeup_get_event_parameters & (proc_id, weight, scale, alpha_qed, alpha_qcd) integer, intent(out), optional :: proc_id real(default), intent(out), optional :: & weight, scale, alpha_qed, alpha_qcd end subroutine hepeup_get_event_parameters <>= module subroutine hepeup_get_event_parameters & (proc_id, weight, scale, alpha_qed, alpha_qcd) integer, intent(out), optional :: proc_id real(default), intent(out), optional :: & weight, scale, alpha_qed, alpha_qcd if (present (proc_id)) proc_id = IDPRUP if (present (weight)) weight = XWGTUP if (present (scale)) scale = SCALUP if (present (alpha_qed)) alpha_qed = AQEDUP if (present (alpha_qcd)) alpha_qcd = AQCDUP end subroutine hepeup_get_event_parameters @ %def hepeup_get_event_parameters @ \subsubsection{Particle data} Below we need the particle status codes which are actually defined in the [[subevents]] module. Set the entry for a specific particle. All parameters are set with the exception of lifetime and spin, where default values are stored. <>= public :: hepeup_set_particle <>= module subroutine hepeup_set_particle (i, pdg, status, parent, col, p, m2) integer, intent(in) :: i integer, intent(in) :: pdg, status integer, dimension(:), intent(in) :: parent type(vector4_t), intent(in) :: p integer, dimension(2), intent(in) :: col real(default), intent(in) :: m2 end subroutine hepeup_set_particle <>= module subroutine hepeup_set_particle (i, pdg, status, parent, col, p, m2) integer, intent(in) :: i integer, intent(in) :: pdg, status integer, dimension(:), intent(in) :: parent type(vector4_t), intent(in) :: p integer, dimension(2), intent(in) :: col real(default), intent(in) :: m2 if (i > MAXNUP) then call msg_error (arr=[ & var_str ("Too many particles in HEPEUP common block. " // & "If this happened "), & var_str ("during event output, your events will be " // & "invalid; please consider "), & var_str ("switching to a modern event format like HEPMC. " // & "If you are not "), & var_str ("using an old, HEPEUP based format and " // & "nevertheless get this error,"), & var_str ("please notify the WHIZARD developers,") ]) return end if IDUP(i) = pdg select case (status) case (PRT_BEAM); ISTUP(i) = -9 case (PRT_INCOMING); ISTUP(i) = -1 case (PRT_BEAM_REMNANT); ISTUP(i) = 3 case (PRT_OUTGOING); ISTUP(i) = 1 case (PRT_RESONANT); ISTUP(i) = 2 case (PRT_VIRTUAL); ISTUP(i) = 3 case default; ISTUP(i) = 0 end select select case (size (parent)) case (0); MOTHUP(:,i) = 0 case (1); MOTHUP(1,i) = parent(1); MOTHUP(2,i) = 0 case default; MOTHUP(:,i) = [ parent(1), parent(size (parent)) ] end select if (col(1) > 0) then ICOLUP(1,i) = 500 + col(1) else ICOLUP(1,i) = 0 end if if (col(2) > 0) then ICOLUP(2,i) = 500 + col(2) else ICOLUP(2,i) = 0 end if PUP(1:3,i) = refmt_tiny (vector3_get_components (space_part (p))) PUP(4,i) = refmt_tiny (energy (p)) PUP(5,i) = refmt_tiny (sign (sqrt (abs (m2)), m2)) VTIMUP(i) = 0 SPINUP(i) = 9 end subroutine hepeup_set_particle @ %def hepeup_set_particle @ Set the lifetime, actually $c\tau$ measured im mm, where $\tau$ is the invariant lifetime. <>= public :: hepeup_set_particle_lifetime <>= module subroutine hepeup_set_particle_lifetime (i, lifetime) integer, intent(in) :: i real(default), intent(in) :: lifetime end subroutine hepeup_set_particle_lifetime <>= module subroutine hepeup_set_particle_lifetime (i, lifetime) integer, intent(in) :: i real(default), intent(in) :: lifetime VTIMUP(i) = lifetime end subroutine hepeup_set_particle_lifetime @ %def hepeup_set_particle_lifetime @ Set the particle spin entry. We need the cosine of the angle of the spin axis with respect to the three-momentum of the parent particle. If the particle has a full polarization density matrix given, we need the particle momentum and polarization as well as the mother-particle momentum. The polarization is transformed into a spin vector (which is sensible only for spin-1/2 or massless particles), which then is transformed into the lab frame (by a rotation of the 3-axis to the particle momentum axis). Finally, we compute the scalar product of this vector with the mother-particle three-momentum. This puts severe restrictions on the applicability of this definition, and Lorentz invariance is lost. Unfortunately, the Les Houches Accord requires this computation. <>= public :: hepeup_set_particle_spin <>= interface hepeup_set_particle_spin module procedure hepeup_set_particle_spin_pol end interface <>= module subroutine hepeup_set_particle_spin_pol (i, p, pol, p_mother) integer, intent(in) :: i type(vector4_t), intent(in) :: p type(polarization_t), intent(in) :: pol type(vector4_t), intent(in) :: p_mother end subroutine hepeup_set_particle_spin_pol <>= module subroutine hepeup_set_particle_spin_pol (i, p, pol, p_mother) integer, intent(in) :: i type(vector4_t), intent(in) :: p type(polarization_t), intent(in) :: pol type(vector4_t), intent(in) :: p_mother type(vector3_t) :: s3, p3 type(vector4_t) :: s4 s3 = vector3_moving (pol%get_axis ()) p3 = space_part (p) s4 = rotation_to_2nd (3, p3) * vector4_moving (0._default, s3) SPINUP(i) = enclosed_angle_ct (s4, p_mother) end subroutine hepeup_set_particle_spin_pol @ %def hepeup_set_particle_spin @ Extract particle data. The caller decides which ones to retrieve. Status codes: beam remnants share the status code with virtual particles. However, for the purpose of WHIZARD we should identify them. We use the PDG code for this. <>= public :: hepeup_get_particle <>= module subroutine hepeup_get_particle (i, pdg, status, parent, col, p, m2) integer, intent(in) :: i integer, intent(out), optional :: pdg, status integer, dimension(:), intent(out), optional :: parent type(vector4_t), intent(out), optional :: p integer, dimension(2), intent(out), optional :: col real(default), dimension(5,MAXNUP) :: pup_def real(default), intent(out), optional :: m2 end subroutine hepeup_get_particle <>= module subroutine hepeup_get_particle (i, pdg, status, parent, col, p, m2) integer, intent(in) :: i integer, intent(out), optional :: pdg, status integer, dimension(:), intent(out), optional :: parent type(vector4_t), intent(out), optional :: p integer, dimension(2), intent(out), optional :: col real(default), dimension(5,MAXNUP) :: pup_def real(default), intent(out), optional :: m2 if (present (pdg)) pdg = IDUP(i) if (present (status)) then select case (ISTUP(i)) case (-9); status = PRT_BEAM case (-1); status = PRT_INCOMING case (1); status = PRT_OUTGOING case (2); status = PRT_RESONANT case (3); select case (abs (IDUP(i))) case (HADRON_REMNANT, HADRON_REMNANT_SINGLET, & HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET) status = PRT_BEAM_REMNANT case default status = PRT_VIRTUAL end select case default status = PRT_UNDEFINED end select end if if (present (parent)) then select case (size (parent)) case (0) case (1); parent(1) = MOTHUP(1,i) case (2); parent = MOTHUP(:,i) end select end if if (present (col)) then col = ICOLUP(:,i) end if if (present (p)) then pup_def = PUP p = vector4_moving (pup_def(4,i), vector3_moving (pup_def(1:3,i))) end if if (present (m2)) then m2 = sign (PUP(5,i) ** 2, PUP(5,i)) end if end subroutine hepeup_get_particle @ %def hepeup_get_particle @ \subsection{The HEPEVT and HEPEV4 common block} For the LEP Monte Carlos, a standard common block has been proposed in AKV89. We strongly recommend its use. (The description is an abbreviated transcription of AKV89, Vol. 3, pp. 327-330). [[NMXHEP]] is the maximum number of entries: <>= integer, parameter :: NMXHEP = 4000 @ %def NMXHEP @ [[NEVHEP]] is normally the event number, but may take special values as follows: 0 the program does not keep track of event numbers. -1 a special initialization record. -2 a special final record. <>= integer :: NEVHEP @ %def NEVHEP @ [[NHEP]] holds the number of entries for this event. <>= integer, public :: NHEP @ %def NHEP @ The entry [[ISTHEP(N)]] gives the status code for the [[N]]th entry, with the following semantics: 0 a null entry. 1 an existing entry, which has not decayed or fragmented. 2 a decayed or fragmented entry, which is retained for event history information. 3 documentation line. 4- 10 reserved for future standards. 11-200 at the disposal of each model builder. 201- at the disposal of users. <>= integer, dimension(NMXHEP), public :: ISTHEP @ %def ISTHEP @ The Particle Data Group has proposed standard particle codes, which are to be stored in [[IDHEP(N)]]. <>= integer, dimension(NMXHEP), public :: IDHEP @ %def IDHEP @ [[JMOHEP(1,N)]] points to the mother of the [[N]]th entry, if any. It is set to zero for initial entries. [[JMOHEP(2,N)]] points to the second mother, if any. <>= integer, dimension(2, NMXHEP), public :: JMOHEP @ %def JMOHEP @ [[JDAHEP(1,N)]] and [[JDAHEP(2,N)]] point to the first and last daughter of the [[N]]th entry, if any. These are zero for entries which have not yet decayed. The other daughters are stored in between these two. <>= integer, dimension(2, NMXHEP), public :: JDAHEP @ %def JDAHEP @ In [[PHEP]] we store the momentum of the particle, more specifically this means that [[PHEP(1,N)]], [[PHEP(2,N)]], and [[PHEP(3,N)]] contain the momentum in the $x$, $y$, and $z$ direction (as defined by the machine people), measured in GeV/c. [[PHEP(4,N)]] contains the energy in GeV and [[PHEP(5,N)]] the mass in GeV$/c^2$. The latter may be negative for spacelike partons. <>= double precision, dimension(5, NMXHEP), public :: PHEP @ %def PHEP @ Finally [[VHEP]] is the place to store the position of the production vertex. [[VHEP(1,N)]], [[VHEP(2,N)]], and [[VHEP(3,N)]] contain the $x$, $y$, and $z$ coordinate (as defined by the machine people), measured in mm. [[VHEP(4,N)]] contains the production time in mm/c. <>= double precision, dimension(4, NMXHEP) :: VHEP @ %def VHEP @ As an amendment to the proposed standard common block HEPEVT, we also have a polarisation common block HEPSPN, as described in AKV89. [[SHEP(1,N)]], [[SHEP(2,N)]], and [[SHEP(3,N)]] give the $x$, $y$, and $z$ component of the spinvector $s$ of a fermion in the fermions restframe. Furthermore, we add the polarization of the corresponding outgoing particles: <>= integer, dimension(NMXHEP) :: hepevt_pol @ %def hepevt_pol @ By this variable the identity of the current process is given, defined via the LPRUP codes. <>= integer, public :: idruplh @ %def idruplh This is the event weight, i.e. the cross section divided by the total number of generated events for the output of the parton shower programs. <>= double precision, public :: eventweightlh @ %def eventweightlh @ There are the values for the electromagnetic and the strong coupling constants, $\alpha_{em}$ and $\alpha_s$. <>= double precision, public :: alphaqedlh, alphaqcdlh @ %def alphaqedlh, alphaqcdlh @ This is the squared scale $Q$ of the event. <>= double precision, dimension(10), public :: scalelh @ %def scalelh @ Finally, these variables contain the spin information and the color/anticolor flow of the particles. <>= double precision, dimension (3,NMXHEP), public :: spinlh integer, dimension (2,NMXHEP), public :: icolorflowlh @ %def spinlh icolorflowlh By convention, [[SHEP(4,N)]] is always 1. All this is taken from StdHep 4.06 manual and written using Fortran90 conventions. <>= common /HEPEVT/ & NEVHEP, NHEP, ISTHEP, IDHEP, & JMOHEP, JDAHEP, PHEP, VHEP save /HEPEVT/ @ %def HEPEVT @ Here we store HEPEVT parameters of the WHIZARD 1 realization which are not part of the HEPEVT common block. <>= integer :: hepevt_n_out, hepevt_n_remnants @ %def hepevt_n_out, hepevt_n_remnants @ <>= double precision :: hepevt_weight, hepevt_function_value double precision :: hepevt_function_ratio @ %def hepevt_weight hepevt_function_value @ The HEPEV4 common block is an extension of the HEPEVT common block to allow for partonic colored events, including especially the color flow etc. <>= common /HEPEV4/ & eventweightlh, alphaqedlh, alphaqcdlh, scalelh, & spinlh, icolorflowlh, idruplh save /HEPEV4/ @ %def HEPEV4 @ Filling HEPEVT: If the event count is not provided, set [[NEVHEP]] to zero. If the event count is [[-1]] or [[-2]], the record corresponds to initialization and finalization, and the event is irrelevant. Note that the event count may be larger than $2^{31}$ (2 GEvents). In that case, cut off the upper bits since [[NEVHEP]] is probably limited to default integer. For the HEPEV4 common block, it is unclear why the [[scalelh]] variable is 10-dimensional. We choose to only set the first value of the array. <>= public :: hepevt_init public :: hepevt_set_event_parameters <>= module subroutine hepevt_init (n_tot, n_out) integer, intent(in) :: n_tot, n_out end subroutine hepevt_init module subroutine hepevt_set_event_parameters & (proc_id, weight, function_value, function_ratio, & alpha_qcd, alpha_qed, scale, i_evt) integer, intent(in), optional :: proc_id integer, intent(in), optional :: i_evt real(default), intent(in), optional :: weight, function_value, & function_ratio, alpha_qcd, alpha_qed, scale end subroutine hepevt_set_event_parameters <>= module subroutine hepevt_init (n_tot, n_out) integer, intent(in) :: n_tot, n_out NHEP = n_tot NEVHEP = 0 idruplh = 0 hepevt_n_out = n_out hepevt_n_remnants = 0 hepevt_weight = 1 eventweightlh = 1 hepevt_function_value = 0 hepevt_function_ratio = 1 alphaqcdlh = -1 alphaqedlh = -1 scalelh = -1 end subroutine hepevt_init module subroutine hepevt_set_event_parameters & (proc_id, weight, function_value, function_ratio, & alpha_qcd, alpha_qed, scale, i_evt) integer, intent(in), optional :: proc_id integer, intent(in), optional :: i_evt real(default), intent(in), optional :: weight, function_value, & function_ratio, alpha_qcd, alpha_qed, scale if (present (proc_id)) idruplh = proc_id if (present (i_evt)) NEVHEP = i_evt if (present (weight)) then hepevt_weight = weight eventweightlh = weight end if if (present (function_value)) hepevt_function_value = & function_value if (present (function_ratio)) hepevt_function_ratio = & function_ratio if (present (alpha_qcd)) alphaqcdlh = alpha_qcd if (present (alpha_qed)) alphaqedlh = alpha_qed if (present (scale)) scalelh(1) = scale if (present (i_evt)) NEVHEP = i_evt end subroutine hepevt_set_event_parameters @ %def hepevt_init hepevt_set_event_parameters @ Set the entry for a specific particle. All parameters are set with the exception of lifetime and spin, where default values are stored. <>= public :: hepevt_set_particle <>= module subroutine hepevt_set_particle & (i, pdg, status, parent, child, p, m2, hel, vtx, & col, pol_status, pol, fill_hepev4) integer, intent(in) :: i integer, intent(in) :: pdg, status integer, dimension(:), intent(in) :: parent integer, dimension(:), intent(in) :: child logical, intent(in), optional :: fill_hepev4 type(vector4_t), intent(in) :: p real(default), intent(in) :: m2 integer, dimension(2), intent(in) :: col integer, intent(in) :: pol_status integer, intent(in) :: hel type(polarization_t), intent(in), optional :: pol type(vector4_t), intent(in) :: vtx end subroutine hepevt_set_particle <>= module subroutine hepevt_set_particle & (i, pdg, status, parent, child, p, m2, hel, vtx, & col, pol_status, pol, fill_hepev4) integer, intent(in) :: i integer, intent(in) :: pdg, status integer, dimension(:), intent(in) :: parent integer, dimension(:), intent(in) :: child logical, intent(in), optional :: fill_hepev4 type(vector4_t), intent(in) :: p real(default), intent(in) :: m2 integer, dimension(2), intent(in) :: col integer, intent(in) :: pol_status integer, intent(in) :: hel type(polarization_t), intent(in), optional :: pol type(vector4_t), intent(in) :: vtx logical :: hepev4 hepev4 = .false.; if (present (fill_hepev4)) hepev4 = fill_hepev4 IDHEP(i) = pdg select case (status) case (PRT_BEAM); ISTHEP(i) = 2 case (PRT_INCOMING); ISTHEP(i) = 2 case (PRT_OUTGOING); ISTHEP(i) = 1 case (PRT_VIRTUAL); ISTHEP(i) = 2 case (PRT_RESONANT); ISTHEP(i) = 2 case default; ISTHEP(i) = 0 end select select case (size (parent)) case (0); JMOHEP(:,i) = 0 case (1); JMOHEP(1,i) = parent(1); JMOHEP(2,i) = 0 case default; JMOHEP(:,i) = [ parent(1), parent(size (parent)) ] end select select case (size (child)) case (0); JDAHEP(:,i) = 0 case (1); JDAHEP(:,i) = child(1) case default; JDAHEP(:,i) = [ child(1), child(size (child)) ] end select PHEP(1:3,i) = refmt_tiny (vector3_get_components (space_part (p))) PHEP(4,i) = refmt_tiny (energy (p)) PHEP(5,i) = refmt_tiny (sign (sqrt (abs (m2)), m2)) VHEP(1:3,i) = vtx%p(1:3) VHEP(4,i) = vtx%p(0) hepevt_pol(i) = hel if (hepev4) then if (col(1) > 0) then icolorflowlh(1,i) = 500 + col(1) else icolorflowlh(1,i) = 0 end if if (col(2) > 0) then icolorflowlh(2,i) = 500 + col(2) else icolorflowlh(2,i) = 0 end if if (present (pol) .and. & pol_status == PRT_GENERIC_POLARIZATION) then if (pol%is_polarized ()) & spinlh(:,i) = pol%get_axis () else spinlh(:,i) = zero spinlh(3,i) = hel end if end if end subroutine hepevt_set_particle @ %def hepevt_set_particle @ \subsection{Event output} This is a verbose output of the HEPEVT block. <>= public :: hepevt_write_verbose <>= module subroutine hepevt_write_verbose (unit) integer, intent(in), optional :: unit end subroutine hepevt_write_verbose <>= module subroutine hepevt_write_verbose (unit) integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "HEPEVT Common Block" write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)") "NEVHEP", NEVHEP, & "Event number" write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)") "NHEP ", NHEP, & "Number of particles in event" do i = 1, NHEP write (u, "(1x,A,I0)") "Particle #", i write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)", advance="no") & "ISTHEP", ISTHEP(i), "Status code: " select case (ISTHEP(i)) case ( 0); write (u, "(A)") "null entry" case ( 1); write (u, "(A)") "outgoing" case ( 2); write (u, "(A)") "decayed" case ( 3); write (u, "(A)") "documentation" case (4:10); write (u, "(A)") "[unspecified]" case (11:200); write (u, "(A)") "[model-specific]" case (201:); write (u, "(A)") "[user-defined]" case default; write (u, "(A)") "[undefined]" end select write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)") "IDHEP ", IDHEP(i), & "PDG code of particle" write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "JMOHEP", JMOHEP(:,i), & "Index of first/second mother" write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "JDAHEP", JDAHEP(:,i), & "Index of first/last daughter" write (u, "(3x,A6,' = ',ES12.5,1x,ES12.5,8x,A)") "PHEP12", & PHEP(1:2,i), "Transversal momentum (x/y) in GeV" write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "PHEP3 ", PHEP(3,i), & "Longitudinal momentum (z) in GeV" write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "PHEP4 ", PHEP(4,i), & "Energy in GeV" write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "PHEP5 ", PHEP(5,i), & "Invariant mass in GeV" write (u, "(3x,A6,' = ',ES12.5,1x,ES12.5,8x,A)") "VHEP12", VHEP(1:2,i), & "Transversal displacement (xy) in mm" write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "VHEP3 ", VHEP(3,i), & "Longitudinal displacement (z) in mm" write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "VHEP4 ", VHEP(4,i), & "Production time in mm" end do end subroutine hepevt_write_verbose @ %def hepevt_write_verbose @ This is a verbose output of the HEPEUP block. <>= public :: hepeup_write_verbose <>= module subroutine hepeup_write_verbose (unit) integer, intent(in), optional :: unit end subroutine hepeup_write_verbose <>= module subroutine hepeup_write_verbose (unit) integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(A)") "HEPEUP Common Block" write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)") "NUP ", NUP, & "Number of particles in event" write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)") "IDPRUP", IDPRUP, & "Subprocess ID" write (u, "(3x,A6,' = ',ES12.5,1x,20x,A)") "XWGTUP", XWGTUP, & "Event weight" write (u, "(3x,A6,' = ',ES12.5,1x,20x,A)") "SCALUP", SCALUP, & "Event energy scale in GeV" write (u, "(3x,A6,' = ',ES12.5,1x,20x,A)") "AQEDUP", AQEDUP, & "QED coupling [-1 = undefined]" write (u, "(3x,A6,' = ',ES12.5,1x,20x,A)") "AQCDUP", AQCDUP, & "QCD coupling [-1 = undefined]" do i = 1, NUP write (u, "(1x,A,I0)") "Particle #", i write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)") "IDUP ", IDUP(i), & "PDG code of particle" write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)", advance="no") & "ISTUP ", ISTUP(i), "Status code: " select case (ISTUP(i)) case (-1); write (u, "(A)") "incoming" case ( 1); write (u, "(A)") "outgoing" case (-2); write (u, "(A)") "spacelike" case ( 2); write (u, "(A)") "resonance" case ( 3); write (u, "(A)") "resonance (doc)" case (-9); write (u, "(A)") "beam" case default; write (u, "(A)") "[undefined]" end select write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "MOTHUP", MOTHUP(:,i), & "Index of first/last mother" write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "ICOLUP", ICOLUP(:,i), & "Color/anticolor flow index" write (u, "(3x,A6,' = ',ES12.5,1x,ES12.5,8x,A)") "PUP1/2", PUP(1:2,i), & "Transversal momentum (x/y) in GeV" write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "PUP3 ", PUP(3,i), & "Longitudinal momentum (z) in GeV" write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "PUP4 ", PUP(4,i), & "Energy in GeV" write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "PUP5 ", PUP(5,i), & "Invariant mass in GeV" write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "VTIMUP", VTIMUP(i), & "Invariant lifetime in mm" write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "SPINUP", SPINUP(i), & "cos(spin angle) [9 = undefined]" end do end subroutine hepeup_write_verbose @ %def hepeup_write_verbose @ \subsection{Event output in various formats} This routine writes event output according to the LHEF standard. It uses the current contents of the HEPEUP block. <>= public :: hepeup_write_lhef public :: hepeup_write_lha <>= module subroutine hepeup_write_lhef (unit) integer, intent(in), optional :: unit end subroutine hepeup_write_lhef module subroutine hepeup_write_lha (unit) integer, intent(in), optional :: unit end subroutine hepeup_write_lha <>= module subroutine hepeup_write_lhef (unit) integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return if (debug_on) call msg_debug (D_EVENTS, "hepeup_write_lhef") if (debug_on) call msg_debug2 (D_EVENTS, "ID IST MOTH ICOL P VTIM SPIN") write (u, "(2(1x,I0),4(1x,ES17.10))") & NUP, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP do i = 1, NUP write (u, "(6(1x,I0),7(1x,ES17.10))") & IDUP(i), ISTUP(i), MOTHUP(:,i), ICOLUP(:,i), & PUP(:,i), VTIMUP(i), SPINUP(i) if (debug2_active (D_EVENTS)) then write (msg_buffer, "(6(1x,I0),7(1x,ES17.10))") & IDUP(i), ISTUP(i), MOTHUP(:,i), ICOLUP(:,i), & PUP(:,i), VTIMUP(i), SPINUP(i) call msg_message () end if end do end subroutine hepeup_write_lhef module subroutine hepeup_write_lha (unit) integer, intent(in), optional :: unit integer :: u, i integer, dimension(MAXNUP) :: spin_up spin_up = int(SPINUP) u = given_output_unit (unit); if (u < 0) return write (u, "(2(1x,I5),1x,ES17.10,3(1x,ES13.6))") & NUP, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP write (u, "(500(1x,I5))") IDUP(:NUP) write (u, "(500(1x,I5))") MOTHUP(1,:NUP) write (u, "(500(1x,I5))") MOTHUP(2,:NUP) write (u, "(500(1x,I5))") ICOLUP(1,:NUP) write (u, "(500(1x,I5))") ICOLUP(2,:NUP) write (u, "(500(1x,I5))") ISTUP(:NUP) write (u, "(500(1x,I5))") spin_up(:NUP) do i = 1, NUP write (u, "(1x,I5,4(1x,ES17.10))") i, PUP([ 4,1,2,3 ], i) end do end subroutine hepeup_write_lha @ %def hepeup_write_lhef hepeup_write_lha @ This routine writes event output according to the HEPEVT standard. It uses the current contents of the HEPEVT block and some additional parameters according to the standard in WHIZARD 1. For the long ASCII format, the value of the sample function (i.e. the product of squared matrix element, structure functions and phase space factor is printed out). The option of reweighting matrix elements with respect to some reference cross section is not implemented in WHIZARD 2 for this event format, therefore the second entry in the long ASCII format (the function ratio) is always one. The ATHENA format is an implementation of the HEPEVT format that is readable by the ATLAS ATHENA software framework. It is very similar to the WHIZARD 1 HEPEVT format, except that it contains an event counter, a particle counter inside the event, and has the HEPEVT [[ISTHEP]] status before the PDG code. The MOKKA format is a special ASCII format that contains the information to be parsed to the MOKKA LC fast simulation software. <>= public :: hepevt_write_hepevt public :: hepevt_write_ascii public :: hepevt_write_athena public :: hepevt_write_mokka <>= module subroutine hepevt_write_hepevt (unit) integer, intent(in), optional :: unit end subroutine hepevt_write_hepevt module subroutine hepevt_write_ascii (unit, long) integer, intent(in), optional :: unit logical, intent(in) :: long end subroutine hepevt_write_ascii module subroutine hepevt_write_athena (unit) integer, intent(in), optional :: unit end subroutine hepevt_write_athena module subroutine hepevt_write_mokka (unit) integer, intent(in), optional :: unit end subroutine hepevt_write_mokka <>= module subroutine hepevt_write_hepevt (unit) integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(3(1x,I0),(1x,ES17.10))") & NHEP, hepevt_n_out, hepevt_n_remnants, hepevt_weight do i = 1, NHEP write (u, "(7(1x,I0))") & ISTHEP(i), IDHEP(i), JMOHEP(:,i), JDAHEP(:,i), hepevt_pol(i) write (u, "(5(1x,ES17.10))") PHEP(:,i) write (u, "(5(1x,ES17.10))") VHEP(:,i), 0.d0 end do end subroutine hepevt_write_hepevt module subroutine hepevt_write_ascii (unit, long) integer, intent(in), optional :: unit logical, intent(in) :: long integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(3(1x,I0),(1x,ES17.10))") & NHEP, hepevt_n_out, hepevt_n_remnants, hepevt_weight do i = 1, NHEP if (ISTHEP(i) /= 1) cycle write (u, "(2(1x,I0))") IDHEP(i), hepevt_pol(i) write (u, "(5(1x,ES17.10))") PHEP(:,i) end do if (long) then write (u, "(2(1x,ES17.10))") & hepevt_function_value, hepevt_function_ratio end if end subroutine hepevt_write_ascii module subroutine hepevt_write_athena (unit) integer, intent(in), optional :: unit integer :: u, i, num_event num_event = 0 u = given_output_unit (unit); if (u < 0) return write (u, "(2(1x,I0))") NEVHEP, NHEP do i = 1, NHEP write (u, "(7(1x,I0))") & i, ISTHEP(i), IDHEP(i), JMOHEP(:,i), JDAHEP(:,i) write (u, "(5(1x,ES17.10))") PHEP(:,i) write (u, "(5(1x,ES17.10))") VHEP(1:4,i) end do end subroutine hepevt_write_athena module subroutine hepevt_write_mokka (unit) integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(3(1x,I0),(1x,ES17.10))") & NHEP, hepevt_n_out, hepevt_n_remnants, hepevt_weight do i = 1, NHEP write (u, "(4(1x,I0),4(1x,ES17.10))") & ISTHEP(i), IDHEP(i), JDAHEP(1,i), JDAHEP(2,i), & PHEP(1:3,i), PHEP(5,i) end do end subroutine hepevt_write_mokka @ %def hepevt_write_hepevt hepevt_write_ascii @ %def hepevt_write_athena @ \subsection{Event input in various formats} This routine writes event output according to the LHEF standard. It uses the current contents of the HEPEUP block. <>= public :: hepeup_read_lhef <>= module subroutine hepeup_read_lhef (u) integer, intent(in) :: u end subroutine hepeup_read_lhef <>= module subroutine hepeup_read_lhef (u) integer, intent(in) :: u integer :: i read (u, *) & NUP, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP do i = 1, NUP read (u, *) & IDUP(i), ISTUP(i), MOTHUP(:,i), ICOLUP(:,i), & PUP(:,i), VTIMUP(i), SPINUP(i) end do end subroutine hepeup_read_lhef @ %def hepeup_read_lhef @ \subsection{Data Transfer: particle sets} The \whizard\ format for handling particle data in events is [[particle_set_t]]. We have to interface this to the common blocks. We first create a new particle set that contains only the particles that are supported by the LHEF format. These are: beam, incoming, resonant, outgoing. We drop particles with unknown, virtual or beam-remnant status. From this set we fill the common block. Event information such as process ID and weight is not transferred here; this has to be done by the caller. The spin information is set only if the particle has a unique mother, and if its polarization is fully defined. We use this routine also to hand over information to Pythia which lets Tauola access SPINUP. Tauola expects in SPINUP the helicity and not the LHA convention. We switch to this mode with [[tauola_convention]]. <>= public :: hepeup_from_particle_set <>= module subroutine hepeup_from_particle_set (pset_in, & keep_beams, keep_remnants, tauola_convention) type(particle_set_t), intent(in) :: pset_in type(particle_set_t), target :: pset logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants logical, intent(in), optional :: tauola_convention end subroutine hepeup_from_particle_set <>= module subroutine hepeup_from_particle_set (pset_in, & keep_beams, keep_remnants, tauola_convention) type(particle_set_t), intent(in) :: pset_in type(particle_set_t), target :: pset logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants logical, intent(in), optional :: tauola_convention integer :: i, n_parents, status, n_tot integer, dimension(1) :: i_mother logical :: kr, tc kr = .true.; if (present (keep_remnants)) kr = keep_remnants tc = .false.; if (present (tauola_convention)) tc = tauola_convention call pset_in%filter_particles (pset, real_parents = .true. , & keep_beams = keep_beams, keep_virtuals = .false.) n_tot = pset%get_n_tot () call hepeup_init (n_tot) do i = 1, n_tot associate (prt => pset%prt(i)) status = prt%get_status () if (kr .and. status == PRT_BEAM_REMNANT & .and. prt%get_n_children () == 0) & status = PRT_OUTGOING call hepeup_set_particle (i, & prt%get_pdg (), & status, & prt%get_parents (), & prt%get_color (), & prt%get_momentum (), & prt%get_p2 ()) n_parents = prt%get_n_parents () call hepeup_set_particle_lifetime (i, & prt%get_lifetime ()) if (.not. tc) then if (n_parents == 1) then i_mother = prt%get_parents () select case (prt%get_polarization_status ()) case (PRT_GENERIC_POLARIZATION) call hepeup_set_particle_spin (i, & prt%get_momentum (), & prt%get_polarization (), & pset%prt(i_mother(1))%get_momentum ()) end select end if else select case (prt%get_polarization_status ()) case (PRT_DEFINITE_HELICITY) SPINUP(i) = prt%get_helicity() end select end if end associate end do end subroutine hepeup_from_particle_set @ %def hepeup_from_particle_set @ Input. The particle set should be allocated properly, but we replace the particle contents. If there are no beam particles in the event, we try to reconstruct beam particles and beam remnants. We assume for simplicity that the beam particles, if any, are the first two particles. If they are absent, the first two particles should be the incoming partons. <>= public :: hepeup_to_particle_set <>= module subroutine hepeup_to_particle_set & (particle_set, recover_beams, model, alt_model) type(particle_set_t), intent(inout), target :: particle_set logical, intent(in), optional :: recover_beams class(model_data_t), intent(in), target :: model, alt_model end subroutine hepeup_to_particle_set <>= module subroutine hepeup_to_particle_set & (particle_set, recover_beams, model, alt_model) type(particle_set_t), intent(inout), target :: particle_set logical, intent(in), optional :: recover_beams class(model_data_t), intent(in), target :: model, alt_model type(particle_t), dimension(:), allocatable :: prt integer, dimension(2) :: parent integer, dimension(:), allocatable :: child integer :: i, j, k, pdg, status type(flavor_t) :: flv type(color_t) :: col integer, dimension(2) :: c type(vector4_t) :: p real(default) :: p2 logical :: reconstruct integer :: off if (present (recover_beams)) then reconstruct = recover_beams .and. .not. all (ISTUP(1:2) == PRT_BEAM) else reconstruct = .false. end if if (reconstruct) then off = 4 else off = 0 end if allocate (prt (NUP + off), child (NUP + off)) do i = 1, NUP k = i + off call hepeup_get_particle (i, pdg, status, col = c, p = p, m2 = p2) call flv%init (pdg, model, alt_model) call prt(k)%set_flavor (flv) call prt(k)%reset_status (status) call col%init (c) call prt(k)%set_color (col) call prt(k)%set_momentum (p, p2) where (MOTHUP(:,i) /= 0) parent = MOTHUP(:,i) + off elsewhere parent = 0 end where call prt(k)%set_parents (parent) child = [(j, j = 1 + off, NUP + off)] where (MOTHUP(1,:NUP) /= i .and. MOTHUP(2,:NUP) /= i) child = 0 call prt(k)%set_children (child) end do if (reconstruct) then do k = 1, 2 call prt(k)%reset_status (PRT_BEAM) call prt(k)%set_children ([k+2,k+4]) end do do k = 3, 4 call prt(k)%reset_status (PRT_BEAM_REMNANT) call prt(k)%set_parents ([k-2]) end do do k = 5, 6 call prt(k)%set_parents ([k-4]) end do end if call particle_set%replace (prt) end subroutine hepeup_to_particle_set @ %def hepeup_to_particle_set @ The HEPEVT common block is quite similar, but does contain less information, e.g. no color flows (it was LEP time). The spin information is set only if the particle has a unique mother, and if its polarization is fully defined. <>= public :: hepevt_from_particle_set <>= module subroutine hepevt_from_particle_set & (particle_set, keep_beams, keep_remnants, ensure_order, fill_hepev4) type(particle_set_t), intent(in) :: particle_set type(particle_set_t), target :: pset_hepevt, pset_tmp logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants logical, intent(in), optional :: ensure_order logical, intent(in), optional :: fill_hepev4 end subroutine hepevt_from_particle_set <>= module subroutine hepevt_from_particle_set & (particle_set, keep_beams, keep_remnants, ensure_order, fill_hepev4) type(particle_set_t), intent(in) :: particle_set type(particle_set_t), target :: pset_hepevt, pset_tmp logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants logical, intent(in), optional :: ensure_order logical, intent(in), optional :: fill_hepev4 integer :: i, status, n_tot logical :: activate_remnants, ensure activate_remnants = .true. if (present (keep_remnants)) activate_remnants = keep_remnants ensure = .false. if (present (ensure_order)) ensure = ensure_order call particle_set%filter_particles (pset_tmp, real_parents = .true., & keep_virtuals = .false., keep_beams = keep_beams) if (ensure) then call pset_tmp%to_hepevt_form (pset_hepevt) else pset_hepevt = pset_tmp end if n_tot = pset_hepevt%get_n_tot () call hepevt_init (n_tot, pset_hepevt%get_n_out ()) do i = 1, n_tot associate (prt => pset_hepevt%prt(i)) status = prt%get_status () if (activate_remnants & .and. status == PRT_BEAM_REMNANT & .and. prt%get_n_children () == 0) & status = PRT_OUTGOING select case (prt%get_polarization_status ()) case (PRT_GENERIC_POLARIZATION) call hepevt_set_particle (i, & prt%get_pdg (), status, & prt%get_parents (), & prt%get_children (), & prt%get_momentum (), & prt%get_p2 (), & prt%get_helicity (), & prt%get_vertex (), & prt%get_color (), & prt%get_polarization_status (), & pol = prt%get_polarization (), & fill_hepev4 = fill_hepev4) case default call hepevt_set_particle (i, & prt%get_pdg (), status, & prt%get_parents (), & prt%get_children (), & prt%get_momentum (), & prt%get_p2 (), & prt%get_helicity (), & prt%get_vertex (), & prt%get_color (), & prt%get_polarization_status (), & fill_hepev4 = fill_hepev4) end select end associate end do call pset_hepevt%final () end subroutine hepevt_from_particle_set @ %def hepevt_from_particle_set @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{HepMC events} This section provides the interface to the HepMC C++ library for handling Monte-Carlo events. Each C++ class of HepMC that we use is mirrored by a Fortran type, which contains as its only component the C pointer to the C++ object. Each C++ method of HepMC that we use has a C wrapper function. This function takes a pointer to the host object as its first argument. Further arguments are either C pointers, or in the case of simple types (integer, real), interoperable C/Fortran objects. The C wrapper functions have explicit interfaces in the Fortran module. They are called by Fortran wrapper procedures. These are treated as methods of the corresponding Fortran type. <<[[hepmc_interface.f90]]>>= <> module hepmc_interface use, intrinsic :: iso_c_binding !NODEP! <> <> use lorentz use flavors use colors use helicities use polarizations use event_handles, only: event_handle_t <> <> <> <> <> interface <> end interface end module hepmc_interface @ %def hepmc_interface @ <<[[hepmc_interface_sub.f90]]>>= <> submodule (hepmc_interface) hepmc_interface_s use constants, only: PI use physics_defs, only: pb_per_fb use system_dependencies, only: HEPMC2_AVAILABLE use system_dependencies, only: HEPMC3_AVAILABLE use diagnostics implicit none contains <> end submodule hepmc_interface_s @ %def hepmc_interface_s @ \subsection{Interface check} This function can be called in order to verify that we are using the actual HepMC library, and not the dummy version. <>= interface logical(c_bool) function hepmc_available () bind(C) import end function hepmc_available end interface <>= public :: hepmc_is_available <>= module function hepmc_is_available () result (flag) logical :: flag end function hepmc_is_available <>= module function hepmc_is_available () result (flag) logical :: flag flag = hepmc_available () end function hepmc_is_available @ %def hepmc_is_available @ \subsection{FourVector} The C version of four-vectors is often transferred by value, and the associated procedures are all inlined. The wrapper needs to transfer by reference, so we create FourVector objects on the heap which have to be deleted explicitly. The input is a [[vector4_t]] or [[vector3_t]] object from the [[lorentz]] module. <>= public :: hepmc_four_vector_t <>= type :: hepmc_four_vector_t private type(c_ptr) :: obj end type hepmc_four_vector_t @ %def hepmc_four_vector_t @ In the C constructor, the zero-component (fourth argument) is optional; if missing, it is set to zero. The Fortran version has initializer form and takes either a three-vector or a four-vector. A further version extracts the four-vector from a HepMC particle object. <>= interface type(c_ptr) function new_four_vector_xyz (x, y, z) bind(C) import real(c_double), value :: x, y, z end function new_four_vector_xyz end interface interface type(c_ptr) function new_four_vector_xyzt (x, y, z, t) bind(C) import real(c_double), value :: x, y, z, t end function new_four_vector_xyzt end interface @ %def new_four_vector_xyz new_four_vector_xyzt <>= public :: hepmc_four_vector_init <>= interface hepmc_four_vector_init module procedure hepmc_four_vector_init_v4 module procedure hepmc_four_vector_init_v3 module procedure hepmc_four_vector_init_hepmc_prt end interface <>= module subroutine hepmc_four_vector_init_v4 (pp, p) type(hepmc_four_vector_t), intent(out) :: pp type(vector4_t), intent(in) :: p end subroutine hepmc_four_vector_init_v4 module subroutine hepmc_four_vector_init_v3 (pp, p) type(hepmc_four_vector_t), intent(out) :: pp type(vector3_t), intent(in) :: p end subroutine hepmc_four_vector_init_v3 module subroutine hepmc_four_vector_init_hepmc_prt (pp, prt) type(hepmc_four_vector_t), intent(out) :: pp type(hepmc_particle_t), intent(in) :: prt end subroutine hepmc_four_vector_init_hepmc_prt <>= module subroutine hepmc_four_vector_init_v4 (pp, p) type(hepmc_four_vector_t), intent(out) :: pp type(vector4_t), intent(in) :: p real(default), dimension(0:3) :: pa pa = vector4_get_components (p) pp%obj = new_four_vector_xyzt & (real (pa(1), c_double), & real (pa(2), c_double), & real (pa(3), c_double), & real (pa(0), c_double)) end subroutine hepmc_four_vector_init_v4 module subroutine hepmc_four_vector_init_v3 (pp, p) type(hepmc_four_vector_t), intent(out) :: pp type(vector3_t), intent(in) :: p real(default), dimension(3) :: pa pa = vector3_get_components (p) pp%obj = new_four_vector_xyz & (real (pa(1), c_double), & real (pa(2), c_double), & real (pa(3), c_double)) end subroutine hepmc_four_vector_init_v3 module subroutine hepmc_four_vector_init_hepmc_prt (pp, prt) type(hepmc_four_vector_t), intent(out) :: pp type(hepmc_particle_t), intent(in) :: prt pp%obj = gen_particle_momentum (prt%obj) end subroutine hepmc_four_vector_init_hepmc_prt @ %def hepmc_four_vector_init @ Here, the destructor is explicitly needed. <>= interface subroutine four_vector_delete (p_obj) bind(C) import type(c_ptr), value :: p_obj end subroutine four_vector_delete end interface @ %def four_vector_delete <>= public :: hepmc_four_vector_final <>= module subroutine hepmc_four_vector_final (p) type(hepmc_four_vector_t), intent(inout) :: p end subroutine hepmc_four_vector_final <>= module subroutine hepmc_four_vector_final (p) type(hepmc_four_vector_t), intent(inout) :: p call four_vector_delete (p%obj) end subroutine hepmc_four_vector_final @ %def hepmc_four_vector_final @ Convert to a Lorentz vector. <>= interface function four_vector_px (p_obj) result (px) bind(C) import real(c_double) :: px type(c_ptr), value :: p_obj end function four_vector_px end interface interface function four_vector_py (p_obj) result (py) bind(C) import real(c_double) :: py type(c_ptr), value :: p_obj end function four_vector_py end interface interface function four_vector_pz (p_obj) result (pz) bind(C) import real(c_double) :: pz type(c_ptr), value :: p_obj end function four_vector_pz end interface interface function four_vector_e (p_obj) result (e) bind(C) import real(c_double) :: e type(c_ptr), value :: p_obj end function four_vector_e end interface @ %def four_vector_px four_vector_py four_vector_pz four_vector_e <>= public :: hepmc_four_vector_to_vector4 <>= module subroutine hepmc_four_vector_to_vector4 (pp, p) type(hepmc_four_vector_t), intent(in) :: pp type(vector4_t), intent(out) :: p end subroutine hepmc_four_vector_to_vector4 <>= module subroutine hepmc_four_vector_to_vector4 (pp, p) type(hepmc_four_vector_t), intent(in) :: pp type(vector4_t), intent(out) :: p real(default) :: E real(default), dimension(3) :: p3 E = four_vector_e (pp%obj) p3(1) = four_vector_px (pp%obj) p3(2) = four_vector_py (pp%obj) p3(3) = four_vector_pz (pp%obj) p = vector4_moving (E, vector3_moving (p3)) end subroutine hepmc_four_vector_to_vector4 @ %def hepmc_four_vector_to_vector4 @ \subsection{Polarization} Polarization objects are temporarily used for assigning particle polarization. We add a flag [[polarized]]. If this is false, the polarization is not set and should not be transferred to [[hepmc_particle]] objects. <>= public :: hepmc_polarization_t <>= type :: hepmc_polarization_t private logical :: polarized = .false. type(c_ptr) :: obj end type hepmc_polarization_t @ %def hepmc_polarization_t @ Constructor. The C wrapper takes polar and azimuthal angle as arguments. The Fortran version allows for either a complete polarization density matrix, or for a definite (diagonal) helicity. \emph{HepMC does not allow to specify the degree of polarization, therefore we have to map it to either 0 or 1. We choose 0 for polarization less than $0.5$ and 1 for polarization greater than $0.5$. Even this simplification works only for spin-1/2 and for massless particles; massive vector bosons cannot be treated this way. In particular, zero helicity is always translated as unpolarized.} \emph{For massive vector bosons, we arbitrarily choose the convention that the longitudinal (zero) helicity state is mapped to the theta angle $\pi/2$. This works under the condition that helicity is projected onto one of the basis states.} <>= interface type(c_ptr) function new_polarization (theta, phi) bind(C) import real(c_double), value :: theta, phi end function new_polarization end interface @ %def new_polarization <>= public :: hepmc_polarization_init <>= interface hepmc_polarization_init module procedure hepmc_polarization_init_pol module procedure hepmc_polarization_init_hel module procedure hepmc_polarization_init_int end interface <>= module subroutine hepmc_polarization_init_pol (hpol, pol) type(hepmc_polarization_t), intent(out) :: hpol type(polarization_t), intent(in) :: pol end subroutine hepmc_polarization_init_pol module subroutine hepmc_polarization_init_hel (hpol, hel) type(hepmc_polarization_t), intent(out) :: hpol type(helicity_t), intent(in) :: hel end subroutine hepmc_polarization_init_hel module subroutine hepmc_polarization_init_int (hpol, hel) type(hepmc_polarization_t), intent(out) :: hpol integer, intent(in) :: hel end subroutine hepmc_polarization_init_int <>= module subroutine hepmc_polarization_init_pol (hpol, pol) type(hepmc_polarization_t), intent(out) :: hpol type(polarization_t), intent(in) :: pol real(default) :: r, theta, phi if (pol%is_polarized ()) then call pol%to_angles (r, theta, phi) if (r >= 0.5) then hpol%polarized = .true. hpol%obj = new_polarization & (real (theta, c_double), real (phi, c_double)) end if end if end subroutine hepmc_polarization_init_pol module subroutine hepmc_polarization_init_hel (hpol, hel) type(hepmc_polarization_t), intent(out) :: hpol type(helicity_t), intent(in) :: hel integer, dimension(2) :: h if (hel%is_defined ()) then h = hel%to_pair () select case (h(1)) case (1:) hpol%polarized = .true. hpol%obj = new_polarization (0._c_double, 0._c_double) case (:-1) hpol%polarized = .true. hpol%obj = new_polarization (real (pi, c_double), 0._c_double) case (0) hpol%polarized = .true. hpol%obj = new_polarization (real (pi/2, c_double), 0._c_double) end select end if end subroutine hepmc_polarization_init_hel module subroutine hepmc_polarization_init_int (hpol, hel) type(hepmc_polarization_t), intent(out) :: hpol integer, intent(in) :: hel select case (hel) case (1:) hpol%polarized = .true. hpol%obj = new_polarization (0._c_double, 0._c_double) case (:-1) hpol%polarized = .true. hpol%obj = new_polarization (real (pi, c_double), 0._c_double) case (0) hpol%polarized = .true. hpol%obj = new_polarization (real (pi/2, c_double), 0._c_double) end select end subroutine hepmc_polarization_init_int @ %def hepmc_polarization_init @ Destructor. The C object is deallocated only if the [[polarized]] flag is set. <>= interface subroutine polarization_delete (pol_obj) bind(C) import type(c_ptr), value :: pol_obj end subroutine polarization_delete end interface @ %def polarization_delete <>= public :: hepmc_polarization_final <>= module subroutine hepmc_polarization_final (hpol) type(hepmc_polarization_t), intent(inout) :: hpol end subroutine hepmc_polarization_final <>= module subroutine hepmc_polarization_final (hpol) type(hepmc_polarization_t), intent(inout) :: hpol if (hpol%polarized) call polarization_delete (hpol%obj) end subroutine hepmc_polarization_final @ %def hepmc_polarization_final @ Recover polarization from HepMC polarization object (with the abovementioned deficiencies). <>= interface function polarization_theta (pol_obj) result (theta) bind(C) import real(c_double) :: theta type(c_ptr), value :: pol_obj end function polarization_theta end interface interface function polarization_phi (pol_obj) result (phi) bind(C) import real(c_double) :: phi type(c_ptr), value :: pol_obj end function polarization_phi end interface @ %def polarization_theta polarization_phi <>= public :: hepmc_polarization_to_pol <>= module subroutine hepmc_polarization_to_pol (hpol, flv, pol) type(hepmc_polarization_t), intent(in) :: hpol type(flavor_t), intent(in) :: flv type(polarization_t), intent(out) :: pol end subroutine hepmc_polarization_to_pol <>= module subroutine hepmc_polarization_to_pol (hpol, flv, pol) type(hepmc_polarization_t), intent(in) :: hpol type(flavor_t), intent(in) :: flv type(polarization_t), intent(out) :: pol real(default) :: theta, phi theta = polarization_theta (hpol%obj) phi = polarization_phi (hpol%obj) call pol%init_angles (flv, 1._default, theta, phi) end subroutine hepmc_polarization_to_pol @ %def hepmc_polarization_to_pol @ Recover helicity. Here, $\phi$ is ignored and only the sign of $\cos\theta$ is relevant, mapped to positive/negative helicity. <>= public :: hepmc_polarization_to_hel <>= module subroutine hepmc_polarization_to_hel (hpol, flv, hel) type(hepmc_polarization_t), intent(in) :: hpol type(flavor_t), intent(in) :: flv type(helicity_t), intent(out) :: hel end subroutine hepmc_polarization_to_hel <>= module subroutine hepmc_polarization_to_hel (hpol, flv, hel) type(hepmc_polarization_t), intent(in) :: hpol type(flavor_t), intent(in) :: flv type(helicity_t), intent(out) :: hel real(default) :: theta integer :: hmax theta = polarization_theta (hpol%obj) hmax = flv%get_spin_type () / 2 call hel%init (sign (hmax, nint (cos (theta)))) end subroutine hepmc_polarization_to_hel @ %def hepmc_polarization_to_hel @ \subsection{GenParticle} Particle objects have the obvious meaning. <>= public :: hepmc_particle_t <>= type :: hepmc_particle_t private type(c_ptr) :: obj end type hepmc_particle_t @ %def hepmc_particle_t @ Constructor. The C version takes a FourVector object, which in the Fortran wrapper is created on the fly from a [[vector4]] Lorentz vector. No destructor is needed as long as all particles are entered into vertex containers. <>= interface type(c_ptr) function new_gen_particle (prt_obj, pdg_id, status) bind(C) import type(c_ptr), value :: prt_obj integer(c_int), value :: pdg_id, status end function new_gen_particle end interface @ %def new_gen_particle <>= public :: hepmc_particle_init <>= module subroutine hepmc_particle_init (prt, p, pdg, status) type(hepmc_particle_t), intent(out) :: prt type(vector4_t), intent(in) :: p integer, intent(in) :: pdg, status end subroutine hepmc_particle_init <>= module subroutine hepmc_particle_init (prt, p, pdg, status) type(hepmc_particle_t), intent(out) :: prt type(vector4_t), intent(in) :: p integer, intent(in) :: pdg, status type(hepmc_four_vector_t) :: pp call hepmc_four_vector_init (pp, p) prt%obj = new_gen_particle (pp%obj, int (pdg, c_int), int (status, c_int)) call hepmc_four_vector_final (pp) end subroutine hepmc_particle_init @ %def hepmc_particle_init @ Set the particle color flow. <>= interface subroutine gen_particle_set_flow (prt_obj, code_index, code) bind(C) import type(c_ptr), value :: prt_obj integer(c_int), value :: code_index, code end subroutine gen_particle_set_flow end interface @ %def gen_particle_set_flow @ Set the particle color. Either from a [[color_t]] object or directly from a pair of integers. <>= interface hepmc_particle_set_color module procedure hepmc_particle_set_color_col module procedure hepmc_particle_set_color_int end interface hepmc_particle_set_color <>= public :: hepmc_particle_set_color <>= module subroutine hepmc_particle_set_color_col (prt, col) type(hepmc_particle_t), intent(inout) :: prt type(color_t), intent(in) :: col end subroutine hepmc_particle_set_color_col module subroutine hepmc_particle_set_color_int (prt, col) type(hepmc_particle_t), intent(inout) :: prt integer, dimension(2), intent(in) :: col end subroutine hepmc_particle_set_color_int <>= module subroutine hepmc_particle_set_color_col (prt, col) type(hepmc_particle_t), intent(inout) :: prt type(color_t), intent(in) :: col integer(c_int) :: c c = col%get_col () if (c /= 0) call gen_particle_set_flow (prt%obj, 1_c_int, c) c = col%get_acl () if (c /= 0) call gen_particle_set_flow (prt%obj, 2_c_int, c) end subroutine hepmc_particle_set_color_col module subroutine hepmc_particle_set_color_int (prt, col) type(hepmc_particle_t), intent(inout) :: prt integer, dimension(2), intent(in) :: col integer(c_int) :: c c = col(1) if (c /= 0) call gen_particle_set_flow (prt%obj, 1_c_int, c) c = col(2) if (c /= 0) call gen_particle_set_flow (prt%obj, 2_c_int, c) end subroutine hepmc_particle_set_color_int @ %def hepmc_particle_set_color @ Set the particle polarization. For the restrictions on particle polarization in HepMC, see above [[hepmc_polarization_init]]. <>= interface subroutine gen_particle_set_polarization (prt_obj, pol_obj) bind(C) import type(c_ptr), value :: prt_obj, pol_obj end subroutine gen_particle_set_polarization end interface @ %def gen_particle_set_polarization <>= public :: hepmc_particle_set_polarization <>= interface hepmc_particle_set_polarization module procedure hepmc_particle_set_polarization_pol module procedure hepmc_particle_set_polarization_hel module procedure hepmc_particle_set_polarization_int end interface <>= module subroutine hepmc_particle_set_polarization_pol (prt, pol) type(hepmc_particle_t), intent(inout) :: prt type(polarization_t), intent(in) :: pol end subroutine hepmc_particle_set_polarization_pol module subroutine hepmc_particle_set_polarization_hel (prt, hel) type(hepmc_particle_t), intent(inout) :: prt type(helicity_t), intent(in) :: hel end subroutine hepmc_particle_set_polarization_hel module subroutine hepmc_particle_set_polarization_int (prt, hel) type(hepmc_particle_t), intent(inout) :: prt integer, intent(in) :: hel end subroutine hepmc_particle_set_polarization_int <>= module subroutine hepmc_particle_set_polarization_pol (prt, pol) type(hepmc_particle_t), intent(inout) :: prt type(polarization_t), intent(in) :: pol type(hepmc_polarization_t) :: hpol call hepmc_polarization_init (hpol, pol) if (hpol%polarized) call gen_particle_set_polarization (prt%obj, hpol%obj) call hepmc_polarization_final (hpol) end subroutine hepmc_particle_set_polarization_pol module subroutine hepmc_particle_set_polarization_hel (prt, hel) type(hepmc_particle_t), intent(inout) :: prt type(helicity_t), intent(in) :: hel type(hepmc_polarization_t) :: hpol call hepmc_polarization_init (hpol, hel) if (hpol%polarized) call gen_particle_set_polarization (prt%obj, hpol%obj) call hepmc_polarization_final (hpol) end subroutine hepmc_particle_set_polarization_hel module subroutine hepmc_particle_set_polarization_int (prt, hel) type(hepmc_particle_t), intent(inout) :: prt integer, intent(in) :: hel type(hepmc_polarization_t) :: hpol call hepmc_polarization_init (hpol, hel) if (hpol%polarized) call gen_particle_set_polarization (prt%obj, hpol%obj) call hepmc_polarization_final (hpol) end subroutine hepmc_particle_set_polarization_int @ %def hepmc_particle_set_polarization @ Return the HepMC barcode (unique integer ID) of the particle. <>= interface function gen_particle_barcode (prt_obj) result (barcode) bind(C) import integer(c_int) :: barcode type(c_ptr), value :: prt_obj end function gen_particle_barcode end interface @ %def gen_particle_barcode <>= public :: hepmc_particle_get_barcode <>= module function hepmc_particle_get_barcode (prt) result (barcode) integer :: barcode type(hepmc_particle_t), intent(in) :: prt end function hepmc_particle_get_barcode <>= module function hepmc_particle_get_barcode (prt) result (barcode) integer :: barcode type(hepmc_particle_t), intent(in) :: prt barcode = gen_particle_barcode (prt%obj) end function hepmc_particle_get_barcode @ %def hepmc_particle_get_barcode @ Return the four-vector component of the particle object as a [[vector4_t]] Lorentz vector. <>= interface type(c_ptr) function gen_particle_momentum (prt_obj) bind(C) import type(c_ptr), value :: prt_obj end function gen_particle_momentum end interface @ %def gen_particle_momentum <>= public :: hepmc_particle_get_momentum <>= module function hepmc_particle_get_momentum (prt) result (p) type(vector4_t) :: p type(hepmc_particle_t), intent(in) :: prt end function hepmc_particle_get_momentum <>= module function hepmc_particle_get_momentum (prt) result (p) type(vector4_t) :: p type(hepmc_particle_t), intent(in) :: prt type(hepmc_four_vector_t) :: pp call hepmc_four_vector_init (pp, prt) call hepmc_four_vector_to_vector4 (pp, p) call hepmc_four_vector_final (pp) end function hepmc_particle_get_momentum @ %def hepmc_particle_get_momentum @ Return the invariant mass squared of the particle object. HepMC stores the signed invariant mass (no squaring). <>= interface function gen_particle_generated_mass (prt_obj) result (mass) bind(C) import real(c_double) :: mass type(c_ptr), value :: prt_obj end function gen_particle_generated_mass end interface @ %def gen_particle_generated_mass <>= public :: hepmc_particle_get_mass_squared <>= module function hepmc_particle_get_mass_squared (prt) result (m2) real(default) :: m2 type(hepmc_particle_t), intent(in) :: prt end function hepmc_particle_get_mass_squared <>= module function hepmc_particle_get_mass_squared (prt) result (m2) real(default) :: m2 type(hepmc_particle_t), intent(in) :: prt real(default) :: m m = gen_particle_generated_mass (prt%obj) m2 = sign (m**2, m) end function hepmc_particle_get_mass_squared @ %def hepmc_particle_get_mass_squared @ Return the PDG ID: <>= interface function gen_particle_pdg_id (prt_obj) result (pdg_id) bind(C) import integer(c_int) :: pdg_id type(c_ptr), value :: prt_obj end function gen_particle_pdg_id end interface @ %def gen_particle_pdg_id <>= public :: hepmc_particle_get_pdg <>= module function hepmc_particle_get_pdg (prt) result (pdg) integer :: pdg type(hepmc_particle_t), intent(in) :: prt end function hepmc_particle_get_pdg <>= module function hepmc_particle_get_pdg (prt) result (pdg) integer :: pdg type(hepmc_particle_t), intent(in) :: prt pdg = gen_particle_pdg_id (prt%obj) end function hepmc_particle_get_pdg @ %def hepmc_particle_get_pdg @ Return the status code: <>= interface function gen_particle_status (prt_obj) result (status) bind(C) import integer(c_int) :: status type(c_ptr), value :: prt_obj end function gen_particle_status end interface @ %def gen_particle_status <>= public :: hepmc_particle_get_status <>= module function hepmc_particle_get_status (prt) result (status) integer :: status type(hepmc_particle_t), intent(in) :: prt end function hepmc_particle_get_status <>= module function hepmc_particle_get_status (prt) result (status) integer :: status type(hepmc_particle_t), intent(in) :: prt status = gen_particle_status (prt%obj) end function hepmc_particle_get_status @ %def hepmc_particle_get_status <>= interface function gen_particle_is_beam (prt_obj) result (is_beam) bind(C) import logical(c_bool) :: is_beam type(c_ptr), value :: prt_obj end function gen_particle_is_beam end interface @ %def gen_particle_is_beam @ Determine whether a particle is a beam particle. <>= public :: hepmc_particle_is_beam <>= module function hepmc_particle_is_beam (prt) result (is_beam) logical :: is_beam type(hepmc_particle_t), intent(in) :: prt end function hepmc_particle_is_beam <>= module function hepmc_particle_is_beam (prt) result (is_beam) logical :: is_beam type(hepmc_particle_t), intent(in) :: prt is_beam = gen_particle_is_beam (prt%obj) end function hepmc_particle_is_beam @ %def hepmc_particle_is_beam @ Return the production/decay vertex (as a pointer, no finalization necessary). <>= interface type(c_ptr) function gen_particle_production_vertex (prt_obj) bind(C) import type(c_ptr), value :: prt_obj end function gen_particle_production_vertex end interface interface type(c_ptr) function gen_particle_end_vertex (prt_obj) bind(C) import type(c_ptr), value :: prt_obj end function gen_particle_end_vertex end interface @ %def gen_particle_production_vertex gen_particle_end_vertex <>= public :: hepmc_particle_get_production_vertex public :: hepmc_particle_get_decay_vertex <>= module function hepmc_particle_get_production_vertex (prt) result (v) type(hepmc_vertex_t) :: v type(hepmc_particle_t), intent(in) :: prt end function hepmc_particle_get_production_vertex module function hepmc_particle_get_decay_vertex (prt) result (v) type(hepmc_vertex_t) :: v type(hepmc_particle_t), intent(in) :: prt end function hepmc_particle_get_decay_vertex <>= module function hepmc_particle_get_production_vertex (prt) result (v) type(hepmc_vertex_t) :: v type(hepmc_particle_t), intent(in) :: prt v%obj = gen_particle_production_vertex (prt%obj) end function hepmc_particle_get_production_vertex module function hepmc_particle_get_decay_vertex (prt) result (v) type(hepmc_vertex_t) :: v type(hepmc_particle_t), intent(in) :: prt v%obj = gen_particle_end_vertex (prt%obj) end function hepmc_particle_get_decay_vertex @ %def hepmc_particle_get_production_vertex hepmc_particle_get_decay_vertex @ Convenience function: Return the array of parent particles for a given HepMC particle. The contents are HepMC barcodes that still have to be mapped to the particle indices. <>= public :: hepmc_particle_get_parent_barcodes public :: hepmc_particle_get_child_barcodes <>= module function hepmc_particle_get_parent_barcodes & (prt) result (parent_barcode) type(hepmc_particle_t), intent(in) :: prt integer, dimension(:), allocatable :: parent_barcode end function hepmc_particle_get_parent_barcodes module function hepmc_particle_get_child_barcodes & (prt) result (child_barcode) type(hepmc_particle_t), intent(in) :: prt integer, dimension(:), allocatable :: child_barcode end function hepmc_particle_get_child_barcodes <>= module function hepmc_particle_get_parent_barcodes & (prt) result (parent_barcode) type(hepmc_particle_t), intent(in) :: prt integer, dimension(:), allocatable :: parent_barcode type(hepmc_vertex_t) :: v type(hepmc_vertex_particle_in_iterator_t) :: it integer :: i v = hepmc_particle_get_production_vertex (prt) if (hepmc_vertex_is_valid (v)) then allocate (parent_barcode (hepmc_vertex_get_n_in (v))) if (size (parent_barcode) /= 0) then if (HEPMC2_AVAILABLE) then call hepmc_vertex_particle_in_iterator_init (it, v) do i = 1, size (parent_barcode) parent_barcode(i) = hepmc_particle_get_barcode & (hepmc_vertex_particle_in_iterator_get (it)) call hepmc_vertex_particle_in_iterator_advance (it) end do call hepmc_vertex_particle_in_iterator_final (it) else if (HEPMC3_AVAILABLE) then do i = 1, size (parent_barcode) parent_barcode(i) = hepmc_particle_get_barcode & (hepmc_vertex_get_nth_particle_in (v, i)) end do end if end if else allocate (parent_barcode (0)) end if end function hepmc_particle_get_parent_barcodes module function hepmc_particle_get_child_barcodes & (prt) result (child_barcode) type(hepmc_particle_t), intent(in) :: prt integer, dimension(:), allocatable :: child_barcode type(hepmc_vertex_t) :: v type(hepmc_vertex_particle_out_iterator_t) :: it integer :: i v = hepmc_particle_get_decay_vertex (prt) if (hepmc_vertex_is_valid (v)) then allocate (child_barcode (hepmc_vertex_get_n_out (v))) if (size (child_barcode) /= 0) then if (HEPMC2_AVAILABLE) then call hepmc_vertex_particle_out_iterator_init (it, v) do i = 1, size (child_barcode) child_barcode(i) = hepmc_particle_get_barcode & (hepmc_vertex_particle_out_iterator_get (it)) call hepmc_vertex_particle_out_iterator_advance (it) end do call hepmc_vertex_particle_out_iterator_final (it) else if (HEPMC3_AVAILABLE) then do i = 1, size (child_barcode) child_barcode(i) = hepmc_particle_get_barcode & (hepmc_vertex_get_nth_particle_out (v, i)) end do end if end if else allocate (child_barcode (0)) end if end function hepmc_particle_get_child_barcodes @ %def hepmc_particle_get_parent_barcodes hepmc_particle_get_child_barcodes @ Return the polarization (assuming that the particle is completely polarized). Note that the generated polarization object needs finalization. <>= interface type(c_ptr) function gen_particle_polarization (prt_obj) bind(C) import type(c_ptr), value :: prt_obj end function gen_particle_polarization end interface @ %def gen_particle_polarization <>= public :: hepmc_particle_get_polarization <>= module function hepmc_particle_get_polarization (prt) result (pol) type(hepmc_polarization_t) :: pol type(hepmc_particle_t), intent(in) :: prt end function hepmc_particle_get_polarization <>= module function hepmc_particle_get_polarization (prt) result (pol) type(hepmc_polarization_t) :: pol type(hepmc_particle_t), intent(in) :: prt pol%obj = gen_particle_polarization (prt%obj) end function hepmc_particle_get_polarization @ %def hepmc_particle_get_polarization @ Return the particle color as a two-dimensional array (color, anticolor). <>= interface function gen_particle_flow (prt_obj, code_index) result (code) bind(C) import integer(c_int) :: code type(c_ptr), value :: prt_obj integer(c_int), value :: code_index end function gen_particle_flow end interface @ %def gen_particle_flow <>= public :: hepmc_particle_get_color <>= module function hepmc_particle_get_color (prt) result (col) integer, dimension(2) :: col type(hepmc_particle_t), intent(in) :: prt end function hepmc_particle_get_color <>= module function hepmc_particle_get_color (prt) result (col) integer, dimension(2) :: col type(hepmc_particle_t), intent(in) :: prt col(1) = gen_particle_flow (prt%obj, 1) col(2) = - gen_particle_flow (prt%obj, 2) end function hepmc_particle_get_color @ %def hepmc_particle_get_color @ <>= interface function gen_vertex_pos_x (v_obj) result (x) bind(C) import type(c_ptr), value :: v_obj real(c_double) :: x end function gen_vertex_pos_x end interface interface function gen_vertex_pos_y (v_obj) result (y) bind(C) import type(c_ptr), value :: v_obj real(c_double) :: y end function gen_vertex_pos_y end interface interface function gen_vertex_pos_z (v_obj) result (z) bind(C) import type(c_ptr), value :: v_obj real(c_double) :: z end function gen_vertex_pos_z end interface interface function gen_vertex_time (v_obj) result (t) bind(C) import type(c_ptr), value :: v_obj real(c_double) :: t end function gen_vertex_time end interface @ <>= public :: hepmc_vertex_to_vertex <>= module function hepmc_vertex_to_vertex (vtx) result (v) type(hepmc_vertex_t), intent(in) :: vtx type(vector4_t) :: v end function hepmc_vertex_to_vertex <>= module function hepmc_vertex_to_vertex (vtx) result (v) type(hepmc_vertex_t), intent(in) :: vtx type(vector4_t) :: v real(default) :: t, vx, vy, vz if (hepmc_vertex_is_valid (vtx)) then t = gen_vertex_time (vtx%obj) vx = gen_vertex_pos_x (vtx%obj) vy = gen_vertex_pos_y (vtx%obj) vz = gen_vertex_pos_z (vtx%obj) v = vector4_moving (t, & vector3_moving ([vx, vy, vz])) end if end function hepmc_vertex_to_vertex @ %def hepmc_vertex_to_vertex @ \subsection{GenVertex} Vertices are made of particles (incoming and outgoing). <>= public :: hepmc_vertex_t <>= type :: hepmc_vertex_t private type(c_ptr) :: obj end type hepmc_vertex_t @ %def hepmc_vertex_t @ Constructor. Two versions, one plain, one with the position in space and time (measured in mm) as argument. The Fortran version has initializer form, and the vertex position is an optional argument. A destructor is unnecessary as long as all vertices are entered into an event container. <>= interface type(c_ptr) function new_gen_vertex () bind(C) import end function new_gen_vertex end interface interface type(c_ptr) function new_gen_vertex_pos (prt_obj) bind(C) import type(c_ptr), value :: prt_obj end function new_gen_vertex_pos end interface @ %def new_gen_vertex new_gen_vertex_pos <>= public :: hepmc_vertex_init <>= module subroutine hepmc_vertex_init (v, x) type(hepmc_vertex_t), intent(out) :: v type(vector4_t), intent(in), optional :: x end subroutine hepmc_vertex_init <>= module subroutine hepmc_vertex_init (v, x) type(hepmc_vertex_t), intent(out) :: v type(vector4_t), intent(in), optional :: x type(hepmc_four_vector_t) :: pos if (present (x)) then call hepmc_four_vector_init (pos, x) v%obj = new_gen_vertex_pos (pos%obj) call hepmc_four_vector_final (pos) else v%obj = new_gen_vertex () end if end subroutine hepmc_vertex_init @ %def hepmc_vertex_init @ Return true if the vertex pointer is non-null: <>= interface function gen_vertex_is_valid (v_obj) result (flag) bind(C) import logical(c_bool) :: flag type(c_ptr), value :: v_obj end function gen_vertex_is_valid end interface @ %def gen_vertex_is_valid <>= public :: hepmc_vertex_is_valid <>= module function hepmc_vertex_is_valid (v) result (flag) logical :: flag type(hepmc_vertex_t), intent(in) :: v end function hepmc_vertex_is_valid <>= module function hepmc_vertex_is_valid (v) result (flag) logical :: flag type(hepmc_vertex_t), intent(in) :: v flag = gen_vertex_is_valid (v%obj) end function hepmc_vertex_is_valid @ %def hepmc_vertex_is_valid @ Add a particle to a vertex, incoming or outgoing. <>= interface subroutine gen_vertex_add_particle_in (v_obj, prt_obj) bind(C) import type(c_ptr), value :: v_obj, prt_obj end subroutine gen_vertex_add_particle_in end interface interface subroutine gen_vertex_add_particle_out (v_obj, prt_obj) bind(C) import type(c_ptr), value :: v_obj, prt_obj end subroutine gen_vertex_add_particle_out end interface <>= public :: hepmc_vertex_add_particle_in public :: hepmc_vertex_add_particle_out @ %def gen_vertex_add_particle_in gen_vertex_add_particle_out <>= module subroutine hepmc_vertex_add_particle_in (v, prt) type(hepmc_vertex_t), intent(inout) :: v type(hepmc_particle_t), intent(in) :: prt end subroutine hepmc_vertex_add_particle_in module subroutine hepmc_vertex_add_particle_out (v, prt) type(hepmc_vertex_t), intent(inout) :: v type(hepmc_particle_t), intent(in) :: prt end subroutine hepmc_vertex_add_particle_out <>= module subroutine hepmc_vertex_add_particle_in (v, prt) type(hepmc_vertex_t), intent(inout) :: v type(hepmc_particle_t), intent(in) :: prt call gen_vertex_add_particle_in (v%obj, prt%obj) end subroutine hepmc_vertex_add_particle_in module subroutine hepmc_vertex_add_particle_out (v, prt) type(hepmc_vertex_t), intent(inout) :: v type(hepmc_particle_t), intent(in) :: prt call gen_vertex_add_particle_out (v%obj, prt%obj) end subroutine hepmc_vertex_add_particle_out @ %def hepmc_vertex_add_particle_in hepmc_vertex_add_particle_out @ Return the number of incoming/outgoing particles. <>= interface function gen_vertex_particles_in_size (v_obj) result (size) bind(C) import integer(c_int) :: size type(c_ptr), value :: v_obj end function gen_vertex_particles_in_size end interface interface function gen_vertex_particles_out_size (v_obj) result (size) bind(C) import integer(c_int) :: size type(c_ptr), value :: v_obj end function gen_vertex_particles_out_size end interface interface function gen_particle_get_n_parents (p_obj) result (size) bind(C) import integer(c_int) :: size type(c_ptr), value :: p_obj end function gen_particle_get_n_parents end interface interface function gen_particle_get_n_children (p_obj) result (size) bind(C) import integer(c_int) :: size type(c_ptr), value :: p_obj end function gen_particle_get_n_children end interface @ %def gen_vertex_particles_in_size gen_vertex_particles_out_size @ %def gen_particle_get_n_parents get_particle_get_n_children <>= public :: hepmc_vertex_get_n_in public :: hepmc_vertex_get_n_out public :: hepmc_particle_get_parents public :: hepmc_particle_get_children <>= module function hepmc_vertex_get_n_in (v) result (n_in) integer :: n_in type(hepmc_vertex_t), intent(in) :: v end function hepmc_vertex_get_n_in module function hepmc_vertex_get_n_out (v) result (n_out) integer :: n_out type(hepmc_vertex_t), intent(in) :: v end function hepmc_vertex_get_n_out module function hepmc_particle_get_parents (p) result (n_p) integer :: n_p type(hepmc_particle_t), intent(in) :: p end function hepmc_particle_get_parents module function hepmc_particle_get_children (p) result (n_ch) integer :: n_ch type(hepmc_particle_t), intent(in) :: p end function hepmc_particle_get_children <>= module function hepmc_vertex_get_n_in (v) result (n_in) integer :: n_in type(hepmc_vertex_t), intent(in) :: v n_in = gen_vertex_particles_in_size (v%obj) end function hepmc_vertex_get_n_in module function hepmc_vertex_get_n_out (v) result (n_out) integer :: n_out type(hepmc_vertex_t), intent(in) :: v n_out = gen_vertex_particles_out_size (v%obj) end function hepmc_vertex_get_n_out module function hepmc_particle_get_parents (p) result (n_p) integer :: n_p type(hepmc_particle_t), intent(in) :: p n_p = gen_particle_get_n_parents (p%obj) end function hepmc_particle_get_parents module function hepmc_particle_get_children (p) result (n_ch) integer :: n_ch type(hepmc_particle_t), intent(in) :: p n_ch = gen_particle_get_n_children (p%obj) end function hepmc_particle_get_children @ %def hepmc_vertex_n_in hepmc_vertex_n_out @ %def hepmc_particle_get_parents hepmc_particle_get_children @ Return the number of parents/children. <>= public :: hepmc_particle_get_n_parents public :: hepmc_particle_get_n_children <>= module function hepmc_particle_get_n_parents (prt) result (n_parents) integer :: n_parents type(hepmc_particle_t), intent(in) :: prt end function hepmc_particle_get_n_parents module function hepmc_particle_get_n_children (prt) result (n_children) integer :: n_children type(hepmc_particle_t), intent(in) :: prt end function hepmc_particle_get_n_children <>= module function hepmc_particle_get_n_parents (prt) result (n_parents) integer :: n_parents type(hepmc_particle_t), intent(in) :: prt type(hepmc_vertex_t) :: v if (HEPMC2_AVAILABLE) then v = hepmc_particle_get_production_vertex (prt) if (hepmc_vertex_is_valid (v)) then n_parents = hepmc_vertex_get_n_in (v) else n_parents = 0 end if else if (HEPMC3_AVAILABLE) then n_parents = hepmc_particle_get_parents (prt) end if end function hepmc_particle_get_n_parents module function hepmc_particle_get_n_children (prt) result (n_children) integer :: n_children type(hepmc_particle_t), intent(in) :: prt type(hepmc_vertex_t) :: v if (HEPMC2_AVAILABLE) then v = hepmc_particle_get_decay_vertex (prt) if (hepmc_vertex_is_valid (v)) then n_children = hepmc_vertex_get_n_out (v) else n_children = 0 end if else if (HEPMC3_AVAILABLE) then n_children = hepmc_particle_get_children (prt) end if end function hepmc_particle_get_n_children @ %def hepmc_particle_get_n_parents @ %def hepmc_particle_get_n_children \subsection{Vertex-particle-in iterator} This iterator iterates over all incoming particles in an vertex. We store a pointer to the vertex in addition to the iterator. This allows for simple end checking. The iterator is actually a constant iterator; it can only read. <>= public :: hepmc_vertex_particle_in_iterator_t <>= type :: hepmc_vertex_particle_in_iterator_t private type(c_ptr) :: obj type(c_ptr) :: v_obj end type hepmc_vertex_particle_in_iterator_t @ %def hepmc_vertex_particle_in_iterator_t @ Constructor. The iterator is initialized at the first particle in the vertex. <>= interface type(c_ptr) function & new_vertex_particles_in_const_iterator (v_obj) bind(C) import type(c_ptr), value :: v_obj end function new_vertex_particles_in_const_iterator end interface @ %def new_vertex_particles_in_const_iterator <>= public :: hepmc_vertex_particle_in_iterator_init <>= module subroutine hepmc_vertex_particle_in_iterator_init (it, v) type(hepmc_vertex_particle_in_iterator_t), intent(out) :: it type(hepmc_vertex_t), intent(in) :: v end subroutine hepmc_vertex_particle_in_iterator_init <>= module subroutine hepmc_vertex_particle_in_iterator_init (it, v) type(hepmc_vertex_particle_in_iterator_t), intent(out) :: it type(hepmc_vertex_t), intent(in) :: v it%obj = new_vertex_particles_in_const_iterator (v%obj) it%v_obj = v%obj end subroutine hepmc_vertex_particle_in_iterator_init @ %def hepmc_vertex_particle_in_iterator_init @ Destructor. Necessary because the iterator is allocated on the heap. <>= interface subroutine vertex_particles_in_const_iterator_delete (it_obj) bind(C) import type(c_ptr), value :: it_obj end subroutine vertex_particles_in_const_iterator_delete end interface @ %def vertex_particles_in_const_iterator_delete <>= public :: hepmc_vertex_particle_in_iterator_final <>= module subroutine hepmc_vertex_particle_in_iterator_final (it) type(hepmc_vertex_particle_in_iterator_t), intent(inout) :: it end subroutine hepmc_vertex_particle_in_iterator_final <>= module subroutine hepmc_vertex_particle_in_iterator_final (it) type(hepmc_vertex_particle_in_iterator_t), intent(inout) :: it call vertex_particles_in_const_iterator_delete (it%obj) end subroutine hepmc_vertex_particle_in_iterator_final @ %def hepmc_vertex_particle_in_iterator_final @ Increment <>= interface subroutine vertex_particles_in_const_iterator_advance (it_obj) bind(C) import type(c_ptr), value :: it_obj end subroutine vertex_particles_in_const_iterator_advance end interface @ %def vertex_particles_in_const_iterator_advance <>= public :: hepmc_vertex_particle_in_iterator_advance <>= module subroutine hepmc_vertex_particle_in_iterator_advance (it) type(hepmc_vertex_particle_in_iterator_t), intent(inout) :: it end subroutine hepmc_vertex_particle_in_iterator_advance <>= module subroutine hepmc_vertex_particle_in_iterator_advance (it) type(hepmc_vertex_particle_in_iterator_t), intent(inout) :: it call vertex_particles_in_const_iterator_advance (it%obj) end subroutine hepmc_vertex_particle_in_iterator_advance @ %def hepmc_vertex_particle_in_iterator_advance @ Reset to the beginning <>= interface subroutine vertex_particles_in_const_iterator_reset & (it_obj, v_obj) bind(C) import type(c_ptr), value :: it_obj, v_obj end subroutine vertex_particles_in_const_iterator_reset end interface @ %def vertex_particles_in_const_iterator_reset <>= public :: hepmc_vertex_particle_in_iterator_reset <>= module subroutine hepmc_vertex_particle_in_iterator_reset (it) type(hepmc_vertex_particle_in_iterator_t), intent(inout) :: it end subroutine hepmc_vertex_particle_in_iterator_reset <>= module subroutine hepmc_vertex_particle_in_iterator_reset (it) type(hepmc_vertex_particle_in_iterator_t), intent(inout) :: it call vertex_particles_in_const_iterator_reset (it%obj, it%v_obj) end subroutine hepmc_vertex_particle_in_iterator_reset @ %def hepmc_vertex_particle_in_iterator_reset @ Test: return true as long as we are not past the end. <>= interface function vertex_particles_in_const_iterator_is_valid & (it_obj, v_obj) result (flag) bind(C) import logical(c_bool) :: flag type(c_ptr), value :: it_obj, v_obj end function vertex_particles_in_const_iterator_is_valid end interface @ %def vertex_particles_in_const_iterator_is_valid <>= public :: hepmc_vertex_particle_in_iterator_is_valid <>= module function hepmc_vertex_particle_in_iterator_is_valid & (it) result (flag) logical :: flag type(hepmc_vertex_particle_in_iterator_t), intent(in) :: it end function hepmc_vertex_particle_in_iterator_is_valid <>= module function hepmc_vertex_particle_in_iterator_is_valid & (it) result (flag) logical :: flag type(hepmc_vertex_particle_in_iterator_t), intent(in) :: it flag = vertex_particles_in_const_iterator_is_valid (it%obj, it%v_obj) end function hepmc_vertex_particle_in_iterator_is_valid @ %def hepmc_vertex_particle_in_iterator_is_valid @ Return the particle pointed to by the iterator. (The particle object should not be finalized, since it contains merely a pointer to the particle which is owned by the vertex.) <>= interface type(c_ptr) function & vertex_particles_in_const_iterator_get (it_obj) bind(C) import type(c_ptr), value :: it_obj end function vertex_particles_in_const_iterator_get end interface @ %def vertex_particles_in_const_iterator_get <>= public :: hepmc_vertex_particle_in_iterator_get <>= module function hepmc_vertex_particle_in_iterator_get (it) result (prt) type(hepmc_particle_t) :: prt type(hepmc_vertex_particle_in_iterator_t), intent(in) :: it end function hepmc_vertex_particle_in_iterator_get <>= module function hepmc_vertex_particle_in_iterator_get (it) result (prt) type(hepmc_particle_t) :: prt type(hepmc_vertex_particle_in_iterator_t), intent(in) :: it prt%obj = vertex_particles_in_const_iterator_get (it%obj) end function hepmc_vertex_particle_in_iterator_get @ %def hepmc_vertex_particle_in_iterator_get @ <>= interface type(c_ptr) function vertex_get_nth_particle_in (vtx_obj, n) bind(C) import type(c_ptr), value :: vtx_obj integer(c_int), value :: n end function vertex_get_nth_particle_in end interface interface type(c_ptr) function vertex_get_nth_particle_out (vtx_obj, n) bind(C) import type(c_ptr), value :: vtx_obj integer(c_int), value :: n end function vertex_get_nth_particle_out end interface @ %def vertex_get_nth_particle_in <>= public :: hepmc_vertex_get_nth_particle_in public :: hepmc_vertex_get_nth_particle_out <>= module function hepmc_vertex_get_nth_particle_in (vtx, n) result (prt) type(hepmc_particle_t) :: prt type(hepmc_vertex_t), intent(in) :: vtx integer, intent(in) :: n end function hepmc_vertex_get_nth_particle_in module function hepmc_vertex_get_nth_particle_out (vtx, n) result (prt) type(hepmc_particle_t) :: prt type(hepmc_vertex_t), intent(in) :: vtx integer, intent(in) :: n end function hepmc_vertex_get_nth_particle_out <>= module function hepmc_vertex_get_nth_particle_in (vtx, n) result (prt) type(hepmc_particle_t) :: prt type(hepmc_vertex_t), intent(in) :: vtx integer, intent(in) :: n integer(c_int) :: nth nth = n prt%obj = vertex_get_nth_particle_in (vtx%obj, nth) end function hepmc_vertex_get_nth_particle_in module function hepmc_vertex_get_nth_particle_out (vtx, n) result (prt) type(hepmc_particle_t) :: prt type(hepmc_vertex_t), intent(in) :: vtx integer, intent(in) :: n integer(c_int) :: nth nth = n prt%obj = vertex_get_nth_particle_out (vtx%obj, nth) end function hepmc_vertex_get_nth_particle_out @ %def hepmc_vertex_get_nth_particle_in @ %def hepmc_vertex_get_nth_particle_out @ \subsection{Vertex-particle-out iterator} This iterator iterates over all incoming particles in an vertex. We store a pointer to the vertex in addition to the iterator. This allows for simple end checking. The iterator is actually a constant iterator; it can only read. <>= public :: hepmc_vertex_particle_out_iterator_t <>= type :: hepmc_vertex_particle_out_iterator_t private type(c_ptr) :: obj type(c_ptr) :: v_obj end type hepmc_vertex_particle_out_iterator_t @ %def hepmc_vertex_particle_out_iterator_t @ Constructor. The iterator is initialized at the first particle in the vertex. <>= interface type(c_ptr) function & new_vertex_particles_out_const_iterator (v_obj) bind(C) import type(c_ptr), value :: v_obj end function new_vertex_particles_out_const_iterator end interface @ %def new_vertex_particles_out_const_iterator <>= public :: hepmc_vertex_particle_out_iterator_init <>= module subroutine hepmc_vertex_particle_out_iterator_init (it, v) type(hepmc_vertex_particle_out_iterator_t), intent(out) :: it type(hepmc_vertex_t), intent(in) :: v end subroutine hepmc_vertex_particle_out_iterator_init <>= module subroutine hepmc_vertex_particle_out_iterator_init (it, v) type(hepmc_vertex_particle_out_iterator_t), intent(out) :: it type(hepmc_vertex_t), intent(in) :: v it%obj = new_vertex_particles_out_const_iterator (v%obj) it%v_obj = v%obj end subroutine hepmc_vertex_particle_out_iterator_init @ %def hepmc_vertex_particle_out_iterator_init @ Destructor. Necessary because the iterator is allocated on the heap. <>= interface subroutine vertex_particles_out_const_iterator_delete (it_obj) bind(C) import type(c_ptr), value :: it_obj end subroutine vertex_particles_out_const_iterator_delete end interface @ %def vertex_particles_out_const_iterator_delete <>= public :: hepmc_vertex_particle_out_iterator_final <>= module subroutine hepmc_vertex_particle_out_iterator_final (it) type(hepmc_vertex_particle_out_iterator_t), intent(inout) :: it end subroutine hepmc_vertex_particle_out_iterator_final <>= module subroutine hepmc_vertex_particle_out_iterator_final (it) type(hepmc_vertex_particle_out_iterator_t), intent(inout) :: it call vertex_particles_out_const_iterator_delete (it%obj) end subroutine hepmc_vertex_particle_out_iterator_final @ %def hepmc_vertex_particle_out_iterator_final @ Increment <>= interface subroutine vertex_particles_out_const_iterator_advance (it_obj) bind(C) import type(c_ptr), value :: it_obj end subroutine vertex_particles_out_const_iterator_advance end interface @ %def vertex_particles_out_const_iterator_advance <>= public :: hepmc_vertex_particle_out_iterator_advance <>= module subroutine hepmc_vertex_particle_out_iterator_advance (it) type(hepmc_vertex_particle_out_iterator_t), intent(inout) :: it end subroutine hepmc_vertex_particle_out_iterator_advance <>= module subroutine hepmc_vertex_particle_out_iterator_advance (it) type(hepmc_vertex_particle_out_iterator_t), intent(inout) :: it call vertex_particles_out_const_iterator_advance (it%obj) end subroutine hepmc_vertex_particle_out_iterator_advance @ %def hepmc_vertex_particle_out_iterator_advance @ Reset to the beginning <>= interface subroutine vertex_particles_out_const_iterator_reset & (it_obj, v_obj) bind(C) import type(c_ptr), value :: it_obj, v_obj end subroutine vertex_particles_out_const_iterator_reset end interface @ %def vertex_particles_out_const_iterator_reset <>= public :: hepmc_vertex_particle_out_iterator_reset <>= module subroutine hepmc_vertex_particle_out_iterator_reset (it) type(hepmc_vertex_particle_out_iterator_t), intent(inout) :: it end subroutine hepmc_vertex_particle_out_iterator_reset <>= module subroutine hepmc_vertex_particle_out_iterator_reset (it) type(hepmc_vertex_particle_out_iterator_t), intent(inout) :: it call vertex_particles_out_const_iterator_reset (it%obj, it%v_obj) end subroutine hepmc_vertex_particle_out_iterator_reset @ %def hepmc_vertex_particle_out_iterator_reset @ Test: return true as long as we are not past the end. <>= interface function vertex_particles_out_const_iterator_is_valid & (it_obj, v_obj) result (flag) bind(C) import logical(c_bool) :: flag type(c_ptr), value :: it_obj, v_obj end function vertex_particles_out_const_iterator_is_valid end interface @ %def vertex_particles_out_const_iterator_is_valid <>= public :: hepmc_vertex_particle_out_iterator_is_valid <>= module function hepmc_vertex_particle_out_iterator_is_valid & (it) result (flag) logical :: flag type(hepmc_vertex_particle_out_iterator_t), intent(in) :: it end function hepmc_vertex_particle_out_iterator_is_valid <>= module function hepmc_vertex_particle_out_iterator_is_valid & (it) result (flag) logical :: flag type(hepmc_vertex_particle_out_iterator_t), intent(in) :: it flag = vertex_particles_out_const_iterator_is_valid (it%obj, it%v_obj) end function hepmc_vertex_particle_out_iterator_is_valid @ %def hepmc_vertex_particle_out_iterator_is_valid @ Return the particle pointed to by the iterator. (The particle object should not be finalized, since it contains merely a pointer to the particle which is owned by the vertex.) <>= interface type(c_ptr) function & vertex_particles_out_const_iterator_get (it_obj) bind(C) import type(c_ptr), value :: it_obj end function vertex_particles_out_const_iterator_get end interface @ %def vertex_particles_out_const_iterator_get <>= public :: hepmc_vertex_particle_out_iterator_get <>= module function hepmc_vertex_particle_out_iterator_get (it) result (prt) type(hepmc_particle_t) :: prt type(hepmc_vertex_particle_out_iterator_t), intent(in) :: it end function hepmc_vertex_particle_out_iterator_get <>= module function hepmc_vertex_particle_out_iterator_get (it) result (prt) type(hepmc_particle_t) :: prt type(hepmc_vertex_particle_out_iterator_t), intent(in) :: it prt%obj = vertex_particles_out_const_iterator_get (it%obj) end function hepmc_vertex_particle_out_iterator_get @ %def hepmc_vertex_particle_out_iterator_get @ \subsection{GenEvent} The main object of HepMC is a GenEvent. The object is filled by GenVertex objects, which in turn contain GenParticle objects. This is an extension of the abstract [[event_handle_t]], so we can use the according communicator features. <>= public :: hepmc_event_t <>= type, extends (event_handle_t) :: hepmc_event_t private type(c_ptr) :: obj = c_null_ptr end type hepmc_event_t @ %def hepmc_event_t @ Constructor. Arguments are process ID (integer) and event ID (integer). The Fortran version has initializer form. <>= interface type(c_ptr) function new_gen_event (proc_id, event_id) bind(C) import integer(c_int), value :: proc_id, event_id end function new_gen_event end interface @ %def new_gen_event <>= public :: hepmc_event_init <>= module subroutine hepmc_event_init (evt, proc_id, event_id) type(hepmc_event_t), intent(out) :: evt integer, intent(in), optional :: proc_id, event_id end subroutine hepmc_event_init <>= module subroutine hepmc_event_init (evt, proc_id, event_id) type(hepmc_event_t), intent(out) :: evt integer, intent(in), optional :: proc_id, event_id integer(c_int) :: pid, eid pid = 0; if (present (proc_id)) pid = proc_id eid = 0; if (present (event_id)) eid = event_id evt%obj = new_gen_event (pid, eid) end subroutine hepmc_event_init @ %def hepmc_event_init @ Destructor. <>= interface subroutine gen_event_delete (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end subroutine gen_event_delete end interface @ %def gen_event_delete @ Finalize: use the HepMC destructor. Also nullify the pointer explicitly, to be on the safe side. <>= public :: hepmc_event_final <>= module subroutine hepmc_event_final (evt) type(hepmc_event_t), intent(inout) :: evt end subroutine hepmc_event_final <>= module subroutine hepmc_event_final (evt) type(hepmc_event_t), intent(inout) :: evt if (c_associated (evt%obj)) then call gen_event_delete (evt%obj) evt%obj = c_null_ptr end if end subroutine hepmc_event_final @ %def hepmc_event_final @ Nullify: do not call the destructor, just nullify the C pointer. There should be another pointer associated with the object. <>= public :: hepmc_event_nullify <>= module subroutine hepmc_event_nullify (evt) type(hepmc_event_t), intent(inout) :: evt end subroutine hepmc_event_nullify <>= module subroutine hepmc_event_nullify (evt) type(hepmc_event_t), intent(inout) :: evt evt%obj = c_null_ptr end subroutine hepmc_event_nullify @ %def hepmc_event_nullify @ Return the actual object as a C pointer. For use in the native C++ interface only. <>= public :: hepmc_event_get_c_ptr <>= module function hepmc_event_get_c_ptr (evt) result (p) type(hepmc_event_t), intent(in) :: evt type(c_ptr) :: p end function hepmc_event_get_c_ptr <>= module function hepmc_event_get_c_ptr (evt) result (p) type(hepmc_event_t), intent(in) :: evt type(c_ptr) :: p p = evt%obj end function hepmc_event_get_c_ptr @ %def hepmc_event_get_c_ptr @ Screen output. Printing to file is possible in principle (using a C++ output channel), by allowing an argument. Printing to an open Fortran unit is obviously not possible. <>= interface subroutine gen_event_print (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end subroutine gen_event_print end interface @ %def gen_event_print <>= public :: hepmc_event_print <>= module subroutine hepmc_event_print (evt) type(hepmc_event_t), intent(in) :: evt end subroutine hepmc_event_print <>= module subroutine hepmc_event_print (evt) type(hepmc_event_t), intent(in) :: evt call gen_event_print (evt%obj) end subroutine hepmc_event_print @ %def hepmc_event_print @ Get the event number. <>= interface integer(c_int) function gen_event_event_number (evt_obj) bind(C) use iso_c_binding !NODEP! type(c_ptr), value :: evt_obj end function gen_event_event_number end interface @ %def gen_event_event_number <>= public :: hepmc_event_get_event_index <>= module function hepmc_event_get_event_index (evt) result (i_proc) integer :: i_proc type(hepmc_event_t), intent(in) :: evt end function hepmc_event_get_event_index <>= module function hepmc_event_get_event_index (evt) result (i_proc) integer :: i_proc type(hepmc_event_t), intent(in) :: evt i_proc = gen_event_event_number (evt%obj) end function hepmc_event_get_event_index @ %def hepmc_event_get_event_index <>= interface integer(c_int) function gen_event_get_n_particles & (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end function gen_event_get_n_particles end interface interface integer(c_int) function gen_event_get_n_beams & (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end function gen_event_get_n_beams end interface @ %def gen_event_get_n_particles gen_event_get_n_beams <>= public :: hepmc_event_get_n_particles public :: hepmc_event_get_n_beams <>= module function hepmc_event_get_n_particles (evt) result (n_tot) integer :: n_tot type(hepmc_event_t), intent(in) :: evt end function hepmc_event_get_n_particles module function hepmc_event_get_n_beams (evt) result (n_tot) integer :: n_tot type(hepmc_event_t), intent(in) :: evt end function hepmc_event_get_n_beams <>= module function hepmc_event_get_n_particles (evt) result (n_tot) integer :: n_tot type(hepmc_event_t), intent(in) :: evt n_tot = gen_event_get_n_particles (evt%obj) end function hepmc_event_get_n_particles module function hepmc_event_get_n_beams (evt) result (n_tot) integer :: n_tot type(hepmc_event_t), intent(in) :: evt n_tot = gen_event_get_n_beams (evt%obj) end function hepmc_event_get_n_beams @ %def hepmc_event_get_n_particles @ %def hepmc_event_get_n_beams @ Set the numeric signal process ID <>= interface subroutine gen_event_set_signal_process_id (evt_obj, proc_id) bind(C) import type(c_ptr), value :: evt_obj integer(c_int), value :: proc_id end subroutine gen_event_set_signal_process_id end interface @ %def gen_event_set_signal_process_id <>= public :: hepmc_event_set_process_id <>= module subroutine hepmc_event_set_process_id (evt, proc) type(hepmc_event_t), intent(in) :: evt integer, intent(in) :: proc end subroutine hepmc_event_set_process_id <>= module subroutine hepmc_event_set_process_id (evt, proc) type(hepmc_event_t), intent(in) :: evt integer, intent(in) :: proc integer(c_int) :: i_proc i_proc = proc call gen_event_set_signal_process_id (evt%obj, i_proc) end subroutine hepmc_event_set_process_id @ %def hepmc_event_set_process_id @ Get the numeric signal process ID <>= interface integer(c_int) function gen_event_signal_process_id (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end function gen_event_signal_process_id end interface @ %def gen_event_signal_process_id <>= public :: hepmc_event_get_process_id <>= module function hepmc_event_get_process_id (evt) result (i_proc) integer :: i_proc type(hepmc_event_t), intent(in) :: evt end function hepmc_event_get_process_id <>= module function hepmc_event_get_process_id (evt) result (i_proc) integer :: i_proc type(hepmc_event_t), intent(in) :: evt i_proc = gen_event_signal_process_id (evt%obj) end function hepmc_event_get_process_id @ %def hepmc_event_get_process_id @ Set the event energy scale <>= interface subroutine gen_event_set_event_scale (evt_obj, scale) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: scale end subroutine gen_event_set_event_scale end interface @ %def gen_event_set_event_scale <>= public :: hepmc_event_set_scale <>= module subroutine hepmc_event_set_scale (evt, scale) type(hepmc_event_t), intent(in) :: evt real(default), intent(in) :: scale end subroutine hepmc_event_set_scale <>= module subroutine hepmc_event_set_scale (evt, scale) type(hepmc_event_t), intent(in) :: evt real(default), intent(in) :: scale real(c_double) :: cscale cscale = scale call gen_event_set_event_scale (evt%obj, cscale) end subroutine hepmc_event_set_scale @ %def hepmc_event_set_scale @ Get the event energy scale <>= interface real(c_double) function gen_event_event_scale (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end function gen_event_event_scale end interface @ %def gen_event_event_scale <>= public :: hepmc_event_get_scale <>= module function hepmc_event_get_scale (evt) result (scale) real(default) :: scale type(hepmc_event_t), intent(in) :: evt end function hepmc_event_get_scale <>= module function hepmc_event_get_scale (evt) result (scale) real(default) :: scale type(hepmc_event_t), intent(in) :: evt scale = gen_event_event_scale (evt%obj) end function hepmc_event_get_scale @ %def hepmc_event_set_scale @ Set the value of $\alpha_{\rm QCD}$. <>= interface subroutine gen_event_set_alpha_qcd (evt_obj, a) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: a end subroutine gen_event_set_alpha_qcd end interface @ %def gen_event_set_alpha_qcd <>= public :: hepmc_event_set_alpha_qcd <>= module subroutine hepmc_event_set_alpha_qcd (evt, alpha) type(hepmc_event_t), intent(in) :: evt real(default), intent(in) :: alpha end subroutine hepmc_event_set_alpha_qcd <>= module subroutine hepmc_event_set_alpha_qcd (evt, alpha) type(hepmc_event_t), intent(in) :: evt real(default), intent(in) :: alpha real(c_double) :: a a = alpha call gen_event_set_alpha_qcd (evt%obj, a) end subroutine hepmc_event_set_alpha_qcd @ %def hepmc_event_set_alpha_qcd @ Get the value of $\alpha_{\rm QCD}$. <>= interface real(c_double) function gen_event_alpha_qcd (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end function gen_event_alpha_qcd end interface @ %def gen_event_get_alpha_qcd <>= public :: hepmc_event_get_alpha_qcd <>= module function hepmc_event_get_alpha_qcd (evt) result (alpha) real(default) :: alpha type(hepmc_event_t), intent(in) :: evt end function hepmc_event_get_alpha_qcd <>= module function hepmc_event_get_alpha_qcd (evt) result (alpha) real(default) :: alpha type(hepmc_event_t), intent(in) :: evt alpha = gen_event_alpha_qcd (evt%obj) end function hepmc_event_get_alpha_qcd @ %def hepmc_event_get_alpha_qcd @ Set the value of $\alpha_{\rm QED}$. <>= interface subroutine gen_event_set_alpha_qed (evt_obj, a) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: a end subroutine gen_event_set_alpha_qed end interface @ %def gen_event_set_alpha_qed <>= public :: hepmc_event_set_alpha_qed <>= module subroutine hepmc_event_set_alpha_qed (evt, alpha) type(hepmc_event_t), intent(in) :: evt real(default), intent(in) :: alpha end subroutine hepmc_event_set_alpha_qed <>= module subroutine hepmc_event_set_alpha_qed (evt, alpha) type(hepmc_event_t), intent(in) :: evt real(default), intent(in) :: alpha real(c_double) :: a a = alpha call gen_event_set_alpha_qed (evt%obj, a) end subroutine hepmc_event_set_alpha_qed @ %def hepmc_event_set_alpha_qed @ Get the value of $\alpha_{\rm QED}$. <>= interface real(c_double) function gen_event_alpha_qed (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end function gen_event_alpha_qed end interface @ %def gen_event_get_alpha_qed <>= public :: hepmc_event_get_alpha_qed <>= module function hepmc_event_get_alpha_qed (evt) result (alpha) real(default) :: alpha type(hepmc_event_t), intent(in) :: evt end function hepmc_event_get_alpha_qed <>= module function hepmc_event_get_alpha_qed (evt) result (alpha) real(default) :: alpha type(hepmc_event_t), intent(in) :: evt alpha = gen_event_alpha_qed (evt%obj) end function hepmc_event_get_alpha_qed @ %def hepmc_event_get_alpha_qed @ Clear a weight value to the end of the weight container. <>= interface subroutine gen_event_clear_weights (evt_obj) bind(C) use iso_c_binding !NODEP! type(c_ptr), value :: evt_obj end subroutine gen_event_clear_weights end interface @ %def gen_event_set_alpha_qed @ The HepMC weights are measured in pb. <>= integer, parameter, public :: HEPMC3_MODE_HEPMC2 = 1 integer, parameter, public :: HEPMC3_MODE_HEPMC3 = 2 integer, parameter, public :: HEPMC3_MODE_ROOT = 3 integer, parameter, public :: HEPMC3_MODE_ROOTTREE = 4 integer, parameter, public :: HEPMC3_MODE_HEPEVT = 5 @ %def HEPMC3_MODE_HEPMC2 HEPMC3_MODE_HEPMC3 @ %def HEPMC3_MODE_ROOT HEPMC3_MODE_ROOTTREE @ %def HEPMC3_MODE_HEPEVT @ <>= public :: hepmc_event_clear_weights <>= module subroutine hepmc_event_clear_weights (evt) type(hepmc_event_t), intent(in) :: evt end subroutine hepmc_event_clear_weights <>= module subroutine hepmc_event_clear_weights (evt) type(hepmc_event_t), intent(in) :: evt call gen_event_clear_weights (evt%obj) end subroutine hepmc_event_clear_weights @ %def hepmc_event_clear_weights @ Add a weight value to the end of the weight container. <>= interface subroutine gen_event_add_weight (evt_obj, w) bind(C) use iso_c_binding !NODEP! type(c_ptr), value :: evt_obj real(c_double), value :: w end subroutine gen_event_add_weight end interface @ %def gen_event_add_weight @ <>= public :: hepmc_event_add_weight <>= module subroutine hepmc_event_add_weight (evt, weight, rescale) type(hepmc_event_t), intent(in) :: evt real(default), intent(in) :: weight logical, intent(in) :: rescale end subroutine hepmc_event_add_weight <>= module subroutine hepmc_event_add_weight (evt, weight, rescale) type(hepmc_event_t), intent(in) :: evt real(default), intent(in) :: weight logical, intent(in) :: rescale real(c_double) :: w if (rescale) then w = weight * pb_per_fb else w = weight end if call gen_event_add_weight (evt%obj, w) end subroutine hepmc_event_add_weight @ %def hepmc_event_add_weight @ Get the size of the weight container (the number of valid elements). <>= interface integer(c_int) function gen_event_weights_size (evt_obj) bind(C) use iso_c_binding !NODEP! type(c_ptr), value :: evt_obj end function gen_event_weights_size end interface @ %def gen_event_get_weight <>= public :: hepmc_event_get_weights_size <>= module function hepmc_event_get_weights_size (evt) result (n) integer :: n type(hepmc_event_t), intent(in) :: evt end function hepmc_event_get_weights_size <>= module function hepmc_event_get_weights_size (evt) result (n) integer :: n type(hepmc_event_t), intent(in) :: evt n = gen_event_weights_size (evt%obj) end function hepmc_event_get_weights_size @ %def hepmc_event_get_weights_size @ Get the value of the weight with index [[i]]. (Count from 1, while C counts from zero.) <>= interface real(c_double) function gen_event_weight (evt_obj, i) bind(C) use iso_c_binding !NODEP! type(c_ptr), value :: evt_obj integer(c_int), value :: i end function gen_event_weight end interface @ %def gen_event_get_weight <>= public :: hepmc_event_get_weight <>= module function hepmc_event_get_weight (evt, index, rescale) result (weight) real(default) :: weight type(hepmc_event_t), intent(in) :: evt integer, intent(in) :: index logical, intent(in) :: rescale end function hepmc_event_get_weight <>= module function hepmc_event_get_weight (evt, index, rescale) result (weight) real(default) :: weight type(hepmc_event_t), intent(in) :: evt integer, intent(in) :: index logical, intent(in) :: rescale integer(c_int) :: i i = index - 1 if (rescale) then weight = gen_event_weight (evt%obj, i) / pb_per_fb else weight = gen_event_weight (evt%obj, i) end if end function hepmc_event_get_weight @ %def hepmc_event_get_weight @ Add a vertex to the event container. <>= interface subroutine gen_event_add_vertex (evt_obj, v_obj) bind(C) import type(c_ptr), value :: evt_obj type(c_ptr), value :: v_obj end subroutine gen_event_add_vertex end interface @ %def gen_event_add_vertex <>= public :: hepmc_event_add_vertex <>= module subroutine hepmc_event_add_vertex (evt, v) type(hepmc_event_t), intent(inout) :: evt type(hepmc_vertex_t), intent(in) :: v end subroutine hepmc_event_add_vertex <>= module subroutine hepmc_event_add_vertex (evt, v) type(hepmc_event_t), intent(inout) :: evt type(hepmc_vertex_t), intent(in) :: v call gen_event_add_vertex (evt%obj, v%obj) end subroutine hepmc_event_add_vertex @ %def hepmc_event_add_vertex @ Mark a particular vertex as the signal process (hard interaction). <>= interface subroutine gen_event_set_signal_process_vertex (evt_obj, v_obj) bind(C) import type(c_ptr), value :: evt_obj type(c_ptr), value :: v_obj end subroutine gen_event_set_signal_process_vertex end interface @ %def gen_event_set_signal_process_vertex <>= public :: hepmc_event_set_signal_process_vertex <>= module subroutine hepmc_event_set_signal_process_vertex (evt, v) type(hepmc_event_t), intent(inout) :: evt type(hepmc_vertex_t), intent(in) :: v end subroutine hepmc_event_set_signal_process_vertex <>= module subroutine hepmc_event_set_signal_process_vertex (evt, v) type(hepmc_event_t), intent(inout) :: evt type(hepmc_vertex_t), intent(in) :: v call gen_event_set_signal_process_vertex (evt%obj, v%obj) end subroutine hepmc_event_set_signal_process_vertex @ %def hepmc_event_set_signal_process_vertex @ Return the the signal process (hard interaction). <>= interface function gen_event_get_signal_process_vertex (evt_obj) & result (v_obj) bind(C) import type(c_ptr), value :: evt_obj type(c_ptr) :: v_obj end function gen_event_get_signal_process_vertex end interface @ %def gen_event_get_signal_process_vertex <>= public :: hepmc_event_get_signal_process_vertex <>= module function hepmc_event_get_signal_process_vertex (evt) result (v) type(hepmc_event_t), intent(in) :: evt type(hepmc_vertex_t) :: v end function hepmc_event_get_signal_process_vertex <>= module function hepmc_event_get_signal_process_vertex (evt) result (v) type(hepmc_event_t), intent(in) :: evt type(hepmc_vertex_t) :: v v%obj = gen_event_get_signal_process_vertex (evt%obj) end function hepmc_event_get_signal_process_vertex @ %def hepmc_event_get_signal_process_vertex @ Set the beam particles explicitly. <>= public :: hepmc_event_set_beam_particles <>= module subroutine hepmc_event_set_beam_particles (evt, prt1, prt2) type(hepmc_event_t), intent(inout) :: evt type(hepmc_particle_t), intent(in) :: prt1, prt2 logical(c_bool) :: flag end subroutine hepmc_event_set_beam_particles <>= module subroutine hepmc_event_set_beam_particles (evt, prt1, prt2) type(hepmc_event_t), intent(inout) :: evt type(hepmc_particle_t), intent(in) :: prt1, prt2 logical(c_bool) :: flag flag = gen_event_set_beam_particles (evt%obj, prt1%obj, prt2%obj) end subroutine hepmc_event_set_beam_particles @ %def hepmc_event_set_beam_particles @ The C function returns a boolean which we do not use. <>= interface logical(c_bool) function gen_event_set_beam_particles & (evt_obj, prt1_obj, prt2_obj) bind(C) import type(c_ptr), value :: evt_obj, prt1_obj, prt2_obj end function gen_event_set_beam_particles end interface @ %def gen_event_set_beam_particles @ Set the cross section and error explicitly. Note that HepMC uses pb, while WHIZARD uses fb. <>= public :: hepmc_event_set_cross_section <>= module subroutine hepmc_event_set_cross_section (evt, xsec, xsec_err) type(hepmc_event_t), intent(inout) :: evt real(default), intent(in) :: xsec, xsec_err end subroutine hepmc_event_set_cross_section <>= module subroutine hepmc_event_set_cross_section (evt, xsec, xsec_err) type(hepmc_event_t), intent(inout) :: evt real(default), intent(in) :: xsec, xsec_err call gen_event_set_cross_section & (evt%obj, & real (xsec * 1e-3_default, c_double), & real (xsec_err * 1e-3_default, c_double)) end subroutine hepmc_event_set_cross_section @ %def hepmc_event_set_cross_section @ The C function returns a boolean which we do not use. <>= interface subroutine gen_event_set_cross_section (evt_obj, xs, xs_err) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: xs, xs_err end subroutine gen_event_set_cross_section end interface @ %def gen_event_set_cross_section @ \subsection{Event-particle iterator} This iterator iterates over all particles in an event. We store a pointer to the event in addition to the iterator. This allows for simple end checking. The iterator is actually a constant iterator; it can only read. <>= public :: hepmc_event_particle_iterator_t <>= type :: hepmc_event_particle_iterator_t private type(c_ptr) :: obj type(c_ptr) :: evt_obj end type hepmc_event_particle_iterator_t @ %def hepmc_event_particle_iterator_t @ Constructor. The iterator is initialized at the first particle in the event. <>= interface type(c_ptr) function new_event_particle_const_iterator (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end function new_event_particle_const_iterator end interface @ %def new_event_particle_const_iterator <>= public :: hepmc_event_particle_iterator_init <>= module subroutine hepmc_event_particle_iterator_init (it, evt) type(hepmc_event_particle_iterator_t), intent(out) :: it type(hepmc_event_t), intent(in) :: evt end subroutine hepmc_event_particle_iterator_init <>= module subroutine hepmc_event_particle_iterator_init (it, evt) type(hepmc_event_particle_iterator_t), intent(out) :: it type(hepmc_event_t), intent(in) :: evt it%obj = new_event_particle_const_iterator (evt%obj) it%evt_obj = evt%obj end subroutine hepmc_event_particle_iterator_init @ %def hepmc_event_particle_iterator_init @ Destructor. Necessary because the iterator is allocated on the heap. <>= interface subroutine event_particle_const_iterator_delete (it_obj) bind(C) import type(c_ptr), value :: it_obj end subroutine event_particle_const_iterator_delete end interface @ %def event_particle_const_iterator_delete <>= public :: hepmc_event_particle_iterator_final <>= module subroutine hepmc_event_particle_iterator_final (it) type(hepmc_event_particle_iterator_t), intent(inout) :: it end subroutine hepmc_event_particle_iterator_final <>= module subroutine hepmc_event_particle_iterator_final (it) type(hepmc_event_particle_iterator_t), intent(inout) :: it call event_particle_const_iterator_delete (it%obj) end subroutine hepmc_event_particle_iterator_final @ %def hepmc_event_particle_iterator_final @ Increment <>= interface subroutine event_particle_const_iterator_advance (it_obj) bind(C) import type(c_ptr), value :: it_obj end subroutine event_particle_const_iterator_advance end interface @ %def event_particle_const_iterator_advance <>= public :: hepmc_event_particle_iterator_advance <>= module subroutine hepmc_event_particle_iterator_advance (it) type(hepmc_event_particle_iterator_t), intent(inout) :: it end subroutine hepmc_event_particle_iterator_advance <>= module subroutine hepmc_event_particle_iterator_advance (it) type(hepmc_event_particle_iterator_t), intent(inout) :: it call event_particle_const_iterator_advance (it%obj) end subroutine hepmc_event_particle_iterator_advance @ %def hepmc_event_particle_iterator_advance @ Reset to the beginning <>= interface subroutine event_particle_const_iterator_reset (it_obj, evt_obj) bind(C) import type(c_ptr), value :: it_obj, evt_obj end subroutine event_particle_const_iterator_reset end interface @ %def event_particle_const_iterator_reset <>= public :: hepmc_event_particle_iterator_reset <>= module subroutine hepmc_event_particle_iterator_reset (it) type(hepmc_event_particle_iterator_t), intent(inout) :: it end subroutine hepmc_event_particle_iterator_reset <>= module subroutine hepmc_event_particle_iterator_reset (it) type(hepmc_event_particle_iterator_t), intent(inout) :: it call event_particle_const_iterator_reset (it%obj, it%evt_obj) end subroutine hepmc_event_particle_iterator_reset @ %def hepmc_event_particle_iterator_reset @ Test: return true as long as we are not past the end. <>= interface function event_particle_const_iterator_is_valid & (it_obj, evt_obj) result (flag) bind(C) import logical(c_bool) :: flag type(c_ptr), value :: it_obj, evt_obj end function event_particle_const_iterator_is_valid end interface @ %def event_particle_const_iterator_is_valid <>= public :: hepmc_event_particle_iterator_is_valid <>= module function hepmc_event_particle_iterator_is_valid (it) result (flag) logical :: flag type(hepmc_event_particle_iterator_t), intent(in) :: it end function hepmc_event_particle_iterator_is_valid <>= module function hepmc_event_particle_iterator_is_valid (it) result (flag) logical :: flag type(hepmc_event_particle_iterator_t), intent(in) :: it flag = event_particle_const_iterator_is_valid (it%obj, it%evt_obj) end function hepmc_event_particle_iterator_is_valid @ %def hepmc_event_particle_iterator_is_valid @ Return the particle pointed to by the iterator. (The particle object should not be finalized, since it contains merely a pointer to the particle which is owned by the vertex.) <>= interface type(c_ptr) function event_particle_const_iterator_get (it_obj) bind(C) import type(c_ptr), value :: it_obj end function event_particle_const_iterator_get end interface @ %def event_particle_const_iterator_get <>= public :: hepmc_event_particle_iterator_get <>= module function hepmc_event_particle_iterator_get (it) result (prt) type(hepmc_particle_t) :: prt type(hepmc_event_particle_iterator_t), intent(in) :: it end function hepmc_event_particle_iterator_get <>= module function hepmc_event_particle_iterator_get (it) result (prt) type(hepmc_particle_t) :: prt type(hepmc_event_particle_iterator_t), intent(in) :: it prt%obj = event_particle_const_iterator_get (it%obj) end function hepmc_event_particle_iterator_get @ %def hepmc_event_particle_iterator_get <>= interface type(c_ptr) function gen_event_get_nth_particle (evt_obj, n) bind(C) import type(c_ptr), value :: evt_obj integer(c_int), value :: n end function gen_event_get_nth_particle end interface interface integer(c_int) function gen_event_get_nth_beam (evt_obj, n) bind(C) import type(c_ptr), value :: evt_obj integer(c_int), value :: n end function gen_event_get_nth_beam end interface @ %def gen_event_get_nth_particle @ %def gen_event_get_nth_beam <>= public :: hepmc_event_get_nth_particle public :: hepmc_event_get_nth_beam <>= module function hepmc_event_get_nth_particle (evt, n) result (prt) type(hepmc_particle_t) :: prt type(hepmc_event_t), intent(in) :: evt integer, intent(in) :: n end function hepmc_event_get_nth_particle module function hepmc_event_get_nth_beam (evt, n) result (beam_barcode) integer :: beam_barcode type(hepmc_event_t), intent(in) :: evt integer, intent(in) :: n end function hepmc_event_get_nth_beam <>= module function hepmc_event_get_nth_particle (evt, n) result (prt) type(hepmc_particle_t) :: prt type(hepmc_event_t), intent(in) :: evt integer, intent(in) :: n integer :: n_tot integer(c_int) :: nth nth = n n_tot = gen_event_get_n_particles (evt%obj) if (n > n_tot .or. n < 1) then prt%obj = c_null_ptr call msg_error ("HepMC interface called for wrong particle ID.") else prt%obj = gen_event_get_nth_particle (evt%obj, nth) end if end function hepmc_event_get_nth_particle module function hepmc_event_get_nth_beam (evt, n) result (beam_barcode) integer :: beam_barcode type(hepmc_event_t), intent(in) :: evt integer, intent(in) :: n integer(c_int) :: bc bc = gen_event_get_nth_beam (evt%obj, n) beam_barcode = bc end function hepmc_event_get_nth_beam @ %def hepmc_event_get_nth_particle @ %def hepmc_event_get_nth_beam @ \subsection{I/O streams} There is a specific I/O stream type for handling the output of GenEvent objects (i.e., Monte Carlo event samples) to file. Opening the file is done by the constructor, closing by the destructor. <>= public :: hepmc_iostream_t <>= type :: hepmc_iostream_t private type(c_ptr) :: obj end type hepmc_iostream_t @ %def hepmc_iostream_t @ Constructor for an output stream associated to a file. <>= interface type(c_ptr) function new_io_gen_event_out (hepmc3_mode, filename) bind(C) import integer(c_int), intent(in) :: hepmc3_mode character(c_char), dimension(*), intent(in) :: filename end function new_io_gen_event_out end interface @ %def new_io_gen_event_out <>= public :: hepmc_iostream_open_out <>= module subroutine hepmc_iostream_open_out (iostream, filename, hepmc3_mode) type(hepmc_iostream_t), intent(out) :: iostream type(string_t), intent(in) :: filename integer, intent(in) :: hepmc3_mode end subroutine hepmc_iostream_open_out <>= module subroutine hepmc_iostream_open_out (iostream, filename, hepmc3_mode) type(hepmc_iostream_t), intent(out) :: iostream type(string_t), intent(in) :: filename integer, intent(in) :: hepmc3_mode integer(c_int) :: mode mode = hepmc3_mode iostream%obj = & new_io_gen_event_out (mode, char (filename) // c_null_char) end subroutine hepmc_iostream_open_out @ %def hepmc_iostream_open_out @ Constructor for an input stream associated to a file. <>= interface type(c_ptr) function new_io_gen_event_in (hepmc3_mode, filename) bind(C) import integer(c_int), intent(in) :: hepmc3_mode character(c_char), dimension(*), intent(in) :: filename end function new_io_gen_event_in end interface @ %def new_io_gen_event_in <>= public :: hepmc_iostream_open_in <>= module subroutine hepmc_iostream_open_in (iostream, filename, hepmc3_mode) type(hepmc_iostream_t), intent(out) :: iostream type(string_t), intent(in) :: filename integer, intent(in) :: hepmc3_mode end subroutine hepmc_iostream_open_in <>= module subroutine hepmc_iostream_open_in (iostream, filename, hepmc3_mode) type(hepmc_iostream_t), intent(out) :: iostream type(string_t), intent(in) :: filename integer, intent(in) :: hepmc3_mode integer(c_int) :: mode mode = hepmc3_mode iostream%obj = & new_io_gen_event_in (mode, char (filename) // c_null_char) end subroutine hepmc_iostream_open_in @ %def hepmc_iostream_open_in @ Destructor: <>= interface subroutine io_gen_event_delete (io_obj) bind(C) import type(c_ptr), value :: io_obj end subroutine io_gen_event_delete end interface @ %def io_gen_event_delete <>= public :: hepmc_iostream_close <>= module subroutine hepmc_iostream_close (iostream) type(hepmc_iostream_t), intent(inout) :: iostream end subroutine hepmc_iostream_close <>= module subroutine hepmc_iostream_close (iostream) type(hepmc_iostream_t), intent(inout) :: iostream call io_gen_event_delete (iostream%obj) end subroutine hepmc_iostream_close @ %def hepmc_iostream_close @ Write a single event to the I/O stream. <>= interface subroutine io_gen_event_write_event (io_obj, evt_obj) bind(C) import type(c_ptr), value :: io_obj, evt_obj end subroutine io_gen_event_write_event end interface interface subroutine io_gen_event_write_event_hepmc2 (io_obj, evt_obj) bind(C) import type(c_ptr), value :: io_obj, evt_obj end subroutine io_gen_event_write_event_hepmc2 end interface @ %def io_gen_event_write_event io_gen_event_write_event_hepmc2 <>= public :: hepmc_iostream_write_event <>= module subroutine hepmc_iostream_write_event (iostream, evt, hepmc3_mode) type(hepmc_iostream_t), intent(inout) :: iostream type(hepmc_event_t), intent(in) :: evt integer, intent(in), optional :: hepmc3_mode end subroutine hepmc_iostream_write_event <>= module subroutine hepmc_iostream_write_event (iostream, evt, hepmc3_mode) type(hepmc_iostream_t), intent(inout) :: iostream type(hepmc_event_t), intent(in) :: evt integer, intent(in), optional :: hepmc3_mode integer :: mode mode = HEPMC3_MODE_HEPMC3 if (present (hepmc3_mode)) mode = hepmc3_mode call io_gen_event_write_event (iostream%obj, evt%obj) end subroutine hepmc_iostream_write_event @ %def hepmc_iostream_write_event @ Read a single event from the I/O stream. Return true if successful. <>= interface logical(c_bool) function io_gen_event_read_event (io_obj, evt_obj) bind(C) import type(c_ptr), value :: io_obj, evt_obj end function io_gen_event_read_event end interface @ %def io_gen_event_read_event <>= public :: hepmc_iostream_read_event <>= module subroutine hepmc_iostream_read_event (iostream, evt, ok) type(hepmc_iostream_t), intent(inout) :: iostream type(hepmc_event_t), intent(inout) :: evt logical, intent(out) :: ok end subroutine hepmc_iostream_read_event <>= module subroutine hepmc_iostream_read_event (iostream, evt, ok) type(hepmc_iostream_t), intent(inout) :: iostream type(hepmc_event_t), intent(inout) :: evt logical, intent(out) :: ok ok = io_gen_event_read_event (iostream%obj, evt%obj) end subroutine hepmc_iostream_read_event @ %def hepmc_iostream_read_event @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[hepmc_interface_ut.f90]]>>= <> module hepmc_interface_ut use unit_tests use system_dependencies, only: HEPMC2_AVAILABLE use system_dependencies, only: HEPMC3_AVAILABLE use hepmc_interface_uti <> <> contains <> end module hepmc_interface_ut @ %def hepmc_interface_ut @ <<[[hepmc_interface_uti.f90]]>>= <> module hepmc_interface_uti <> <> use io_units use lorentz use flavors use colors use polarizations use hepmc_interface <> <> contains <> end module hepmc_interface_uti @ %def hepmc_interface_ut @ API: driver for the unit tests below. <>= public :: hepmc_interface_test <>= subroutine hepmc_interface_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine hepmc_interface_test @ %def hepmc_test @ This test example is an abridged version from the build-from-scratch example in the HepMC distribution. We create two vertices for $p\to q$ PDF splitting, then a vertex for a $qq\to W^-g$ hard-interaction process, and finally a vertex for $W^-\to qq$ decay. The setup is for LHC kinematics. Extending the original example, we set color flow for the incoming quarks and polarization for the outgoing photon. For the latter, we have to define a particle-data object for the photon, so a flavor object can be correctly initialized. <>= if (HEPMC2_AVAILABLE) then call test (hepmc_interface_1, "hepmc2_interface_1", & "check HepMC2 interface", & u, results) else if (HEPMC3_AVAILABLE) then call test (hepmc_interface_1, "hepmc3_interface_1", & "check HepMC3 interface", & u, results) end if <>= public :: hepmc_interface_1 <>= subroutine hepmc_interface_1 (u) use physics_defs, only: VECTOR use model_data, only: field_data_t integer, intent(in) :: u integer :: u_file, iostat type(hepmc_event_t) :: evt type(hepmc_vertex_t) :: v1, v2, v3, v4 type(hepmc_particle_t) :: prt1, prt2, prt3, prt4, prt5, prt6, prt7, prt8 type(hepmc_iostream_t) :: iostream type(flavor_t) :: flv type(color_t) :: col type(polarization_t) :: pol type(field_data_t), target :: photon_data character(80) :: buffer write (u, "(A)") "* Test output: HepMC interface" write (u, "(A)") "* Purpose: test HepMC interface" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") ! Initialize a photon flavor object and some polarization call photon_data%init (var_str ("PHOTON"), 22) call photon_data%set (spin_type=VECTOR) call photon_data%freeze () call flv%init (photon_data) call pol%init_angles & (flv, 0.6_default, 1._default, 0.5_default) ! Event initialization call hepmc_event_init (evt, 20, 1) write (u, "(A)") "* p -> q splitting" write (u, "(A)") ! $p\to q$ splittings call hepmc_vertex_init (v1) call hepmc_event_add_vertex (evt, v1) call hepmc_vertex_init (v2) call hepmc_event_add_vertex (evt, v2) call particle_init (prt1, & 0._default, 0._default, 7000._default, 7000._default, & 2212, 3) call hepmc_vertex_add_particle_in (v1, prt1) call particle_init (prt2, & 0._default, 0._default,-7000._default, 7000._default, & 2212, 3) call hepmc_vertex_add_particle_in (v2, prt2) call particle_init (prt3, & .750_default, -1.569_default, 32.191_default, 32.238_default, & 1, 3) call color_init_from_array (col, [501]) call hepmc_particle_set_color (prt3, col) call hepmc_vertex_add_particle_out (v1, prt3) call particle_init (prt4, & -3.047_default, -19._default, -54.629_default, 57.920_default, & -2, 3) call color_init_from_array (col, [-501]) call hepmc_particle_set_color (prt4, col) call hepmc_vertex_add_particle_out (v2, prt4) write (u, "(A)") "* Hard interaction" write (u, "(A)") ! Hard interaction call hepmc_vertex_init (v3) call hepmc_event_add_vertex (evt, v3) call hepmc_vertex_add_particle_in (v3, prt3) call hepmc_vertex_add_particle_in (v3, prt4) call particle_init (prt6, & -3.813_default, 0.113_default, -1.833_default, 4.233_default, & 22, 1) call hepmc_particle_set_polarization (prt6, pol) call hepmc_vertex_add_particle_out (v3, prt6) call particle_init (prt5, & 1.517_default, -20.68_default, -20.605_default, 85.925_default, & -24, 3) call hepmc_vertex_add_particle_out (v3, prt5) call hepmc_event_set_signal_process_vertex (evt, v3) ! $W^-$ decay call vertex_init_pos (v4, & 0.12_default, -0.3_default, 0.05_default, 0.004_default) call hepmc_event_add_vertex (evt, v4) call hepmc_vertex_add_particle_in (v4, prt5) call particle_init (prt7, & -2.445_default, 28.816_default, 6.082_default, 29.552_default, & 1, 1) call hepmc_vertex_add_particle_out (v4, prt7) call particle_init (prt8, & 3.962_default, -49.498_default, -26.687_default, 56.373_default, & -2, 1) call hepmc_vertex_add_particle_out (v4, prt8) ! Event output call hepmc_event_print (evt) write (u, "(A)") "Writing to file 'hepmc_test.hepmc'" write (u, "(A)") call hepmc_iostream_open_out (iostream , var_str ("hepmc_test.hepmc"), 2) call hepmc_iostream_write_event (iostream, evt) call hepmc_iostream_close (iostream) write (u, "(A)") "Writing completed" write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = "hepmc_test.hepmc", & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:14) == "HepMC::Version") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") ! Wrapup ! call pol%final () call hepmc_event_final (evt) write (u, "(A)") write (u, "(A)") "* Test output end: hepmc_interface_1" contains subroutine vertex_init_pos (v, x, y, z, t) type(hepmc_vertex_t), intent(out) :: v real(default), intent(in) :: x, y, z, t type(vector4_t) :: xx xx = vector4_moving (t, vector3_moving ([x, y, z])) call hepmc_vertex_init (v, xx) end subroutine vertex_init_pos subroutine particle_init (prt, px, py, pz, E, pdg, status) type(hepmc_particle_t), intent(out) :: prt real(default), intent(in) :: px, py, pz, E integer, intent(in) :: pdg, status type(vector4_t) :: p p = vector4_moving (E, vector3_moving ([px, py, pz])) call hepmc_particle_init (prt, p, pdg, status) end subroutine particle_init end subroutine hepmc_interface_1 @ %def hepmc_interface_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{LCIO events} This section provides the interface to the LCIO C++ library for handling Monte-Carlo events. Each C++ class of LCIO that we use is mirrored by a Fortran type, which contains as its only component the C pointer to the C++ object. Each C++ method of LCIO that we use has a C wrapper function. This function takes a pointer to the host object as its first argument. Further arguments are either C pointers, or in the case of simple types (integer, real), interoperable C/Fortran objects. The C wrapper functions have explicit interfaces in the Fortran module. They are called by Fortran wrapper procedures. These are treated as methods of the corresponding Fortran type. <<[[lcio_interface.f90]]>>= <> module lcio_interface use, intrinsic :: iso_c_binding !NODEP! <> <> use lorentz use flavors use colors use helicities use polarizations use event_handles, only: event_handle_t <> <> <> <> interface <> end interface end module lcio_interface @ %def lcio_interface @ <<[[lcio_interface_sub.f90]]>>= <> submodule (lcio_interface) lcio_interface_s use constants, only: PI use physics_defs, only: ns_per_mm use diagnostics implicit none contains <> end submodule lcio_interface_s @ %def lcio_interface_s @ \subsection{Interface check} This function can be called in order to verify that we are using the actual LCIO library, and not the dummy version. <>= interface logical(c_bool) function lcio_available () bind(C) import end function lcio_available end interface <>= public :: lcio_is_available <>= module function lcio_is_available () result (flag) logical :: flag end function lcio_is_available <>= module function lcio_is_available () result (flag) logical :: flag flag = lcio_available () end function lcio_is_available @ %def lcio_is_available @ \subsection{LCIO Run Header} This is a type for the run header of the LCIO file. <>= public :: lcio_run_header_t <>= type :: lcio_run_header_t private type(c_ptr) :: obj end type lcio_run_header_t @ %def lcio_run_header_t The Fortran version has initializer form. <>= interface type(c_ptr) function new_lcio_run_header (proc_id) bind(C) import integer(c_int), value :: proc_id end function new_lcio_run_header end interface @ %def new_lcio_run_header <>= interface subroutine run_header_set_simstring & (runhdr_obj, simstring) bind(C) import type(c_ptr), value :: runhdr_obj character(c_char), dimension(*), intent(in) :: simstring end subroutine run_header_set_simstring end interface @ %def run_header_set_simstring <>= public :: lcio_run_header_init <>= module subroutine lcio_run_header_init (runhdr, proc_id, run_id) type(lcio_run_header_t), intent(out) :: runhdr integer, intent(in), optional :: proc_id, run_id end subroutine lcio_run_header_init <>= module subroutine lcio_run_header_init (runhdr, proc_id, run_id) type(lcio_run_header_t), intent(out) :: runhdr integer, intent(in), optional :: proc_id, run_id integer(c_int) :: rid rid = 0; if (present (run_id)) rid = run_id runhdr%obj = new_lcio_run_header (rid) call run_header_set_simstring (runhdr%obj, & "WHIZARD version:" // "<>") end subroutine lcio_run_header_init @ %def lcio_run_header_init @ <>= interface subroutine write_run_header (lcwrt_obj, runhdr_obj) bind(C) import type(c_ptr), value :: lcwrt_obj type(c_ptr), value :: runhdr_obj end subroutine write_run_header end interface @ %def write_run_header <>= public :: lcio_run_header_write <>= module subroutine lcio_run_header_write (wrt, hdr) type(lcio_writer_t), intent(inout) :: wrt type(lcio_run_header_t), intent(inout) :: hdr end subroutine lcio_run_header_write <>= module subroutine lcio_run_header_write (wrt, hdr) type(lcio_writer_t), intent(inout) :: wrt type(lcio_run_header_t), intent(inout) :: hdr call write_run_header (wrt%obj, hdr%obj) end subroutine lcio_run_header_write @ %def lcio_run_header_write @ \subsection{LCIO Event and LC Collection} The main object of LCIO is a LCEventImpl. The object is filled by MCParticle objects, which are set as LCCollection. <>= public :: lccollection_t <>= type :: lccollection_t private type(c_ptr) :: obj = c_null_ptr end type lccollection_t @ %def lccollection_t @ Initializer. <>= interface type(c_ptr) function new_lccollection () bind(C) import end function new_lccollection end interface @ %def new_lccollection <>= public :: lcio_event_t <>= type, extends (event_handle_t) :: lcio_event_t private type(c_ptr) :: obj = c_null_ptr type(lccollection_t) :: lccoll end type lcio_event_t @ %def lcio_event_t @ Constructor. Arguments are process ID (integer) and event ID (integer). The Fortran version has initializer form. <>= interface type(c_ptr) function new_lcio_event (proc_id, event_id, run_id) bind(C) import integer(c_int), value :: proc_id, event_id, run_id end function new_lcio_event end interface @ %def new_lcio_event @ <>= public :: lcio_event_init <>= module subroutine lcio_event_init (evt, proc_id, event_id, run_id) type(lcio_event_t), intent(out) :: evt integer, intent(in), optional :: proc_id, event_id, run_id end subroutine lcio_event_init <>= module subroutine lcio_event_init (evt, proc_id, event_id, run_id) type(lcio_event_t), intent(out) :: evt integer, intent(in), optional :: proc_id, event_id, run_id integer(c_int) :: pid, eid, rid pid = 0; if (present (proc_id)) pid = proc_id eid = 0; if (present (event_id)) eid = event_id rid = 0; if (present (run_id)) rid = run_id evt%obj = new_lcio_event (pid, eid, rid) evt%lccoll%obj = new_lccollection () end subroutine lcio_event_init @ %def lcio_event_init @ Destructor. <>= interface subroutine lcio_event_delete (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end subroutine lcio_event_delete end interface @ %def lcio_event_delete @ Show event on screen. <>= interface subroutine dump_lcio_event (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end subroutine dump_lcio_event end interface @ %def dump_lcio_event <>= public :: show_lcio_event <>= module subroutine show_lcio_event (evt) type(lcio_event_t), intent(in) :: evt end subroutine show_lcio_event <>= module subroutine show_lcio_event (evt) type(lcio_event_t), intent(in) :: evt if (c_associated (evt%obj)) then call dump_lcio_event (evt%obj) else call msg_error ("LCIO event is not allocated.") end if end subroutine show_lcio_event @ %def show_lcio_event @ Put a single event to file. <>= interface subroutine lcio_event_to_file (evt_obj, filename) bind(C) import type(c_ptr), value :: evt_obj character(c_char), dimension(*), intent(in) :: filename end subroutine lcio_event_to_file end interface @ %def lcio_event_to_file <>= public :: write_lcio_event <>= module subroutine write_lcio_event (evt, filename) type(lcio_event_t), intent(in) :: evt type(string_t), intent(in) :: filename end subroutine write_lcio_event <>= module subroutine write_lcio_event (evt, filename) type(lcio_event_t), intent(in) :: evt type(string_t), intent(in) :: filename call lcio_event_to_file (evt%obj, char (filename) // c_null_char) end subroutine write_lcio_event @ %def write_lcio_event @ Finalize: use the LCIO destructor. Also nullify the pointer explicitly, to be on the safe side. <>= public :: lcio_event_final <>= module subroutine lcio_event_final (evt, delete) type(lcio_event_t), intent(inout) :: evt logical, intent(in) :: delete end subroutine lcio_event_final <>= module subroutine lcio_event_final (evt, delete) type(lcio_event_t), intent(inout) :: evt logical, intent(in) :: delete if (c_associated (evt%obj)) then if (delete) call lcio_event_delete (evt%obj) evt%obj = c_null_ptr evt%lccoll%obj = c_null_ptr end if end subroutine lcio_event_final @ %def lcio_event_final @ Nullify: do not call the destructor, just nullify the C pointer. There should be another pointer associated with the object. <>= public :: lcio_event_nullify <>= module subroutine lcio_event_nullify (evt) type(lcio_event_t), intent(inout) :: evt end subroutine lcio_event_nullify <>= module subroutine lcio_event_nullify (evt) type(lcio_event_t), intent(inout) :: evt evt%obj = c_null_ptr evt%lccoll%obj = c_null_ptr end subroutine lcio_event_nullify @ %def lcio_event_nullify @ Return the actual object as a C pointer. For use in the native C++ interface only. <>= public :: lcio_event_get_c_ptr <>= module function lcio_event_get_c_ptr (evt) result (p) type(lcio_event_t), intent(in) :: evt type(c_ptr) :: p end function lcio_event_get_c_ptr <>= module function lcio_event_get_c_ptr (evt) result (p) type(lcio_event_t), intent(in) :: evt type(c_ptr) :: p p = evt%obj end function lcio_event_get_c_ptr @ %def lcio_event_get_c_ptr @ <>= interface subroutine lcio_set_weight (evt_obj, weight) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: weight end subroutine lcio_set_weight end interface interface subroutine lcio_set_alpha_qcd (evt_obj, alphas) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: alphas end subroutine lcio_set_alpha_qcd end interface interface subroutine lcio_set_scale (evt_obj, scale) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: scale end subroutine lcio_set_scale end interface interface subroutine lcio_set_sqrts (evt_obj, sqrts) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: sqrts end subroutine lcio_set_sqrts end interface interface subroutine lcio_set_xsec (evt_obj, xsec, xsec_err) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: xsec, xsec_err end subroutine lcio_set_xsec end interface interface subroutine lcio_set_beam (evt_obj, pdg, beam) bind(C) import type(c_ptr), value :: evt_obj integer(c_int), value :: pdg, beam end subroutine lcio_set_beam end interface interface subroutine lcio_set_pol (evt_obj, pol, beam) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: pol integer(c_int), value :: beam end subroutine lcio_set_pol end interface interface subroutine lcio_set_beam_file (evt_obj, file) bind(C) import type(c_ptr), value :: evt_obj character(len=1, kind=c_char), dimension(*), intent(in) :: file end subroutine lcio_set_beam_file end interface interface subroutine lcio_set_process_name (evt_obj, name) bind(C) import type(c_ptr), value :: evt_obj character(len=1, kind=c_char), dimension(*), intent(in) :: name end subroutine lcio_set_process_name end interface interface subroutine lcio_set_sqme (evt_obj, sqme) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: sqme end subroutine lcio_set_sqme end interface interface subroutine lcio_set_alt_sqme (evt_obj, sqme, index) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: sqme integer(c_int), value :: index end subroutine lcio_set_alt_sqme end interface interface subroutine lcio_set_alt_weight (evt_obj, weight, index) bind(C) import type(c_ptr), value :: evt_obj real(c_double), value :: weight integer(c_int), value :: index end subroutine lcio_set_alt_weight end interface @ %def lcio_set_weight lcio_set_alpha_qcd lcio_set_scale lcio_set_sqrts @ %def lcio_set_xsec lcio_set_beam lcio_set_pol @ %def lcio_set_beam_file lcio_set_process_name @ %def lcio_set_sqme lcio_set_alt_sqme lcio_set_alt_weight @ <>= public :: lcio_event_set_weight <>= module subroutine lcio_event_set_weight (evt, weight) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: weight end subroutine lcio_event_set_weight <>= module subroutine lcio_event_set_weight (evt, weight) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: weight call lcio_set_weight (evt%obj, real (weight, c_double)) end subroutine lcio_event_set_weight @ %def lcio_event_set_weight @ <>= public :: lcio_event_set_alpha_qcd <>= module subroutine lcio_event_set_alpha_qcd (evt, alphas) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: alphas end subroutine lcio_event_set_alpha_qcd <>= module subroutine lcio_event_set_alpha_qcd (evt, alphas) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: alphas call lcio_set_alpha_qcd (evt%obj, real (alphas, c_double)) end subroutine lcio_event_set_alpha_qcd @ %def lcio_event_set_alpha_qcd @ <>= public :: lcio_event_set_scale <>= module subroutine lcio_event_set_scale (evt, scale) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: scale end subroutine lcio_event_set_scale <>= module subroutine lcio_event_set_scale (evt, scale) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: scale call lcio_set_scale (evt%obj, real (scale, c_double)) end subroutine lcio_event_set_scale @ %def lcio_event_set_scale @ <>= public :: lcio_event_set_sqrts <>= module subroutine lcio_event_set_sqrts (evt, sqrts) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: sqrts end subroutine lcio_event_set_sqrts <>= module subroutine lcio_event_set_sqrts (evt, sqrts) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: sqrts call lcio_set_sqrts (evt%obj, real (sqrts, c_double)) end subroutine lcio_event_set_sqrts @ %def lcio_event_set_sqrts @ <>= public :: lcio_event_set_xsec <>= module subroutine lcio_event_set_xsec (evt, xsec, xsec_err) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: xsec, xsec_err end subroutine lcio_event_set_xsec <>= module subroutine lcio_event_set_xsec (evt, xsec, xsec_err) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: xsec, xsec_err call lcio_set_xsec (evt%obj, & real (xsec, c_double), real (xsec_err, c_double)) end subroutine lcio_event_set_xsec @ %def lcio_event_set_xsec @ <>= public :: lcio_event_set_beam <>= module subroutine lcio_event_set_beam (evt, pdg, beam) type(lcio_event_t), intent(inout) :: evt integer, intent(in) :: pdg, beam end subroutine lcio_event_set_beam <>= module subroutine lcio_event_set_beam (evt, pdg, beam) type(lcio_event_t), intent(inout) :: evt integer, intent(in) :: pdg, beam call lcio_set_beam (evt%obj, & int (pdg, c_int), int (beam, c_int)) end subroutine lcio_event_set_beam @ %def lcio_event_set_beam @ <>= public :: lcio_event_set_polarization <>= module subroutine lcio_event_set_polarization (evt, pol, beam) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: pol integer, intent(in) :: beam end subroutine lcio_event_set_polarization <>= module subroutine lcio_event_set_polarization (evt, pol, beam) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: pol integer, intent(in) :: beam call lcio_set_pol (evt%obj, real (pol, c_double), & int (beam, c_int)) end subroutine lcio_event_set_polarization @ %def lcio_event_set_polarization @ <>= public :: lcio_event_set_beam_file <>= module subroutine lcio_event_set_beam_file (evt, file) type(lcio_event_t), intent(inout) :: evt type(string_t), intent(in) :: file end subroutine lcio_event_set_beam_file <>= module subroutine lcio_event_set_beam_file (evt, file) type(lcio_event_t), intent(inout) :: evt type(string_t), intent(in) :: file call lcio_set_beam_file (evt%obj, & char (file) // c_null_char) end subroutine lcio_event_set_beam_file @ %def lcio_event_set_beam_file @ <>= public :: lcio_event_set_process_name <>= module subroutine lcio_event_set_process_name (evt, name) type(lcio_event_t), intent(inout) :: evt type(string_t), intent(in) :: name end subroutine lcio_event_set_process_name <>= module subroutine lcio_event_set_process_name (evt, name) type(lcio_event_t), intent(inout) :: evt type(string_t), intent(in) :: name call lcio_set_process_name (evt%obj, & char (name) // c_null_char) end subroutine lcio_event_set_process_name @ %def lcio_event_set_process_name @ <>= public :: lcio_event_set_alt_sqme <>= module subroutine lcio_event_set_alt_sqme (evt, sqme, index) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: sqme integer, intent(in) :: index end subroutine lcio_event_set_alt_sqme <>= module subroutine lcio_event_set_alt_sqme (evt, sqme, index) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: sqme integer, intent(in) :: index call lcio_set_alt_sqme (evt%obj, real (sqme, c_double), & int (index, c_int)) end subroutine lcio_event_set_alt_sqme @ %def lcio_event_set_alt_sqme @ <>= public :: lcio_event_set_sqme <>= module subroutine lcio_event_set_sqme (evt, sqme) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: sqme end subroutine lcio_event_set_sqme <>= module subroutine lcio_event_set_sqme (evt, sqme) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: sqme call lcio_set_sqme (evt%obj, real (sqme, c_double)) end subroutine lcio_event_set_sqme @ %def lcio_event_set_sqme @ <>= public :: lcio_event_set_alt_weight <>= module subroutine lcio_event_set_alt_weight (evt, weight, index) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: weight integer, intent(in) :: index end subroutine lcio_event_set_alt_weight <>= module subroutine lcio_event_set_alt_weight (evt, weight, index) type(lcio_event_t), intent(inout) :: evt real(default), intent(in) :: weight integer, intent(in) :: index call lcio_set_alt_weight (evt%obj, real (weight, c_double), & int (index, c_int)) end subroutine lcio_event_set_alt_weight @ %def lcio_event_set_alt_weight @ <>= interface subroutine lcio_event_add_collection & (evt_obj, lccoll_obj) bind(C) import type(c_ptr), value :: evt_obj, lccoll_obj end subroutine lcio_event_add_collection end interface @ %def lcio_event_add_collection <>= public :: lcio_event_add_coll <>= module subroutine lcio_event_add_coll (evt) type(lcio_event_t), intent(inout) :: evt end subroutine lcio_event_add_coll <>= module subroutine lcio_event_add_coll (evt) type(lcio_event_t), intent(inout) :: evt call lcio_event_add_collection (evt%obj, & evt%lccoll%obj) end subroutine lcio_event_add_coll @ %def lcio_event_add_coll @ \subsection{LCIO Particle} Particle objects have the obvious meaning. <>= public :: lcio_particle_t <>= type :: lcio_particle_t private type(c_ptr) :: obj end type lcio_particle_t @ %def lcio_particle_t @ Constructor. <>= interface type(c_ptr) function new_lcio_particle & (px, py, pz, pdg_id, mass, charge, status) bind(C) import integer(c_int), value :: pdg_id, status real(c_double), value :: px, py, pz, mass, charge end function new_lcio_particle end interface @ %def new_lcio_particle @ <>= interface subroutine add_particle_to_collection & (prt_obj, lccoll_obj) bind(C) import type(c_ptr), value :: prt_obj, lccoll_obj end subroutine add_particle_to_collection end interface @ %def add_particle_to_collection <>= public :: lcio_particle_add_to_evt_coll <>= module subroutine lcio_particle_add_to_evt_coll & (lprt, evt) type(lcio_particle_t), intent(in) :: lprt type(lcio_event_t), intent(inout) :: evt end subroutine lcio_particle_add_to_evt_coll <>= module subroutine lcio_particle_add_to_evt_coll & (lprt, evt) type(lcio_particle_t), intent(in) :: lprt type(lcio_event_t), intent(inout) :: evt call add_particle_to_collection (lprt%obj, evt%lccoll%obj) end subroutine lcio_particle_add_to_evt_coll @ %def lcio_particle_to_collection @ <>= public :: lcio_particle_init <>= module subroutine lcio_particle_init (prt, p, pdg, charge, status) type(lcio_particle_t), intent(out) :: prt type(vector4_t), intent(in) :: p real(default), intent(in) :: charge integer, intent(in) :: pdg, status end subroutine lcio_particle_init <>= module subroutine lcio_particle_init (prt, p, pdg, charge, status) type(lcio_particle_t), intent(out) :: prt type(vector4_t), intent(in) :: p real(default), intent(in) :: charge real(default) :: mass real(default) :: px, py, pz integer, intent(in) :: pdg, status px = vector4_get_component (p, 1) py = vector4_get_component (p, 2) pz = vector4_get_component (p, 3) mass = p**1 prt%obj = new_lcio_particle (real (px, c_double), real (py, c_double), & real (pz, c_double), int (pdg, c_int), & real (mass, c_double), real (charge, c_double), int (status, c_int)) end subroutine lcio_particle_init @ %def lcio_particle_init @ Set the particle color flow. <>= interface subroutine lcio_set_color_flow (prt_obj, col1, col2) bind(C) import type(c_ptr), value :: prt_obj integer(c_int), value :: col1, col2 end subroutine lcio_set_color_flow end interface @ %def lcio_set_color_flow @ Set the particle color. Either from a [[color_t]] object or directly from a pair of integers. <>= interface lcio_particle_set_color module procedure lcio_particle_set_color_col module procedure lcio_particle_set_color_int end interface lcio_particle_set_color <>= public :: lcio_particle_set_color <>= module subroutine lcio_particle_set_color_col (prt, col) type(lcio_particle_t), intent(inout) :: prt type(color_t), intent(in) :: col end subroutine lcio_particle_set_color_col module subroutine lcio_particle_set_color_int (prt, col) type(lcio_particle_t), intent(inout) :: prt integer, dimension(2), intent(in) :: col end subroutine lcio_particle_set_color_int <>= module subroutine lcio_particle_set_color_col (prt, col) type(lcio_particle_t), intent(inout) :: prt type(color_t), intent(in) :: col integer(c_int), dimension(2) :: c c(1) = col%get_col () c(2) = col%get_acl () if (c(1) /= 0 .or. c(2) /= 0) then call lcio_set_color_flow (prt%obj, c(1), c(2)) end if end subroutine lcio_particle_set_color_col module subroutine lcio_particle_set_color_int (prt, col) type(lcio_particle_t), intent(inout) :: prt integer, dimension(2), intent(in) :: col integer(c_int), dimension(2) :: c c = col if (c(1) /= 0 .or. c(2) /= 0) then call lcio_set_color_flow (prt%obj, c(1), c(2)) end if end subroutine lcio_particle_set_color_int @ %def lcio_particle_set_color @ Return the particle color as a two-dimensional array (color, anticolor). <>= interface integer(c_int) function lcio_particle_flow (prt_obj, col_index) bind(C) use iso_c_binding !NODEP! type(c_ptr), value :: prt_obj integer(c_int), value :: col_index end function lcio_particle_flow end interface @ %def lcio_particle_flow <>= public :: lcio_particle_get_flow <>= module function lcio_particle_get_flow (prt) result (col) integer, dimension(2) :: col type(lcio_particle_t), intent(in) :: prt end function lcio_particle_get_flow <>= module function lcio_particle_get_flow (prt) result (col) integer, dimension(2) :: col type(lcio_particle_t), intent(in) :: prt col(1) = lcio_particle_flow (prt%obj, 0_c_int) col(2) = - lcio_particle_flow (prt%obj, 1_c_int) end function lcio_particle_get_flow @ %def lcio_particle_get_flow @ Return the four-momentum of a LCIO particle. <>= interface real(c_double) function lcio_three_momentum (prt_obj, p_index) bind(C) use iso_c_binding !NODEP! type(c_ptr), value :: prt_obj integer(c_int), value :: p_index end function lcio_three_momentum end interface @ %def lcio_three_momentum <>= interface real(c_double) function lcio_energy (prt_obj) bind(C) import type(c_ptr), intent(in), value :: prt_obj end function lcio_energy end interface @ %def lcio_energy <>= public :: lcio_particle_get_momentum <>= module function lcio_particle_get_momentum (prt) result (p) type(vector4_t) :: p type(lcio_particle_t), intent(in) :: prt end function lcio_particle_get_momentum <>= module function lcio_particle_get_momentum (prt) result (p) type(vector4_t) :: p type(lcio_particle_t), intent(in) :: prt real(default) :: E, px, py, pz E = lcio_energy (prt%obj) px = lcio_three_momentum (prt%obj, 0_c_int) py = lcio_three_momentum (prt%obj, 1_c_int) pz = lcio_three_momentum (prt%obj, 2_c_int) p = vector4_moving ( E, vector3_moving ([ px, py, pz ])) end function lcio_particle_get_momentum @ %def lcio_particle_get_momentum @ Return the invariant mass squared of the particle object. LCIO stores the signed invariant mass (no squaring). <>= interface function lcio_mass (prt_obj) result (mass) bind(C) import real(c_double) :: mass type(c_ptr), value :: prt_obj end function lcio_mass end interface @ %def lcio_mass <>= public :: lcio_particle_get_mass_squared <>= module function lcio_particle_get_mass_squared (prt) result (m2) real(default) :: m2 type(lcio_particle_t), intent(in) :: prt end function lcio_particle_get_mass_squared <>= module function lcio_particle_get_mass_squared (prt) result (m2) real(default) :: m2 type(lcio_particle_t), intent(in) :: prt real(default) :: m m = lcio_mass (prt%obj) m2 = sign (m**2, m) end function lcio_particle_get_mass_squared @ %def lcio_particle_get_mass_squared @ Return vertex and production time of a LCIO particle. <>= interface real(c_double) function lcio_vtx_x (prt) bind(C) import type(c_ptr), value :: prt end function lcio_vtx_x end interface interface real(c_double) function lcio_vtx_y (prt) bind(C) import type(c_ptr), value :: prt end function lcio_vtx_y end interface interface real(c_double) function lcio_vtx_z (prt) bind(C) import type(c_ptr), value :: prt end function lcio_vtx_z end interface interface real(c_float) function lcio_prt_time (prt) bind(C) import type(c_ptr), value :: prt end function lcio_prt_time end interface @ @ (Decay) times in LCIO are in nanoseconds, so they need to get converted to mm for the internal format. <>= public :: lcio_particle_get_vertex public :: lcio_particle_get_time <>= module function lcio_particle_get_vertex (prt) result (vtx) type(vector3_t) :: vtx type(lcio_particle_t), intent(in) :: prt end function lcio_particle_get_vertex module function lcio_particle_get_time (prt) result (time) real(default) :: time type(lcio_particle_t), intent(in) :: prt end function lcio_particle_get_time <>= module function lcio_particle_get_vertex (prt) result (vtx) type(vector3_t) :: vtx type(lcio_particle_t), intent(in) :: prt real(default) :: vx, vy, vz vx = lcio_vtx_x (prt%obj) vy = lcio_vtx_y (prt%obj) vz = lcio_vtx_z (prt%obj) vtx = vector3_moving ([vx, vy, vz]) end function lcio_particle_get_vertex module function lcio_particle_get_time (prt) result (time) real(default) :: time type(lcio_particle_t), intent(in) :: prt time = lcio_prt_time (prt%obj) time = time / ns_per_mm end function lcio_particle_get_time @ %def lcio_particle_get_vertex lcio_particle_get_time @ \subsection{Polarization} For polarization there is a three-component float entry foreseen in the LCIO format. Completely generic density matrices can in principle be attached to events as float vectors added to [[LCCollection]] of the [[LCEvent]]. This is not yet implemented currently. Here, we restrict ourselves to the same implementation as in HepMC format: we use two entries as the polarization angles, while the first entry gives the degree of polarization (something not specified in the HepMC format). \emph{For massive vector bosons, we arbitrarily choose the convention that the longitudinal (zero) helicity state is mapped to the theta angle $\pi/2$. This works under the condition that helicity is projected onto one of the basis states.} <>= interface subroutine lcio_particle_set_spin (prt_obj, s1, s2, s3) bind(C) import type(c_ptr), value :: prt_obj real(c_double), value :: s1, s2, s3 end subroutine lcio_particle_set_spin end interface @ %def lcio_particle_set_spin @ <>= public :: lcio_polarization_init <>= interface lcio_polarization_init module procedure lcio_polarization_init_pol module procedure lcio_polarization_init_hel module procedure lcio_polarization_init_int end interface <>= module subroutine lcio_polarization_init_pol (prt, pol) type(lcio_particle_t), intent(inout) :: prt type(polarization_t), intent(in) :: pol end subroutine lcio_polarization_init_pol module subroutine lcio_polarization_init_hel (prt, hel) type(lcio_particle_t), intent(inout) :: prt type(helicity_t), intent(in) :: hel end subroutine lcio_polarization_init_hel module subroutine lcio_polarization_init_int (prt, hel) type(lcio_particle_t), intent(inout) :: prt integer, intent(in) :: hel end subroutine lcio_polarization_init_int <>= module subroutine lcio_polarization_init_pol (prt, pol) type(lcio_particle_t), intent(inout) :: prt type(polarization_t), intent(in) :: pol real(default) :: r, theta, phi if (pol%is_polarized ()) then call pol%to_angles (r, theta, phi) call lcio_particle_set_spin (prt%obj, & real(r, c_double), real (theta, c_double), real (phi, c_double)) end if end subroutine lcio_polarization_init_pol module subroutine lcio_polarization_init_hel (prt, hel) type(lcio_particle_t), intent(inout) :: prt type(helicity_t), intent(in) :: hel integer, dimension(2) :: h if (hel%is_defined ()) then h = hel%to_pair () select case (h(1)) case (1:) call lcio_particle_set_spin (prt%obj, 1._c_double, & 0._c_double, 0._c_double) case (:-1) call lcio_particle_set_spin (prt%obj, 1._c_double, & real (pi, c_double), 0._c_double) case (0) call lcio_particle_set_spin (prt%obj, 1._c_double, & real (pi/2, c_double), 0._c_double) end select end if end subroutine lcio_polarization_init_hel module subroutine lcio_polarization_init_int (prt, hel) type(lcio_particle_t), intent(inout) :: prt integer, intent(in) :: hel call lcio_particle_set_spin (prt%obj, 0._c_double, & 0._c_double, real (hel, c_double)) end subroutine lcio_polarization_init_int @ %def lcio_polarization_init @ Recover polarization from LCIO particle (with the abovementioned deficiencies). <>= interface function lcio_polarization_degree (prt_obj) result (degree) bind(C) import real(c_double) :: degree type(c_ptr), value :: prt_obj end function lcio_polarization_degree end interface interface function lcio_polarization_theta (prt_obj) result (theta) bind(C) import real(c_double) :: theta type(c_ptr), value :: prt_obj end function lcio_polarization_theta end interface interface function lcio_polarization_phi (prt_obj) result (phi) bind(C) import real(c_double) :: phi type(c_ptr), value :: prt_obj end function lcio_polarization_phi end interface @ %def lcio_polarization_degree lcio_polarization_theta lcio_polarization_phi <>= public :: lcio_particle_to_pol <>= module subroutine lcio_particle_to_pol (prt, flv, pol) type(lcio_particle_t), intent(in) :: prt type(flavor_t), intent(in) :: flv type(polarization_t), intent(out) :: pol end subroutine lcio_particle_to_pol <>= module subroutine lcio_particle_to_pol (prt, flv, pol) type(lcio_particle_t), intent(in) :: prt type(flavor_t), intent(in) :: flv type(polarization_t), intent(out) :: pol real(default) :: degree, theta, phi degree = lcio_polarization_degree (prt%obj) theta = lcio_polarization_theta (prt%obj) phi = lcio_polarization_phi (prt%obj) call pol%init_angles (flv, degree, theta, phi) end subroutine lcio_particle_to_pol @ %def lcio_polarization_to_pol @ Recover helicity. Here, $\phi$ and [[degree]] is ignored and only the sign of $\cos\theta$ is relevant, mapped to positive/negative helicity. <>= public :: lcio_particle_to_hel <>= module subroutine lcio_particle_to_hel (prt, flv, hel) type(lcio_particle_t), intent(in) :: prt type(flavor_t), intent(in) :: flv type(helicity_t), intent(out) :: hel end subroutine lcio_particle_to_hel <>= module subroutine lcio_particle_to_hel (prt, flv, hel) type(lcio_particle_t), intent(in) :: prt type(flavor_t), intent(in) :: flv type(helicity_t), intent(out) :: hel real(default) :: theta integer :: hmax theta = lcio_polarization_theta (prt%obj) hmax = flv%get_spin_type () / 2 call hel%init (sign (hmax, nint (cos (theta)))) end subroutine lcio_particle_to_hel @ %def lcio_particle_to_hel @ Set the vertex of a particle. <>= interface subroutine lcio_particle_set_vertex (prt_obj, vx, vy, vz) bind(C) import type(c_ptr), value :: prt_obj real(c_double), value :: vx, vy, vz end subroutine lcio_particle_set_vertex end interface interface subroutine lcio_particle_set_time (prt_obj, t) bind(C) import type(c_ptr), value :: prt_obj real(c_float), value :: t end subroutine lcio_particle_set_time end interface @ %def lcio_particle_set_vertex lcio_particle_set_time @ <>= public :: lcio_particle_set_vtx <>= module subroutine lcio_particle_set_vtx (prt, vtx) type(lcio_particle_t), intent(inout) :: prt type(vector3_t), intent(in) :: vtx end subroutine lcio_particle_set_vtx <>= module subroutine lcio_particle_set_vtx (prt, vtx) type(lcio_particle_t), intent(inout) :: prt type(vector3_t), intent(in) :: vtx call lcio_particle_set_vertex (prt%obj, real(vtx%p(1), c_double), & real(vtx%p(2), c_double), real(vtx%p(3), c_double)) end subroutine lcio_particle_set_vtx @ %def lcio_particle_set_vtx @ Times in LCIO are in nanoseconds, not in mm, so need to be converted. <>= public :: lcio_particle_set_t <>= module subroutine lcio_particle_set_t (prt, t) type(lcio_particle_t), intent(inout) :: prt real(default), intent(in) :: t end subroutine lcio_particle_set_t <>= module subroutine lcio_particle_set_t (prt, t) type(lcio_particle_t), intent(inout) :: prt real(default), intent(in) :: t real(default) :: ns_from_t_mm ns_from_t_mm = ns_per_mm * t call lcio_particle_set_time (prt%obj, real(ns_from_t_mm, c_float)) end subroutine lcio_particle_set_t @ %def lcio_particle_set_t @ <>= interface subroutine lcio_particle_add_parent (prt_obj1, prt_obj2) bind(C) import type(c_ptr), value :: prt_obj1, prt_obj2 end subroutine lcio_particle_add_parent end interface @ %def lcio_particle_add_parent <>= public :: lcio_particle_set_parent <>= module subroutine lcio_particle_set_parent (daughter, parent) type(lcio_particle_t), intent(inout) :: daughter, parent end subroutine lcio_particle_set_parent <>= module subroutine lcio_particle_set_parent (daughter, parent) type(lcio_particle_t), intent(inout) :: daughter, parent call lcio_particle_add_parent (daughter%obj, parent%obj) end subroutine lcio_particle_set_parent @ %def lcio_particle_set_parent @ <>= interface integer(c_int) function lcio_particle_get_generator_status & (prt_obj) bind(C) import type(c_ptr), value :: prt_obj end function lcio_particle_get_generator_status end interface @ %def lcio_particle_get_generator_status <>= public :: lcio_particle_get_status <>= module function lcio_particle_get_status (lptr) result (status) integer :: status type(lcio_particle_t), intent(in) :: lptr end function lcio_particle_get_status <>= module function lcio_particle_get_status (lptr) result (status) integer :: status type(lcio_particle_t), intent(in) :: lptr status = lcio_particle_get_generator_status (lptr%obj) end function lcio_particle_get_status @ %def lcio_particle_get_status @ Getting the PDG code. <>= interface integer(c_int) function lcio_particle_get_pdg_code (prt_obj) bind(C) import type(c_ptr), value :: prt_obj end function lcio_particle_get_pdg_code end interface @ %def lcio_particle_get_pdg_code @ <>= public :: lcio_particle_get_pdg <>= module function lcio_particle_get_pdg (lptr) result (pdg) integer :: pdg type(lcio_particle_t), intent(in) :: lptr end function lcio_particle_get_pdg <>= module function lcio_particle_get_pdg (lptr) result (pdg) integer :: pdg type(lcio_particle_t), intent(in) :: lptr pdg = lcio_particle_get_pdg_code (lptr%obj) end function lcio_particle_get_pdg @ %def lcio_particle_get_pdg @ Obtaining the number of parents and daughters of an LCIO particle. <>= interface integer(c_int) function lcio_n_parents (prt_obj) bind(C) import type(c_ptr), value :: prt_obj end function lcio_n_parents end interface @ %def lcio_n_parents @ <>= interface integer(c_int) function lcio_n_daughters (prt_obj) bind(C) import type(c_ptr), value :: prt_obj end function lcio_n_daughters end interface @ %def lcio_n_daughters @ <>= public :: lcio_particle_get_n_parents <>= module function lcio_particle_get_n_parents (lptr) result (n_parents) integer :: n_parents type(lcio_particle_t), intent(in) :: lptr end function lcio_particle_get_n_parents <>= module function lcio_particle_get_n_parents (lptr) result (n_parents) integer :: n_parents type(lcio_particle_t), intent(in) :: lptr n_parents = lcio_n_parents (lptr%obj) end function lcio_particle_get_n_parents @ %def lcio_particle_get_n_parents @ <>= public :: lcio_particle_get_n_children <>= module function lcio_particle_get_n_children (lptr) result (n_children) integer :: n_children type(lcio_particle_t), intent(in) :: lptr end function lcio_particle_get_n_children <>= module function lcio_particle_get_n_children (lptr) result (n_children) integer :: n_children type(lcio_particle_t), intent(in) :: lptr n_children = lcio_n_daughters (lptr%obj) end function lcio_particle_get_n_children @ %def lcio_particle_get_n_children @ This provides access from the LCIO event [[lcio_event_t]] to the array entries of the parent and daughter arrays of the LCIO particles. <>= interface integer(c_int) function lcio_event_parent_k & (evt_obj, num_part, k_parent) bind (C) use iso_c_binding !NODEP! type(c_ptr), value :: evt_obj integer(c_int), value :: num_part, k_parent end function lcio_event_parent_k end interface @ %def lcio_event_parent_k <>= interface integer(c_int) function lcio_event_daughter_k & (evt_obj, num_part, k_daughter) bind (C) use iso_c_binding !NODEP! type(c_ptr), value :: evt_obj integer(c_int), value :: num_part, k_daughter end function lcio_event_daughter_k end interface @ %def lcio_event_daughter_k @ <>= public :: lcio_get_n_parents <>= module function lcio_get_n_parents & (evt, num_part, k_parent) result (index_parent) type(lcio_event_t), intent(in) :: evt integer, intent(in) :: num_part, k_parent integer :: index_parent end function lcio_get_n_parents <>= module function lcio_get_n_parents & (evt, num_part, k_parent) result (index_parent) type(lcio_event_t), intent(in) :: evt integer, intent(in) :: num_part, k_parent integer :: index_parent index_parent = lcio_event_parent_k (evt%obj, int (num_part, c_int), & int (k_parent, c_int)) end function lcio_get_n_parents @ %def lcio_get_n_parents @ <>= public :: lcio_get_n_children <>= module function lcio_get_n_children & (evt, num_part, k_daughter) result (index_daughter) type(lcio_event_t), intent(in) :: evt integer, intent(in) :: num_part, k_daughter integer :: index_daughter end function lcio_get_n_children <>= module function lcio_get_n_children & (evt, num_part, k_daughter) result (index_daughter) type(lcio_event_t), intent(in) :: evt integer, intent(in) :: num_part, k_daughter integer :: index_daughter index_daughter = lcio_event_daughter_k (evt%obj, int (num_part, c_int), & int (k_daughter, c_int)) end function lcio_get_n_children @ %def lcio_get_n_children @ \subsection{LCIO Writer type} There is a specific LCIO Writer type for handling the output of LCEventImpl objects (i.e., Monte Carlo event samples) to file. Opening the file is done by the constructor, closing by the destructor. <>= public :: lcio_writer_t <>= type :: lcio_writer_t private type(c_ptr) :: obj end type lcio_writer_t @ %def lcio_writer_t @ Constructor for an output associated to a file. <>= interface type(c_ptr) function open_lcio_writer_new (filename, complevel) bind(C) import character(c_char), dimension(*), intent(in) :: filename integer(c_int), intent(in) :: complevel end function open_lcio_writer_new end interface @ %def open_lcio_writer_now <>= public :: lcio_writer_open_out <>= module subroutine lcio_writer_open_out (lcio_writer, filename) type(lcio_writer_t), intent(out) :: lcio_writer type(string_t), intent(in) :: filename end subroutine lcio_writer_open_out <>= module subroutine lcio_writer_open_out (lcio_writer, filename) type(lcio_writer_t), intent(out) :: lcio_writer type(string_t), intent(in) :: filename lcio_writer%obj = open_lcio_writer_new (char (filename) // & c_null_char, 9_c_int) end subroutine lcio_writer_open_out @ %def lcio_writer_open_out @ Destructor: <>= interface subroutine lcio_writer_delete (io_obj) bind(C) import type(c_ptr), value :: io_obj end subroutine lcio_writer_delete end interface @ %def lcio_writer_delete <>= public :: lcio_writer_close <>= module subroutine lcio_writer_close (lciowriter) type(lcio_writer_t), intent(inout) :: lciowriter end subroutine lcio_writer_close <>= module subroutine lcio_writer_close (lciowriter) type(lcio_writer_t), intent(inout) :: lciowriter call lcio_writer_delete (lciowriter%obj) end subroutine lcio_writer_close @ %def lcio_writer_close @ Write a single event to the LCIO writer. <>= interface subroutine lcio_write_event (io_obj, evt_obj) bind(C) import type(c_ptr), value :: io_obj, evt_obj end subroutine lcio_write_event end interface @ %def lcio_write_event <>= public :: lcio_event_write <>= module subroutine lcio_event_write (wrt, evt) type(lcio_writer_t), intent(inout) :: wrt type(lcio_event_t), intent(in) :: evt end subroutine lcio_event_write <>= module subroutine lcio_event_write (wrt, evt) type(lcio_writer_t), intent(inout) :: wrt type(lcio_event_t), intent(in) :: evt call lcio_write_event (wrt%obj, evt%obj) end subroutine lcio_event_write @ %def lcio_event_write @ \subsection{LCIO Reader type} There is a specific LCIO Reader type for handling the input of LCEventImpl objects (i.e., Monte Carlo event samples) from file. Opening the file is done by the constructor, closing by the destructor. <>= public :: lcio_reader_t <>= type :: lcio_reader_t private type(c_ptr) :: obj end type lcio_reader_t @ %def lcio_reader_t @ Constructor for an output associated to a file. <>= interface type(c_ptr) function open_lcio_reader (filename) bind(C) import character(c_char), dimension(*), intent(in) :: filename end function open_lcio_reader end interface @ %def open_lcio_reader <>= public :: lcio_open_file <>= module subroutine lcio_open_file (lcio_reader, filename) type(lcio_reader_t), intent(out) :: lcio_reader type(string_t), intent(in) :: filename end subroutine lcio_open_file <>= module subroutine lcio_open_file (lcio_reader, filename) type(lcio_reader_t), intent(out) :: lcio_reader type(string_t), intent(in) :: filename lcio_reader%obj = open_lcio_reader (char (filename) // c_null_char) end subroutine lcio_open_file @ %def lcio_open_file @ Destructor: <>= interface subroutine lcio_reader_delete (io_obj) bind(C) import type(c_ptr), value :: io_obj end subroutine lcio_reader_delete end interface @ %def lcio_reader_delete <>= public :: lcio_reader_close <>= module subroutine lcio_reader_close (lcioreader) type(lcio_reader_t), intent(inout) :: lcioreader end subroutine lcio_reader_close <>= module subroutine lcio_reader_close (lcioreader) type(lcio_reader_t), intent(inout) :: lcioreader call lcio_reader_delete (lcioreader%obj) end subroutine lcio_reader_close @ %def lcio_reader_close @ @ Read a single event from the event file. Return true if successful. <>= interface type(c_ptr) function read_lcio_event (io_obj) bind(C) import type(c_ptr), value :: io_obj end function read_lcio_event end interface @ %def read_lcio_event <>= public :: lcio_read_event <>= module subroutine lcio_read_event (lcrdr, evt, ok) type(lcio_reader_t), intent(inout) :: lcrdr type(lcio_event_t), intent(out) :: evt logical, intent(out) :: ok end subroutine lcio_read_event <>= module subroutine lcio_read_event (lcrdr, evt, ok) type(lcio_reader_t), intent(inout) :: lcrdr type(lcio_event_t), intent(out) :: evt logical, intent(out) :: ok evt%obj = read_lcio_event (lcrdr%obj) ok = c_associated (evt%obj) end subroutine lcio_read_event @ %def lcio_read_event @ Get the event index. <>= interface integer(c_int) function lcio_event_get_event_number (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end function lcio_event_get_event_number end interface @ %def lcio_event_get_event_number <>= public :: lcio_event_get_event_index <>= module function lcio_event_get_event_index (evt) result (i_evt) integer :: i_evt type(lcio_event_t), intent(in) :: evt end function lcio_event_get_event_index <>= module function lcio_event_get_event_index (evt) result (i_evt) integer :: i_evt type(lcio_event_t), intent(in) :: evt i_evt = lcio_event_get_event_number (evt%obj) end function lcio_event_get_event_index @ %def lcio_event_get_event_index @ Extract the process ID. This is stored (at the moment abusively) in the RUN ID as well as in an additional event parameter. <>= interface integer(c_int) function lcio_event_signal_process_id (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end function lcio_event_signal_process_id end interface @ %def lcio_event_signal_process_id <>= public :: lcio_event_get_process_id <>= module function lcio_event_get_process_id (evt) result (i_proc) integer :: i_proc type(lcio_event_t), intent(in) :: evt end function lcio_event_get_process_id <>= module function lcio_event_get_process_id (evt) result (i_proc) integer :: i_proc type(lcio_event_t), intent(in) :: evt i_proc = lcio_event_signal_process_id (evt%obj) end function lcio_event_get_process_id @ %def lcio_event_get_process_id @ Number of particles in an LCIO event. <>= interface integer(c_int) function lcio_event_get_n_particles (evt_obj) bind(C) import type(c_ptr), value :: evt_obj end function lcio_event_get_n_particles end interface @ %def lcio_event_get_n_particles <>= @ <>= public :: lcio_event_get_n_tot <>= module function lcio_event_get_n_tot (evt) result (n_tot) integer :: n_tot type(lcio_event_t), intent(in) :: evt end function lcio_event_get_n_tot <>= module function lcio_event_get_n_tot (evt) result (n_tot) integer :: n_tot type(lcio_event_t), intent(in) :: evt n_tot = lcio_event_get_n_particles (evt%obj) end function lcio_event_get_n_tot @ %def lcio_event_get_n_tot @ Extracting $\alpha_s$ and the scale. <>= interface function lcio_event_get_alpha_qcd (evt_obj) result (as) bind(C) import real(c_double) :: as type(c_ptr), value :: evt_obj end function lcio_event_get_alpha_qcd end interface interface function lcio_event_get_scale (evt_obj) result (scale) bind(C) import real(c_double) :: scale type(c_ptr), value :: evt_obj end function lcio_event_get_scale end interface @ %def lcio_event_get_alpha_qcd lcio_event_get_scale @ <>= public :: lcio_event_get_alphas <>= module function lcio_event_get_alphas (evt) result (as) type(lcio_event_t), intent(in) :: evt real(default) :: as end function lcio_event_get_alphas <>= module function lcio_event_get_alphas (evt) result (as) type(lcio_event_t), intent(in) :: evt real(default) :: as as = lcio_event_get_alpha_qcd (evt%obj) end function lcio_event_get_alphas @ %def lcio_event_get_alphas @ <>= public :: lcio_event_get_scaleval <>= module function lcio_event_get_scaleval (evt) result (scale) type(lcio_event_t), intent(in) :: evt real(default) :: scale end function lcio_event_get_scaleval <>= module function lcio_event_get_scaleval (evt) result (scale) type(lcio_event_t), intent(in) :: evt real(default) :: scale scale = lcio_event_get_scale (evt%obj) end function lcio_event_get_scaleval @ %def lcio_event_get_scaleval @ Extracting particles by index from an LCIO event. <>= interface type(c_ptr) function lcio_event_particle_k (evt_obj, k) bind(C) import type(c_ptr), value :: evt_obj integer(c_int), value :: k end function lcio_event_particle_k end interface @ %def lcio_event_particle_k @ <>= public :: lcio_event_get_particle <>= module function lcio_event_get_particle (evt, n) result (prt) type(lcio_event_t), intent(in) :: evt integer, intent(in) :: n type(lcio_particle_t) :: prt end function lcio_event_get_particle <>= module function lcio_event_get_particle (evt, n) result (prt) type(lcio_event_t), intent(in) :: evt integer, intent(in) :: n type(lcio_particle_t) :: prt prt%obj = lcio_event_particle_k (evt%obj, int (n, c_int)) end function lcio_event_get_particle @ %def lcio_event_get_particle @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[lcio_interface_ut.f90]]>>= <> module lcio_interface_ut use unit_tests use lcio_interface_uti <> <> contains <> end module lcio_interface_ut @ %def lcio_interface_ut @ <<[[lcio_interface_uti.f90]]>>= <> module lcio_interface_uti <> <> use io_units use lorentz use flavors use colors use polarizations use lcio_interface <> <> contains <> end module lcio_interface_uti @ %def lcio_interface_ut @ API: driver for the unit tests below. <>= public :: lcio_interface_test <>= subroutine lcio_interface_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine lcio_interface_test @ %def lcio_interface_test @ <>= call test (lcio_interface_1, "lcio_interface_1", & "check LCIO interface", & u, results) <>= public :: lcio_interface_1 <>= subroutine lcio_interface_1 (u) use physics_defs, only: VECTOR use model_data, only: field_data_t integer, intent(in) :: u integer :: u_file, iostat type(lcio_event_t) :: evt type(lcio_particle_t) :: prt1, prt2, prt3, prt4, prt5, prt6, prt7, prt8 type(flavor_t) :: flv type(color_t) :: col type(polarization_t) :: pol type(field_data_t), target :: photon_data character(220) :: buffer write (u, "(A)") "* Test output: LCIO interface" write (u, "(A)") "* Purpose: test LCIO interface" write (u, "(A)") write (u, "(A)") "* Initialization" write (u, "(A)") ! Initialize a photon flavor object and some polarization call photon_data%init (var_str ("PHOTON"), 22) call photon_data%set (spin_type=VECTOR) call photon_data%freeze () call flv%init (photon_data) call pol%init_angles & (flv, 0.6_default, 1._default, 0.5_default) ! Event initialization call lcio_event_init (evt, 20, 1, 42) write (u, "(A)") "* p -> q splitting" write (u, "(A)") ! $p\to q$ splittings call particle_init (prt1, & 0._default, 0._default, 7000._default, 7000._default, & 2212, 1._default, 3) call particle_init (prt2, & 0._default, 0._default,-7000._default, 7000._default, & 2212, 1._default, 3) call particle_init (prt3, & .750_default, -1.569_default, 32.191_default, 32.238_default, & 1, -1._default/3._default, 3) call color_init_from_array (col, [501]) call lcio_particle_set_color (prt3, col) call lcio_particle_set_parent (prt3, prt1) call lcio_particle_set_parent (prt3, prt2) call particle_init (prt4, & -3.047_default, -19._default, -54.629_default, 57.920_default, & -2, -2._default/3._default, 3) call color_init_from_array (col, [-501]) call lcio_particle_set_color (prt4, col) call lcio_particle_set_parent (prt4, prt1) call lcio_particle_set_parent (prt4, prt2) write (u, "(A)") "* Hard interaction" write (u, "(A)") ! Hard interaction call particle_init (prt6, & -3.813_default, 0.113_default, -1.833_default, 4.233_default, & 22, 0._default, 1) call lcio_polarization_init (prt6, pol) call particle_init (prt5, & 1.517_default, -20.68_default, -20.605_default, 85.925_default, & -24, -1._default, 3) call lcio_particle_set_parent (prt5, prt3) call lcio_particle_set_parent (prt5, prt4) call lcio_particle_set_parent (prt6, prt3) call lcio_particle_set_parent (prt6, prt4) ! $W^-$ decay call particle_init (prt7, & -2.445_default, 28.816_default, 6.082_default, 29.552_default, & 1, -1._default/3._default, 1) call particle_init (prt8, & 3.962_default, -49.498_default, -26.687_default, 56.373_default, & -2, -2._default/3._default, 1) call lcio_particle_set_t (prt7, 0.12_default) call lcio_particle_set_t (prt8, 0.12_default) call lcio_particle_set_vtx & (prt7, vector3_moving ([-0.3_default, 0.05_default, 0.004_default])) call lcio_particle_set_vtx & (prt8, vector3_moving ([-0.3_default, 0.05_default, 0.004_default])) call lcio_particle_set_parent (prt7, prt5) call lcio_particle_set_parent (prt8, prt5) call lcio_particle_add_to_evt_coll (prt1, evt) call lcio_particle_add_to_evt_coll (prt2, evt) call lcio_particle_add_to_evt_coll (prt3, evt) call lcio_particle_add_to_evt_coll (prt4, evt) call lcio_particle_add_to_evt_coll (prt5, evt) call lcio_particle_add_to_evt_coll (prt6, evt) call lcio_particle_add_to_evt_coll (prt7, evt) call lcio_particle_add_to_evt_coll (prt8, evt) call lcio_event_add_coll (evt) ! Event output write (u, "(A)") "Writing in ASCII form to file 'lcio_test.slcio'" write (u, "(A)") call write_lcio_event (evt, var_str ("lcio_test.slcio")) write (u, "(A)") "Writing completed" write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = "lcio_test.slcio", & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (trim (buffer) == "") cycle if (buffer(1:12) == " - timestamp") buffer = "[...]" if (buffer(1:6) == " date:") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") ! Wrapup ! call pol%final () call lcio_event_final (evt, .true.) write (u, "(A)") write (u, "(A)") "* Test output end: lcio_interface_1" contains subroutine particle_init & (prt, px, py, pz, E, pdg, charge, status) type(lcio_particle_t), intent(out) :: prt real(default), intent(in) :: px, py, pz, E, charge integer, intent(in) :: pdg, status type(vector4_t) :: p p = vector4_moving (E, vector3_moving ([px, py, pz])) call lcio_particle_init (prt, p, pdg, charge, status) end subroutine particle_init end subroutine lcio_interface_1 @ %def lcio_interface_1 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{HEP Common and Events} This is a separate module that manages data exchange between the common blocks and [[event_t]] objects. We separate this from the previous module in order to avoid a circular module dependency. It also contains the functions necessary for communication between [[hepmc_event_t]] and [[event_t]] or [[lcio_event_t]] and [[event_t]] as well as [[particle_set_t]] and [[particle_t]] objects. <<[[hep_events.f90]]>>= <> module hep_events <> <> use lorentz use polarizations use model_data use particles use hepmc_interface use lcio_interface use event_base <> <> interface <> end interface end module hep_events @ %def hep_events @ <<[[hep_events_sub.f90]]>>= <> submodule (hep_events) hep_events_s use system_dependencies, only: HEPMC2_AVAILABLE use system_dependencies, only: HEPMC3_AVAILABLE use diagnostics use numeric_utils use flavors use colors use helicities use subevents, only: PRT_BEAM, PRT_INCOMING, PRT_OUTGOING use subevents, only: PRT_UNDEFINED use subevents, only: PRT_VIRTUAL, PRT_RESONANT, PRT_BEAM_REMNANT use hep_common implicit none contains <> end submodule hep_events_s @ %def hep_events_s @ \subsection{Data Transfer: events} Fill the HEPEUP block, given a \whizard\ event object. <>= public :: hepeup_from_event <>= module subroutine hepeup_from_event & (event, keep_beams, keep_remnants, process_index) class(generic_event_t), intent(in), target :: event logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants integer, intent(in), optional :: process_index end subroutine hepeup_from_event <>= module subroutine hepeup_from_event & (event, keep_beams, keep_remnants, process_index) class(generic_event_t), intent(in), target :: event logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants integer, intent(in), optional :: process_index type(particle_set_t), pointer :: particle_set real(default) :: scale, alpha_qcd if (event%has_valid_particle_set ()) then particle_set => event%get_particle_set_ptr () call hepeup_from_particle_set (particle_set, keep_beams, keep_remnants) if (present (process_index)) then call hepeup_set_event_parameters (proc_id = process_index) end if scale = event%get_fac_scale () if (.not. vanishes (scale)) then call hepeup_set_event_parameters (scale = scale) end if alpha_qcd = event%get_alpha_s () if (.not. vanishes (alpha_qcd)) then call hepeup_set_event_parameters (alpha_qcd = alpha_qcd) end if if (event%weight_prc_is_known ()) then call hepeup_set_event_parameters (weight = event%get_weight_prc ()) end if else call msg_bug ("HEPEUP: event incomplete") end if end subroutine hepeup_from_event @ %def hepeup_from_event @ Reverse. Note: The current implementation sets the particle set of the hard process and is therefore not useful if the event on file is dressed. This should be reconsidered. Note: setting of scale or alpha is not yet supported by the [[event_t]] object. Ticket \#628. <>= public :: hepeup_to_event <>= module subroutine hepeup_to_event & (event, fallback_model, process_index, recover_beams, & use_alpha_s, use_scale) class(generic_event_t), intent(inout), target :: event class(model_data_t), intent(in), target :: fallback_model integer, intent(out), optional :: process_index logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alpha_s logical, intent(in), optional :: use_scale end subroutine hepeup_to_event <>= module subroutine hepeup_to_event & (event, fallback_model, process_index, recover_beams, & use_alpha_s, use_scale) class(generic_event_t), intent(inout), target :: event class(model_data_t), intent(in), target :: fallback_model integer, intent(out), optional :: process_index logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alpha_s logical, intent(in), optional :: use_scale class(model_data_t), pointer :: model real(default) :: weight, scale, alpha_qcd type(particle_set_t) :: particle_set model => event%get_model_ptr () call hepeup_to_particle_set & (particle_set, recover_beams, model, fallback_model) call event%set_hard_particle_set (particle_set) call particle_set%final () if (present (process_index)) then call hepeup_get_event_parameters (proc_id = process_index) end if call hepeup_get_event_parameters (weight = weight, & scale = scale, alpha_qcd = alpha_qcd) call event%set_weight_ref (weight) if (present (use_alpha_s)) then if (use_alpha_s .and. alpha_qcd > 0) & call event%set_alpha_qcd_forced (alpha_qcd) end if if (present (use_scale)) then if (use_scale .and. scale > 0) & call event%set_scale_forced (scale) end if end subroutine hepeup_to_event @ %def hepeup_to_event @ Fill the HEPEVT (event) common block. The [[i_evt]] argument overrides the index stored in the [[event]] object. <>= public :: hepevt_from_event <>= module subroutine hepevt_from_event & (event, process_index, i_evt, keep_beams, keep_remnants, & ensure_order, fill_hepev4) class(generic_event_t), intent(in), target :: event integer, intent(in), optional :: i_evt, process_index logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants logical, intent(in), optional :: ensure_order logical, intent(in), optional :: fill_hepev4 end subroutine hepevt_from_event <>= module subroutine hepevt_from_event & (event, process_index, i_evt, keep_beams, keep_remnants, & ensure_order, fill_hepev4) class(generic_event_t), intent(in), target :: event integer, intent(in), optional :: i_evt, process_index logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants logical, intent(in), optional :: ensure_order logical, intent(in), optional :: fill_hepev4 type(particle_set_t), pointer :: particle_set real(default) :: alpha_qcd, scale if (event%has_valid_particle_set ()) then particle_set => event%get_particle_set_ptr () call hepevt_from_particle_set (particle_set, keep_beams, & keep_remnants, ensure_order, fill_hepev4) if (present (process_index)) then call hepevt_set_event_parameters (proc_id = process_index) end if if (event%weight_prc_is_known ()) then call hepevt_set_event_parameters (weight = event%get_weight_prc ()) end if if (event%sqme_prc_is_known ()) then call hepevt_set_event_parameters & (function_value = event%get_sqme_prc ()) end if scale = event%get_fac_scale () if (.not. vanishes (scale)) then call hepevt_set_event_parameters (scale = scale) end if alpha_qcd = event%get_alpha_s () if (.not. vanishes (alpha_qcd)) then call hepevt_set_event_parameters (alpha_qcd = alpha_qcd) end if if (present (i_evt)) then call hepevt_set_event_parameters (i_evt = i_evt) else if (event%has_index ()) then call hepevt_set_event_parameters (i_evt = event%get_index ()) else call hepevt_set_event_parameters (i_evt = 0) end if else call msg_bug ("HEPEVT: event incomplete") end if end subroutine hepevt_from_event @ %def hepevt_from_event @ \subsubsection{HepMC format} The master output function fills a HepMC GenEvent object that is already initialized, but has no vertices in it. We first set up the vertex lists and enter the vertices into the HepMC event. Then, we assign first all incoming particles and then all outgoing particles to their associated vertices. Particles which have neither parent nor children entries (this should not happen) are dropped. Finally, we insert the beam particles. If there are none, use the incoming particles instead. @ Transform a particle into a [[hepmc_particle]] object, including color and polarization. The HepMC status is equivalent to the HEPEVT status, in particular: 0 = null entry, 1 = physical particle, 2 = decayed/fragmented SM hadron, tau or muon, 3 = other unphysical particle entry, 4 = incoming particles, 11 = intermediate resonance such as squarks. The use of 11 for intermediate resonances is as done by HERWIG, see http://herwig.hepforge.org/trac/wiki/FaQs. <>= subroutine particle_to_hepmc (prt, hprt) type(particle_t), intent(in) :: prt type(hepmc_particle_t), intent(out) :: hprt integer :: hepmc_status select case (prt%get_status ()) case (PRT_UNDEFINED) hepmc_status = 0 case (PRT_OUTGOING) hepmc_status = 1 case (PRT_BEAM) hepmc_status = 4 case (PRT_RESONANT) hepmc_status = 2 case (PRT_BEAM_REMNANT) if (prt%get_n_children () == 0) then hepmc_status = 1 else hepmc_status = 3 end if case default hepmc_status = 3 end select call hepmc_particle_init (hprt, & prt%get_momentum (), prt%get_pdg (), & hepmc_status) if (HEPMC2_AVAILABLE) then call hepmc_particle_set_color (hprt, prt%get_color ()) select case (prt%get_polarization_status ()) case (PRT_DEFINITE_HELICITY) call hepmc_particle_set_polarization (hprt, & prt%get_helicity ()) case (PRT_GENERIC_POLARIZATION) call hepmc_particle_set_polarization (hprt, & prt%get_polarization ()) end select end if end subroutine particle_to_hepmc @ %def particle_to_hepmc @ For HepMC3, a HepMC particle needs first to be attached to a vertex and an event before non-intrinsic particle properties (color flow and helicity) could be set. <>= public :: hepmc_event_from_particle_set <>= module subroutine hepmc_event_from_particle_set & (evt, particle_set, cross_section, error, color) type(hepmc_event_t), intent(inout) :: evt type(particle_set_t), intent(in) :: particle_set real(default), intent(in), optional :: cross_section, error logical, intent(in), optional :: color end subroutine hepmc_event_from_particle_set <>= module subroutine hepmc_event_from_particle_set & (evt, particle_set, cross_section, error, color) type(hepmc_event_t), intent(inout) :: evt type(particle_set_t), intent(in) :: particle_set real(default), intent(in), optional :: cross_section, error logical, intent(in), optional :: color type(hepmc_vertex_t), dimension(:), allocatable :: v type(hepmc_particle_t), dimension(:), allocatable :: hprt type(hepmc_particle_t), dimension(2) :: hbeam type(vector4_t), dimension(:), allocatable :: vtx logical, dimension(:), allocatable :: is_beam integer, dimension(:), allocatable :: v_from, v_to integer :: n_vertices, n_tot, i logical :: write_color write_color = .false. if (present (color)) write_color = color n_tot = particle_set%get_n_tot () allocate (v_from (n_tot), v_to (n_tot)) call particle_set%assign_vertices (v_from, v_to, n_vertices) allocate (hprt (n_tot)) allocate (vtx (n_vertices)) vtx = vector4_null do i = 1, n_tot if (v_to(i) /= 0 .or. v_from(i) /= 0) then call particle_to_hepmc (particle_set%prt(i), hprt(i)) if (v_from(i) /= 0) then vtx(v_from(i)) = particle_set%prt(i)%get_vertex () end if end if end do if (present (cross_section) .and. present(error)) & call hepmc_event_set_cross_section (evt, cross_section, error) allocate (v (n_vertices)) do i = 1, n_vertices call hepmc_vertex_init (v(i), vtx(i)) call hepmc_event_add_vertex (evt, v(i)) end do allocate (is_beam (n_tot)) is_beam = particle_set%prt(1:n_tot)%get_status () == PRT_BEAM if (.not. any (is_beam)) then is_beam = particle_set%prt(1:n_tot)%get_status () == PRT_INCOMING end if if (count (is_beam) == 2) then hbeam = pack (hprt, is_beam) call hepmc_event_set_beam_particles (evt, hbeam(1), hbeam(2)) end if do i = 1, n_tot if (v_to(i) /= 0) then call hepmc_vertex_add_particle_in (v(v_to(i)), hprt(i)) end if end do do i = 1, n_tot if (v_from(i) /= 0) then call hepmc_vertex_add_particle_out (v(v_from(i)), hprt(i)) end if end do FIND_SIGNAL_PROCESS: do i = 1, n_tot if (particle_set%prt(i)%get_status () == PRT_INCOMING) then call hepmc_event_set_signal_process_vertex (evt, v(v_to(i))) exit FIND_SIGNAL_PROCESS end if end do FIND_SIGNAL_PROCESS if (HEPMC3_AVAILABLE) then do i = 1, n_tot if (write_color) then call hepmc_particle_set_color (hprt(i), & particle_set%prt(i)%get_color ()) end if select case (particle_set%prt(i)%get_polarization_status ()) case (PRT_DEFINITE_HELICITY) call hepmc_particle_set_polarization (hprt(i), & particle_set%prt(i)%get_helicity ()) case (PRT_GENERIC_POLARIZATION) call hepmc_particle_set_polarization (hprt(i), & particle_set%prt(i)%get_polarization ()) end select end do end if end subroutine hepmc_event_from_particle_set @ %def hepmc_event_from_particle_set @ Initialize a particle from a HepMC particle object. The model is necessary for making a fully qualified flavor component. We have the additional flag [[polarized]] which tells whether the polarization information should be interpreted or ignored, and the lookup array of barcodes. Note that the lookup array is searched linearly, a possible bottleneck for large particle arrays. If necessary, the barcode array could be replaced by a hash table. <>= subroutine particle_from_hepmc_particle & (prt, hprt, model, fallback_model, polarization, barcode) type(particle_t), intent(out) :: prt type(hepmc_particle_t), intent(in) :: hprt type(model_data_t), intent(in), target :: model type(model_data_t), intent(in), target :: fallback_model type(hepmc_vertex_t) :: vtx integer, intent(in) :: polarization integer, dimension(:), intent(in) :: barcode type(hepmc_polarization_t) :: hpol type(flavor_t) :: flv type(color_t) :: col type(helicity_t) :: hel type(polarization_t) :: pol type(vector4_t) :: vertex integer :: n_parents, n_children integer, dimension(:), allocatable :: & parent_barcode, child_barcode, parent, child integer :: i select case (hepmc_particle_get_status (hprt)) case (1); call prt%set_status (PRT_OUTGOING) case (2); call prt%set_status (PRT_RESONANT) case (3); call prt%set_status (PRT_VIRTUAL) end select if (hepmc_particle_is_beam (hprt)) call prt%set_status (PRT_BEAM) call flv%init (hepmc_particle_get_pdg (hprt), model, fallback_model) call col%init (hepmc_particle_get_color (hprt)) call prt%set_flavor (flv) call prt%set_color (col) call prt%set_polarization (polarization) select case (polarization) case (PRT_DEFINITE_HELICITY) hpol = hepmc_particle_get_polarization (hprt) call hepmc_polarization_to_hel (hpol, prt%get_flv (), hel) call prt%set_helicity (hel) call hepmc_polarization_final (hpol) case (PRT_GENERIC_POLARIZATION) hpol = hepmc_particle_get_polarization (hprt) call hepmc_polarization_to_pol (hpol, prt%get_flv (), pol) call prt%set_pol (pol) call hepmc_polarization_final (hpol) end select call prt%set_momentum (hepmc_particle_get_momentum (hprt), & hepmc_particle_get_mass_squared (hprt)) n_parents = hepmc_particle_get_n_parents (hprt) n_children = hepmc_particle_get_n_children (hprt) if (HEPMC2_AVAILABLE) then allocate (parent_barcode (n_parents), parent (n_parents)) allocate (child_barcode (n_children), child (n_children)) parent_barcode = hepmc_particle_get_parent_barcodes (hprt) child_barcode = hepmc_particle_get_child_barcodes (hprt) do i = 1, size (barcode) where (parent_barcode == barcode(i)) parent = i where (child_barcode == barcode(i)) child = i end do call prt%set_parents (parent) call prt%set_children (child) else if (HEPMC3_AVAILABLE) then allocate (parent_barcode (n_parents), parent (n_parents)) allocate (child_barcode (n_children), child (n_children)) parent_barcode = hepmc_particle_get_parent_barcodes (hprt) child_barcode = hepmc_particle_get_child_barcodes (hprt) do i = 1, size (barcode) where (parent_barcode == barcode(i)) parent = i where (child_barcode == barcode(i)) child = i end do call prt%set_parents (parent) call prt%set_children (child) end if if (prt%get_status () == PRT_VIRTUAL .and. n_parents == 0) & call prt%set_status (PRT_INCOMING) if (HEPMC2_AVAILABLE) then vtx = hepmc_particle_get_decay_vertex (hprt) if (hepmc_vertex_is_valid (vtx)) then vertex = hepmc_vertex_to_vertex (vtx) if (vertex /= vector4_null) call prt%set_vertex (vertex) end if end if end subroutine particle_from_hepmc_particle @ %def particle_from_hepmc_particle @ If a particle set is initialized from a HepMC event record, we have to specify the treatment of polarization (unpolarized or density matrix) which is common to all particles. Correlated polarization information is not available. There is some complication in reconstructing incoming particles and beam remnants. First of all, they all will be tagged as virtual. We then define an incoming particle as <>= public :: hepmc_event_to_particle_set <>= module subroutine hepmc_event_to_particle_set & (particle_set, evt, model, fallback_model, polarization) type(particle_set_t), intent(inout), target :: particle_set type(hepmc_event_t), intent(in) :: evt class(model_data_t), intent(in), target :: model, fallback_model integer, intent(in) :: polarization end subroutine hepmc_event_to_particle_set <>= module subroutine hepmc_event_to_particle_set & (particle_set, evt, model, fallback_model, polarization) type(particle_set_t), intent(inout), target :: particle_set type(hepmc_event_t), intent(in) :: evt class(model_data_t), intent(in), target :: model, fallback_model integer, intent(in) :: polarization type(hepmc_event_particle_iterator_t) :: it type(hepmc_vertex_t) :: v type(hepmc_vertex_particle_in_iterator_t) :: v_it type(hepmc_particle_t) :: prt integer, dimension(:), allocatable :: barcode, n_parents integer :: n_tot, n_beam, i, bc n_tot = hepmc_event_get_n_particles(evt) allocate (barcode (n_tot)) if (HEPMC2_AVAILABLE) then call hepmc_event_particle_iterator_init (it, evt) do i = 1, n_tot barcode(i) = hepmc_particle_get_barcode & (hepmc_event_particle_iterator_get (it)) call hepmc_event_particle_iterator_advance (it) end do allocate (particle_set%prt (n_tot)) call hepmc_event_particle_iterator_reset (it) do i = 1, n_tot prt = hepmc_event_particle_iterator_get (it) call particle_from_hepmc_particle (particle_set%prt(i), & prt, model, fallback_model, polarization, barcode) call hepmc_event_particle_iterator_advance (it) end do call hepmc_event_particle_iterator_final (it) v = hepmc_event_get_signal_process_vertex (evt) if (hepmc_vertex_is_valid (v)) then call hepmc_vertex_particle_in_iterator_init (v_it, v) do while (hepmc_vertex_particle_in_iterator_is_valid (v_it)) prt = hepmc_vertex_particle_in_iterator_get (v_it) bc = hepmc_particle_get_barcode & (hepmc_vertex_particle_in_iterator_get (v_it)) do i = 1, size(barcode) if (bc == barcode(i)) & call particle_set%prt(i)%set_status (PRT_INCOMING) end do call hepmc_vertex_particle_in_iterator_advance (v_it) end do call hepmc_vertex_particle_in_iterator_final (v_it) end if else if (HEPMC3_AVAILABLE) then allocate (particle_set%prt (n_tot)) do i = 1, n_tot barcode(i) = hepmc_particle_get_barcode & (hepmc_event_get_nth_particle (evt, i)) end do do i = 1, n_tot prt = hepmc_event_get_nth_particle (evt, i) call particle_from_hepmc_particle (particle_set%prt(i), & prt, model, fallback_model, polarization, barcode) end do end if do i = 1, n_tot if (particle_set%prt(i)%get_status () == PRT_VIRTUAL & .and. particle_set%prt(i)%get_n_children () == 0) & call particle_set%prt(i)%set_status (PRT_OUTGOING) end do if (HEPMC3_AVAILABLE) then n_beam = hepmc_event_get_n_beams (evt) do i = 1, n_beam bc = hepmc_event_get_nth_beam (evt, i) if (.not. particle_set%prt(bc)%get_status () == PRT_INCOMING) & call particle_set%prt(bc)%set_status (PRT_BEAM) end do do i = 1, n_tot if (particle_set%prt(i)%get_status () == PRT_VIRTUAL) then n_parents = particle_set%prt(i)%get_parents () if (all & (particle_set%prt(n_parents)%get_status () == PRT_BEAM)) then call particle_set%prt(i)%set_status (PRT_INCOMING) end if end if end do end if particle_set%n_tot = n_tot particle_set%n_beam = & count (particle_set%prt%get_status () == PRT_BEAM) particle_set%n_in = & count (particle_set%prt%get_status () == PRT_INCOMING) particle_set%n_out = & count (particle_set%prt%get_status () == PRT_OUTGOING) particle_set%n_vir = & particle_set%n_tot - particle_set%n_in - particle_set%n_out end subroutine hepmc_event_to_particle_set @ %def hepmc_event_to_particle_set @ Fill a WHIZARD event from a HepMC event record. In HepMC the weights are in a weight container. If the size of this container is larger than one, it is ambiguous to assign the event a specific weight. For now we only allow to read in unweighted events. <>= public :: hepmc_to_event <>= module subroutine hepmc_to_event & (event, hepmc_event, fallback_model, process_index, & recover_beams, use_alpha_s, use_scale) class(generic_event_t), intent(inout), target :: event type(hepmc_event_t), intent(inout) :: hepmc_event class(model_data_t), intent(in), target :: fallback_model integer, intent(out), optional :: process_index logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alpha_s logical, intent(in), optional :: use_scale end subroutine hepmc_to_event <>= module subroutine hepmc_to_event & (event, hepmc_event, fallback_model, process_index, & recover_beams, use_alpha_s, use_scale) class(generic_event_t), intent(inout), target :: event type(hepmc_event_t), intent(inout) :: hepmc_event class(model_data_t), intent(in), target :: fallback_model integer, intent(out), optional :: process_index logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alpha_s logical, intent(in), optional :: use_scale class(model_data_t), pointer :: model real(default) :: scale, alpha_qcd type(particle_set_t) :: particle_set model => event%get_model_ptr () call event%set_index (hepmc_event_get_event_index (hepmc_event)) call hepmc_event_to_particle_set (particle_set, & hepmc_event, model, fallback_model, PRT_DEFINITE_HELICITY) call event%set_hard_particle_set (particle_set) call particle_set%final () call event%set_weight_ref (1._default) alpha_qcd = hepmc_event_get_alpha_qcd (hepmc_event) scale = hepmc_event_get_scale (hepmc_event) if (present (use_alpha_s)) then if (use_alpha_s .and. alpha_qcd > 0) & call event%set_alpha_qcd_forced (alpha_qcd) end if if (present (use_scale)) then if (use_scale .and. scale > 0) & call event%set_scale_forced (scale) end if end subroutine hepmc_to_event @ %def hepmc_to_event @ \subsubsection{LCIO event format} The master output function fills a LCIO event object that is already initialized, but has no particles in it. In contrast to HepMC in LCIO there are no vertices (except for tracker and other detector specifications). So we assign first all incoming particles and then all outgoing particles to LCIO particle types. Particles which have neither parent nor children entries (this should not happen) are dropped. Finally, we insert the beam particles. If there are none, use the incoming particles instead. Transform a particle into a [[lcio_particle]] object, including color and polarization. The LCIO status is equivalent to the HepMC status, in particular: 0 = null entry, 1 = physical particle, 2 = decayed/fragmented SM hadron, tau or muon, 3 = other unphysical particle entry, 4 = incoming particles, 11 = intermediate resonance such as squarks. The use of 11 for intermediate resonances is as done by HERWIG, see http://herwig.hepforge.org/trac/wiki/FaQs. A beam-remnant particle (e.g., ISR photon) that has no children is tagged as outgoing, otherwise unphysical. <>= public :: particle_to_lcio <>= module subroutine particle_to_lcio (prt, lprt) type(particle_t), intent(in) :: prt type(lcio_particle_t), intent(out) :: lprt end subroutine particle_to_lcio <>= module subroutine particle_to_lcio (prt, lprt) type(particle_t), intent(in) :: prt type(lcio_particle_t), intent(out) :: lprt integer :: lcio_status type(vector4_t) :: vtx select case (prt%get_status ()) case (PRT_UNDEFINED) lcio_status = 0 case (PRT_OUTGOING) lcio_status = 1 case (PRT_BEAM_REMNANT) if (prt%get_n_children () == 0) then lcio_status = 1 else lcio_status = 3 end if case (PRT_BEAM) lcio_status = 4 case (PRT_RESONANT) lcio_status = 2 case default lcio_status = 3 end select call lcio_particle_init (lprt, & prt%get_momentum (), & prt%get_pdg (), & prt%flv%get_charge (), & lcio_status) call lcio_particle_set_color (lprt, prt%get_color ()) vtx = prt%get_vertex () call lcio_particle_set_vtx (lprt, space_part (vtx)) call lcio_particle_set_t (lprt, vtx%p(0)) select case (prt%get_polarization_status ()) case (PRT_DEFINITE_HELICITY) call lcio_polarization_init (lprt, prt%get_helicity ()) case (PRT_GENERIC_POLARIZATION) call lcio_polarization_init (lprt, prt%get_polarization ()) end select end subroutine particle_to_lcio @ %def particle_to_lcio @ @ Initialize a particle from a LCIO particle object. The model is necessary for making a fully qualified flavor component. <>= public :: particle_from_lcio_particle <>= module subroutine particle_from_lcio_particle & (prt, lprt, model, fallback_model, daughters, parents, polarization) type(particle_t), intent(out) :: prt type(lcio_particle_t), intent(in) :: lprt type(model_data_t), intent(in), target :: model type(model_data_t), intent(in), target :: fallback_model integer, dimension(:), intent(in) :: daughters, parents integer, intent(in) :: polarization end subroutine particle_from_lcio_particle <>= module subroutine particle_from_lcio_particle & (prt, lprt, model, fallback_model, daughters, parents, polarization) type(particle_t), intent(out) :: prt type(lcio_particle_t), intent(in) :: lprt type(model_data_t), intent(in), target :: model type(model_data_t), intent(in), target :: fallback_model integer, dimension(:), intent(in) :: daughters, parents integer, intent(in) :: polarization type(vector4_t) :: vtx4 type(flavor_t) :: flv type(color_t) :: col type(helicity_t) :: hel type(polarization_t) :: pol select case (lcio_particle_get_status (lprt)) case (1); call prt%set_status (PRT_OUTGOING) case (2); call prt%set_status (PRT_RESONANT) case (3) select case (size (parents)) case (0) call prt%set_status (PRT_INCOMING) case default call prt%set_status (PRT_VIRTUAL) end select case (4); call prt%set_status (PRT_BEAM) end select call flv%init (lcio_particle_get_pdg (lprt), model, fallback_model) call col%init (lcio_particle_get_flow (lprt)) if (flv%is_beam_remnant ()) call prt%set_status (PRT_BEAM_REMNANT) call prt%set_flavor (flv) call prt%set_color (col) call prt%set_polarization (polarization) select case (polarization) case (PRT_DEFINITE_HELICITY) call lcio_particle_to_hel (lprt, prt%get_flv (), hel) call prt%set_helicity (hel) case (PRT_GENERIC_POLARIZATION) call lcio_particle_to_pol (lprt, prt%get_flv (), pol) call prt%set_pol (pol) end select call prt%set_momentum (lcio_particle_get_momentum (lprt), & lcio_particle_get_mass_squared (lprt)) call prt%set_parents (parents) call prt%set_children (daughters) vtx4 = vector4_moving (lcio_particle_get_time (lprt), & lcio_particle_get_vertex (lprt)) if (vtx4 /= vector4_null) call prt%set_vertex (vtx4) end subroutine particle_from_lcio_particle @ %def particle_from_lcio_particle @ <>= public :: lcio_event_from_particle_set <>= module subroutine lcio_event_from_particle_set (evt, particle_set) type(lcio_event_t), intent(inout) :: evt type(particle_set_t), intent(in) :: particle_set end subroutine lcio_event_from_particle_set <>= module subroutine lcio_event_from_particle_set (evt, particle_set) type(lcio_event_t), intent(inout) :: evt type(particle_set_t), intent(in) :: particle_set type(lcio_particle_t), dimension(:), allocatable :: lprt type(particle_set_t), target :: pset_filtered integer, dimension(:), allocatable :: parent integer :: n_tot, i, j, n_beam, n_parents, type, beam_count call particle_set%filter_particles ( pset_filtered, & real_parents = .true. , keep_beams = .true. , keep_virtuals = .false.) n_tot = pset_filtered%n_tot n_beam = count (pset_filtered%prt%get_status () == PRT_BEAM) if (n_beam == 0) then type = PRT_INCOMING else type = PRT_BEAM end if beam_count = 0 allocate (lprt (n_tot)) do i = 1, n_tot call particle_to_lcio (pset_filtered%prt(i), lprt(i)) n_parents = pset_filtered%prt(i)%get_n_parents () if (n_parents /= 0) then allocate (parent (n_parents)) parent = pset_filtered%prt(i)%get_parents () do j = 1, n_parents call lcio_particle_set_parent (lprt(i), lprt(parent(j))) end do deallocate (parent) end if if (pset_filtered%prt(i)%get_status () == type) then beam_count = beam_count + 1 call lcio_event_set_beam & (evt, pset_filtered%prt(i)%get_pdg (), beam_count) end if call lcio_particle_add_to_evt_coll (lprt(i), evt) end do call lcio_event_add_coll (evt) end subroutine lcio_event_from_particle_set @ %def lcio_event_from_particle_set @ If a particle set is initialized from a LCIO event record, we have to specify the treatment of polarization (unpolarized or density matrix) which is common to all particles. Correlated polarization information is not available. <>= public :: lcio_event_to_particle_set <>= module subroutine lcio_event_to_particle_set & (particle_set, evt, model, fallback_model, polarization) type(particle_set_t), intent(inout), target :: particle_set type(lcio_event_t), intent(in) :: evt class(model_data_t), intent(in), target :: model, fallback_model integer, intent(in) :: polarization end subroutine lcio_event_to_particle_set <>= module subroutine lcio_event_to_particle_set & (particle_set, evt, model, fallback_model, polarization) type(particle_set_t), intent(inout), target :: particle_set type(lcio_event_t), intent(in) :: evt class(model_data_t), intent(in), target :: model, fallback_model integer, intent(in) :: polarization type(lcio_particle_t) :: prt integer, dimension(:), allocatable :: parents, daughters integer :: n_tot, i, j, n_parents, n_children n_tot = lcio_event_get_n_tot (evt) allocate (particle_set%prt (n_tot)) do i = 1, n_tot prt = lcio_event_get_particle (evt, i-1) n_parents = lcio_particle_get_n_parents (prt) n_children = lcio_particle_get_n_children (prt) allocate (daughters (n_children)) allocate (parents (n_parents)) if (n_children > 0) then do j = 1, n_children daughters(j) = lcio_get_n_children (evt,i,j) end do end if if (n_parents > 0) then do j = 1, n_parents parents(j) = lcio_get_n_parents (evt,i,j) end do end if call particle_from_lcio_particle (particle_set%prt(i), & prt, model, fallback_model, & daughters, parents, polarization) deallocate (daughters, parents) end do do i = 1, n_tot if (particle_set%prt(i)%get_status () == PRT_VIRTUAL) then CHECK_BEAM: do j = 1, particle_set%prt(i)%get_n_parents () if (particle_set%prt(j)%get_status () == PRT_BEAM) & call particle_set%prt(i)%set_status (PRT_INCOMING) exit CHECK_BEAM end do CHECK_BEAM end if end do particle_set%n_tot = n_tot particle_set%n_beam = & count (particle_set%prt%get_status () == PRT_BEAM) particle_set%n_in = & count (particle_set%prt%get_status () == PRT_INCOMING) particle_set%n_out = & count (particle_set%prt%get_status () == PRT_OUTGOING) particle_set%n_vir = & particle_set%n_tot - particle_set%n_in - particle_set%n_out end subroutine lcio_event_to_particle_set @ %def lcio_event_to_particle_set @ <>= public :: lcio_to_event <>= module subroutine lcio_to_event & (event, lcio_event, fallback_model, process_index, recover_beams, & use_alpha_s, use_scale) class(generic_event_t), intent(inout), target :: event type(lcio_event_t), intent(inout) :: lcio_event class(model_data_t), intent(in), target :: fallback_model integer, intent(out), optional :: process_index logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alpha_s logical, intent(in), optional :: use_scale end subroutine lcio_to_event <>= module subroutine lcio_to_event & (event, lcio_event, fallback_model, process_index, recover_beams, & use_alpha_s, use_scale) class(generic_event_t), intent(inout), target :: event type(lcio_event_t), intent(inout) :: lcio_event class(model_data_t), intent(in), target :: fallback_model integer, intent(out), optional :: process_index logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alpha_s logical, intent(in), optional :: use_scale class(model_data_t), pointer :: model real(default) :: scale, alpha_qcd type(particle_set_t) :: particle_set model => event%get_model_ptr () call lcio_event_to_particle_set (particle_set, & lcio_event, model, fallback_model, PRT_DEFINITE_HELICITY) call event%set_hard_particle_set (particle_set) call particle_set%final () call event%set_weight_ref (1._default) alpha_qcd = lcio_event_get_alphas (lcio_event) scale = lcio_event_get_scaleval (lcio_event) if (present (use_alpha_s)) then if (use_alpha_s .and. alpha_qcd > 0) & call event%set_alpha_qcd_forced (alpha_qcd) end if if (present (use_scale)) then if (use_scale .and. scale > 0) & call event%set_scale_forced (scale) end if end subroutine lcio_to_event @ %def lcio_to_event @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[hep_events_ut.f90]]>>= <> module hep_events_ut use unit_tests use hepmc_interface, only: HEPMC_IS_AVAILABLE use system_dependencies, only: HEPMC2_AVAILABLE use hep_events_uti <> <> contains <> end module hep_events_ut @ %def hep_events_ut @ <<[[hep_events_uti.f90]]>>= <> module hep_events_uti <> <> use lorentz use flavors use colors use helicities use quantum_numbers use state_matrices, only: FM_SELECT_HELICITY, FM_FACTOR_HELICITY use interactions use evaluators use model_data use particles use subevents use hepmc_interface use hep_events <> <> contains <> end module hep_events_uti @ %def hep_events_ut @ API: driver for the unit tests below. <>= public :: hep_events_test <>= subroutine hep_events_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine hep_events_test @ %def particles_test @ If [[HepMC]] is available, check the routines via [[HepMC]]. Set up a chain of production and decay and factorize the result into particles. The process is $d\bar d \to Z \to q\bar q$. <>= if (hepmc_is_available ()) then call test (hep_events_1, "hep_events_1", & "check HepMC event routines", & u, results) end if <>= public :: hep_events_1 <>= subroutine hep_events_1 (u) use os_interface integer, intent(in) :: u type(model_data_t), target :: model type(flavor_t), dimension(3) :: flv type(color_t), dimension(3) :: col type(helicity_t), dimension(3) :: hel type(quantum_numbers_t), dimension(3) :: qn type(vector4_t), dimension(3) :: p type(interaction_t), target :: int1, int2 type(quantum_numbers_mask_t) :: qn_mask_conn type(evaluator_t), target :: eval type(interaction_t), pointer :: int type(particle_set_t) :: particle_set1, particle_set2 type(hepmc_event_t) :: hepmc_event type(hepmc_iostream_t) :: iostream real(default) :: cross_section, error, weight logical :: ok write (u, "(A)") "* Test output: HEP events" write (u, "(A)") "* Purpose: test HepMC event routines" write (u, "(A)") write (u, "(A)") "* Reading model file" call model%init_sm_test () write (u, "(A)") write (u, "(A)") "* Initializing production process" call int1%basic_init (2, 0, 1, set_relations=.true.) call flv%init ([1, -1, 23], model) call col%init_col_acl ([0, 0, 0], [0, 0, 0]) call hel(3)%init ( 1, 1) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0.25_default, 0._default)) call hel(3)%init ( 1,-1) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0._default, 0.25_default)) call hel(3)%init (-1, 1) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0._default,-0.25_default)) call hel(3)%init (-1,-1) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0.25_default, 0._default)) call hel(3)%init ( 0, 0) call qn%init (flv, col, hel) call int1%add_state (qn, value=(0.5_default, 0._default)) call int1%freeze () p(1) = vector4_moving (45._default, 45._default, 3) p(2) = vector4_moving (45._default,-45._default, 3) p(3) = p(1) + p(2) call int1%set_momenta (p) write (u, "(A)") write (u, "(A)") "* Setup decay process" call int2%basic_init (1, 0, 2, set_relations=.true.) call flv%init ([23, 1, -1], model) call col%init_col_acl ([0, 501, 0], [0, 0, 501]) call hel%init ([1, 1, 1], [1, 1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(1._default, 0._default)) call hel%init ([1, 1, 1], [-1,-1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(0._default, 0.1_default)) call hel%init ([-1,-1,-1], [1, 1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(0._default,-0.1_default)) call hel%init ([-1,-1,-1], [-1,-1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(1._default, 0._default)) call hel%init ([0, 1,-1], [0, 1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(4._default, 0._default)) call hel%init ([0,-1, 1], [0, 1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(2._default, 0._default)) call hel%init ([0, 1,-1], [0,-1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(2._default, 0._default)) call hel%init ([0,-1, 1], [0,-1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(4._default, 0._default)) call flv%init ([23, 2, -2], model) call hel%init ([0, 1,-1], [0, 1,-1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(0.5_default, 0._default)) call hel%init ([0,-1, 1], [0,-1, 1]) call qn%init (flv, col, hel) call int2%add_state (qn, value=(0.5_default, 0._default)) call int2%freeze () p(2) = vector4_moving (45._default, 45._default, 2) p(3) = vector4_moving (45._default,-45._default, 2) call int2%set_momenta (p) call int2%set_source_link (1, int1, 3) call int1%basic_write (u) call int2%basic_write (u) write (u, "(A)") write (u, "(A)") "* Concatenate production and decay" call eval%init_product (int1, int2, qn_mask_conn, & connections_are_resonant=.true.) call eval%receive_momenta () call eval%evaluate () call eval%write (u) write (u, "(A)") write (u, "(A)") "* Factorize as subevent (complete, polarized)" write (u, "(A)") int => eval%interaction_t call particle_set1%init & (ok, int, int, FM_FACTOR_HELICITY, & [0.2_default, 0.2_default], .false., .true.) call particle_set1%write (u) write (u, "(A)") write (u, "(A)") "* Factorize as subevent (in/out only, selected helicity)" write (u, "(A)") int => eval%interaction_t call particle_set2%init & (ok, int, int, FM_SELECT_HELICITY, & [0.9_default, 0.9_default], .false., .false.) call particle_set2%write (u) call particle_set2%final () write (u, "(A)") write (u, "(A)") "* Factorize as subevent (complete, selected helicity)" write (u, "(A)") int => eval%interaction_t call particle_set2%init & (ok, int, int, FM_SELECT_HELICITY, & [0.7_default, 0.7_default], .false., .true.) call particle_set2%write (u) write (u, "(A)") write (u, "(A)") "* Transfer particle_set to HepMC, print, and output to" write (u, "(A)") " hep_events.hepmc.dat" write (u, "(A)") cross_section = 42.0_default error = 17.0_default weight = 1.0_default call hepmc_event_init (hepmc_event, 11, 127) call hepmc_event_from_particle_set (hepmc_event, particle_set2, & cross_section, error, .true.) call hepmc_event_add_weight (hepmc_event, weight, .true.) call hepmc_event_print (hepmc_event) call hepmc_iostream_open_out & (iostream , var_str ("hep_events.hepmc.dat"), 2) call hepmc_iostream_write_event (iostream, hepmc_event) call hepmc_iostream_close (iostream) write (u, "(A)") write (u, "(A)") "* Recover from HepMC file" write (u, "(A)") call particle_set2%final () call hepmc_event_final (hepmc_event) call hepmc_event_init (hepmc_event) call hepmc_iostream_open_in & (iostream , var_str ("hep_events.hepmc.dat"), HEPMC3_MODE_HEPMC3) call hepmc_iostream_read_event (iostream, hepmc_event, ok=ok) call hepmc_iostream_close (iostream) call hepmc_event_to_particle_set (particle_set2, & hepmc_event, model, model, PRT_DEFINITE_HELICITY) call particle_set2%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call particle_set1%final () call particle_set2%final () call eval%final () call int1%final () call int2%final () call hepmc_event_final (hepmc_event) call model%final () write (u, "(A)") write (u, "(A)") "* Test output end: hep_events_1" end subroutine hep_events_1 @ @ %def hep_events_1 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{LHEF Input/Output} The LHEF event record is standardized. It is an ASCII format. We try our best at using it for both input and output. <<[[eio_lhef.f90]]>>= <> module eio_lhef <> <> use xml use event_base use event_handles, only: event_handle_t use eio_data use eio_base <> <> <> interface <> end interface end module eio_lhef @ %def eio_lhef @ <<[[eio_lhef_sub.f90]]>>= <> submodule (eio_lhef) eio_lhef_s use io_units use string_utils use numeric_utils use diagnostics use os_interface use hep_common use hep_events implicit none contains <> end submodule eio_lhef_s @ %def eio_lhef_s @ \subsection{Type} With sufficient confidence that it will always be three characters, we can store the version string with a default value. <>= public :: eio_lhef_t <>= type, extends (eio_t) :: eio_lhef_t logical :: writing = .false. logical :: reading = .false. integer :: unit = 0 type(event_sample_data_t) :: data type(cstream_t) :: cstream character(3) :: version = "1.0" logical :: keep_beams = .false. logical :: keep_remnants = .true. logical :: keep_virtuals = .false. logical :: recover_beams = .true. logical :: unweighted = .true. logical :: write_sqme_ref = .false. logical :: write_sqme_prc = .false. logical :: write_sqme_alt = .false. logical :: use_alphas_from_file = .false. logical :: use_scale_from_file = .false. integer :: n_alt = 0 integer, dimension(:), allocatable :: proc_num_id integer :: i_weight_sqme = 0 type(xml_tag_t) :: tag_lhef, tag_head, tag_init, tag_event type(xml_tag_t), allocatable :: tag_whiz_info type(xml_tag_t), allocatable :: tag_gen_n, tag_gen_v type(xml_tag_t), allocatable :: tag_generator, tag_xsecinfo type(xml_tag_t), allocatable :: tag_sqme_ref, tag_sqme_prc type(xml_tag_t), dimension(:), allocatable :: tag_sqme_alt, tag_wgts_alt type(xml_tag_t), allocatable :: tag_weight, tag_weightinfo, tag_weights contains <> end type eio_lhef_t @ %def eio_lhef_t @ \subsection{Specific Methods} Set parameters that are specifically used with LHEF. <>= procedure :: set_parameters => eio_lhef_set_parameters <>= module subroutine eio_lhef_set_parameters (eio, & keep_beams, keep_remnants, recover_beams, & use_alphas_from_file, use_scale_from_file, & version, extension, write_sqme_ref, write_sqme_prc, write_sqme_alt) class(eio_lhef_t), intent(inout) :: eio logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alphas_from_file logical, intent(in), optional :: use_scale_from_file character(*), intent(in), optional :: version type(string_t), intent(in), optional :: extension logical, intent(in), optional :: write_sqme_ref logical, intent(in), optional :: write_sqme_prc logical, intent(in), optional :: write_sqme_alt end subroutine eio_lhef_set_parameters <>= module subroutine eio_lhef_set_parameters (eio, & keep_beams, keep_remnants, recover_beams, & use_alphas_from_file, use_scale_from_file, & version, extension, write_sqme_ref, write_sqme_prc, write_sqme_alt) class(eio_lhef_t), intent(inout) :: eio logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alphas_from_file logical, intent(in), optional :: use_scale_from_file character(*), intent(in), optional :: version type(string_t), intent(in), optional :: extension logical, intent(in), optional :: write_sqme_ref logical, intent(in), optional :: write_sqme_prc logical, intent(in), optional :: write_sqme_alt if (present (keep_beams)) eio%keep_beams = keep_beams if (present (keep_remnants)) eio%keep_remnants = keep_remnants if (present (recover_beams)) eio%recover_beams = recover_beams if (present (use_alphas_from_file)) & eio%use_alphas_from_file = use_alphas_from_file if (present (use_scale_from_file)) & eio%use_scale_from_file = use_scale_from_file if (present (version)) then select case (version) case ("1.0", "2.0", "3.0") eio%version = version case default call msg_error ("LHEF version " // version & // " is not supported. Inserting 2.0") eio%version = "2.0" end select end if if (present (extension)) then eio%extension = extension else eio%extension = "lhe" end if if (present (write_sqme_ref)) eio%write_sqme_ref = write_sqme_ref if (present (write_sqme_prc)) eio%write_sqme_prc = write_sqme_prc if (present (write_sqme_alt)) eio%write_sqme_alt = write_sqme_alt end subroutine eio_lhef_set_parameters @ %def eio_lhef_set_parameters @ \subsection{Common Methods} Output. This is not the actual event format, but a readable account of the current object status. <>= procedure :: write => eio_lhef_write <>= module subroutine eio_lhef_write (object, unit) class(eio_lhef_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine eio_lhef_write <>= module subroutine eio_lhef_write (object, unit) class(eio_lhef_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "LHEF event stream:" if (object%writing) then write (u, "(3x,A,A)") "Writing to file = ", char (object%filename) else if (object%reading) then write (u, "(3x,A,A)") "Reading from file = ", char (object%filename) else write (u, "(3x,A)") "[closed]" end if write (u, "(3x,A,L1)") "Keep beams = ", object%keep_beams write (u, "(3x,A,L1)") "Keep remnants = ", object%keep_remnants write (u, "(3x,A,L1)") "Recover beams = ", object%recover_beams write (u, "(3x,A,L1)") "Alpha_s from file = ", & object%use_alphas_from_file write (u, "(3x,A,L1)") "Scale from file = ", & object%use_scale_from_file write (u, "(3x,A,A)") "Version = ", object%version write (u, "(3x,A,A,A)") "File extension = '", & char (object%extension), "'" if (allocated (object%proc_num_id)) then write (u, "(3x,A)") "Numerical process IDs:" do i = 1, size (object%proc_num_id) write (u, "(5x,I0,': ',I0)") i, object%proc_num_id(i) end do end if end subroutine eio_lhef_write @ %def eio_lhef_write @ Finalizer: close any open file. <>= procedure :: final => eio_lhef_final <>= module subroutine eio_lhef_final (object) class(eio_lhef_t), intent(inout) :: object end subroutine eio_lhef_final <>= module subroutine eio_lhef_final (object) class(eio_lhef_t), intent(inout) :: object if (allocated (object%proc_num_id)) deallocate (object%proc_num_id) if (object%writing) then write (msg_buffer, "(A,A,A)") "Events: closing LHEF file '", & char (object%filename), "'" call msg_message () call object%write_footer () close (object%unit) object%writing = .false. else if (object%reading) then write (msg_buffer, "(A,A,A)") "Events: closing LHEF file '", & char (object%filename), "'" call msg_message () call object%cstream%final () close (object%unit) object%reading = .false. end if end subroutine eio_lhef_final @ %def eio_lhef_final @ Common initialization for input and output. <>= procedure :: common_init => eio_lhef_common_init <>= module subroutine eio_lhef_common_init (eio, sample, data, extension) class(eio_lhef_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data end subroutine eio_lhef_common_init <>= module subroutine eio_lhef_common_init (eio, sample, data, extension) class(eio_lhef_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data if (.not. present (data)) & call msg_bug ("LHEF initialization: missing data") eio%data = data eio%unweighted = data%unweighted if (eio%unweighted) then select case (data%norm_mode) case (NORM_UNIT) case default; call msg_fatal & ("LHEF: normalization for unweighted events must be '1'") end select else select case (data%norm_mode) case (NORM_SIGMA) case default; call msg_fatal & ("LHEF: normalization for weighted events must be 'sigma'") end select end if eio%n_alt = data%n_alt eio%sample = sample if (present (extension)) then eio%extension = extension end if call eio%set_filename () eio%unit = free_unit () call eio%init_tags (data) allocate (eio%proc_num_id (data%n_proc), source = data%proc_num_id) end subroutine eio_lhef_common_init @ %def eio_lhef_common_init @ Initialize the tag objects. Some tags depend on the LHEF version. In particular, the tags that in LHEF 2.0 identify individual weights by name in each event block, in LHEF 3.0 are replaced by info tags in the init block and a single \texttt{weights} tag in the event block. The name attributes of those tags are specific for \whizard. <>= procedure :: init_tags => eio_lhef_init_tags <>= module subroutine eio_lhef_init_tags (eio, data) class(eio_lhef_t), intent(inout) :: eio type(event_sample_data_t), intent(in) :: data end subroutine eio_lhef_init_tags <>= module subroutine eio_lhef_init_tags (eio, data) class(eio_lhef_t), intent(inout) :: eio type(event_sample_data_t), intent(in) :: data real(default), parameter :: pb_per_fb = 1.e-3_default real(default) :: xsec_width integer :: i call eio%tag_lhef%init ( & var_str ("LesHouchesEvents"), & [xml_attribute (var_str ("version"), var_str (eio%version))], & .true.) call eio%tag_head%init ( & var_str ("header"), & .true.) call eio%tag_init%init ( & var_str ("init"), & .true.) call eio%tag_event%init (var_str ("event"), & .true.) allocate (eio%tag_whiz_info) call eio%tag_whiz_info%init (var_str ("WhizardInfo"), .true.) select case (eio%version) case ("1.0") allocate (eio%tag_gen_n) call eio%tag_gen_n%init ( & var_str ("generator_name"), & .true.) allocate (eio%tag_gen_v) call eio%tag_gen_v%init ( & var_str ("generator_version"), & .true.) end select select case (eio%version) case ("2.0", "3.0") allocate (eio%tag_generator) call eio%tag_generator%init ( & var_str ("generator"), & [xml_attribute (var_str ("version"), var_str ("<>"))], & .true.) allocate (eio%tag_xsecinfo) if (data%n_beam == 2) then xsec_width = data%total_cross_section * pb_per_fb else xsec_width = data%total_cross_section end if call eio%tag_xsecinfo%init ( & var_str ("xsecinfo"), & [xml_attribute (var_str ("neve"), str (data%n_evt)), & xml_attribute (var_str ("totxsec"), & str (xsec_width))]) end select select case (eio%version) case ("2.0") allocate (eio%tag_weight) call eio%tag_weight%init (var_str ("weight"), & [xml_attribute (var_str ("name"))]) if (eio%write_sqme_ref) then allocate (eio%tag_sqme_ref) call eio%tag_sqme_ref%init (var_str ("weight"), & [xml_attribute (var_str ("name"), var_str ("sqme_ref"))], & .true.) end if if (eio%write_sqme_prc) then allocate (eio%tag_sqme_prc) call eio%tag_sqme_prc%init (var_str ("weight"), & [xml_attribute (var_str ("name"), var_str ("sqme_prc"))], & .true.) end if if (eio%n_alt > 0) then if (eio%write_sqme_alt) then allocate (eio%tag_sqme_alt (1)) call eio%tag_sqme_alt(1)%init (var_str ("weight"), & [xml_attribute (var_str ("name"), var_str ("sqme_alt"))], & .true.) end if allocate (eio%tag_wgts_alt (1)) call eio%tag_wgts_alt(1)%init (var_str ("weight"), & [xml_attribute (var_str ("name"), var_str ("wgts_alt"))], & .true.) end if case ("3.0") if (eio%write_sqme_ref) then allocate (eio%tag_sqme_ref) call eio%tag_sqme_ref%init (var_str ("weightinfo"), & [xml_attribute (var_str ("name"), var_str ("sqme_ref"))]) end if if (eio%write_sqme_prc) then allocate (eio%tag_sqme_prc) call eio%tag_sqme_prc%init (var_str ("weightinfo"), & [xml_attribute (var_str ("name"), var_str ("sqme_prc"))]) end if if (eio%n_alt > 0) then if (eio%write_sqme_alt) then allocate (eio%tag_sqme_alt (eio%n_alt)) do i = 1, eio%n_alt call eio%tag_sqme_alt(i)%init (var_str ("weightinfo"), & [xml_attribute (var_str ("name"), & var_str ("sqme_alt") // str (i))]) end do end if allocate (eio%tag_wgts_alt (eio%n_alt)) do i = 1, eio%n_alt call eio%tag_wgts_alt(i)%init (var_str ("weightinfo"), & [xml_attribute (var_str ("name"), & var_str ("wgts_alt") // str (i))]) end do end if allocate (eio%tag_weightinfo) call eio%tag_weightinfo%init (var_str ("weightinfo"), & [xml_attribute (var_str ("name"))]) allocate (eio%tag_weights) call eio%tag_weights%init (var_str ("weights"), .true.) end select end subroutine eio_lhef_init_tags @ %def eio_lhef_init_tags @ Initialize event writing. <>= procedure :: init_out => eio_lhef_init_out <>= module subroutine eio_lhef_init_out (eio, sample, data, success, extension) class(eio_lhef_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success end subroutine eio_lhef_init_out <>= module subroutine eio_lhef_init_out (eio, sample, data, success, extension) class(eio_lhef_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success integer :: u, i logical :: is_width is_width = data%n_beam == 1 call eio%set_splitting (data) call eio%common_init (sample, data, extension) write (msg_buffer, "(A,A,A)") "Events: writing to LHEF file '", & char (eio%filename), "'" call msg_message () eio%writing = .true. u = eio%unit open (u, file = char (eio%filename), & action = "write", status = "replace") call eio%write_header (is_width) call heprup_init & (data%pdg_beam, & data%energy_beam, & n_processes = data%n_proc, & unweighted = data%unweighted, & negative_weights = data%negative_weights) do i = 1, data%n_proc call heprup_set_process_parameters (i = i, & process_id = data%proc_num_id(i), & cross_section = data%cross_section(i), & error = data%error(i), & is_width = is_width) end do call eio%tag_init%write (u); write (u, *) call heprup_write_lhef (u) select case (eio%version) case ("2.0"); call eio%write_init_20 (data) case ("3.0"); call eio%write_init_30 (data) end select call eio%tag_init%close (u); write (u, *) if (present (success)) success = .true. end subroutine eio_lhef_init_out @ %def eio_lhef_init_out @ Initialize event reading. First read the LHEF tag and version, then read the header and skip over its contents, then read the init block. (We require the opening and closing tags of the init block to be placed on separate lines without extra stuff.) For input, we do not (yet?) support split event files. <>= procedure :: init_in => eio_lhef_init_in <>= module subroutine eio_lhef_init_in (eio, sample, data, success, extension) class(eio_lhef_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success end subroutine eio_lhef_init_in <>= module subroutine eio_lhef_init_in (eio, sample, data, success, extension) class(eio_lhef_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success logical :: exist, ok, closing type(event_sample_data_t) :: data_file type(string_t) :: string integer :: u eio%split = .false. call eio%common_init (sample, data, extension) write (msg_buffer, "(A,A,A)") "Events: reading from LHEF file '", & char (eio%filename), "'" call msg_message () inquire (file = char (eio%filename), exist = exist) if (.not. exist) call msg_fatal ("Events: LHEF file not found.") eio%reading = .true. u = eio%unit open (u, file = char (eio%filename), & action = "read", status = "old") call eio%cstream%init (u) call eio%read_header () call eio%tag_init%read (eio%cstream, ok) if (.not. ok) call err_init select case (eio%version) case ("1.0"); call eio%read_init_10 (data_file) call eio%tag_init%read_content (eio%cstream, string, closing) if (string /= "" .or. .not. closing) call err_init case ("2.0"); call eio%read_init_20 (data_file) case ("3.0"); call eio%read_init_30 (data_file) end select call eio%merge_data (data, data_file) if (present (success)) success = .true. contains subroutine err_init call msg_fatal ("LHEF: syntax error in init tag") end subroutine err_init end subroutine eio_lhef_init_in @ %def eio_lhef_init_in @ Merge event sample data: we can check the data in the file against our assumptions and set or reset parameters. <>= procedure :: merge_data => eio_merge_data <>= module subroutine eio_merge_data (eio, data, data_file) class(eio_lhef_t), intent(inout) :: eio type(event_sample_data_t), intent(inout) :: data type(event_sample_data_t), intent(in) :: data_file end subroutine eio_merge_data <>= module subroutine eio_merge_data (eio, data, data_file) class(eio_lhef_t), intent(inout) :: eio type(event_sample_data_t), intent(inout) :: data type(event_sample_data_t), intent(in) :: data_file real, parameter :: tolerance = 1000 * epsilon (1._default) if (data%unweighted .neqv. data_file%unweighted) call err_weights if (data%negative_weights .neqv. data_file%negative_weights) & call err_weights if (data%norm_mode /= data_file%norm_mode) call err_norm if (data%n_beam /= data_file%n_beam) call err_beams if (any (data%pdg_beam /= data_file%pdg_beam)) call err_beams if (any (abs ((data%energy_beam - data_file%energy_beam)) & > (data%energy_beam + data_file%energy_beam) * tolerance)) & call err_beams if (data%n_proc /= data_file%n_proc) call err_proc if (any (data%proc_num_id /= data_file%proc_num_id)) call err_proc where (data%cross_section == 0) data%cross_section = data_file%cross_section data%error = data_file%error end where data%total_cross_section = sum (data%cross_section) if (data_file%n_evt > 0) then if (data%n_evt > 0 .and. data_file%n_evt /= data%n_evt) call err_n_evt data%n_evt = data_file%n_evt end if contains subroutine err_weights call msg_fatal ("LHEF: mismatch in event weight properties") end subroutine err_weights subroutine err_norm call msg_fatal ("LHEF: mismatch in event normalization") end subroutine err_norm subroutine err_beams call msg_fatal ("LHEF: mismatch in beam properties") end subroutine err_beams subroutine err_proc call msg_fatal ("LHEF: mismatch in process definitions") end subroutine err_proc subroutine err_n_evt call msg_error ("LHEF: mismatch in specified number of events (ignored)") end subroutine err_n_evt end subroutine eio_merge_data @ %def eio_merge_data @ Switch from input to output: reopen the file for reading. <>= procedure :: switch_inout => eio_lhef_switch_inout <>= module subroutine eio_lhef_switch_inout (eio, success) class(eio_lhef_t), intent(inout) :: eio logical, intent(out), optional :: success end subroutine eio_lhef_switch_inout <>= module subroutine eio_lhef_switch_inout (eio, success) class(eio_lhef_t), intent(inout) :: eio logical, intent(out), optional :: success call msg_bug ("LHEF: in-out switch not supported") if (present (success)) success = .false. end subroutine eio_lhef_switch_inout @ %def eio_lhef_switch_inout @ Split event file: increment the counter, close the current file, open a new one. If the file needs a header, repeat it for the new file. (We assume that the common block contents are still intact.) <>= procedure :: split_out => eio_lhef_split_out <>= module subroutine eio_lhef_split_out (eio) class(eio_lhef_t), intent(inout) :: eio end subroutine eio_lhef_split_out <>= module subroutine eio_lhef_split_out (eio) class(eio_lhef_t), intent(inout) :: eio integer :: u if (eio%split) then eio%split_index = eio%split_index + 1 call eio%set_filename () write (msg_buffer, "(A,A,A)") "Events: writing to LHEF file '", & char (eio%filename), "'" call msg_message () call eio%write_footer () u = eio%unit close (u) open (u, file = char (eio%filename), & action = "write", status = "replace") call eio%write_header () call eio%tag_init%write (u); write (u, *) call heprup_write_lhef (u) select case (eio%version) case ("2.0"); call eio%write_init_20 (eio%data) case ("3.0"); call eio%write_init_30 (eio%data) end select call eio%tag_init%close (u); write (u, *) end if end subroutine eio_lhef_split_out @ %def eio_lhef_split_out @ Output an event. Write first the event indices, then weight and squared matrix element, then the particle set. <>= procedure :: output => eio_lhef_output <>= module subroutine eio_lhef_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_lhef_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_lhef_output <>= module subroutine eio_lhef_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_lhef_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle integer :: u u = given_output_unit (eio%unit); if (u < 0) return if (present (passed)) then if (.not. passed) return end if if (eio%writing) then call hepeup_from_event (event, & process_index = eio%proc_num_id (i_prc), & keep_beams = eio%keep_beams, & keep_remnants = eio%keep_remnants) write (u, '(A)') "" call hepeup_write_lhef (eio%unit) select case (eio%version) case ("2.0"); call eio%write_event_20 (event) case ("3.0"); call eio%write_event_30 (event) end select write (u, '(A)') "" else call eio%write () call msg_fatal ("LHEF file is not open for writing") end if end subroutine eio_lhef_output @ %def eio_lhef_output @ Input an event. Upon input of [[i_prc]], we can just read in the whole HEPEUP common block. These data are known to come first. The [[i_prc]] value can be deduced from the IDPRUP value by a table lookup. Reading the common block bypasses the [[cstream]] which accesses the input unit. This is consistent with the LHEF specification. After the common-block data have been swallowed, we can resume reading from stream. We don't catch actual I/O errors. However, we return a negative value in [[iostat]] if we reached the terminating [[]] tag. <>= procedure :: input_i_prc => eio_lhef_input_i_prc <>= module subroutine eio_lhef_input_i_prc (eio, i_prc, iostat) class(eio_lhef_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat end subroutine eio_lhef_input_i_prc <>= module subroutine eio_lhef_input_i_prc (eio, i_prc, iostat) class(eio_lhef_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat integer :: i, proc_num_id type(string_t) :: s logical :: ok iostat = 0 call eio%tag_lhef%read_content (eio%cstream, s, ok) if (ok) then if (s == "") then iostat = -1 else call err_close end if return else call eio%cstream%revert_record (s) end if call eio%tag_event%read (eio%cstream, ok) if (.not. ok) then call err_evt1 return end if call hepeup_read_lhef (eio%unit) call hepeup_get_event_parameters (proc_id = proc_num_id) i_prc = 0 FIND_I_PRC: do i = 1, size (eio%proc_num_id) if (eio%proc_num_id(i) == proc_num_id) then i_prc = i exit FIND_I_PRC end if end do FIND_I_PRC if (i_prc == 0) call err_index contains subroutine err_close call msg_error ("LHEF: reading events: syntax error in closing tag") iostat = 1 end subroutine subroutine err_evt1 call msg_error ("LHEF: reading events: invalid event tag, & &aborting read") iostat = 2 end subroutine err_evt1 subroutine err_index call msg_error ("LHEF: reading events: undefined process ID " & // char (str (proc_num_id)) // ", aborting read") iostat = 3 end subroutine err_index end subroutine eio_lhef_input_i_prc @ %def eio_lhef_input_i_prc @ Since we have already read the event information from file, this input routine can transfer the common-block contents to the event record. Also, we read any further information in the event record. Since LHEF does not give this information, we must assume that the MCI group, term, and channel can all be safely set to 1. This works if there is only one MCI group and term. The channel doesn't matter for the matrix element. The event index is incremented, as if the event was generated. The LHEF format does not support event indices. <>= procedure :: input_event => eio_lhef_input_event <>= module subroutine eio_lhef_input_event (eio, event, iostat, event_handle) class(eio_lhef_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_lhef_input_event <>= module subroutine eio_lhef_input_event (eio, event, iostat, event_handle) class(eio_lhef_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle type(string_t) :: s logical :: closing iostat = 0 call event%reset_contents () call event%select (1, 1, 1) call hepeup_to_event (event, eio%fallback_model, & recover_beams = eio%recover_beams, & use_alpha_s = eio%use_alphas_from_file, & use_scale = eio%use_scale_from_file) select case (eio%version) case ("1.0") call eio%tag_event%read_content (eio%cstream, s, closing = closing) if (s /= "" .or. .not. closing) call err_evt2 case ("2.0"); call eio%read_event_20 (event) case ("3.0"); call eio%read_event_30 (event) end select call event%increment_index () contains subroutine err_evt2 call msg_error ("LHEF: reading events: syntax error in event record, & &aborting read") iostat = 2 end subroutine err_evt2 end subroutine eio_lhef_input_event @ %def eio_lhef_input_event @ <>= procedure :: skip => eio_lhef_skip <>= module subroutine eio_lhef_skip (eio, iostat) class(eio_lhef_t), intent(inout) :: eio integer, intent(out) :: iostat end subroutine eio_lhef_skip <>= module subroutine eio_lhef_skip (eio, iostat) class(eio_lhef_t), intent(inout) :: eio integer, intent(out) :: iostat if (eio%reading) then read (eio%unit, iostat = iostat) else call eio%write () call msg_fatal ("Raw event file is not open for reading") end if end subroutine eio_lhef_skip @ %def eio_lhef_skip @ \subsection{Les Houches Event File: header/footer} These two routines write the header and footer for the Les Houches Event File format (LHEF). The current version writes no information except for the generator name and version (v.1.0 only). <>= procedure :: write_header => eio_lhef_write_header procedure :: write_footer => eio_lhef_write_footer <>= module subroutine eio_lhef_write_header (eio, is_width) class(eio_lhef_t), intent(in) :: eio logical, intent(in), optional :: is_width end subroutine eio_lhef_write_header module subroutine eio_lhef_write_footer (eio) class(eio_lhef_t), intent(in) :: eio end subroutine eio_lhef_write_footer <>= module subroutine eio_lhef_write_header (eio, is_width) class(eio_lhef_t), intent(in) :: eio logical, intent(in), optional :: is_width logical :: is_w integer :: u u = given_output_unit (eio%unit); if (u < 0) return is_w = .false. if (present (is_width)) is_w = is_width call eio%tag_lhef%write (u); write (u, *) call eio%tag_head%write (u); write (u, *) select case (eio%version) case ("1.0") write (u, "(2x)", advance = "no") call eio%tag_gen_n%write (var_str ("WHIZARD"), u) write (u, *) write (u, "(2x)", advance = "no") call eio%tag_gen_v%write (var_str ("<>"), u) write (u, *) end select if (is_w) then call eio%tag_whiz_info%write (u); write (u, *) write (u, "(A)") & "# Special LHE event setup for decays, units in GeV" call eio%tag_whiz_info%close (u); write (u, *) end if call eio%tag_head%close (u); write (u, *) end subroutine eio_lhef_write_header module subroutine eio_lhef_write_footer (eio) class(eio_lhef_t), intent(in) :: eio integer :: u u = given_output_unit (eio%unit); if (u < 0) return call eio%tag_lhef%close (u) end subroutine eio_lhef_write_footer @ %def eio_lhef_write_header eio_lhef_write_footer @ Reading the header just means finding the tags and ignoring any contents. When done, we should stand just after the header tag. <>= procedure :: read_header => eio_lhef_read_header <>= module subroutine eio_lhef_read_header (eio) class(eio_lhef_t), intent(inout) :: eio end subroutine eio_lhef_read_header <>= module subroutine eio_lhef_read_header (eio) class(eio_lhef_t), intent(inout) :: eio logical :: success, closing type(string_t) :: content call eio%tag_lhef%read (eio%cstream, success) if (.not. success .or. .not. eio%tag_lhef%has_content) call err_lhef if (eio%tag_lhef%get_attribute (1) /= eio%version) call err_version call eio%tag_head%read (eio%cstream, success) if (.not. success) call err_header if (eio%tag_head%has_content) then SKIP_HEADER_CONTENT: do call eio%tag_head%read_content (eio%cstream, content, closing) if (closing) exit SKIP_HEADER_CONTENT end do SKIP_HEADER_CONTENT end if contains subroutine err_lhef call msg_fatal ("LHEF: LesHouchesEvents tag absent or corrupted") end subroutine err_lhef subroutine err_header call msg_fatal ("LHEF: header tag absent or corrupted") end subroutine err_header subroutine err_version call msg_error ("LHEF: version mismatch: expected " & // eio%version // ", found " & // char (eio%tag_lhef%get_attribute (1))) end subroutine err_version end subroutine eio_lhef_read_header @ %def eio_lhef_read_header @ \subsection{Version-Specific Code: 1.0} In version 1.0, the init tag contains just HEPRUP data. While a [[cstream]] is connected to the input unit, we bypass it temporarily for the purpose of reading the HEPRUP contents. This is consistent with the LHEF standard. This routine does not read the closing tag of the init block. <>= procedure :: read_init_10 => eio_lhef_read_init_10 <>= module subroutine eio_lhef_read_init_10 (eio, data) class(eio_lhef_t), intent(in) :: eio type(event_sample_data_t), intent(out) :: data end subroutine eio_lhef_read_init_10 <>= module subroutine eio_lhef_read_init_10 (eio, data) class(eio_lhef_t), intent(in) :: eio type(event_sample_data_t), intent(out) :: data integer :: n_proc, i logical :: is_width call heprup_read_lhef (eio%unit) call heprup_get_run_parameters (n_processes = n_proc) call data%init (n_proc) if (IDBMUP(2) == 0) then data%n_beam = 1 is_width = .true. else data%n_beam = 2 is_width = .false. end if call heprup_get_run_parameters ( & unweighted = data%unweighted, & negative_weights = data%negative_weights, & beam_pdg = data%pdg_beam, & beam_energy = data%energy_beam) if (data%unweighted) then data%norm_mode = NORM_UNIT else data%norm_mode = NORM_SIGMA end if do i = 1, n_proc call heprup_get_process_parameters (i, & process_id = data%proc_num_id(i), & cross_section = data%cross_section(i), & error = data%error(i), & is_width = is_width) end do end subroutine eio_lhef_read_init_10 @ %def eio_lhef_read_init_10 @ \subsection{Version-Specific Code: 2.0} This is the init information for the 2.0 format, after the HEPRUP data. We have the following tags: \begin{itemize} \item \texttt{generator} Generator name and version. \item \texttt{xsecinfo} Cross section and weights data. We have the total cross section and number of events (assuming that the event file is intact), but information on minimum and maximum weights is not available before the file is complete. We just write the mandatory tags. (Note that the default values of the other tags describe a uniform unit weight, but we can determine most values only after the sample is complete.) \item \texttt{cutsinfo} This optional tag is too specific to represent the possibilities of WHIZARD, so we skip it. \item \texttt{procinfo} This optional tag is useful for giving details of NLO calculations. Skipped. \item \texttt{mergetype} Optional, also not applicable. \end{itemize} <>= procedure :: write_init_20 => eio_lhef_write_init_20 <>= module subroutine eio_lhef_write_init_20 (eio, data) class(eio_lhef_t), intent(in) :: eio type(event_sample_data_t), intent(in) :: data end subroutine eio_lhef_write_init_20 <>= module subroutine eio_lhef_write_init_20 (eio, data) class(eio_lhef_t), intent(in) :: eio type(event_sample_data_t), intent(in) :: data integer :: u u = eio%unit call eio%tag_generator%write (u) write (u, "(A)", advance="no") "WHIZARD" call eio%tag_generator%close (u); write (u, *) call eio%tag_xsecinfo%write (u); write (u, *) end subroutine eio_lhef_write_init_20 @ %def eio_lhef_write_init_20 @ When reading the init block, we first call the 1.0 routine that fills HEPRUP. Then we consider the possible tags. Only the \texttt{generator} and \texttt{xsecinfo} tags are of interest. We skip everything else except for the closing tag. <>= procedure :: read_init_20 => eio_lhef_read_init_20 <>= module subroutine eio_lhef_read_init_20 (eio, data) class(eio_lhef_t), intent(inout) :: eio type(event_sample_data_t), intent(out) :: data end subroutine eio_lhef_read_init_20 <>= module subroutine eio_lhef_read_init_20 (eio, data) class(eio_lhef_t), intent(inout) :: eio type(event_sample_data_t), intent(out) :: data real(default), parameter :: pb_per_fb = 1.e-3_default type(string_t) :: content logical :: found, closing call eio_lhef_read_init_10 (eio, data) SCAN_INIT_TAGS: do call eio%tag_generator%read (eio%cstream, found) if (found) then if (.not. eio%tag_generator%has_content) call err_generator call eio%tag_generator%read_content (eio%cstream, content, closing) call msg_message ("LHEF: Event file has been generated by " & // char (content) // " " & // char (eio%tag_generator%get_attribute (1))) cycle SCAN_INIT_TAGS end if call eio%tag_xsecinfo%read (eio%cstream, found) if (found) then if (eio%tag_xsecinfo%has_content) call err_xsecinfo cycle SCAN_INIT_TAGS end if call eio%tag_init%read_content (eio%cstream, content, closing) if (closing) then if (content /= "") call err_init exit SCAN_INIT_TAGS end if end do SCAN_INIT_TAGS data%n_evt = & read_ival (eio%tag_xsecinfo%get_attribute (1)) if (data%n_beam == 1) then data%total_cross_section = & read_rval (eio%tag_xsecinfo%get_attribute (2)) else data%total_cross_section = & read_rval (eio%tag_xsecinfo%get_attribute (2)) / pb_per_fb end if contains subroutine err_generator call msg_fatal ("LHEF: invalid generator tag") end subroutine err_generator subroutine err_xsecinfo call msg_fatal ("LHEF: invalid xsecinfo tag") end subroutine err_xsecinfo subroutine err_init call msg_fatal ("LHEF: syntax error after init tag") end subroutine err_init end subroutine eio_lhef_read_init_20 @ %def eio_lhef_read_init_20 @ This is additional event-specific information for the 2.0 format, after the HEPEUP data. We can specify weights, starting from the master weight and adding alternative weights. The alternative weights are collected in a common tag. <>= procedure :: write_event_20 => eio_lhef_write_event_20 <>= module subroutine eio_lhef_write_event_20 (eio, event) class(eio_lhef_t), intent(in) :: eio class(generic_event_t), intent(in) :: event end subroutine eio_lhef_write_event_20 <>= module subroutine eio_lhef_write_event_20 (eio, event) class(eio_lhef_t), intent(in) :: eio class(generic_event_t), intent(in) :: event type(string_t) :: s integer :: i, u u = eio%unit if (eio%write_sqme_ref) then s = str (event%get_sqme_ref ()) call eio%tag_sqme_ref%write (s, u); write (u, *) end if if (eio%write_sqme_prc) then s = str (event%get_sqme_prc ()) call eio%tag_sqme_prc%write (s, u); write (u, *) end if if (eio%n_alt > 0) then if (eio%write_sqme_alt) then s = str (event%get_sqme_alt(1)) do i = 2, eio%n_alt s = s // " " // str (event%get_sqme_alt(i)); write (u, *) end do call eio%tag_sqme_alt(1)%write (s, u) end if s = str (event%get_weight_alt(1)) do i = 2, eio%n_alt s = s // " " // str (event%get_weight_alt(i)); write (u, *) end do call eio%tag_wgts_alt(1)%write (s, u) end if end subroutine eio_lhef_write_event_20 @ %def eio_lhef_write_event_20 @ Read extra event data. If there is a weight entry labeled [[sqme_prc]], we take this as the squared matrix-element value (the new \emph{reference} value [[sqme_ref]]). Other tags, including tags written by the above writer, are skipped. <>= procedure :: read_event_20 => eio_lhef_read_event_20 <>= module subroutine eio_lhef_read_event_20 (eio, event) class(eio_lhef_t), intent(inout) :: eio class(generic_event_t), intent(inout) :: event end subroutine eio_lhef_read_event_20 <>= module subroutine eio_lhef_read_event_20 (eio, event) class(eio_lhef_t), intent(inout) :: eio class(generic_event_t), intent(inout) :: event type(string_t) :: content logical :: found, closing SCAN_EVENT_TAGS: do call eio%tag_weight%read (eio%cstream, found) if (found) then if (.not. eio%tag_weight%has_content) call err_weight call eio%tag_weight%read_content (eio%cstream, content, closing) if (.not. closing) call err_weight if (eio%tag_weight%get_attribute (1) == "sqme_prc") then call event%set_sqme_ref (read_rval (content)) end if cycle SCAN_EVENT_TAGS end if call eio%tag_event%read_content (eio%cstream, content, closing) if (closing) then if (content /= "") call err_event exit SCAN_EVENT_TAGS end if end do SCAN_EVENT_TAGS contains subroutine err_weight call msg_fatal ("LHEF: invalid weight tag in event record") end subroutine err_weight subroutine err_event call msg_fatal ("LHEF: syntax error after event tag") end subroutine err_event end subroutine eio_lhef_read_event_20 @ %def eio_lhef_read_event_20 @ \subsection{Version-Specific Code: 3.0} This is the init information for the 3.0 format, after the HEPRUP data. We have the following tags: \begin{itemize} \item \texttt{generator} Generator name and version. \item \texttt{xsecinfo} Cross section and weights data. We have the total cross section and number of events (assuming that the event file is intact), but information on minimum and maximum weights is not available before the file is complete. We just write the mandatory tags. (Note that the default values of the other tags describe a uniform unit weight, but we can determine most values only after the sample is complete.) \item \texttt{cutsinfo} This optional tag is too specific to represent the possibilities of WHIZARD, so we skip it. \item \texttt{procinfo} This optional tag is useful for giving details of NLO calculations. Skipped. \item \texttt{weightinfo} Determine the meaning of optional weights, whose values are given in the event record. \end{itemize} <>= procedure :: write_init_30 => eio_lhef_write_init_30 <>= module subroutine eio_lhef_write_init_30 (eio, data) class(eio_lhef_t), intent(in) :: eio type(event_sample_data_t), intent(in) :: data end subroutine eio_lhef_write_init_30 <>= module subroutine eio_lhef_write_init_30 (eio, data) class(eio_lhef_t), intent(in) :: eio type(event_sample_data_t), intent(in) :: data integer :: u, i u = given_output_unit (eio%unit) call eio%tag_generator%write (u) write (u, "(A)", advance="no") "WHIZARD" call eio%tag_generator%close (u); write (u, *) call eio%tag_xsecinfo%write (u); write (u, *) if (eio%write_sqme_ref) then call eio%tag_sqme_ref%write (u); write (u, *) end if if (eio%write_sqme_prc) then call eio%tag_sqme_prc%write (u); write (u, *) end if if (eio%write_sqme_alt) then do i = 1, eio%n_alt call eio%tag_sqme_alt(i)%write (u); write (u, *) end do end if do i = 1, eio%n_alt call eio%tag_wgts_alt(i)%write (u); write (u, *) end do end subroutine eio_lhef_write_init_30 @ %def eio_lhef_write_init_30 @ When reading the init block, we first call the 1.0 routine that fills HEPRUP. Then we consider the possible tags. Only the \texttt{generator} and \texttt{xsecinfo} tags are of interest. We skip everything else except for the closing tag. <>= procedure :: read_init_30 => eio_lhef_read_init_30 <>= module subroutine eio_lhef_read_init_30 (eio, data) class(eio_lhef_t), intent(inout) :: eio type(event_sample_data_t), intent(out) :: data end subroutine eio_lhef_read_init_30 <>= module subroutine eio_lhef_read_init_30 (eio, data) class(eio_lhef_t), intent(inout) :: eio type(event_sample_data_t), intent(out) :: data real(default), parameter :: pb_per_fb = 1.e-3_default type(string_t) :: content logical :: found, closing integer :: n_weightinfo call eio_lhef_read_init_10 (eio, data) n_weightinfo = 0 eio%i_weight_sqme = 0 SCAN_INIT_TAGS: do call eio%tag_generator%read (eio%cstream, found) if (found) then if (.not. eio%tag_generator%has_content) call err_generator call eio%tag_generator%read_content (eio%cstream, content, closing) call msg_message ("LHEF: Event file has been generated by " & // char (content) // " " & // char (eio%tag_generator%get_attribute (1))) cycle SCAN_INIT_TAGS end if call eio%tag_xsecinfo%read (eio%cstream, found) if (found) then if (eio%tag_xsecinfo%has_content) call err_xsecinfo cycle SCAN_INIT_TAGS end if call eio%tag_weightinfo%read (eio%cstream, found) if (found) then if (eio%tag_weightinfo%has_content) call err_xsecinfo n_weightinfo = n_weightinfo + 1 if (eio%tag_weightinfo%get_attribute (1) == "sqme_prc") then eio%i_weight_sqme = n_weightinfo end if cycle SCAN_INIT_TAGS end if call eio%tag_init%read_content (eio%cstream, content, closing) if (closing) then if (content /= "") call err_init exit SCAN_INIT_TAGS end if end do SCAN_INIT_TAGS data%n_evt = & read_ival (eio%tag_xsecinfo%get_attribute (1)) if (data%n_beam == 1) then data%total_cross_section = & read_rval (eio%tag_xsecinfo%get_attribute (2)) else data%total_cross_section = & read_rval (eio%tag_xsecinfo%get_attribute (2)) / pb_per_fb end if contains subroutine err_generator call msg_fatal ("LHEF: invalid generator tag") end subroutine err_generator subroutine err_xsecinfo call msg_fatal ("LHEF: invalid xsecinfo tag") end subroutine err_xsecinfo subroutine err_init call msg_fatal ("LHEF: syntax error after init tag") end subroutine err_init end subroutine eio_lhef_read_init_30 @ %def eio_lhef_read_init_30 @ This is additional event-specific information for the 3.0 format, after the HEPEUP data. We can specify weights, starting from the master weight and adding alternative weights. The weight tags are already allocated, so we just have to transfer the weight values to strings, assemble them and write them to file. All weights are collected in a single tag. Note: If efficiency turns out to be an issue, we may revert to traditional character buffer writing. However, we need to know the maximum length. <>= procedure :: write_event_30 => eio_lhef_write_event_30 <>= module subroutine eio_lhef_write_event_30 (eio, event) class(eio_lhef_t), intent(in) :: eio class(generic_event_t), intent(in) :: event end subroutine eio_lhef_write_event_30 <>= module subroutine eio_lhef_write_event_30 (eio, event) class(eio_lhef_t), intent(in) :: eio class(generic_event_t), intent(in) :: event type(string_t) :: s integer :: u, i u = eio%unit s = "" if (eio%write_sqme_ref) then s = s // str (event%get_sqme_ref ()) // " " end if if (eio%write_sqme_prc) then s = s // str (event%get_sqme_prc ()) // " " end if if (eio%n_alt > 0) then if (eio%write_sqme_alt) then s = s // str (event%get_sqme_alt(1)) // " " do i = 2, eio%n_alt s = s // str (event%get_sqme_alt(i)) // " " end do end if s = s // str (event%get_weight_alt(1)) // " " do i = 2, eio%n_alt s = s // str (event%get_weight_alt(i)) // " " end do end if if (len_trim (s) > 0) then call eio%tag_weights%write (trim (s), u); write (u, *) end if end subroutine eio_lhef_write_event_30 @ %def eio_lhef_write_event_30 @ Read extra event data. If there is a [[weights]] tag and if there was a [[weightinfo]] entry labeled [[sqme_prc]], we extract the corresponding entry from the weights string and store this as the event's squared matrix-element value. Other tags, including tags written by the above writer, are skipped. <>= procedure :: read_event_30 => eio_lhef_read_event_30 <>= module subroutine eio_lhef_read_event_30 (eio, event) class(eio_lhef_t), intent(inout) :: eio class(generic_event_t), intent(inout) :: event end subroutine eio_lhef_read_event_30 <>= module subroutine eio_lhef_read_event_30 (eio, event) class(eio_lhef_t), intent(inout) :: eio class(generic_event_t), intent(inout) :: event type(string_t) :: content, string logical :: found, closing integer :: i SCAN_EVENT_TAGS: do call eio%tag_weights%read (eio%cstream, found) if (found) then if (.not. eio%tag_weights%has_content) call err_weights call eio%tag_weights%read_content (eio%cstream, content, closing) if (.not. closing) call err_weights if (eio%i_weight_sqme > 0) then SCAN_WEIGHTS: do i = 1, eio%i_weight_sqme call split (content, string, " ") content = adjustl (content) if (i == eio%i_weight_sqme) then call event%set_sqme_ref (read_rval (string)) exit SCAN_WEIGHTS end if end do SCAN_WEIGHTS end if cycle SCAN_EVENT_TAGS end if call eio%tag_event%read_content (eio%cstream, content, closing) if (closing) then if (content /= "") call err_event exit SCAN_EVENT_TAGS end if end do SCAN_EVENT_TAGS contains subroutine err_weights call msg_fatal ("LHEF: invalid weights tag in event record") end subroutine err_weights subroutine err_event call msg_fatal ("LHEF: syntax error after event tag") end subroutine err_event end subroutine eio_lhef_read_event_30 @ %def eio_lhef_read_event_30 @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_lhef_ut.f90]]>>= <> module eio_lhef_ut use unit_tests use eio_lhef_uti <> <> contains <> end module eio_lhef_ut @ %def eio_lhef_ut @ <<[[eio_lhef_uti.f90]]>>= <> module eio_lhef_uti <> <> use io_units use model_data use event_base use eio_data use eio_base use eio_lhef use eio_base_ut, only: eio_prepare_test, eio_cleanup_test use eio_base_ut, only: eio_prepare_fallback_model, eio_cleanup_fallback_model <> <> contains <> end module eio_lhef_uti @ %def eio_lhef_ut @ API: driver for the unit tests below. <>= public :: eio_lhef_test <>= subroutine eio_lhef_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_lhef_test @ %def eio_lhef_test @ \subsubsection{Version 1.0 Output} We test the implementation of all I/O methods. We start with output according to version 1.0. <>= call test (eio_lhef_1, "eio_lhef_1", & "write version 1.0", & u, results) <>= public :: eio_lhef_1 <>= subroutine eio_lhef_1 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_lhef_1" write (u, "(A)") "* Purpose: generate an event and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%unweighted = .true. data%norm_mode = NORM_UNIT data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_lhef_1" allocate (eio_lhef_t :: eio) select type (eio) type is (eio_lhef_t) call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // "." // eio%extension), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:21) == " ") buffer = "[...]" if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_lhef_t :: eio) select type (eio) type is (eio_lhef_t) call eio%set_parameters () end select select type (eio) type is (eio_lhef_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_lhef_1" end subroutine eio_lhef_1 @ %def eio_lhef_1 @ \subsubsection{Version 2.0 Output} Version 2.0 has added a lot of options to the LHEF format. We implement some of them. <>= call test (eio_lhef_2, "eio_lhef_2", & "write version 2.0", & u, results) <>= public :: eio_lhef_2 <>= subroutine eio_lhef_2 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_lhef_2" write (u, "(A)") "* Purpose: generate an event and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%unweighted = .false. data%norm_mode = NORM_SIGMA data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_lhef_2" allocate (eio_lhef_t :: eio) select type (eio) type is (eio_lhef_t) call eio%set_parameters (version = "2.0", write_sqme_prc = .true.) end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // "." // eio%extension), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:10) == ">= call test (eio_lhef_3, "eio_lhef_3", & "write version 3.0", & u, results) <>= public :: eio_lhef_3 <>= subroutine eio_lhef_3 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(80) :: buffer write (u, "(A)") "* Test output: eio_lhef_3" write (u, "(A)") "* Purpose: generate an event and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%unweighted = .false. data%norm_mode = NORM_SIGMA data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_lhef_3" allocate (eio_lhef_t :: eio) select type (eio) type is (eio_lhef_t) call eio%set_parameters (version = "3.0", write_sqme_prc = .true.) end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents:" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".lhe"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:10) == ">= call test (eio_lhef_4, "eio_lhef_4", & "read version 1.0", & u, results) <>= public :: eio_lhef_4 <>= subroutine eio_lhef_4 (u) integer, intent(in) :: u class(model_data_t), pointer :: fallback_model class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat, i_prc write (u, "(A)") "* Test output: eio_lhef_4" write (u, "(A)") "* Purpose: read a LHEF 1.0 file" write (u, "(A)") write (u, "(A)") "* Write a LHEF data file" write (u, "(A)") u_file = free_unit () sample = "eio_lhef_4" open (u_file, file = char (sample // ".lhe"), & status = "replace", action = "readwrite") write (u_file, "(A)") '' write (u_file, "(A)") '
' write (u_file, "(A)") ' content' write (u_file, "(A)") ' Text' write (u_file, "(A)") ' ' write (u_file, "(A)") '
' write (u_file, "(A)") '' write (u_file, "(A)") ' 25 25 5.0000000000E+02 5.0000000000E+02 & & -1 -1 -1 -1 3 1' write (u_file, "(A)") ' 1.0000000000E-01 1.0000000000E-03 & & 1.0000000000E+00 42' write (u_file, "(A)") '' write (u_file, "(A)") '' write (u_file, "(A)") ' 4 42 3.0574068604E+08 1.0000000000E+03 & & -1.0000000000E+00 -1.0000000000E+00' write (u_file, "(A)") ' 25 -1 0 0 0 0 0.0000000000E+00 0.0000000000E+00 & & 4.8412291828E+02 5.0000000000E+02 1.2500000000E+02 & & 0.0000000000E+00 9.0000000000E+00' write (u_file, "(A)") ' 25 -1 0 0 0 0 0.0000000000E+00 0.0000000000E+00 & &-4.8412291828E+02 5.0000000000E+02 1.2500000000E+02 & & 0.0000000000E+00 9.0000000000E+00' write (u_file, "(A)") ' 25 1 1 2 0 0 -1.4960220911E+02 -4.6042825611E+02 & & 0.0000000000E+00 5.0000000000E+02 1.2500000000E+02 & & 0.0000000000E+00 9.0000000000E+00' write (u_file, "(A)") ' 25 1 1 2 0 0 1.4960220911E+02 4.6042825611E+02 & & 0.0000000000E+00 5.0000000000E+02 1.2500000000E+02 & & 0.0000000000E+00 9.0000000000E+00' write (u_file, "(A)") '' write (u_file, "(A)") '' close (u_file) write (u, "(A)") "* Initialize test process" write (u, "(A)") allocate (fallback_model) call eio_prepare_fallback_model (fallback_model) call eio_prepare_test (event, unweighted = .false.) allocate (eio_lhef_t :: eio) select type (eio) type is (eio_lhef_t) call eio%set_parameters (recover_beams = .false.) end select call eio%set_fallback_model (fallback_model) call data%init (1) data%n_beam = 2 data%unweighted = .true. data%norm_mode = NORM_UNIT data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] call data%write (u) write (u, *) write (u, "(A)") "* Initialize and read header" write (u, "(A)") call eio%init_in (sample, data) call eio%write (u) write (u, *) select type (eio) type is (eio_lhef_t) call eio%tag_lhef%write (u); write (u, *) end select write (u, *) call data%write (u) write (u, "(A)") write (u, "(A)") "* Read event" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) select type (eio) type is (eio_lhef_t) write (u, "(A,I0,A,I0)") "Found process #", i_prc, & " with ID = ", eio%proc_num_id(i_prc) end select call eio%input_event (event, iostat) call event%write (u) write (u, "(A)") write (u, "(A)") "* Read closing" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) write (u, "(A,I0)") "iostat = ", iostat write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call eio_cleanup_test (event) call eio_cleanup_fallback_model (fallback_model) deallocate (fallback_model) write (u, "(A)") write (u, "(A)") "* Test output end: eio_lhef_4" end subroutine eio_lhef_4 @ %def eio_lhef_4 @ \subsubsection{Version 2.0 Input} Check input of a version-2.0 conforming LHEF file. <>= call test (eio_lhef_5, "eio_lhef_5", & "read version 2.0", & u, results) <>= public :: eio_lhef_5 <>= subroutine eio_lhef_5 (u) integer, intent(in) :: u class(model_data_t), pointer :: fallback_model class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat, i_prc write (u, "(A)") "* Test output: eio_lhef_5" write (u, "(A)") "* Purpose: read a LHEF 2.0 file" write (u, "(A)") write (u, "(A)") "* Write a LHEF data file" write (u, "(A)") u_file = free_unit () sample = "eio_lhef_5" open (u_file, file = char (sample // ".lhe"), & status = "replace", action = "readwrite") write (u_file, "(A)") '' write (u_file, "(A)") '
' write (u_file, "(A)") '
' write (u_file, "(A)") '' write (u_file, "(A)") ' 25 25 5.0000000000E+02 5.0000000000E+02 & &-1 -1 -1 -1 4 1' write (u_file, "(A)") ' 1.0000000000E-01 1.0000000000E-03 & & 0.0000000000E+00 42' write (u_file, "(A)") 'WHIZARD& &' write (u_file, "(A)") '' write (u_file, "(A)") '' write (u_file, "(A)") '' write (u_file, "(A)") ' 4 42 3.0574068604E+08 1.0000000000E+03 & &-1.0000000000E+00 -1.0000000000E+00' write (u_file, "(A)") ' 25 -1 0 0 0 0 0.0000000000E+00 & & 0.0000000000E+00 4.8412291828E+02 5.0000000000E+02 & & 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00' write (u_file, "(A)") ' 25 -1 0 0 0 0 0.0000000000E+00 & & 0.0000000000E+00 -4.8412291828E+02 5.0000000000E+02 & & 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00' write (u_file, "(A)") ' 25 1 1 2 0 0 -1.4960220911E+02 & &-4.6042825611E+02 0.0000000000E+00 5.0000000000E+02 & & 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00' write (u_file, "(A)") ' 25 1 1 2 0 0 1.4960220911E+02 & & 4.6042825611E+02 0.0000000000E+00 5.0000000000E+02 & & 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00' write (u_file, "(A)") '1.0000000000E+00' write (u_file, "(A)") '' write (u_file, "(A)") '' close (u_file) write (u, "(A)") "* Initialize test process" write (u, "(A)") allocate (fallback_model) call eio_prepare_fallback_model (fallback_model) call eio_prepare_test (event, unweighted = .false.) allocate (eio_lhef_t :: eio) select type (eio) type is (eio_lhef_t) call eio%set_parameters (version = "2.0", recover_beams = .false.) end select call eio%set_fallback_model (fallback_model) call data%init (1) data%unweighted = .false. data%norm_mode = NORM_SIGMA data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] call data%write (u) write (u, *) write (u, "(A)") "* Initialize and read header" write (u, "(A)") call eio%init_in (sample, data) call eio%write (u) write (u, *) select type (eio) type is (eio_lhef_t) call eio%tag_lhef%write (u); write (u, *) end select write (u, *) call data%write (u) write (u, "(A)") write (u, "(A)") "* Read event" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) select type (eio) type is (eio_lhef_t) write (u, "(A,I0,A,I0)") "Found process #", i_prc, & " with ID = ", eio%proc_num_id(i_prc) end select call eio%input_event (event, iostat) call event%write (u) write (u, "(A)") write (u, "(A)") "* Read closing" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) write (u, "(A,I0)") "iostat = ", iostat write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call eio_cleanup_test (event) call eio_cleanup_fallback_model (fallback_model) deallocate (fallback_model) write (u, "(A)") write (u, "(A)") "* Test output end: eio_lhef_5" end subroutine eio_lhef_5 @ %def eio_lhef_5 @ \subsubsection{Version 3.0 Input} Check input of a version-3.0 conforming LHEF file. <>= call test (eio_lhef_6, "eio_lhef_6", & "read version 3.0", & u, results) <>= public :: eio_lhef_6 <>= subroutine eio_lhef_6 (u) integer, intent(in) :: u class(model_data_t), pointer :: fallback_model class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat, i_prc write (u, "(A)") "* Test output: eio_lhef_6" write (u, "(A)") "* Purpose: read a LHEF 3.0 file" write (u, "(A)") write (u, "(A)") "* Write a LHEF data file" write (u, "(A)") u_file = free_unit () sample = "eio_lhef_6" open (u_file, file = char (sample // ".lhe"), & status = "replace", action = "readwrite") write (u_file, "(A)") '' write (u_file, "(A)") '
' write (u_file, "(A)") '
' write (u_file, "(A)") '' write (u_file, "(A)") ' 25 25 5.0000000000E+02 5.0000000000E+02 & &-1 -1 -1 -1 4 1' write (u_file, "(A)") ' 1.0000000000E-01 1.0000000000E-03 & & 0.0000000000E+00 42' write (u_file, "(A)") 'WHIZARD& &' write (u_file, "(A)") '' write (u_file, "(A)") '' write (u_file, "(A)") '' write (u_file, "(A)") '' write (u_file, "(A)") ' 4 42 3.0574068604E+08 1.0000000000E+03 & &-1.0000000000E+00 -1.0000000000E+00' write (u_file, "(A)") ' 25 -1 0 0 0 0 0.0000000000E+00 & & 0.0000000000E+00 4.8412291828E+02 5.0000000000E+02 & & 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00' write (u_file, "(A)") ' 25 -1 0 0 0 0 0.0000000000E+00 & & 0.0000000000E+00 -4.8412291828E+02 5.0000000000E+02 & & 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00' write (u_file, "(A)") ' 25 1 1 2 0 0 -1.4960220911E+02 & &-4.6042825611E+02 0.0000000000E+00 5.0000000000E+02 & & 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00' write (u_file, "(A)") ' 25 1 1 2 0 0 1.4960220911E+02 & & 4.6042825611E+02 0.0000000000E+00 5.0000000000E+02 & & 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00' write (u_file, "(A)") '1.0000000000E+00' write (u_file, "(A)") '' write (u_file, "(A)") '' close (u_file) write (u, "(A)") "* Initialize test process" write (u, "(A)") allocate (fallback_model) call eio_prepare_fallback_model (fallback_model) call eio_prepare_test (event, unweighted = .false.) allocate (eio_lhef_t :: eio) select type (eio) type is (eio_lhef_t) call eio%set_parameters (version = "3.0", recover_beams = .false.) end select call eio%set_fallback_model (fallback_model) call data%init (1) data%unweighted = .false. data%norm_mode = NORM_SIGMA data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] call data%write (u) write (u, *) write (u, "(A)") "* Initialize and read header" write (u, "(A)") call eio%init_in (sample, data) call eio%write (u) write (u, *) select type (eio) type is (eio_lhef_t) call eio%tag_lhef%write (u); write (u, *) end select write (u, *) call data%write (u) write (u, "(A)") write (u, "(A)") "* Read event" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) select type (eio) type is (eio_lhef_t) write (u, "(A,I0,A,I0)") "Found process #", i_prc, & " with ID = ", eio%proc_num_id(i_prc) end select call eio%input_event (event, iostat) call event%write (u) write (u, "(A)") write (u, "(A)") "* Read closing" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) write (u, "(A,I0)") "iostat = ", iostat write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call eio_cleanup_test (event) call eio_cleanup_fallback_model (fallback_model) deallocate (fallback_model) write (u, "(A)") write (u, "(A)") "* Test output end: eio_lhef_6" end subroutine eio_lhef_6 @ %def eio_lhef_6 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{STDHEP File Formats} Here, we implement the two existing STDHEP file formats, one based on the HEPRUP/HEPEUP common blocks, the other based on the HEPEVT common block. The second one is actually the standard STDHEP format. <<[[eio_stdhep.f90]]>>= <> module eio_stdhep use kinds, only: i32, i64 <> use event_base use event_handles, only: event_handle_t use eio_data use eio_base <> <> <> interface <> end interface end module eio_stdhep @ %def eio_stdhep @ <<[[eio_stdhep_sub.f90]]>>= <> submodule (eio_stdhep) eio_stdhep_s use io_units use string_utils use diagnostics use hep_common use hep_events implicit none <> contains <> end submodule eio_stdhep_s @ %def eio_stdhep_s @ \subsection{Type} <>= public :: eio_stdhep_t <>= type, abstract, extends (eio_t) :: eio_stdhep_t logical :: writing = .false. logical :: reading = .false. integer :: unit = 0 logical :: keep_beams = .false. logical :: keep_remnants = .true. logical :: ensure_order = .false. logical :: recover_beams = .false. logical :: use_alphas_from_file = .false. logical :: use_scale_from_file = .false. integer, dimension(:), allocatable :: proc_num_id integer(i64) :: n_events_expected = 0 contains <> end type eio_stdhep_t @ %def eio_stdhep_t @ <>= public :: eio_stdhep_hepevt_t <>= type, extends (eio_stdhep_t) :: eio_stdhep_hepevt_t end type eio_stdhep_hepevt_t @ %def eio_stdhep_hepevt_t @ <>= public :: eio_stdhep_hepeup_t <>= type, extends (eio_stdhep_t) :: eio_stdhep_hepeup_t end type eio_stdhep_hepeup_t @ %def eio_stdhep_hepeup_t @ <>= public :: eio_stdhep_hepev4_t <>= type, extends (eio_stdhep_t) :: eio_stdhep_hepev4_t end type eio_stdhep_hepev4_t @ %def eio_stdhep_hepev4_t @ \subsection{Specific Methods} Set parameters that are specifically used with STDHEP file formats. <>= procedure :: set_parameters => eio_stdhep_set_parameters <>= module subroutine eio_stdhep_set_parameters (eio, & keep_beams, keep_remnants, ensure_order, recover_beams, & use_alphas_from_file, use_scale_from_file, extension) class(eio_stdhep_t), intent(inout) :: eio logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants logical, intent(in), optional :: ensure_order logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alphas_from_file logical, intent(in), optional :: use_scale_from_file type(string_t), intent(in), optional :: extension end subroutine eio_stdhep_set_parameters <>= module subroutine eio_stdhep_set_parameters (eio, & keep_beams, keep_remnants, ensure_order, recover_beams, & use_alphas_from_file, use_scale_from_file, extension) class(eio_stdhep_t), intent(inout) :: eio logical, intent(in), optional :: keep_beams logical, intent(in), optional :: keep_remnants logical, intent(in), optional :: ensure_order logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alphas_from_file logical, intent(in), optional :: use_scale_from_file type(string_t), intent(in), optional :: extension if (present (keep_beams)) eio%keep_beams = keep_beams if (present (keep_remnants)) eio%keep_remnants = keep_remnants if (present (ensure_order)) eio%ensure_order = ensure_order if (present (recover_beams)) eio%recover_beams = recover_beams if (present (use_alphas_from_file)) & eio%use_alphas_from_file = use_alphas_from_file if (present (use_scale_from_file)) & eio%use_scale_from_file = use_scale_from_file if (present (extension)) then eio%extension = extension else select type (eio) type is (eio_stdhep_hepevt_t) eio%extension = "hep" type is (eio_stdhep_hepev4_t) eio%extension = "ev4.hep" type is (eio_stdhep_hepeup_t) eio%extension = "up.hep" end select end if end subroutine eio_stdhep_set_parameters @ %def eio_ascii_stdhep_parameters @ \subsection{Common Methods} Output. This is not the actual event format, but a readable account of the current object status. <>= procedure :: write => eio_stdhep_write <>= module subroutine eio_stdhep_write (object, unit) class(eio_stdhep_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine eio_stdhep_write <>= module subroutine eio_stdhep_write (object, unit) class(eio_stdhep_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "STDHEP event stream:" if (object%writing) then write (u, "(3x,A,A)") "Writing to file = ", char (object%filename) else if (object%reading) then write (u, "(3x,A,A)") "Reading from file = ", char (object%filename) else write (u, "(3x,A)") "[closed]" end if write (u, "(3x,A,L1)") "Keep beams = ", object%keep_beams write (u, "(3x,A,L1)") "Keep remnants = ", object%keep_remnants write (u, "(3x,A,L1)") "Recover beams = ", object%recover_beams write (u, "(3x,A,L1)") "Alpha_s from file = ", & object%use_alphas_from_file write (u, "(3x,A,L1)") "Scale from file = ", & object%use_scale_from_file if (allocated (object%proc_num_id)) then write (u, "(3x,A)") "Numerical process IDs:" do i = 1, size (object%proc_num_id) write (u, "(5x,I0,': ',I0)") i, object%proc_num_id(i) end do end if end subroutine eio_stdhep_write @ %def eio_stdhep_write @ Finalizer: close any open file. <>= procedure :: final => eio_stdhep_final <>= module subroutine eio_stdhep_final (object) class(eio_stdhep_t), intent(inout) :: object end subroutine eio_stdhep_final <>= module subroutine eio_stdhep_final (object) class(eio_stdhep_t), intent(inout) :: object if (allocated (object%proc_num_id)) deallocate (object%proc_num_id) if (object%writing) then write (msg_buffer, "(A,A,A)") "Events: closing STDHEP file '", & char (object%filename), "'" call msg_message () call stdhep_write (200) call stdhep_end () object%writing = .false. else if (object%reading) then write (msg_buffer, "(A,A,A)") "Events: closing STDHEP file '", & char (object%filename), "'" call msg_message () object%reading = .false. end if end subroutine eio_stdhep_final @ %def eio_stdhep_final @ Common initialization for input and output. <>= procedure :: common_init => eio_stdhep_common_init <>= module subroutine eio_stdhep_common_init (eio, sample, data, extension) class(eio_stdhep_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data end subroutine eio_stdhep_common_init <>= module subroutine eio_stdhep_common_init (eio, sample, data, extension) class(eio_stdhep_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data if (.not. present (data)) & call msg_bug ("STDHEP initialization: missing data") if (present (extension)) then eio%extension = extension end if eio%sample = sample call eio%set_filename () eio%unit = free_unit () allocate (eio%proc_num_id (data%n_proc), source = data%proc_num_id) end subroutine eio_stdhep_common_init @ %def eio_stdhep_common_init @ Split event file: increment the counter, close the current file, open a new one. If the file needs a header, repeat it for the new file. (We assume that the common block contents are still intact.) <>= procedure :: split_out => eio_stdhep_split_out <>= module subroutine eio_stdhep_split_out (eio) class(eio_stdhep_t), intent(inout) :: eio end subroutine eio_stdhep_split_out <>= module subroutine eio_stdhep_split_out (eio) class(eio_stdhep_t), intent(inout) :: eio if (eio%split) then eio%split_index = eio%split_index + 1 call eio%set_filename () write (msg_buffer, "(A,A,A)") "Events: writing to STDHEP file '", & char (eio%filename), "'" call msg_message () call stdhep_write (200) call stdhep_end () select type (eio) type is (eio_stdhep_hepeup_t) call stdhep_init_out (char (eio%filename), & "WHIZARD <>", eio%n_events_expected) call stdhep_write (100) call stdhep_write (STDHEP_HEPRUP) type is (eio_stdhep_hepevt_t) call stdhep_init_out (char (eio%filename), & "WHIZARD <>", eio%n_events_expected) call stdhep_write (100) type is (eio_stdhep_hepev4_t) call stdhep_init_out (char (eio%filename), & "WHIZARD <>", eio%n_events_expected) call stdhep_write (100) end select end if end subroutine eio_stdhep_split_out @ %def eio_stdhep_split_out @ Initialize event writing. <>= procedure :: init_out => eio_stdhep_init_out <>= module subroutine eio_stdhep_init_out & (eio, sample, data, success, extension) class(eio_stdhep_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success end subroutine eio_stdhep_init_out <>= module subroutine eio_stdhep_init_out & (eio, sample, data, success, extension) class(eio_stdhep_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success logical :: is_width integer :: i if (.not. present (data)) & call msg_bug ("STDHEP initialization: missing data") is_width = data%n_beam == 1 call eio%set_splitting (data) call eio%common_init (sample, data, extension) eio%n_events_expected = data%n_evt write (msg_buffer, "(A,A,A)") "Events: writing to STDHEP file '", & char (eio%filename), "'" call msg_message () eio%writing = .true. select type (eio) type is (eio_stdhep_hepeup_t) call heprup_init & (data%pdg_beam, & data%energy_beam, & n_processes = data%n_proc, & unweighted = data%unweighted, & negative_weights = data%negative_weights) do i = 1, data%n_proc call heprup_set_process_parameters (i = i, & process_id = data%proc_num_id(i), & cross_section = data%cross_section(i), & error = data%error(i), & is_width = is_width) end do call stdhep_init_out (char (eio%filename), & "WHIZARD <>", eio%n_events_expected) call stdhep_write (100) call stdhep_write (STDHEP_HEPRUP) type is (eio_stdhep_hepevt_t) call stdhep_init_out (char (eio%filename), & "WHIZARD <>", eio%n_events_expected) call stdhep_write (100) type is (eio_stdhep_hepev4_t) call stdhep_init_out (char (eio%filename), & "WHIZARD <>", eio%n_events_expected) call stdhep_write (100) end select if (present (success)) success = .true. end subroutine eio_stdhep_init_out @ %def eio_stdhep_init_out @ Initialize event reading. <>= procedure :: init_in => eio_stdhep_init_in <>= module subroutine eio_stdhep_init_in & (eio, sample, data, success, extension) class(eio_stdhep_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success end subroutine eio_stdhep_init_in <>= module subroutine eio_stdhep_init_in & (eio, sample, data, success, extension) class(eio_stdhep_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success integer :: ilbl, lok logical :: exist call eio%common_init (sample, data, extension) write (msg_buffer, "(A,A,A)") "Events: reading from STDHEP file '", & char (eio%filename), "'" call msg_message () inquire (file = char (eio%filename), exist = exist) if (.not. exist) call msg_fatal ("Events: STDHEP file not found.") eio%reading = .true. call stdhep_init_in (char (eio%filename), eio%n_events_expected) call stdhep_read (ilbl, lok) if (lok /= 0) then call stdhep_end () write (msg_buffer, "(A)") "Events: STDHEP file appears to" // & " be empty." call msg_message () end if if (ilbl == 100) then write (msg_buffer, "(A)") "Events: reading in STDHEP events" call msg_message () end if if (present (success)) success = .false. end subroutine eio_stdhep_init_in @ %def eio_stdhep_init_in @ Switch from input to output: reopen the file for reading. <>= procedure :: switch_inout => eio_stdhep_switch_inout <>= module subroutine eio_stdhep_switch_inout (eio, success) class(eio_stdhep_t), intent(inout) :: eio logical, intent(out), optional :: success end subroutine eio_stdhep_switch_inout <>= module subroutine eio_stdhep_switch_inout (eio, success) class(eio_stdhep_t), intent(inout) :: eio logical, intent(out), optional :: success call msg_bug ("STDHEP: in-out switch not supported") if (present (success)) success = .false. end subroutine eio_stdhep_switch_inout @ %def eio_stdhep_switch_inout @ Output an event. Write first the event indices, then weight and squared matrix element, then the particle set. <>= procedure :: output => eio_stdhep_output <>= module subroutine eio_stdhep_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_stdhep_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_stdhep_output <>= module subroutine eio_stdhep_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_stdhep_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle if (present (passed)) then if (.not. passed) return end if if (eio%writing) then select type (eio) type is (eio_stdhep_hepeup_t) call hepeup_from_event (event, & process_index = eio%proc_num_id (i_prc), & keep_beams = eio%keep_beams, & keep_remnants = eio%keep_remnants) call stdhep_write (STDHEP_HEPEUP) type is (eio_stdhep_hepevt_t) call hepevt_from_event (event, & keep_beams = eio%keep_beams, & keep_remnants = eio%keep_remnants, & ensure_order = eio%ensure_order) call stdhep_write (STDHEP_HEPEVT) type is (eio_stdhep_hepev4_t) call hepevt_from_event (event, & process_index = eio%proc_num_id (i_prc), & keep_beams = eio%keep_beams, & keep_remnants = eio%keep_remnants, & ensure_order = eio%ensure_order, & fill_hepev4 = .true.) call stdhep_write (STDHEP_HEPEV4) end select else call eio%write () call msg_fatal ("STDHEP file is not open for writing") end if end subroutine eio_stdhep_output @ %def eio_stdhep_output @ Input an event. We do not allow to read in STDHEP files written via the HEPEVT common block as there is no control on the process ID. This implies that the event index cannot be read; it is simply incremented to count the current event sample. <>= procedure :: input_i_prc => eio_stdhep_input_i_prc procedure :: input_event => eio_stdhep_input_event <>= module subroutine eio_stdhep_input_i_prc (eio, i_prc, iostat) class(eio_stdhep_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat end subroutine eio_stdhep_input_i_prc module subroutine eio_stdhep_input_event (eio, event, iostat, event_handle) class(eio_stdhep_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_stdhep_input_event <>= module subroutine eio_stdhep_input_i_prc (eio, i_prc, iostat) class(eio_stdhep_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat integer :: i, ilbl, proc_num_id iostat = 0 select type (eio) type is (eio_stdhep_hepevt_t) if (size (eio%proc_num_id) > 1) then call msg_fatal ("Events: only single processes allowed " // & "with the STDHEP HEPEVT format.") else proc_num_id = eio%proc_num_id (1) call stdhep_read (ilbl, lok) end if type is (eio_stdhep_hepev4_t) call stdhep_read (ilbl, lok) proc_num_id = idruplh type is (eio_stdhep_hepeup_t) call stdhep_read (ilbl, lok) if (lok /= 0) call msg_error ("Events: STDHEP appears to be " // & "empty or corrupted.") if (ilbl == 12) then call stdhep_read (ilbl, lok) end if if (ilbl == 11) then proc_num_id = IDPRUP end if end select FIND_I_PRC: do i = 1, size (eio%proc_num_id) if (eio%proc_num_id(i) == proc_num_id) then i_prc = i exit FIND_I_PRC end if end do FIND_I_PRC if (i_prc == 0) call err_index contains subroutine err_index call msg_error ("STDHEP: reading events: undefined process ID " & // char (str (proc_num_id)) // ", aborting read") iostat = 1 end subroutine err_index end subroutine eio_stdhep_input_i_prc module subroutine eio_stdhep_input_event (eio, event, iostat, event_handle) class(eio_stdhep_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle iostat = 0 call event%reset_contents () call event%select (1, 1, 1) call hepeup_to_event (event, eio%fallback_model, & recover_beams = eio%recover_beams, & use_alpha_s = eio%use_alphas_from_file, & use_scale = eio%use_scale_from_file) call event%increment_index () end subroutine eio_stdhep_input_event @ %def eio_stdhep_input_i_prc @ %def eio_stdhep_input_event <>= procedure :: skip => eio_stdhep_skip <>= module subroutine eio_stdhep_skip (eio, iostat) class(eio_stdhep_t), intent(inout) :: eio integer, intent(out) :: iostat end subroutine eio_stdhep_skip <>= module subroutine eio_stdhep_skip (eio, iostat) class(eio_stdhep_t), intent(inout) :: eio integer, intent(out) :: iostat if (eio%reading) then read (eio%unit, iostat = iostat) else call eio%write () call msg_fatal ("Raw event file is not open for reading") end if end subroutine eio_stdhep_skip @ %def eio_stdhep_skip @ STDHEP speficic routines. <>= public :: stdhep_init_out public :: stdhep_init_in public :: stdhep_write public :: stdhep_end <>= module subroutine stdhep_init_out (file, title, nevt) character(len=*), intent(in) :: file, title integer(i64), intent(in) :: nevt end subroutine stdhep_init_out module subroutine stdhep_init_in (file, nevt) character(len=*), intent(in) :: file integer(i64), intent(out) :: nevt end subroutine stdhep_init_in module subroutine stdhep_write (ilbl) integer, intent(in) :: ilbl end subroutine stdhep_write module subroutine stdhep_read (ilbl, lok) integer, intent(out) :: ilbl, lok end subroutine stdhep_read module subroutine stdhep_end () end subroutine stdhep_end <>= module subroutine stdhep_init_out (file, title, nevt) character(len=*), intent(in) :: file, title integer(i64), intent(in) :: nevt integer(i32) :: nevt32 nevt32 = min (nevt, int (huge (1_i32), i64)) call stdxwinit (file, title, nevt32, istr, lok) end subroutine stdhep_init_out module subroutine stdhep_init_in (file, nevt) character(len=*), intent(in) :: file integer(i64), intent(out) :: nevt integer(i32) :: nevt32 call stdxrinit (file, nevt32, istr, lok) if (lok /= 0) call msg_fatal ("STDHEP: error in reading file '" // & file // "'.") nevt = int (nevt32, i64) end subroutine stdhep_init_in module subroutine stdhep_write (ilbl) integer, intent(in) :: ilbl call stdxwrt (ilbl, istr, lok) end subroutine stdhep_write module subroutine stdhep_read (ilbl, lok) integer, intent(out) :: ilbl, lok call stdxrd (ilbl, istr, lok) if (lok /= 0) return end subroutine stdhep_read module subroutine stdhep_end () call stdxend (istr) end subroutine stdhep_end @ %def stdhep_init stdhep_read stdhep_write stdhep_end @ \subsection{Variables} <>= integer, save :: istr, lok integer, parameter :: & STDHEP_HEPEVT = 1, STDHEP_HEPEV4 = 4, & STDHEP_HEPEUP = 11, STDHEP_HEPRUP = 12 @ @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_stdhep_ut.f90]]>>= <> module eio_stdhep_ut use unit_tests use eio_stdhep_uti <> <> contains <> end module eio_stdhep_ut @ %def eio_stdhep_ut @ <<[[eio_stdhep_uti.f90]]>>= <> module eio_stdhep_uti <> <> use io_units use model_data use event_base use eio_data use eio_base use xdr_wo_stdhep use eio_stdhep use eio_base_ut, only: eio_prepare_test, eio_cleanup_test use eio_base_ut, only: eio_prepare_fallback_model, eio_cleanup_fallback_model <> <> contains <> end module eio_stdhep_uti @ %def eio_stdhep_ut @ API: driver for the unit tests below. <>= public :: eio_stdhep_test <>= subroutine eio_stdhep_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_stdhep_test @ %def eio_stdhep_test @ \subsubsection{Test I/O methods} We test the implementation of the STDHEP HEPEVT I/O method: <>= call test (eio_stdhep_1, "eio_stdhep_1", & "read and write event contents, format [stdhep]", & u, results) <>= public :: eio_stdhep_1 <>= subroutine eio_stdhep_1 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(215) :: buffer write (u, "(A)") "* Test output: eio_stdhep_1" write (u, "(A)") "* Purpose: generate an event in STDHEP HEPEVT format" write (u, "(A)") "* and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_stdhep_1" allocate (eio_stdhep_hepevt_t :: eio) select type (eio) type is (eio_stdhep_hepevt_t) call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%set_index (61) ! not supported by reader, actually call event%evaluate_expressions () call event%pacify_particle_set () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* Write STDHEP file contents to ASCII file" write (u, "(A)") call write_stdhep_event & (sample // ".hep", var_str ("eio_stdhep_1.hep.out"), 1) write (u, "(A)") write (u, "(A)") "* Read in ASCII contents of STDHEP file" write (u, "(A)") u_file = free_unit () open (u_file, file = "eio_stdhep_1.hep.out", & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (iostat /= 0) exit if (trim (buffer) == "") cycle if (buffer(1:18) == " total blocks: ") & buffer = " total blocks: [...]" if (buffer(1:25) == " title: WHIZARD") & buffer = " title: WHIZARD [version]" if (buffer(1:17) == " date:") & buffer = " date: [...]" if (buffer(1:17) == " closing date:") & buffer = " closing date: [...]" write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_stdhep_hepevt_t :: eio) select type (eio) type is (eio_stdhep_hepevt_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_stdhep_1" end subroutine eio_stdhep_1 @ %def eio_stdhep_1 @ We test the implementation of the STDHEP HEPEUP I/O method: <>= call test (eio_stdhep_2, "eio_stdhep_2", & "read and write event contents, format [stdhep]", & u, results) <>= public :: eio_stdhep_2 <>= subroutine eio_stdhep_2 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(model_data_t), pointer :: fallback_model class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(215) :: buffer write (u, "(A)") "* Test output: eio_stdhep_2" write (u, "(A)") "* Purpose: generate an event in STDHEP HEPEUP format" write (u, "(A)") "* and write weight to file" write (u, "(A)") write (u, "(A)") "* Initialize test process" allocate (fallback_model) call eio_prepare_fallback_model (fallback_model) call eio_prepare_test (event, unweighted = .false.) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_stdhep_2" allocate (eio_stdhep_hepeup_t :: eio) select type (eio) type is (eio_stdhep_hepeup_t) call eio%set_parameters () end select call eio%set_fallback_model (fallback_model) call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%set_index (62) ! not supported by reader, actually call event%evaluate_expressions () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* Write STDHEP file contents to ASCII file" write (u, "(A)") call write_stdhep_event & (sample // ".up.hep", var_str ("eio_stdhep_2.hep.out"), 2) write (u, "(A)") write (u, "(A)") "* Read in ASCII contents of STDHEP file" write (u, "(A)") u_file = free_unit () open (u_file, file = "eio_stdhep_2.hep.out", & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (iostat /= 0) exit if (trim (buffer) == "") cycle if (buffer(1:18) == " total blocks: ") & buffer = " total blocks: [...]" if (buffer(1:25) == " title: WHIZARD") & buffer = " title: WHIZARD [version]" if (buffer(1:17) == " date:") & buffer = " date: [...]" if (buffer(1:17) == " closing date:") & buffer = " closing date: [...]" write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_stdhep_hepeup_t :: eio) select type (eio) type is (eio_stdhep_hepeup_t) call eio%set_parameters (keep_beams = .true.) end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) call eio_cleanup_fallback_model (fallback_model) deallocate (fallback_model) write (u, "(A)") write (u, "(A)") "* Test output end: eio_stdhep_2" end subroutine eio_stdhep_2 @ %def eio_stdhep_2 @ Check input from a StdHep file, HEPEVT block. <>= call test (eio_stdhep_3, "eio_stdhep_3", & "read StdHep file, HEPEVT block", & u, results) <>= public :: eio_stdhep_3 <>= subroutine eio_stdhep_3 (u) integer, intent(in) :: u class(model_data_t), pointer :: fallback_model class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: iostat, i_prc write (u, "(A)") "* Test output: eio_stdhep_3" write (u, "(A)") "* Purpose: read a StdHep file, HEPEVT block" write (u, "(A)") write (u, "(A)") "* Write a StdHep data file, HEPEVT block" write (u, "(A)") allocate (fallback_model) call eio_prepare_fallback_model (fallback_model) call eio_prepare_test (event) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_stdhep_3" allocate (eio_stdhep_hepevt_t :: eio) select type (eio) type is (eio_stdhep_hepevt_t) call eio%set_parameters () end select call eio%set_fallback_model (fallback_model) call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%set_index (63) ! not supported by reader, actually call event%evaluate_expressions () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () call eio_cleanup_test (event) call eio_cleanup_fallback_model (fallback_model) deallocate (eio) deallocate (fallback_model) write (u, "(A)") "* Initialize test process" write (u, "(A)") allocate (fallback_model) call eio_prepare_fallback_model (fallback_model) call eio_prepare_test (event, unweighted = .false.) allocate (eio_stdhep_hepevt_t :: eio) select type (eio) type is (eio_stdhep_hepevt_t) call eio%set_parameters (recover_beams = .false.) end select call eio%set_fallback_model (fallback_model) call data%init (1) data%n_beam = 2 data%unweighted = .true. data%norm_mode = NORM_UNIT data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] call data%write (u) write (u, *) write (u, "(A)") "* Initialize" write (u, "(A)") call eio%init_in (sample, data) call eio%write (u) write (u, "(A)") write (u, "(A)") "* Read event" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) select type (eio) type is (eio_stdhep_hepevt_t) write (u, "(A,I0,A,I0)") "Found process #", i_prc, & " with ID = ", eio%proc_num_id(i_prc) end select call eio%input_event (event, iostat) call event%write (u) write (u, "(A)") write (u, "(A)") "* Read closing" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) write (u, "(A,I0)") "iostat = ", iostat write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call eio_cleanup_test (event) call eio_cleanup_fallback_model (fallback_model) deallocate (fallback_model) write (u, "(A)") write (u, "(A)") "* Test output end: eio_stdhep_3" end subroutine eio_stdhep_3 @ %def eio_stdhep_3 @ Check input from a StdHep file, HEPEVT block. <>= call test (eio_stdhep_4, "eio_stdhep_4", & "read StdHep file, HEPRUP/HEPEUP block", & u, results) <>= public :: eio_stdhep_4 <>= subroutine eio_stdhep_4 (u) integer, intent(in) :: u class(model_data_t), pointer :: fallback_model class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: iostat, i_prc write (u, "(A)") "* Test output: eio_stdhep_3" write (u, "(A)") "* Purpose: read a StdHep file, HEPRUP/HEPEUP block" write (u, "(A)") write (u, "(A)") "* Write a StdHep data file, HEPRUP/HEPEUP block" write (u, "(A)") allocate (fallback_model) call eio_prepare_fallback_model (fallback_model) call eio_prepare_test (event) call data%init (1) data%n_evt = 1 data%n_beam = 2 data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event, HEPEUP/HEPRUP" write (u, "(A)") sample = "eio_stdhep_4" allocate (eio_stdhep_hepeup_t :: eio) select type (eio) type is (eio_stdhep_hepeup_t) call eio%set_parameters () end select call eio%set_fallback_model (fallback_model) call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%set_index (64) ! not supported by reader, actually call event%evaluate_expressions () call event%pacify_particle_set () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () call eio_cleanup_test (event) call eio_cleanup_fallback_model (fallback_model) deallocate (eio) deallocate (fallback_model) write (u, "(A)") "* Initialize test process" write (u, "(A)") allocate (fallback_model) call eio_prepare_fallback_model (fallback_model) call eio_prepare_test (event, unweighted = .false.) allocate (eio_stdhep_hepeup_t :: eio) select type (eio) type is (eio_stdhep_hepeup_t) call eio%set_parameters (recover_beams = .false.) end select call eio%set_fallback_model (fallback_model) call data%init (1) data%n_beam = 2 data%unweighted = .true. data%norm_mode = NORM_UNIT data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] call data%write (u) write (u, *) write (u, "(A)") "* Initialize" write (u, "(A)") call eio%init_in (sample, data) call eio%write (u) write (u, "(A)") write (u, "(A)") "* Read event" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) select type (eio) type is (eio_stdhep_hepeup_t) write (u, "(A,I0,A,I0)") "Found process #", i_prc, & " with ID = ", eio%proc_num_id(i_prc) end select call eio%input_event (event, iostat) call event%write (u) write (u, "(A)") write (u, "(A)") "* Read closing" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) write (u, "(A,I0)") "iostat = ", iostat write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call eio_cleanup_test (event) call eio_cleanup_fallback_model (fallback_model) deallocate (fallback_model) write (u, "(A)") write (u, "(A)") "* Test output end: eio_stdhep_4" end subroutine eio_stdhep_4 @ %def eio_stdhep_4 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{HepMC Output} The HepMC event record is standardized. It is an ASCII format. We try our best at using it for both input and output. <<[[eio_hepmc.f90]]>>= <> module eio_hepmc <> <> use event_base use event_handles, only: event_handle_t use eio_data use eio_base use hepmc_interface <> <> <> interface <> end interface end module eio_hepmc @ %def eio_hepmc @ <<[[eio_hepmc_sub.f90]]>>= <> submodule (eio_hepmc) eio_hepmc_s use io_units use string_utils use diagnostics use particles use model_data use hep_events implicit none contains <> end submodule eio_hepmc_s @ %def eio_hepmc_s @ \subsection{Type} A type [[hepmc_event]] is introduced as container to store HepMC event data, particularly for splitting the reading into read out of the process index and the proper event data. Note: the [[keep_beams]] flag is not supported. Beams will always be written. Tools like \texttt{Rivet} can use the cross section information of a HepMC file for scaling plots. As there is no header in HepMC and this is written for every event, we make it optional with [[output_cross_section]]. <>= public :: eio_hepmc_t <>= type, extends (eio_t) :: eio_hepmc_t logical :: writing = .false. logical :: reading = .false. type(event_sample_data_t) :: data ! logical :: keep_beams = .false. logical :: recover_beams = .false. logical :: use_alphas_from_file = .false. logical :: use_scale_from_file = .false. logical :: output_cross_section = .false. integer :: hepmc3_mode = HEPMC3_MODE_HEPMC3 logical :: hepmc3_flows = .false. type(hepmc_iostream_t) :: iostream type(hepmc_event_t) :: hepmc_event integer, dimension(:), allocatable :: proc_num_id contains <> end type eio_hepmc_t @ %def eio_hepmc_t @ \subsection{Specific Methods} Set parameters that are specifically used with HepMC. <>= procedure :: set_parameters => eio_hepmc_set_parameters <>= module subroutine eio_hepmc_set_parameters & (eio, recover_beams, use_alphas_from_file, & use_scale_from_file, extension, output_cross_section, & hepmc3_mode, hepmc3_write_flows) class(eio_hepmc_t), intent(inout) :: eio logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alphas_from_file logical, intent(in), optional :: use_scale_from_file logical, intent(in), optional :: output_cross_section type(string_t), intent(in), optional :: extension integer, intent(in), optional :: hepmc3_mode logical ,intent(in), optional :: hepmc3_write_flows end subroutine eio_hepmc_set_parameters <>= module subroutine eio_hepmc_set_parameters & (eio, recover_beams, use_alphas_from_file, & use_scale_from_file, extension, output_cross_section, & hepmc3_mode, hepmc3_write_flows) class(eio_hepmc_t), intent(inout) :: eio logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alphas_from_file logical, intent(in), optional :: use_scale_from_file logical, intent(in), optional :: output_cross_section type(string_t), intent(in), optional :: extension integer, intent(in), optional :: hepmc3_mode logical ,intent(in), optional :: hepmc3_write_flows if (present (recover_beams)) & eio%recover_beams = recover_beams if (present (use_alphas_from_file)) & eio%use_alphas_from_file = use_alphas_from_file if (present (use_scale_from_file)) & eio%use_scale_from_file = use_scale_from_file if (present (extension)) then eio%extension = extension else eio%extension = "hepmc" end if if (present (output_cross_section)) & eio%output_cross_section = output_cross_section if (present (hepmc3_mode)) & eio%hepmc3_mode = hepmc3_mode if (present (hepmc3_write_flows)) & eio%hepmc3_flows = hepmc3_write_flows end subroutine eio_hepmc_set_parameters @ %def eio_hepmc_set_parameters @ \subsection{Common Methods} Output. This is not the actual event format, but a readable account of the current object status. <>= procedure :: write => eio_hepmc_write <>= module subroutine eio_hepmc_write (object, unit) class(eio_hepmc_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine eio_hepmc_write <>= module subroutine eio_hepmc_write (object, unit) class(eio_hepmc_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "HepMC event stream:" if (object%writing) then write (u, "(3x,A,A)") "Writing to file = ", char (object%filename) else if (object%reading) then write (u, "(3x,A,A)") "Reading from file = ", char (object%filename) else write (u, "(3x,A)") "[closed]" end if write (u, "(3x,A,L1)") "Recover beams = ", object%recover_beams write (u, "(3x,A,L1)") "Alpha_s from file = ", & object%use_alphas_from_file write (u, "(3x,A,L1)") "Scale from file = ", & object%use_scale_from_file write (u, "(3x,A,A,A)") "File extension = '", & char (object%extension), "'" write (u, "(3x,A,I0)") "HepMC3 mode = ", object%hepmc3_mode write (u, "(3x,A,L1)") "HepMC3 flows = ", object%hepmc3_flows if (allocated (object%proc_num_id)) then write (u, "(3x,A)") "Numerical process IDs:" do i = 1, size (object%proc_num_id) write (u, "(5x,I0,': ',I0)") i, object%proc_num_id(i) end do end if end subroutine eio_hepmc_write @ %def eio_hepmc_write @ Finalizer: close any open file. <>= procedure :: final => eio_hepmc_final <>= module subroutine eio_hepmc_final (object) class(eio_hepmc_t), intent(inout) :: object end subroutine eio_hepmc_final <>= module subroutine eio_hepmc_final (object) class(eio_hepmc_t), intent(inout) :: object if (allocated (object%proc_num_id)) deallocate (object%proc_num_id) if (object%writing) then write (msg_buffer, "(A,A,A)") "Events: closing HepMC file '", & char (object%filename), "'" call msg_message () call hepmc_iostream_close (object%iostream) object%writing = .false. else if (object%reading) then write (msg_buffer, "(A,A,A)") "Events: closing HepMC file '", & char (object%filename), "'" call msg_message () call hepmc_iostream_close (object%iostream) object%reading = .false. end if end subroutine eio_hepmc_final @ %def eio_hepmc_final @ Split event file: increment the counter, close the current file, open a new one. If the file needs a header, repeat it for the new file. <>= procedure :: split_out => eio_hepmc_split_out <>= module subroutine eio_hepmc_split_out (eio) class(eio_hepmc_t), intent(inout) :: eio end subroutine eio_hepmc_split_out <>= module subroutine eio_hepmc_split_out (eio) class(eio_hepmc_t), intent(inout) :: eio if (eio%split) then eio%split_index = eio%split_index + 1 call eio%set_filename () write (msg_buffer, "(A,A,A)") "Events: writing to HepMC file '", & char (eio%filename), "'" call msg_message () call hepmc_iostream_close (eio%iostream) call hepmc_iostream_open_out (eio%iostream, & eio%filename, eio%hepmc3_mode) end if end subroutine eio_hepmc_split_out @ %def eio_hepmc_split_out @ Common initialization for input and output. <>= procedure :: common_init => eio_hepmc_common_init <>= module subroutine eio_hepmc_common_init (eio, sample, data, extension) class(eio_hepmc_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data end subroutine eio_hepmc_common_init <>= module subroutine eio_hepmc_common_init (eio, sample, data, extension) class(eio_hepmc_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data if (.not. present (data)) & call msg_bug ("HepMC initialization: missing data") eio%data = data ! We could relax this condition now with weighted hepmc events if (data%unweighted) then select case (data%norm_mode) case (NORM_UNIT) case default; call msg_fatal & ("HepMC: normalization for unweighted events must be '1'") end select end if eio%sample = sample if (present (extension)) then eio%extension = extension end if call eio%set_filename () allocate (eio%proc_num_id (data%n_proc), source = data%proc_num_id) end subroutine eio_hepmc_common_init @ %def eio_hepmc_common_init @ Initialize event writing. <>= procedure :: init_out => eio_hepmc_init_out <>= module subroutine eio_hepmc_init_out (eio, sample, data, success, extension) class(eio_hepmc_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success end subroutine eio_hepmc_init_out <>= module subroutine eio_hepmc_init_out (eio, sample, data, success, extension) class(eio_hepmc_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success call eio%set_splitting (data) call eio%common_init (sample, data, extension) write (msg_buffer, "(A,A,A)") "Events: writing to HepMC file '", & char (eio%filename), "'" call msg_message () eio%writing = .true. call hepmc_iostream_open_out (eio%iostream, & eio%filename, eio%hepmc3_mode) if (present (success)) success = .true. end subroutine eio_hepmc_init_out @ %def eio_hepmc_init_out @ Initialize event reading. For input, we do not (yet) support split event files. <>= procedure :: init_in => eio_hepmc_init_in <>= module subroutine eio_hepmc_init_in (eio, sample, data, success, extension) class(eio_hepmc_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success end subroutine eio_hepmc_init_in <>= module subroutine eio_hepmc_init_in (eio, sample, data, success, extension) class(eio_hepmc_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success logical :: exist eio%split = .false. call eio%common_init (sample, data, extension) write (msg_buffer, "(A,A,A)") "Events: reading from HepMC file '", & char (eio%filename), "'" call msg_message () inquire (file = char (eio%filename), exist = exist) if (.not. exist) call msg_fatal ("Events: HepMC file not found.") eio%reading = .true. call hepmc_iostream_open_in (eio%iostream, & eio%filename, eio%hepmc3_mode) if (present (success)) success = .true. end subroutine eio_hepmc_init_in @ %def eio_hepmc_init_in @ Switch from input to output: reopen the file for reading. <>= procedure :: switch_inout => eio_hepmc_switch_inout <>= module subroutine eio_hepmc_switch_inout (eio, success) class(eio_hepmc_t), intent(inout) :: eio logical, intent(out), optional :: success end subroutine eio_hepmc_switch_inout <>= module subroutine eio_hepmc_switch_inout (eio, success) class(eio_hepmc_t), intent(inout) :: eio logical, intent(out), optional :: success call msg_bug ("HepMC: in-out switch not supported") if (present (success)) success = .false. end subroutine eio_hepmc_switch_inout @ %def eio_hepmc_switch_inout @ Output an event to the allocated HepMC output stream. For the moment, we set [[alpha_qed]] always to -1. There should be methods for the handling of $\alpha$ in [[me_methods]] in the same way as for $\alpha_s$. If an [[event_handle]] is in the argument list, and it is of the correct HepMC type, do not destroy the event but transfer it there (i.e., the enclosed C pointer). <>= procedure :: output => eio_hepmc_output <>= module subroutine eio_hepmc_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_hepmc_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_hepmc_output <>= module subroutine eio_hepmc_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_hepmc_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle type(particle_set_t), pointer :: pset_ptr if (present (passed)) then if (.not. passed) return end if if (eio%writing) then pset_ptr => event%get_particle_set_ptr () call hepmc_event_init (eio%hepmc_event, & proc_id = eio%proc_num_id(i_prc), & event_id = event%get_index ()) if (eio%output_cross_section .and. eio%data%n_beam == 2) then call hepmc_event_from_particle_set (eio%hepmc_event, pset_ptr, & eio%data%cross_section(i_prc), eio%data%error(i_prc), & color = eio%hepmc3_flows) else call hepmc_event_from_particle_set (eio%hepmc_event, pset_ptr, & color = eio%hepmc3_flows) end if call hepmc_event_set_scale (eio%hepmc_event, event%get_fac_scale ()) call hepmc_event_set_alpha_qcd (eio%hepmc_event, event%get_alpha_s ()) call hepmc_event_set_alpha_qed (eio%hepmc_event, -1._default) if (.not. eio%data%unweighted .or. eio%data%negative_weights) then select case (eio%data%norm_mode) case (NORM_UNIT,NORM_N_EVT) call hepmc_event_add_weight & (eio%hepmc_event, event%weight_prc, .false.) case default call hepmc_event_add_weight & (eio%hepmc_event, event%weight_prc, .true.) end select end if call hepmc_iostream_write_event (eio%iostream, & eio%hepmc_event, eio%hepmc3_mode) call maybe_transfer_event_to_handle (eio%hepmc_event, event_handle) call hepmc_event_final (eio%hepmc_event) else call eio%write () call msg_fatal ("HepMC file is not open for writing") end if end subroutine eio_hepmc_output @ %def eio_hepmc_output @ Input an event. <>= procedure :: input_i_prc => eio_hepmc_input_i_prc procedure :: input_event => eio_hepmc_input_event <>= module subroutine eio_hepmc_input_i_prc (eio, i_prc, iostat) class(eio_hepmc_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat end subroutine eio_hepmc_input_i_prc module subroutine eio_hepmc_input_event (eio, event, iostat, event_handle) class(eio_hepmc_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_hepmc_input_event <>= module subroutine eio_hepmc_input_i_prc (eio, i_prc, iostat) class(eio_hepmc_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat logical :: ok integer :: i, proc_num_id iostat = 0 call hepmc_event_init (eio%hepmc_event) call hepmc_iostream_read_event (eio%iostream, & eio%hepmc_event, ok=ok) proc_num_id = hepmc_event_get_process_id (eio%hepmc_event) if (.not. ok) then iostat = -1 return end if i_prc = 0 FIND_I_PRC: do i = 1, size (eio%proc_num_id) if (eio%proc_num_id(i) == proc_num_id) then i_prc = i exit FIND_I_PRC end if end do FIND_I_PRC if (i_prc == 0) call err_index contains subroutine err_index call msg_error ("HepMC: reading events: undefined process ID " & // char (str (proc_num_id)) // ", aborting read") iostat = 1 end subroutine err_index end subroutine eio_hepmc_input_i_prc module subroutine eio_hepmc_input_event (eio, event, iostat, event_handle) class(eio_hepmc_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle iostat = 0 call event%reset_contents () call event%select (1, 1, 1) call hepmc_to_event (event, eio%hepmc_event, & eio%fallback_model, & recover_beams = eio%recover_beams, & use_alpha_s = eio%use_alphas_from_file, & use_scale = eio%use_scale_from_file) call maybe_transfer_event_to_handle (eio%hepmc_event, event_handle) call hepmc_event_final (eio%hepmc_event) end subroutine eio_hepmc_input_event @ %def eio_hepmc_input_i_prc @ %def eio_hepmc_input_event @ If an [[event_handle]] is in the argument list, and it is of the correct HepMC type, do not destroy the event but transfer it to the handle (i.e., the enclosed C pointer). Nullify the original pointer, so the event does not get destroyed. <>= subroutine maybe_transfer_event_to_handle (hepmc_event, event_handle) type(hepmc_event_t), intent(inout) :: hepmc_event class(event_handle_t), intent(inout), optional :: event_handle if (present (event_handle)) then select type (event_handle) type is (hepmc_event_t) call hepmc_event_final (event_handle) ! just in case event_handle = hepmc_event call hepmc_event_nullify (hepmc_event) ! avoid destructor call end select end if end subroutine maybe_transfer_event_to_handle @ %def transfer_event_to_handle @ <>= procedure :: skip => eio_hepmc_skip <>= module subroutine eio_hepmc_skip (eio, iostat) class(eio_hepmc_t), intent(inout) :: eio integer, intent(out) :: iostat end subroutine eio_hepmc_skip <>= module subroutine eio_hepmc_skip (eio, iostat) class(eio_hepmc_t), intent(inout) :: eio integer, intent(out) :: iostat iostat = 0 end subroutine eio_hepmc_skip @ %def eio_hepmc_skip @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_hepmc_ut.f90]]>>= <> module eio_hepmc_ut use unit_tests use system_dependencies, only: HEPMC2_AVAILABLE use system_dependencies, only: HEPMC3_AVAILABLE use eio_hepmc_uti <> <> contains <> end module eio_hepmc_ut @ %def eio_hepmc_ut @ <<[[eio_hepmc_uti.f90]]>>= <> module eio_hepmc_uti <> <> use system_dependencies, only: HEPMC2_AVAILABLE use system_dependencies, only: HEPMC3_AVAILABLE use io_units use diagnostics use model_data use event_base use eio_data use eio_base use eio_hepmc use eio_base_ut, only: eio_prepare_test, eio_cleanup_test use eio_base_ut, only: eio_prepare_fallback_model, eio_cleanup_fallback_model <> <> contains <> end module eio_hepmc_uti @ %def eio_hepmc_ut @ API: driver for the unit tests below. <>= public :: eio_hepmc_test <>= subroutine eio_hepmc_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_hepmc_test @ %def eio_hepmc_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= if (HEPMC2_AVAILABLE) then call test (eio_hepmc_1, "eio_hepmc2_1", & "write event contents", & u, results) else if (HEPMC3_AVAILABLE) then call test (eio_hepmc_1, "eio_hepmc3_1", & "write event contents", & u, results) end if <>= public :: eio_hepmc_1 <>= subroutine eio_hepmc_1 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(116) :: buffer write (u, "(A)") "* Test output: eio_hepmc_1" write (u, "(A)") "* Purpose: write a HepMC file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted=.false.) call data%init (1) data%n_beam = 2 data%unweighted = .true. data%norm_mode = NORM_UNIT data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_hepmc_1" allocate (eio_hepmc_t :: eio) select type (eio) type is (eio_hepmc_t) call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%set_index (55) call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents (blanking out last two digits):" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".hepmc"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (iostat /= 0) exit if (trim (buffer) == "") cycle if (buffer(1:14) == "HepMC::Version") cycle if (HEPMC2_AVAILABLE) then if (buffer(1:10) == "P 10001 25") & call buffer_blanker (buffer, 32, 55, 78) if (buffer(1:10) == "P 10002 25") & call buffer_blanker (buffer, 33, 56, 79) if (buffer(1:10) == "P 10003 25") & call buffer_blanker (buffer, 29, 53, 78, 101) if (buffer(1:10) == "P 10004 25") & call buffer_blanker (buffer, 28, 51, 76, 99) else if (HEPMC3_AVAILABLE) then if (buffer(1:8) == "P 1 0 25") & call buffer_blanker (buffer, 26, 49, 72) if (buffer(1:8) == "P 2 0 25") & call buffer_blanker (buffer, 26, 49, 73) if (buffer(1:9) == "P 3 -1 25") & call buffer_blanker (buffer, 28, 52, 75) if (buffer(1:9) == "P 4 -1 25") & call buffer_blanker (buffer, 27, 50, 73) end if write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_hepmc_t :: eio) select type (eio) type is (eio_hepmc_t) call eio%set_parameters () end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_hepmc_1" contains subroutine buffer_blanker (buf, pos1, pos2, pos3, pos4) character(len=*), intent(inout) :: buf integer, intent(in) :: pos1, pos2, pos3 integer, intent(in), optional :: pos4 type(string_t) :: line line = var_str (trim (buf)) line = replace (line, pos1, "XX") line = replace (line, pos2, "XX") line = replace (line, pos3, "XX") if (present (pos4)) then line = replace (line, pos4, "XX") end if line = replace (line, "4999999999999", "5000000000000") buf = char (line) end subroutine buffer_blanker end subroutine eio_hepmc_1 @ %def eio_hepmc_1 @ Test also the reading of HepMC events. <>= if (HEPMC2_AVAILABLE) then call test (eio_hepmc_2, "eio_hepmc2_2", & "read event contents", & u, results) else if (HEPMC3_AVAILABLE) then call test (eio_hepmc_2, "eio_hepmc3_2", & "read event contents", & u, results) end if <>= public :: eio_hepmc_2 <>= subroutine eio_hepmc_2 (u) integer, intent(in) :: u class(model_data_t), pointer :: fallback_model class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat, i_prc write (u, "(A)") "* Test output: eio_hepmc_2" write (u, "(A)") "* Purpose: read a HepMC event" write (u, "(A)") write (u, "(A)") "* Write a HepMC data file" write (u, "(A)") u_file = free_unit () sample = "eio_hepmc_2" open (u_file, file = char (sample // ".hepmc"), & status = "replace", action = "readwrite") if (HEPMC2_AVAILABLE) then write (u_file, "(A)") "HepMC::Version 2.06.09" write (u_file, "(A)") "HepMC::IO_GenEvent-START_EVENT_LISTING" write (u_file, "(A)") "E 66 -1 -1.0000000000000000e+00 & &-1.0000000000000000e+00 & &-1.0000000000000000e+00 42 0 1 10001 10002 0 0" write (u_file, "(A)") "U GEV MM" write (u_file, "(A)") "V -1 0 0 0 0 0 2 2 0" write (u_file, "(A)") "P 10001 25 0 0 4.8412291827592713e+02 & &5.0000000000000000e+02 & &1.2499999999999989e+02 3 0 0 -1 0" write (u_file, "(A)") "P 10002 25 0 0 -4.8412291827592713e+02 & &5.0000000000000000e+02 & &1.2499999999999989e+02 3 0 0 -1 0" write (u_file, "(A)") "P 10003 25 -1.4960220911365536e+02 & &-4.6042825611414656e+02 & &0 5.0000000000000000e+02 1.2500000000000000e+02 1 0 0 0 0" write (u_file, "(A)") "P 10004 25 1.4960220911365536e+02 & &4.6042825611414656e+02 & &0 5.0000000000000000e+02 1.2500000000000000e+02 1 0 0 0 0" write (u_file, "(A)") "HepMC::IO_GenEvent-END_EVENT_LISTING" else if (HEPMC3_AVAILABLE) then write (u_file, "(A)") "HepMC::Version 3.01.01" write (u_file, "(A)") "HepMC::Asciiv3-START_EVENT_LISTING" write (u_file, "(A)") "E 55 1 4" write (u_file, "(A)") "U GEV MM" write (u_file, "(A)") "A 0 alphaQCD -1" write (u_file, "(A)") "A 0 event_scale 1000" write (u_file, "(A)") "A 0 signal_process_id 42" write (u_file, "(A)") "P 1 0 25 0.0000000000000000e+00 & &0.0000000000000000e+00 4.8412291827592713e+02 & &5.0000000000000000e+02 1.2499999999999989e+02 3" write (u_file, "(A)") "P 2 0 25 0.0000000000000000e+00 & &0.0000000000000000e+00 -4.8412291827592713e+02 & &5.0000000000000000e+02 1.2499999999999989e+02 3" write (u_file, "(A)") "V -1 0 [1,2]" write (u_file, "(A)") "P 3 -1 25 -1.4960220911365536e+02 & &-4.6042825611414656e+02 0.0000000000000000e+00 & &5.0000000000000000e+02 1.2500000000000000e+02 1" write (u_file, "(A)") "P 4 -1 25 1.4960220911365536e+02 & &4.6042825611414656e+02 0.0000000000000000e+00 & &5.0000000000000000e+02 1.2500000000000000e+02 1" write (u_file, "(A)") "HepMC::Asciiv3-END_EVENT_LISTING" else call msg_fatal & ("Trying to execute eio_hepmc unit tests without a linked HepMC") end if close (u_file) write (u, "(A)") "* Initialize test process" write (u, "(A)") allocate (fallback_model) call eio_prepare_fallback_model (fallback_model) call eio_prepare_test (event, unweighted=.false.) allocate (eio_hepmc_t :: eio) select type (eio) type is (eio_hepmc_t) call eio%set_parameters (recover_beams = .false.) end select call eio%set_fallback_model (fallback_model) call data%init (1) data%n_beam = 2 data%unweighted = .true. data%norm_mode = NORM_UNIT data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] call data%write (u) write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") call eio%init_in (sample, data) call eio%write (u) write (u, "(A)") write (u, "(A)") "* Read event" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) select type (eio) type is (eio_hepmc_t) write (u, "(A,I0,A,I0)") "Found process #", i_prc, & " with ID = ", eio%proc_num_id(i_prc) end select call eio%input_event (event, iostat) call event%write (u) write (u, "(A)") write (u, "(A)") "* Read closing" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) write (u, "(A,I0)") "iostat = ", iostat write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call eio_cleanup_test (event) call eio_cleanup_fallback_model (fallback_model) deallocate (fallback_model) write (u, "(A)") write (u, "(A)") "* Test output end: eio_hepmc_2" end subroutine eio_hepmc_2 @ %def eio_hepmc_2 @ Test also the correct normalization of weighted HepMC events. <>= if (HEPMC2_AVAILABLE) then call test (eio_hepmc_3, "eio_hepmc2_3", & "write event contents", & u, results) else if (HEPMC3_AVAILABLE) then call test (eio_hepmc_3, "eio_hepmc3_3", & "event contents weighted, '1' normalization", & u, results) end if <>= public :: eio_hepmc_3 <>= subroutine eio_hepmc_3 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: u_file, iostat character(126) :: buffer write (u, "(A)") "* Test output: eio_hepmc_3" write (u, "(A)") "* Purpose: test correct HepMC normalization" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event, unweighted=.false., & sample_norm = var_str ("1")) call data%init (1) data%n_beam = 2 data%unweighted = .false. data%norm_mode = NORM_UNIT data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 20 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_hepmc_3" allocate (eio_hepmc_t :: eio) select type (eio) type is (eio_hepmc_t) call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%set_index (55) call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* File contents (blanking out last two digits):" write (u, "(A)") u_file = free_unit () open (u_file, file = char (sample // ".hepmc"), & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (iostat /= 0) exit if (trim (buffer) == "") cycle if (buffer(1:14) == "HepMC::Version") cycle if (HEPMC2_AVAILABLE) then if (buffer(1:4) == "E 55") then buffer = replace (buffer, 113, "XXXXXXXXX") end if if (buffer(1:10) == "P 10001 25") & call buffer_blanker (buffer, 32, 55, 78) if (buffer(1:10) == "P 10002 25") & call buffer_blanker (buffer, 33, 56, 79) if (buffer(1:10) == "P 10003 25") & call buffer_blanker (buffer, 29, 53, 78, 101) if (buffer(1:10) == "P 10004 25") & call buffer_blanker (buffer, 28, 51, 76, 99) else if (HEPMC3_AVAILABLE) then if (buffer(1:4) == "W 3.") then buffer = replace (buffer, 11, "XXXXXXXXXXXXXXXX") end if if (buffer(1:8) == "P 1 0 25") & call buffer_blanker (buffer, 26, 49, 72, 118) if (buffer(1:8) == "P 2 0 25") & call buffer_blanker (buffer, 26, 49, 73, 119) if (buffer(1:9) == "P 3 -1 25") & call buffer_blanker (buffer, 28, 52, 75, 121) if (buffer(1:9) == "P 4 -1 25") & call buffer_blanker (buffer, 27, 50, 73, 119) end if write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_hepmc_t :: eio) select type (eio) type is (eio_hepmc_t) call eio%set_parameters () end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_hepmc_3" contains subroutine buffer_blanker (buf, pos1, pos2, pos3, pos4) character(len=*), intent(inout) :: buf integer, intent(in) :: pos1, pos2, pos3 integer, intent(in), optional :: pos4 type(string_t) :: line line = var_str (trim (buf)) line = replace (line, pos1, "XX") line = replace (line, pos2, "XX") line = replace (line, pos3, "XX") if (present (pos4)) then line = replace (line, pos4, "XX") end if line = replace (line, "4999999999999", "5000000000000") buf = char (line) end subroutine buffer_blanker end subroutine eio_hepmc_3 @ %def eio_hepmc_3 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{LCIO Output} The LCIO event record is standardized for the use with Linear $e^+e^-$ colliders. It is a binary event format. We try our best at using it for both input and output. <<[[eio_lcio.f90]]>>= <> module eio_lcio <> <> use event_base use event_handles, only: event_handle_t use eio_data use eio_base use lcio_interface <> <> <> interface <> end interface end module eio_lcio @ %def eio_lcio @ <<[[eio_lcio_sub.f90]]>>= <> submodule (eio_lcio) eio_lcio_s use io_units use string_utils use diagnostics use particles use hep_events implicit none contains <> end submodule eio_lcio_s @ %def eio_lcio_s @ \subsection{Type} A type [[lcio_event]] is introduced as container to store LCIO event data, particularly for splitting the reading into read out of the process index and the proper event data. Note: the [[keep_beams]] flag is not supported. <>= public :: eio_lcio_t <>= type, extends (eio_t) :: eio_lcio_t logical :: writing = .false. logical :: reading = .false. type(event_sample_data_t) :: data logical :: recover_beams = .false. logical :: use_alphas_from_file = .false. logical :: use_scale_from_file = .false. logical :: proc_as_run_id = .true. integer :: n_alt = 0 integer :: lcio_run_id = 0 type(lcio_writer_t) :: lcio_writer type(lcio_reader_t) :: lcio_reader type(lcio_run_header_t) :: lcio_run_hdr type(lcio_event_t) :: lcio_event integer, dimension(:), allocatable :: proc_num_id contains <> end type eio_lcio_t @ %def eio_lcio_t @ \subsection{Specific Methods} Set parameters that are specifically used with LCIO. <>= procedure :: set_parameters => eio_lcio_set_parameters <>= module subroutine eio_lcio_set_parameters & (eio, recover_beams, use_alphas_from_file, use_scale_from_file, & extension, proc_as_run_id, lcio_run_id) class(eio_lcio_t), intent(inout) :: eio logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alphas_from_file logical, intent(in), optional :: use_scale_from_file logical, intent(in), optional :: proc_as_run_id integer, intent(in), optional :: lcio_run_id type(string_t), intent(in), optional :: extension end subroutine eio_lcio_set_parameters <>= module subroutine eio_lcio_set_parameters & (eio, recover_beams, use_alphas_from_file, use_scale_from_file, & extension, proc_as_run_id, lcio_run_id) class(eio_lcio_t), intent(inout) :: eio logical, intent(in), optional :: recover_beams logical, intent(in), optional :: use_alphas_from_file logical, intent(in), optional :: use_scale_from_file logical, intent(in), optional :: proc_as_run_id integer, intent(in), optional :: lcio_run_id type(string_t), intent(in), optional :: extension if (present (recover_beams)) eio%recover_beams = recover_beams if (present (use_alphas_from_file)) & eio%use_alphas_from_file = use_alphas_from_file if (present (use_scale_from_file)) & eio%use_scale_from_file = use_scale_from_file if (present (proc_as_run_id)) & eio%proc_as_run_id = proc_as_run_id if (present (lcio_run_id)) & eio%lcio_run_id = lcio_run_id if (present (extension)) then eio%extension = extension else eio%extension = "slcio" end if end subroutine eio_lcio_set_parameters @ %def eio_lcio_set_parameters @ \subsection{Common Methods} Output. This is not the actual event format, but a readable account of the current object status. <>= procedure :: write => eio_lcio_write <>= module subroutine eio_lcio_write (object, unit) class(eio_lcio_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine eio_lcio_write <>= module subroutine eio_lcio_write (object, unit) class(eio_lcio_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A)") "LCIO event stream:" if (object%writing) then write (u, "(3x,A,A)") "Writing to file = ", char (object%filename) else if (object%reading) then write (u, "(3x,A,A)") "Reading from file = ", char (object%filename) else write (u, "(3x,A)") "[closed]" end if write (u, "(3x,A,L1)") "Recover beams = ", object%recover_beams write (u, "(3x,A,L1)") "Alpha_s from file = ", & object%use_alphas_from_file write (u, "(3x,A,L1)") "Scale from file = ", & object%use_scale_from_file write (u, "(3x,A,L1)") "Process as run ID = ", & object%proc_as_run_id write (u, "(3x,A,I0)") "LCIO run ID = ", & object%lcio_run_id write (u, "(3x,A,A,A)") "File extension = '", & char (object%extension), "'" if (allocated (object%proc_num_id)) then write (u, "(3x,A)") "Numerical process IDs:" do i = 1, size (object%proc_num_id) write (u, "(5x,I0,': ',I0)") i, object%proc_num_id(i) end do end if end subroutine eio_lcio_write @ %def eio_lcio_write @ Finalizer: close any open file. <>= procedure :: final => eio_lcio_final <>= module subroutine eio_lcio_final (object) class(eio_lcio_t), intent(inout) :: object end subroutine eio_lcio_final <>= module subroutine eio_lcio_final (object) class(eio_lcio_t), intent(inout) :: object if (allocated (object%proc_num_id)) deallocate (object%proc_num_id) if (object%writing) then write (msg_buffer, "(A,A,A)") "Events: closing LCIO file '", & char (object%filename), "'" call msg_message () call lcio_writer_close (object%lcio_writer) object%writing = .false. else if (object%reading) then write (msg_buffer, "(A,A,A)") "Events: closing LCIO file '", & char (object%filename), "'" call msg_message () call lcio_reader_close (object%lcio_reader) object%reading = .false. end if end subroutine eio_lcio_final @ %def eio_lcio_final @ Split event file: increment the counter, close the current file, open a new one. If the file needs a header, repeat it for the new file. <>= procedure :: split_out => eio_lcio_split_out <>= module subroutine eio_lcio_split_out (eio) class(eio_lcio_t), intent(inout) :: eio end subroutine eio_lcio_split_out <>= module subroutine eio_lcio_split_out (eio) class(eio_lcio_t), intent(inout) :: eio if (eio%split) then eio%split_index = eio%split_index + 1 call eio%set_filename () write (msg_buffer, "(A,A,A)") "Events: writing to LCIO file '", & char (eio%filename), "'" call msg_message () call lcio_writer_close (eio%lcio_writer) call lcio_writer_open_out (eio%lcio_writer, eio%filename) end if end subroutine eio_lcio_split_out @ %def eio_lcio_split_out @ Common initialization for input and output. <>= procedure :: common_init => eio_lcio_common_init <>= module subroutine eio_lcio_common_init (eio, sample, data, extension) class(eio_lcio_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data end subroutine eio_lcio_common_init <>= module subroutine eio_lcio_common_init (eio, sample, data, extension) class(eio_lcio_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data if (.not. present (data)) & call msg_bug ("LCIO initialization: missing data") eio%data = data if (data%unweighted) then select case (data%norm_mode) case (NORM_UNIT) case default; call msg_fatal & ("LCIO: normalization for unweighted events must be '1'") end select else call msg_fatal ("LCIO: events must be unweighted") end if eio%n_alt = data%n_alt eio%sample = sample if (present (extension)) then eio%extension = extension end if call eio%set_filename () allocate (eio%proc_num_id (data%n_proc), source = data%proc_num_id) end subroutine eio_lcio_common_init @ %def eio_lcio_common_init @ Initialize event writing. <>= procedure :: init_out => eio_lcio_init_out <>= module subroutine eio_lcio_init_out & (eio, sample, data, success, extension) class(eio_lcio_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success end subroutine eio_lcio_init_out <>= module subroutine eio_lcio_init_out & (eio, sample, data, success, extension) class(eio_lcio_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(in), optional :: data logical, intent(out), optional :: success call eio%set_splitting (data) call eio%common_init (sample, data, extension) write (msg_buffer, "(A,A,A)") "Events: writing to LCIO file '", & char (eio%filename), "'" call msg_message () eio%writing = .true. call lcio_writer_open_out (eio%lcio_writer, eio%filename) call lcio_run_header_init (eio%lcio_run_hdr) call lcio_run_header_write (eio%lcio_writer, eio%lcio_run_hdr) if (present (success)) success = .true. end subroutine eio_lcio_init_out @ %def eio_lcio_init_out @ Initialize event reading. For input, we do not (yet) support split event files. <>= procedure :: init_in => eio_lcio_init_in <>= module subroutine eio_lcio_init_in (eio, sample, data, success, extension) class(eio_lcio_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success end subroutine eio_lcio_init_in <>= module subroutine eio_lcio_init_in (eio, sample, data, success, extension) class(eio_lcio_t), intent(inout) :: eio type(string_t), intent(in) :: sample type(string_t), intent(in), optional :: extension type(event_sample_data_t), intent(inout), optional :: data logical, intent(out), optional :: success logical :: exist eio%split = .false. call eio%common_init (sample, data, extension) write (msg_buffer, "(A,A,A)") "Events: reading from LCIO file '", & char (eio%filename), "'" call msg_message () inquire (file = char (eio%filename), exist = exist) if (.not. exist) call msg_fatal ("Events: LCIO file not found.") eio%reading = .true. call lcio_open_file (eio%lcio_reader, eio%filename) if (present (success)) success = .true. end subroutine eio_lcio_init_in @ %def eio_lcio_init_in @ Switch from input to output: reopen the file for reading. <>= procedure :: switch_inout => eio_lcio_switch_inout <>= module subroutine eio_lcio_switch_inout (eio, success) class(eio_lcio_t), intent(inout) :: eio logical, intent(out), optional :: success end subroutine eio_lcio_switch_inout <>= module subroutine eio_lcio_switch_inout (eio, success) class(eio_lcio_t), intent(inout) :: eio logical, intent(out), optional :: success call msg_bug ("LCIO: in-out switch not supported") if (present (success)) success = .false. end subroutine eio_lcio_switch_inout @ %def eio_lcio_switch_inout @ Output an event to the allocated LCIO writer. <>= procedure :: output => eio_lcio_output <>= module subroutine eio_lcio_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_lcio_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_lcio_output <>= module subroutine eio_lcio_output & (eio, event, i_prc, reading, passed, pacify, event_handle) class(eio_lcio_t), intent(inout) :: eio class(generic_event_t), intent(in), target :: event integer, intent(in) :: i_prc logical, intent(in), optional :: reading, passed, pacify class(event_handle_t), intent(inout), optional :: event_handle type(particle_set_t), pointer :: pset_ptr real(default) :: sqme_prc, weight real(default), dimension(:), allocatable :: pol integer :: i if (present (passed)) then if (.not. passed) return end if if (eio%writing) then pset_ptr => event%get_particle_set_ptr () if (eio%proc_as_run_id) then call lcio_event_init (eio%lcio_event, & proc_id = eio%proc_num_id (i_prc), & event_id = event%get_index (), & run_id = eio%proc_num_id (i_prc)) else call lcio_event_init (eio%lcio_event, & proc_id = eio%proc_num_id (i_prc), & event_id = event%get_index (), & run_id = eio%lcio_run_id) end if call lcio_event_from_particle_set (eio%lcio_event, pset_ptr) call lcio_event_set_weight (eio%lcio_event, event%weight_prc) call lcio_event_set_sqrts (eio%lcio_event, event%get_sqrts ()) call lcio_event_set_sqme (eio%lcio_event, event%get_sqme_prc ()) call lcio_event_set_scale (eio%lcio_event, event%get_fac_scale ()) call lcio_event_set_alpha_qcd (eio%lcio_event, event%get_alpha_s ()) if (eio%data%n_beam == 2) then call lcio_event_set_xsec (eio%lcio_event, eio%data%cross_section(i_prc), & eio%data%error(i_prc)) end if pol = event%get_polarization () do i = 1, eio%data%n_beam call lcio_event_set_polarization (eio%lcio_event, pol(i), i) end do call lcio_event_set_beam_file (eio%lcio_event, & event%get_beam_file ()) call lcio_event_set_process_name (eio%lcio_event, & event%get_process_name ()) do i = 1, eio%n_alt sqme_prc = event%get_sqme_alt(i) weight = event%get_weight_alt(i) call lcio_event_set_alt_sqme (eio%lcio_event, sqme_prc, i) call lcio_event_set_alt_weight (eio%lcio_event, weight, i) end do call lcio_event_write (eio%lcio_writer, eio%lcio_event) call maybe_transfer_event_to_handle (eio%lcio_event, & event_handle, .true.) call lcio_event_final (eio%lcio_event, .true.) else call eio%write () call msg_fatal ("LCIO file is not open for writing") end if end subroutine eio_lcio_output @ %def eio_lcio_output @ Input an event. [WK 22-04-21] We do no longer fix the [[i_mci]] and [[i_term]] indices to 1, this can now be done by [[simulation_recalculate]]. <>= procedure :: input_i_prc => eio_lcio_input_i_prc procedure :: input_event => eio_lcio_input_event <>= module subroutine eio_lcio_input_i_prc (eio, i_prc, iostat) class(eio_lcio_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat end subroutine eio_lcio_input_i_prc module subroutine eio_lcio_input_event (eio, event, iostat, event_handle) class(eio_lcio_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle end subroutine eio_lcio_input_event <>= module subroutine eio_lcio_input_i_prc (eio, i_prc, iostat) class(eio_lcio_t), intent(inout) :: eio integer, intent(out) :: i_prc integer, intent(out) :: iostat logical :: ok integer :: i, proc_num_id iostat = 0 call lcio_read_event (eio%lcio_reader, eio%lcio_event, ok) if (.not. ok) then iostat = -1 return end if proc_num_id = lcio_event_get_process_id (eio%lcio_event) i_prc = 0 FIND_I_PRC: do i = 1, size (eio%proc_num_id) if (eio%proc_num_id(i) == proc_num_id) then i_prc = i exit FIND_I_PRC end if end do FIND_I_PRC if (i_prc == 0) call err_index contains subroutine err_index call msg_error ("LCIO: reading events: undefined process ID " & // char (str (proc_num_id)) // ", aborting read") iostat = 1 end subroutine err_index end subroutine eio_lcio_input_i_prc module subroutine eio_lcio_input_event (eio, event, iostat, event_handle) class(eio_lcio_t), intent(inout) :: eio class(generic_event_t), intent(inout), target :: event integer, intent(out) :: iostat class(event_handle_t), intent(inout), optional :: event_handle iostat = 0 call event%reset_contents () call event%select (0, 0, 1) call event%set_index (lcio_event_get_event_index (eio%lcio_event)) call lcio_to_event (event, eio%lcio_event, eio%fallback_model, & recover_beams = eio%recover_beams, & use_alpha_s = eio%use_alphas_from_file, & use_scale = eio%use_scale_from_file) call maybe_transfer_event_to_handle (eio%lcio_event, & event_handle, .false.) call lcio_event_final (eio%lcio_event, .false.) end subroutine eio_lcio_input_event @ %def eio_lcio_input_i_prc @ %def eio_lcio_input_event @ If an [[event_handle]] is in the argument list, and it is of the correct HepMC type, do not destroy the event but transfer it to the handle (i.e., the enclosed C pointer). Nullify the original pointer, so the event does not get destroyed. <>= subroutine maybe_transfer_event_to_handle (lcio_event, event_handle, delete) type(lcio_event_t), intent(inout) :: lcio_event class(event_handle_t), intent(inout), optional :: event_handle logical, intent(in) :: delete if (present (event_handle)) then select type (event_handle) type is (lcio_event_t) call lcio_event_final (event_handle, delete) ! just in case event_handle = lcio_event call lcio_event_nullify (lcio_event) ! avoid destructor call end select end if end subroutine maybe_transfer_event_to_handle @ %def transfer_event_to_handle @ <>= procedure :: skip => eio_lcio_skip <>= module subroutine eio_lcio_skip (eio, iostat) class(eio_lcio_t), intent(inout) :: eio integer, intent(out) :: iostat end subroutine eio_lcio_skip <>= module subroutine eio_lcio_skip (eio, iostat) class(eio_lcio_t), intent(inout) :: eio integer, intent(out) :: iostat iostat = 0 end subroutine eio_lcio_skip @ %def eio_lcio_skip @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eio_lcio_ut.f90]]>>= <> module eio_lcio_ut use unit_tests use eio_lcio_uti <> <> contains <> end module eio_lcio_ut @ %def eio_lcio_ut @ <<[[eio_lcio_uti.f90]]>>= <> module eio_lcio_uti <> <> use io_units use model_data use particles use event_base use eio_data use eio_base use hep_events use lcio_interface use eio_lcio use eio_base_ut, only: eio_prepare_test, eio_cleanup_test use eio_base_ut, only: eio_prepare_fallback_model, eio_cleanup_fallback_model <> <> contains <> end module eio_lcio_uti @ %def eio_lcio_ut @ API: driver for the unit tests below. <>= public :: eio_lcio_test <>= subroutine eio_lcio_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_lcio_test @ %def eio_lcio_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_lcio_1, "eio_lcio_1", & "write event contents", & u, results) <>= public :: eio_lcio_1 <>= subroutine eio_lcio_1 (u) integer, intent(in) :: u class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(particle_set_t), pointer :: pset_ptr type(string_t) :: sample integer :: u_file, iostat character(215) :: buffer write (u, "(A)") "* Test output: eio_lcio_1" write (u, "(A)") "* Purpose: write a LCIO file" write (u, "(A)") write (u, "(A)") "* Initialize test process" call eio_prepare_test (event) call data%init (1) data%n_beam = 2 data%unweighted = .true. data%norm_mode = NORM_UNIT data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_lcio_1" allocate (eio_lcio_t :: eio) select type (eio) type is (eio_lcio_t) call eio%set_parameters () end select call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%set_index (77) call event%pacify_particle_set () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () write (u, "(A)") write (u, "(A)") "* Reset data" write (u, "(A)") deallocate (eio) allocate (eio_lcio_t :: eio) select type (eio) type is (eio_lcio_t) call eio%set_parameters () end select call eio%write (u) write (u, "(A)") write (u, "(A)") "* Write LCIO file contents to ASCII file" write (u, "(A)") select type (eio) type is (eio_lcio_t) call lcio_event_init (eio%lcio_event, & proc_id = 42, & event_id = event%get_index ()) pset_ptr => event%get_particle_set_ptr () call lcio_event_from_particle_set & (eio%lcio_event, pset_ptr) call write_lcio_event (eio%lcio_event, var_str ("test_file.slcio")) call lcio_event_final (eio%lcio_event, .true.) end select write (u, "(A)") write (u, "(A)") "* Read in ASCII contents of LCIO file" write (u, "(A)") u_file = free_unit () open (u_file, file = "test_file.slcio", & action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (iostat /= 0) exit if (trim (buffer) == "") cycle if (buffer(1:12) == " - timestamp") cycle if (buffer(1:6) == " date:") cycle write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" call eio_cleanup_test (event) write (u, "(A)") write (u, "(A)") "* Test output end: eio_lcio_1" end subroutine eio_lcio_1 @ %def eio_lcio_1 @ Test also the reading of LCIO events. <>= call test (eio_lcio_2, "eio_lcio_2", & "read event contents", & u, results) <>= public :: eio_lcio_2 <>= subroutine eio_lcio_2 (u) integer, intent(in) :: u class(model_data_t), pointer :: fallback_model class(generic_event_t), pointer :: event type(event_sample_data_t) :: data class(eio_t), allocatable :: eio type(string_t) :: sample integer :: iostat, i_prc write (u, "(A)") "* Test output: eio_lcio_2" write (u, "(A)") "* Purpose: read a LCIO event" write (u, "(A)") write (u, "(A)") "* Initialize test process" allocate (fallback_model) call eio_prepare_fallback_model (fallback_model) call eio_prepare_test (event) call data%init (1) data%n_beam = 2 data%unweighted = .true. data%norm_mode = NORM_UNIT data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] data%cross_section(1) = 100 data%error(1) = 1 data%total_cross_section = sum (data%cross_section) write (u, "(A)") write (u, "(A)") "* Generate and write an event" write (u, "(A)") sample = "eio_lcio_2" allocate (eio_lcio_t :: eio) select type (eio) type is (eio_lcio_t) call eio%set_parameters (recover_beams = .false.) end select call eio%set_fallback_model (fallback_model) call eio%init_out (sample, data) call event%generate (1, [0._default, 0._default]) call event%set_index (88) call event%evaluate_expressions () call event%pacify_particle_set () call eio%output (event, i_prc = 1) call eio%write (u) call eio%final () deallocate (eio) call event%reset_contents () call event%reset_index () write (u, "(A)") write (u, "(A)") "* Initialize" write (u, "(A)") allocate (eio_lcio_t :: eio) select type (eio) type is (eio_lcio_t) call eio%set_parameters (recover_beams = .false.) end select call eio%set_fallback_model (fallback_model) call data%init (1) data%n_beam = 2 data%unweighted = .true. data%norm_mode = NORM_UNIT data%pdg_beam = 25 data%energy_beam = 500 data%proc_num_id = [42] call data%write (u) write (u, *) write (u, "(A)") "* Initialize" write (u, "(A)") call eio%init_in (sample, data) call eio%write (u) write (u, "(A)") write (u, "(A)") "* Read event" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) select type (eio) type is (eio_lcio_t) write (u, "(A,I0,A,I0)") "Found process #", i_prc, & " with ID = ", eio%proc_num_id(i_prc) end select call eio%input_event (event, iostat) call event%select (1, 1, 1) call event%write (u) write (u, "(A)") write (u, "(A)") "* Read closing" write (u, "(A)") call eio%input_i_prc (i_prc, iostat) write (u, "(A,I0)") "iostat = ", iostat write (u, "(A)") write (u, "(A)") "* Cleanup" call eio%final () call eio_cleanup_test (event) call eio_cleanup_fallback_model (fallback_model) deallocate (fallback_model) write (u, "(A)") write (u, "(A)") "* Test output end: eio_lcio_2" end subroutine eio_lcio_2 @ %def eio_lcio_2 Index: trunk/omega/share/doc/noweb.sty =================================================================== --- trunk/omega/share/doc/noweb.sty (revision 8914) +++ trunk/omega/share/doc/noweb.sty (revision 8915) @@ -1,927 +1,976 @@ % noweb.sty -- LaTeX support for noweb % DON'T read or edit this file! Use ...noweb-source/tex/support.nw instead. {\obeyspaces\AtBeginDocument{\global\let =\ }} % from texbook, p 381 \def\nwopt@nomargintag{\let\nwmargintag=\@gobble} \def\nwopt@margintag{% \def\nwmargintag##1{\leavevmode\llap{##1\kern\nwmarginglue\kern\codemargin}}} \def\nwopt@margintag{% \def\nwmargintag##1{\leavevmode\kern-\codemargin\nwthemargintag{##1}\kern\codemargin}} \def\nwthemargintag#1{\llap{#1\kern\nwmarginglue}} \nwopt@margintag \newdimen\nwmarginglue \nwmarginglue=0.3in \def\nwtagstyle{\footnotesize\Rm} +\def\nwgitversion{|GITVERSION|} % make \hsize in code sufficient for 88 columns -\setbox0=\hbox{\tt m} +\ifx\ttfamily\undefined + \setbox0=\hbox{\tt m} +\else + \setbox0=\hbox{\ttfamily m} +\fi \newdimen\codehsize \codehsize=91\wd0 % 88 columns wasn't enough; I don't know why \newdimen\codemargin \codemargin=0pt \newdimen\nwdefspace \nwdefspace=\codehsize % need to use \textwidth in {\LaTeX} to handle styles with % non-standard margins (David Bruce). Don't know why we sometimes % wanted \hsize. 27 August 1997. %% \advance\nwdefspace by -\hsize\relax \ifx\textwidth\undefined \advance\nwdefspace by -\hsize\relax \else \advance\nwdefspace by -\textwidth\relax \fi \chardef\other=12 \def\setupcode{% \chardef\\=`\\ \chardef\{=`\{ \chardef\}=`\} \catcode`\$=\other \catcode`\&=\other \catcode`\#=\other \catcode`\%=\other \catcode`\~=\other \catcode`\_=\other \catcode`\^=\other \catcode`\"=\other % fixes problem with german.sty \obeyspaces\Tt } -\let\nwlbrace=\{ -\let\nwrbrace=\} \def\nwendquote{\relax\ifhmode\spacefactor=1000 \fi} {\catcode`\^^M=\active % make CR an active character \gdef\newlines{\catcode`\^^M=\active % make CR an active character \def^^M{\par\startline}}% \gdef\eatline#1^^M{\relax}% } %%% DON'T \gdef^^M{\par\startline}}% in case ^^M appears in a \write \def\startline{\noindent\hskip\parindent\ignorespaces} \def\nwnewline{\ifvmode\else\hfil\break\leavevmode\hbox{}\fi} \def\setupmodname{% \catcode`\$=3 \catcode`\&=4 \catcode`\#=6 \catcode`\%=14 \catcode`\~=13 \catcode`\_=8 \catcode`\^=7 \catcode`\ =10 \catcode`\^^M=5 - \let\{\nwlbrace - \let\}\nwrbrace + \let\{\lbrace + \let\}\rbrace % bad news --- don't know what catcode to give " \Rm} \def\LA{\begingroup\maybehbox\bgroup\setupmodname\It$\langle$} \def\RA{\/$\rangle$\egroup\endgroup} \def\code{\leavevmode\begingroup\setupcode\newlines} \def\edoc{\endgroup} \let\maybehbox\relax \newbox\equivbox \setbox\equivbox=\hbox{$\equiv$} \newbox\plusequivbox \setbox\plusequivbox=\hbox{$\mathord{+}\mathord{\equiv}$} % \moddef can't have an argument because there might be \code...\edoc \def\moddef{\leavevmode\kern-\codemargin\LA} \def\endmoddef{\RA\ifmmode\equiv\else\unhcopy\equivbox\fi \nobreak\hfill\nobreak} \def\plusendmoddef{\RA\ifmmode\mathord{+}\mathord{\equiv}\else\unhcopy\plusequivbox\fi \nobreak\hfill\nobreak} \def\chunklist{% \errhelp{I changed \chunklist to \nowebchunks. I'll try to avoid such incompatible changes in the future.}% \errmessage{Use \string\nowebchunks\space instead of \string\chunklist}} \def\nowebchunks{\message{}} \def\nowebindex{\message{}} % here is support for the new-style (capitalized) font-changing commands % thanks to Dave Love \ifx\documentstyle\undefined \let\Rm=\rm \let\It=\it \let\Tt=\tt % plain \else\ifx\selectfont\undefined \let\Rm=\rm \let\It=\it \let\Tt=\tt % LaTeX OFSS \else % LaTeX NFSS - \def\Rm{\reset@font\rm} - \def\It{\reset@font\it} - \def\Tt{\reset@font\tt} - \def\Bf{\reset@font\bf} + \def\Rm{\reset@font\rmfamily} + \def\It{\reset@font\itshape} + \def\Tt{\reset@font\ttfamily} + \def\Bf{\reset@font\bfseries} \fi\fi \ifx\reset@font\undefined \let\reset@font=\relax \fi +\def\nwbackslash{\char92} +\def\nwlbrace{\char123} +\def\nwrbrace{\char125} \def\noweboptions#1{% \def\@nwoptionlist{#1}% \@for\@nwoption:=\@nwoptionlist\do{% \@ifundefined{nwopt@\@nwoption}{% \@latexerr{There is no such noweb option as '\@nwoption'}\@eha}{% \csname nwopt@\@nwoption\endcsname}}} \codemargin=10pt \advance\codehsize by \codemargin % make room for indentation of code \advance\nwdefspace by \codemargin % and fix adjustment for def/use \def\setcodemargin#1{% \advance\codehsize by -\codemargin % make room for indentation of code \advance\nwdefspace by -\codemargin % and fix adjustment for def/use \codemargin=#1 \advance\codehsize by \codemargin % make room for indentation of code \advance\nwdefspace by \codemargin % and fix adjustment for % def/use } \def\nwopt@shift{% \dimen@=-0.8in \if@twoside % Values for two-sided printing: \advance\evensidemargin by \dimen@ \else % Values for one-sided printing: \advance\evensidemargin by \dimen@ \advance\oddsidemargin by \dimen@ \fi % \advance \marginparwidth -\dimen@ } \let\nwopt@noshift\@empty \def\nwbegincode#1{% \begingroup \topsep \nwcodetopsep \@beginparpenalty \@highpenalty \@endparpenalty -\@highpenalty \@begincode } \def\nwendcode{\endtrivlist \endgroup \filbreak} % keeps code on 1 page \newenvironment{webcode}{% \@begincode }{% \endtrivlist} +\newdimen\@nwbegincodelinewidth \def\@begincode{% + \@nwbegincodelinewidth=\linewidth \trivlist \item[]% \leftskip\@totalleftmargin \advance\leftskip\codemargin \rightskip\hsize \advance\rightskip -\codehsize \parskip\z@ \parindent\z@ \parfillskip\@flushglue \linewidth\codehsize \@@par \def\par{\leavevmode\null \@@par \penalty\nwcodepenalty}% \obeylines + \nowebsize \setupcode \@noligs \ifx\verbatim@nolig@list\undefined\else \let\do=\nw@makeother \verbatim@nolig@list \do@noligs\` \fi \setupcode \frenchspacing \@vobeyspaces - \nowebsize \setupcode \let\maybehbox\mbox } \newskip\nwcodetopsep \nwcodetopsep = 3pt plus 1.2pt minus 1pt \let\nowebsize=\normalsize \def\nwopt@tinycode{\let\nowebsize=\tiny} \def\nwopt@footnotesizecode{\let\nowebsize=\footnotesize} \def\nwopt@scriptsizecode{\let\nowebsize=\scriptsize} \def\nwopt@smallcode{\let\nowebsize=\small} \def\nwopt@normalsizecode{\let\nowebsize=\normalsize} \def\nwopt@largecode{\let\nowebsize=\large} \def\nwopt@Largecode{\let\nowebsize=\Large} \def\nwopt@LARGEcode{\let\nowebsize=\LARGE} \def\nwopt@hugecode{\let\nowebsize=\huge} \def\nwopt@Hugecode{\let\nowebsize=\Huge} \newcount\nwcodepenalty \nwcodepenalty=\@highpenalty \def\nw@makeother#1{\catcode`#1=12 } \def\nwbegindocs#1{\ifvmode\noindent\fi} \let\nwenddocs=\relax \let\nwdocspar=\filbreak \def\@nwsemifilbreak#1{\vskip0pt plus#1\penalty-200\vskip0pt plus -#1} \newdimen\nwbreakcodespace \nwbreakcodespace=0.2in % by default, leave no more than this on a page \def\nwopt@breakcode{% \def\nwdocspar{\@nwsemifilbreak{0.2in}}% \def\nwendcode{\endtrivlist\endgroup} % ditches filbreak } \raggedbottom \def\code{\leavevmode\begingroup\setupcode\@vobeyspaces\obeylines} \let\edoc=\endgroup \newdimen\@original@textwidth \def\ps@noweb{% \@original@textwidth=\textwidth \let\@mkboth\@gobbletwo \def\@oddfoot{}\def\@evenfoot{}% No feet. \if@twoside % If two-sided printing. \def\@evenhead{\hbox to \@original@textwidth{% \Rm \thepage\qquad{\Tt\leftmark}\hfil\today}}% Left heading. \def\@oddhead{\hbox to \@original@textwidth{% \Rm \today\hfil{\Tt\leftmark}\qquad\thepage}}% Right heading. \else % If one-sided printing. \def\@oddhead{\hbox to \@original@textwidth{% \Rm \today\hfil{\Tt\leftmark}\qquad\thepage}}% Right heading. \let\@evenhead\@oddhead \fi \let\chaptermark\@gobble \let\sectionmark\@gobble \let\subsectionmark\@gobble \let\subsubsectionmark\@gobble \let\paragraphmark\@gobble \let\subparagraphmark\@gobble \def\nwfilename{\begingroup\let\do\@makeother\dospecials \catcode`\{=1 \catcode`\}=2 \nw@filename} \def\nw@filename##1{\endgroup\markboth{##1}{##1}\let\nw@filename=\nw@laterfilename}% } \def\nw@laterfilename#1{\endgroup\clearpage \markboth{#1}{#1}} \let\nwfilename=\@gobble \def\nwcodecomment#1{\@@par\penalty\nwcodepenalty \if@firstnwcodecomment \vskip\nwcodecommentsep\penalty\nwcodepenalty\@firstnwcodecommentfalse \fi% \hspace{-\codemargin}{% \rightskip=0pt plus1in \interlinepenalty\nwcodepenalty \let\\\relax\footnotesize\Rm #1\@@par\penalty\nwcodepenalty}} \def\@nwalsodefined#1{\nwcodecomment{\@nwlangdepdef\ \nwpageprep\ \@pagesl{#1}.}} \def\@nwused#1{\nwcodecomment{\@nwlangdepcud\ \nwpageprep\ \@pagesl{#1}.}} \def\@nwnotused#1{\nwcodecomment{\@nwlangdeprtc.}} \def\nwoutput#1{\nwcodecomment{\@nwlangdepcwf\ {\Tt \@stripstar#1*\stripped}.}} \def\@stripstar#1*#2\stripped{#1} \newcommand{\nwprevdefptr}[1]{% \mbox{$\mathord{\triangleleft}\,\mathord{\mbox{\subpageref{#1}}}$}} \newcommand{\nwnextdefptr}[1]{% \mbox{$\mathord{\mbox{\subpageref{#1}}}\,\mathord{\triangleright}$}} \newcommand{\@nwprevnextdefs}[2]{% {\nwtagstyle \ifx\relax#1\else ~~\nwprevdefptr{#1}\fi \ifx\relax#2\else ~~\nwnextdefptr{#2}\fi}} \newcommand{\@nwusesondefline}[1]{{\nwtagstyle~~(\@pagenumsl{#1})}} \newcommand{\@nwstartdeflinemarkup}{\nobreak\hskip 1.5em plus 1fill\nobreak} \newcommand{\@nwenddeflinemarkup}{\nobreak\hskip \nwdefspace minus\nwdefspace\nobreak} \def\nwopt@longxref{% \let\nwalsodefined\@nwalsodefined \let\nwused\@nwused \let\nwnotused\@nwnotused \let\nwprevnextdefs\@gobbletwo \let\nwusesondefline\@gobble \let\nwstartdeflinemarkup\relax \let\nwenddeflinemarkup\relax } \def\nwopt@shortxref{% \let\nwalsodefined\@gobble \let\nwused\@gobble \let\nwnotused\@gobble \let\nwprevnextdefs\@nwprevnextdefs \let\nwusesondefline\@nwusesondefline \let\nwstartdeflinemarkup\@nwstartdeflinemarkup \let\nwenddeflinemarkup\@nwenddeflinemarkup } \def\nwopt@noxref{% \let\nwalsodefined\@gobble \let\nwused\@gobble \let\nwnotused\@gobble \let\nwprevnextdefs\@gobbletwo \let\nwusesondefline\@gobble \let\nwstartdeflinemarkup\relax \let\nwenddeflinemarkup\relax } \nwopt@shortxref % to hell with backward compatibility! \newskip\nwcodecommentsep \nwcodecommentsep=3pt plus 1pt minus 1pt \newif\if@firstnwcodecomment\@firstnwcodecommenttrue \newcount\@nwlopage\newcount\@nwhipage % range lo..hi-1 \newcount\@nwlosub % subpage of lo \newcount\@nwhisub % subpage of hi \def\@nwfirstpage#1#2#3{% subpage page xref-tag \@nwlopage=#2 \@nwlosub=#1 \def\@nwloxreftag{#3}% \advance\@nwpagecount by \@ne \@nwhipage=\@nwlopage\advance\@nwhipage by \@ne } \def\@nwnextpage#1#2#3{% subpage page xref-tag \ifnum\@nwhipage=#2 \advance\@nwhipage by \@ne \advance\@nwpagecount by \@ne \@nwhisub=#1 \def\@nwhixreftag{#3}\else \ifnum#2<\@nwlopage \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\@nwfirstpage{#1}{#2}{#3}\else \ifnum#2>\@nwhipage \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\@nwfirstpage{#1}{#2}{#3}\else \@nwlosub=0 \@nwhisub=0 \fi\fi\fi } \newcount\@nwpagetemp \newcount\@nwpagecount \def\@nwfirstpagel#1{% label \@ifundefined{r@#1}{\@warning{Reference `#1' on page \thepage \space undefined}% - \nwix@cons\nw@pages{\\{\bf ??}}}{% + \nwix@cons\nw@pages{\\{\bfseries ??}}}{% \edef\@tempa{\noexpand\@nwfirstpage\subpagepair{#1}{#1}}\@tempa}} \def\@nwnextpagel#1{% label \@ifundefined{r@#1}{\@warning{Reference `#1' on page \thepage \space undefined}% - \nwix@cons\nw@pages{\\{\bf ??}}}{% + \nwix@cons\nw@pages{\\{\bfseries ??}}}{% \edef\@tempa{\noexpand\@nwnextpage\subpagepair{#1}{#1}}\@tempa}} \def\@pagesl#1{% list of labels \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\@nwfirstpagel{##1}\let\\=\@nwnextpagel}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\def\\##1{\@nwhyperpagenum##1}% \ifnum\@nwpagecount=1 \nwpageword \else \nwpagesword\fi~\commafy{\nw@pages}} \def\@nwhyperpagenum#1#2{\nwhyperreference{#2}{#1}} \def\@pagenumsl#1{% list of labels -- doesn't include word `pages', commas, or `and' \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\@nwfirstpagel{##1}\let\\=\@nwnextpagel}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa% \def\\##1{\@nwhyperpagenum##1\let\\=\@nwpagenumslrest}\nw@pages} \def\@nwpagenumslrest#1{~\@nwhyperpagenum#1} \def\subpages#1{% list of {{subpage}{page}} \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\edef\@tempa{\noexpand\@nwfirstpage##1{}}\@tempa \def\\####1{\edef\@tempa{\noexpand\@nwnextpage####1}\@tempa}}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\def\\##1{\@firstoftwo##1}% \ifnum\@nwpagecount=1 \nwpageword \else \nwpagesword\fi~\commafy{\nw@pages}} \def\@nwaddrange{\advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa} \def\nwpageword{\@nwlangdepchk} % chunk, was page \def\nwpagesword{\@nwlangdepchks} % chunk, was page \def\nwpageprep{\@nwlangdepin} % in, was on \newcommand\nw@genericref[2]{% what to do, name of ref \expandafter\nw@g@nericref\csname r@#2\endcsname#1{#2}} \newcommand\nw@g@nericref[3]{% control sequence, what to do, name \ifx#1\relax \ref{#3}% trigger the standard `undefined ref' mechanisms \else \expandafter#2#1.\\% \fi} \def\nw@selectone#1#2#3\\{#1} \def\nw@selecttwo#1#2#3\\{#2} \def\nw@selectonetwo#1#2#3\\{{#1}{#2}} \newcommand{\subpageref}[1]{% \nwhyperreference{#1}{\nw@genericref\@subpageref{#1}}} \def\@subpageref#1#2#3\\{% \@ifundefined{2on#2}{#2}{\nwthepagenum{#1}{#2}}} \newcommand{\subpagepair}[1]{% % produces {subpage}{page} \@ifundefined{r@#1}% {{0}{0}}% {\nw@genericref\@subpagepair{#1}}} \def\@subpagepair#1#2#3\\{% \@ifundefined{2on#2}{{0}{#2}}{{#1}{#2}}} \newcommand{\sublabel}[1]{% + \leavevmode % needed to make \@bsphack work \@bsphack \nwblindhyperanchor{#1}% \if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newsublabel{#1}{{}{\thepage}}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand{\nosublabel}[1]{% \@bsphack\if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newlabel{#1}{{0}{\thepage}}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand\newsublabel{% \nw@settrailers \global\let\newsublabel\@newsublabel \@newsublabel} \newcommand{\@newsublabel}[2]{% \edef\this@page{\@cdr#2\@nil}% \ifx\this@page\last@page\else \sub@page=\z@ \fi \edef\last@page{\this@page} \advance\sub@page by \@ne \ifnum\sub@page=\tw@ \global\@namedef{2on\this@page}{}% \fi \pendingsublabel{#1}% \edef\@tempa##1{\noexpand\newlabel{##1}% {{\number\sub@page}{\this@page}\nw@labeltrailers}}% \pending@sublabels \def\pending@sublabels{}} \newcommand\nw@settrailers{% -- won't work on first run \@ifpackageloaded{nameref}% {\gdef\nw@labeltrailers{{}{}{}}}% {\gdef\nw@labeltrailers{}}} \renewcommand\nw@settrailers{% \@ifundefined{@secondoffive}% {\gdef\nw@labeltrailers{}}% {\gdef\nw@labeltrailers{{}{}{}}}} \newcommand{\nextchunklabel}[1]{% \nwblindhyperanchor{#1}% % looks slightly bogus --- nr \@bsphack\if@filesw {\let\thepage\relax \edef\@tempa{\write\@auxout{\string\pendingsublabel{#1}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand\pendingsublabel[1]{% \def\@tempa{\noexpand\@tempa}% \edef\pending@sublabels{\noexpand\@tempa{#1}\pending@sublabels}} \def\pending@sublabels{} \def\last@page{\relax} \newcount\sub@page \def\@alphasubpagenum#1#2{#2\ifnum#1=0 \else\@alph{#1}\fi} \def\@nosubpagenum#1#2{#2} \def\@numsubpagenum#1#2{#2\ifnum#1=0 \else.\@arabic{#1}\fi} \def\nwopt@nosubpage{\let\nwthepagenum=\@nosubpagenum\nwopt@nomargintag} \def\nwopt@numsubpage{\let\nwthepagenum=\@numsubpagenum} \def\nwopt@alphasubpage{\let\nwthepagenum=\@alphasubpagenum} \nwopt@alphasubpage \newcount\@nwalph@n \let\@nwalph@d\@tempcnta \let\@nwalph@bound\@tempcntb \def\@nwlongalph#1{{% \@nwalph@n=#1\advance\@nwalph@n by-1 \@nwalph@bound=26 \loop\ifnum\@nwalph@n<\@nwalph@bound\else \advance\@nwalph@n by -\@nwalph@bound \multiply\@nwalph@bound by 26 \repeat \loop\ifnum\@nwalph@bound>1 \divide\@nwalph@bound by 26 \@nwalph@d=\@nwalph@n\divide\@nwalph@d by \@nwalph@bound % d := d * bound ; n -:= d; d := d / bound --- saves a temporary \multiply\@nwalph@d by \@nwalph@bound \advance\@nwalph@n by -\@nwalph@d \divide\@nwalph@d by \@nwalph@bound \advance\@nwalph@d by 1 \@alph{\@nwalph@d}% \repeat }} \newcount\nw@chunkcount \nw@chunkcount=\@ne \newcommand{\weblabel}[1]{% \@bsphack \nwblindhyperanchor{#1}% \if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newsublabel{#1}{{}{\number\nw@chunkcount}}}}% \expandafter}\@tempa \global\advance\nw@chunkcount by \@ne \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \def\nwopt@webnumbering{% \let\sublabel=\weblabel \def\nwpageword{chunk}\def\nwpagesword{chunks}% \def\nwpageprep{in}} % \nwindexdefn{printable name}{identifying label}{label of chunk} % \nwindexuse{printable name}{identifying label}{label of chunk} \def\nwindexdefn#1#2#3{\@auxix{\protect\nwixd}{#2}{#3}} \def\nwindexuse#1#2#3{\@auxix{\protect\nwixu}{#2}{#3}} \def\@auxix#1#2#3{% {marker}{id label}{subpage label} \@bsphack\if@filesw {\let\nwixd\relax\let\nwixu\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string\nwixadd{#1}{#2}{#3}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} % \nwixadd{marker}{idlabel}{subpage label} \def\nwixadd#1#2#3{% \@ifundefined{nwixl@#2}% {\global\@namedef{nwixl@#2}{#1{#3}}}% {\expandafter\nwix@cons\csname nwixl@#2\endcsname{#1{#3}}}} \def\@nwsubscriptident#1#2{\mbox{$\mbox{#1}_{\mathrm{\subpageref{#2}}}$}} \def\@nwnosubscriptident#1#2{#1} \def\@nwhyperident#1#2{\leavevmode\nwhyperreference{#2}{#1}} \def\nwopt@subscriptidents{% \let\nwlinkedidentq\@nwsubscriptident \let\nwlinkedidentc\@nwsubscriptident } \def\nwopt@nosubscriptidents{% \let\nwlinkedidentq\@nwnosubscriptident \let\nwlinkedidentc\@nwnosubscriptident } \def\nwopt@hyperidents{% \let\nwlinkedidentq\@nwhyperident \let\nwlinkedidentc\@nwhyperident } \def\nwopt@nohyperidents{% \let\nwlinkedidentq\@nwnosubscriptident \let\nwlinkedidentc\@nwnosubscriptident } \def\nwopt@subscriptquotedidents{% \let\nwlinkedidentq\@nwsubscriptident } \def\nwopt@nosubscriptquotedidents{% \let\nwlinkedidentq\@nwnosubscriptident } \def\nwopt@hyperquotedidents{% \let\nwlinkedidentq\@nwhyperident } \def\nwopt@nohyperquotedidents{% \let\nwlinkedidentq\@nwnosubscriptident } \nwopt@hyperidents \newcount\@commacount \def\commafy#1{% {\nwix@listcount{#1}\@commacount=\nwix@counter \let\@comma@each=\\% \ifcase\@commacount\let\\=\@comma@each\or\let\\=\@comma@each\or \def\\{\def\\{ \@nwlangdepand\ \@comma@each}\@comma@each}\else \def\\{\def\\{, % \advance\@commacount by \m@ne \ifnum\@commacount=1 \@nwlangdepand~\fi\@comma@each}\@comma@each}\fi #1}} \def\nwix@cons#1#2{% {list}{\marker{element}} {\toks0=\expandafter{#1}\def\@tempa{#2}\toks2=\expandafter{\@tempa}% \xdef#1{\the\toks0 \the\toks2 }}} \def\nwix@uses#1{% {label} \def\nwixu{\\}\let\nwixd\@gobble\@nameuse{nwixl@#1}} \def\nwix@defs#1{% {label} \def\nwixd{\\}\let\nwixu\@gobble\@nameuse{nwixl@#1}} \newcount\nwix@counter \def\nwix@listcount#1{% {list with \\} {\count@=0 \def\\##1{\advance\count@ by \@ne }% #1\global\nwix@counter=\count@ }} \def\nwix@usecount#1{\nwix@listcount{\nwix@uses{#1}}} \def\nwix@defcount#1{\nwix@listcount{\nwix@defs{#1}}} \def\nwix@id@defs#1{% index pair {{\Tt \@car#1\@nil}% \def\\##1{\nwix@defs@space\subpageref{##1}}\nwix@defs{\@cdr#1\@nil}}} % useful above to change ~ into something that can break % this option is undocumented because I think breakdefs is always right \def\nwopt@breakdefs{\def\nwix@defs@space{\penalty200\ }} \def\nwopt@nobreakdefs{\def\nwix@defs@space{~}} % old code \nwopt@breakdefs \def\nwidentuses#1{% list of index pairs \nwcodecomment{\@nwlangdepuss\ \let\\=\nwix@id@defs\commafy{#1}.}} \def\nwix@totaluses#1{% list of index pairs {\count@=0 \def\\##1{\nwix@usecount{\@cdr##1\@nil}\advance\count@ by\nwix@counter}% #1\global\nwix@counter\count@ }} \def\nwix@id@uses#1#2{% {ident}{label} \nwix@usecount{#2}\ifnum\nwix@counter>0 {\advance\leftskip by \codemargin \nwcodecomment{{\Tt #1}, \@nwlangdepusd\ \nwpageprep\ \@pagesl{\nwix@uses{#2}}.}}% \else \ifnw@hideunuseddefs\else {\advance\leftskip by \codemargin \nwcodecomment{{\Tt #1}, \@nwlangdepnvu.}}% \fi \fi} \def\nwidentdefs#1{% list of index pairs \ifnw@hideunuseddefs\nwix@totaluses{#1}\else\nwix@listcount{#1}\fi \ifnum\nwix@counter>0 \nwcodecomment{\@nwlangdepdfs:}% {\def\\##1{\nwix@id@uses ##1}#1}% \fi} \newif\ifnw@hideunuseddefs\nw@hideunuseddefsfalse \def\nwopt@hideunuseddefs{\nw@hideunuseddefstrue} \def\nwopt@noidentxref{% \let\nwidentdefs\@gobble \let\nwidentuses\@gobble} \def\nw@underlinedefs{% {list with \nwixd, \nwixu} \let\\=\relax\def\nw@comma{, } \def\nwixd##1{\\\underline{\subpageref{##1}}\let\\\nw@comma}% \def\nwixu##1{\\\subpageref{##1}\let\\\nw@comma}} \def\nw@indexline#1#2{% {\indent {\Tt #1}: \nw@underlinedefs\@nameuse{nwixl@#2}\par}} \newenvironment{thenowebindex}{\parindent=-10pt \parskip=\z@ \advance\leftskip by 10pt \advance\rightskip by 0pt plus1in\par\@afterindenttrue \def\\##1{\nw@indexline##1}}{} \def\nowebindex{% \@ifundefined{nwixs@i}% {\@warning{The \string\nowebindex\space is empty}}% {\begin{thenowebindex}\@nameuse{nwixs@i}\end{thenowebindex}}} \def\nowebindex@external{% {\let\nwixadds@c=\@gobble \def\nwixadds@i##1{\nw@indexline##1}% \def\nwixaddsx##1##2{\@nameuse{nwixadds@##1}{##2}}% \begin{thenowebindex}\@input{\jobname.nwi}\end{thenowebindex}}} \def\nwixlogsorted#1#2{% list data \@bsphack\if@filesw \toks0={#2}\immediate\write\@auxout{\string\nwixadds{#1}{\the\toks0}} \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \def\nwixadds#1#2{% \@ifundefined{nwixs@#1}% {\global\@namedef{nwixs@#1}{\\{#2}}}% {\expandafter\nwix@cons\csname nwixs@#1\endcsname{\\{#2}}}} \let\nwixaddsx=\@gobbletwo \def\nwopt@externalindex{% \ifx\nwixadds\@gobbletwo % already called \else \let\nwixaddsx=\nwixadds \let\nwixadds=\@gobbletwo \let\nowebindex=\nowebindex@external \let\nowebchunks=\nowebchunks@external \fi} \def\nowebchunks{% \@ifundefined{nwixs@c}% {\@warning{The are no \string\nowebchunks}}% {\begin{thenowebchunks}\@nameuse{nwixs@c}\end{thenowebchunks}}} \def\nowebchunks@external{% {\let\nwixadds@i=\@gobble \def\nwixadds@c##1{\nw@onechunk##1}% \def\nwixaddsx##1##2{\@nameuse{nwixadds@##1}{##2}}% \begin{thenowebchunks}\@input{\jobname.nwi}\end{thenowebchunks}}} \@namedef{r@nw@notdef}{{0}{(\@nwlangdepnvd)}} \def\nw@chunkunderlinedefs{% {list of labels with \nwixd, \nwixu} \let\\=\relax\def\nw@comma{, } \def\nwixd##1{\\\underline{\subpageref{##1}}\let\\\nw@comma}% \def\nwixu##1{\\\subpageref{##1}\let\\\nw@comma}} \def\nw@onechunk#1#2#3{% {name}{label of first definition}{list with \nwixd, \nwixu} \@ifundefined{r@#2}{}{% \indent\LA #1~{\nwtagstyle\subpageref{#2}}\RA \if@nwlongchunks{~\nw@chunkunderlinedefs#3}\fi\par}} \newenvironment{thenowebchunks}{\vskip3pt \parskip=\z@\parindent=-10pt \advance\leftskip by 10pt \advance\rightskip by 0pt plus10pt \@afterindenttrue \def\\##1{\nw@onechunk##1}}{} \newif\if@nwlongchunks \@nwlongchunksfalse \let\nwopt@longchunks\@nwlongchunkstrue \newcommand\@nw@hyper@ref{\hyperreference} % naras \newcommand\@nw@hyper@anc{\blindhyperanchor} % naras \newcommand\@nw@hyperref@ref[2]{\hyperlink{noweb.#1}{#2}} % nr \newcommand\@nw@hyperref@anc[1]{\hypertarget{noweb.#1}{\relax}} % nr %%\renewcommand\@nw@hyperref@ref[2]{{#2}} % nr %%\renewcommand\@nw@hyperref@anc[1]{} % nr \newcommand\nwhyperreference{% \@ifundefined{hyperlink} {\@ifundefined{hyperreference} {\global\let\nwhyperreference\@gobble} {\global\let\nwhyperreference\@nw@hyper@ref}} {\global\let\nwhyperreference\@nw@hyperref@ref}% \nwhyperreference } \newcommand\nwblindhyperanchor{% \@ifundefined{hyperlink} {\@ifundefined{hyperreference} {\global\let\nwblindhyperanchor\@gobble} {\global\let\nwblindhyperanchor\@nw@hyper@anc}} {\global\let\nwblindhyperanchor\@nw@hyperref@anc}% \nwblindhyperanchor } \newcommand\nwanchorto{% \begingroup\let\do\@makeother\dospecials \catcode`\{=1 \catcode`\}=2 \nw@anchorto} \newcommand\nw@anchorto[1]{\endgroup\def\nw@next{#1}\nw@anchortofin} \newcommand\nw@anchortofin[1]{#1\footnote{See URL \texttt{\nw@next}.}} \let\nwanchorname\@gobble \newif\ifhtml \htmlfalse \let\nwixident=\relax -\def\nwbackslash{\char92} -\def\nwlbrace{\char123} -\def\nwrbrace{\char125} \def\nwopt@english{% \def\@nwlangdepdef{This definition is continued}% \def\@nwlangdepcud{This code is used}% \def\@nwlangdeprtc{Root chunk (not used in this document)}% \def\@nwlangdepcwf{This code is written to file}% \def\@nwlangdepchk{chunk}% \def\@nwlangdepchks{chunks}% \def\@nwlangdepin{in}% \def\@nwlangdepand{and}% \def\@nwlangdepuss{Uses}% \def\@nwlangdepusd{used}% \def\@nwlangdepnvu{never used}% \def\@nwlangdepdfs{Defines}% \def\@nwlangdepnvd{never defined}% } \let\nwopt@american\nwopt@english +\def\nwopt@icelandic{% + \def\@nwlangdepdef{This definition is continued}% + \def\@nwlangdepcud{This code is used}% + \def\@nwlangdeprtc{Root chunk (not used in this document)}% + \def\@nwlangdepcwf{This code is written to file}% + \def\@nwlangdepchk{kóða}% + \def\@nwlangdepchks{kóðum}% + \def\@nwlangdepin{í}% + \def\@nwlangdepand{og}% + \def\@nwlangdepuss{Notar}% + \def\@nwlangdepusd{notað}% + \def\@nwlangdepnvu{hvergi notað}% + \def\@nwlangdepdfs{Skilgreinir}% + \def\@nwlangdepnvd{hvergi skilgreint}% +} \def\nwopt@portuges{% \def\@nwlangdepdef{Defini\c{c}\~ao continuada em}% % This definition is continued \def\@nwlangdepcud{C\'odigo usado em}% % This code is used \def\@nwlangdeprtc{Fragmento de topo (sem uso no documento)}% % Root chunk (not used in this document) \def\@nwlangdepcwf{Este c\'odigo foi escrito no ficheiro}% % This code is written to file \def\@nwlangdepchk{fragmento}% % chunk \def\@nwlangdepchks{fragmentos}% % chunks \def\@nwlangdepin{no(s)}% % in \def\@nwlangdepand{e}% % and \def\@nwlangdepuss{Usa}% % Uses \def\@nwlangdepusd{usado}% % used \def\@nwlangdepnvu{nunca usado}% % never used \def\@nwlangdepdfs{Define}% % Defines \def\@nwlangdepnvd{nunca definido}% % never defined } \def\nwopt@frenchb{% - \def\@nwlangdepdef{Cette d\'efinition suit}% + \def\@nwlangdepdef{Suite de la d\'efinition}% % This definition is continued \def\@nwlangdepcud{Ce code est employ\'e}% % This code is used \def\@nwlangdeprtc{Morceau racine (pas employ\'e dans ce document)}% % Root chunk (not used in this document) - \def\@nwlangdepcwf{Ce code est \'ecrit aux fichier}% + \def\@nwlangdepcwf{Ce code est \'ecrit dans le fichier}% % This code is written to file \def\@nwlangdepchk{le morceau}% % chunk \def\@nwlangdepchks{les morceaux}% % chunks \def\@nwlangdepin{dans}% % in \def\@nwlangdepand{et}% % and - \def\@nwlangdepuss{Il emploie}% + \def\@nwlangdepuss{Utilise}% % Uses - \def\@nwlangdepusd{employ\'{e}}% + \def\@nwlangdepusd{utilis\'{e}}% % used \def\@nwlangdepnvu{jamais employ\'{e}}% % never used - \def\@nwlangdepdfs{Il d\'{e}fine}% + \def\@nwlangdepdfs{D\'{e}finit}% % Defines % Cannot use the accent here: \def\@nwlangdepnvd{jamais d\'{e}fini}% \def\@nwlangdepnvd{jamais defini}% % never defined } \let\nwopt@french\nwopt@frenchb \def\nwopt@german{% \def\@nwlangdepdef{Diese Definition wird fortgesetzt}% % This definition is continued \def\@nwlangdepcud{Dieser Code wird benutzt}% % This code is used \def\@nwlangdeprtc{Hauptteil (nicht in diesem Dokument benutzt)}% % Root chunk (not used in this document) - \def\@nwlangdepcwf{Dieser Code schreibt man zum File}% + \def\@nwlangdepcwf{Geh\"ort in die Datei}% % This code is written to file + \def\@nwlangdepchk{Abschnitt}% + % chunk + \def\@nwlangdepchks{den Abschnitten}% + % chunks + \def\@nwlangdepin{in}% + % in + \def\@nwlangdepand{und}% + % and + \def\@nwlangdepuss{Benutzt}% + % Uses + \def\@nwlangdepusd{benutzt}% + % used + \def\@nwlangdepnvu{nicht benutzt}% + % never used + \def\@nwlangdepdfs{Definiert}% + % Defines + \def\@nwlangdepnvd{nicht definiert}% + % never defined +} +\def\nwopt@german{% + \def\@nwlangdepdef{Diese Definition wird fortgesetzt}% + % This definition is continued + \def\@nwlangdepcud{Dieser Code wird benutzt}% + % This code is used + \def\@nwlangdeprtc{Hauptteil (nicht in diesem Dokument benutzt)}% + % Root chunk (not used in this document) + \def\@nwlangdepcwf{Dieser Code erzeugt die Datei} + % This code generates the file \def\@nwlangdepchk{Teil}% % chunk \def\@nwlangdepchks{Teils}% % chunks \def\@nwlangdepin{im}% % in \def\@nwlangdepand{und}% % and \def\@nwlangdepuss{Benutzt}% % Uses \def\@nwlangdepusd{benutzt}% % used \def\@nwlangdepnvu{nicht benutzt}% % never used \def\@nwlangdepdfs{Definiert}% % Defines \def\@nwlangdepnvd{nicht definiert}% % never defined } \let\nwopt@ngerman\nwopt@german \ifx\languagename\undefined % default is English \noweboptions{english} \else \@ifundefined{nwopt@\languagename} {\noweboptions{english}} {\expandafter\noweboptions\expandafter{\languagename}} \fi Index: trunk/share/doc/noweb.sty =================================================================== --- trunk/share/doc/noweb.sty (revision 8914) +++ trunk/share/doc/noweb.sty (revision 8915) @@ -1,927 +1,976 @@ % noweb.sty -- LaTeX support for noweb % DON'T read or edit this file! Use ...noweb-source/tex/support.nw instead. {\obeyspaces\AtBeginDocument{\global\let =\ }} % from texbook, p 381 \def\nwopt@nomargintag{\let\nwmargintag=\@gobble} \def\nwopt@margintag{% \def\nwmargintag##1{\leavevmode\llap{##1\kern\nwmarginglue\kern\codemargin}}} \def\nwopt@margintag{% \def\nwmargintag##1{\leavevmode\kern-\codemargin\nwthemargintag{##1}\kern\codemargin}} \def\nwthemargintag#1{\llap{#1\kern\nwmarginglue}} \nwopt@margintag \newdimen\nwmarginglue \nwmarginglue=0.3in \def\nwtagstyle{\footnotesize\Rm} +\def\nwgitversion{|GITVERSION|} % make \hsize in code sufficient for 88 columns -\setbox0=\hbox{\tt m} +\ifx\ttfamily\undefined + \setbox0=\hbox{\tt m} +\else + \setbox0=\hbox{\ttfamily m} +\fi \newdimen\codehsize \codehsize=91\wd0 % 88 columns wasn't enough; I don't know why \newdimen\codemargin \codemargin=0pt \newdimen\nwdefspace \nwdefspace=\codehsize % need to use \textwidth in {\LaTeX} to handle styles with % non-standard margins (David Bruce). Don't know why we sometimes % wanted \hsize. 27 August 1997. %% \advance\nwdefspace by -\hsize\relax \ifx\textwidth\undefined \advance\nwdefspace by -\hsize\relax \else \advance\nwdefspace by -\textwidth\relax \fi \chardef\other=12 \def\setupcode{% \chardef\\=`\\ \chardef\{=`\{ \chardef\}=`\} \catcode`\$=\other \catcode`\&=\other \catcode`\#=\other \catcode`\%=\other \catcode`\~=\other \catcode`\_=\other \catcode`\^=\other \catcode`\"=\other % fixes problem with german.sty \obeyspaces\Tt } -\let\nwlbrace=\{ -\let\nwrbrace=\} \def\nwendquote{\relax\ifhmode\spacefactor=1000 \fi} {\catcode`\^^M=\active % make CR an active character \gdef\newlines{\catcode`\^^M=\active % make CR an active character \def^^M{\par\startline}}% \gdef\eatline#1^^M{\relax}% } %%% DON'T \gdef^^M{\par\startline}}% in case ^^M appears in a \write \def\startline{\noindent\hskip\parindent\ignorespaces} \def\nwnewline{\ifvmode\else\hfil\break\leavevmode\hbox{}\fi} \def\setupmodname{% \catcode`\$=3 \catcode`\&=4 \catcode`\#=6 \catcode`\%=14 \catcode`\~=13 \catcode`\_=8 \catcode`\^=7 \catcode`\ =10 \catcode`\^^M=5 - \let\{\nwlbrace - \let\}\nwrbrace + \let\{\lbrace + \let\}\rbrace % bad news --- don't know what catcode to give " \Rm} \def\LA{\begingroup\maybehbox\bgroup\setupmodname\It$\langle$} \def\RA{\/$\rangle$\egroup\endgroup} \def\code{\leavevmode\begingroup\setupcode\newlines} \def\edoc{\endgroup} \let\maybehbox\relax \newbox\equivbox \setbox\equivbox=\hbox{$\equiv$} \newbox\plusequivbox \setbox\plusequivbox=\hbox{$\mathord{+}\mathord{\equiv}$} % \moddef can't have an argument because there might be \code...\edoc \def\moddef{\leavevmode\kern-\codemargin\LA} \def\endmoddef{\RA\ifmmode\equiv\else\unhcopy\equivbox\fi \nobreak\hfill\nobreak} \def\plusendmoddef{\RA\ifmmode\mathord{+}\mathord{\equiv}\else\unhcopy\plusequivbox\fi \nobreak\hfill\nobreak} \def\chunklist{% \errhelp{I changed \chunklist to \nowebchunks. I'll try to avoid such incompatible changes in the future.}% \errmessage{Use \string\nowebchunks\space instead of \string\chunklist}} \def\nowebchunks{\message{}} \def\nowebindex{\message{}} % here is support for the new-style (capitalized) font-changing commands % thanks to Dave Love \ifx\documentstyle\undefined \let\Rm=\rm \let\It=\it \let\Tt=\tt % plain \else\ifx\selectfont\undefined \let\Rm=\rm \let\It=\it \let\Tt=\tt % LaTeX OFSS \else % LaTeX NFSS - \def\Rm{\reset@font\rm} - \def\It{\reset@font\it} - \def\Tt{\reset@font\tt} - \def\Bf{\reset@font\bf} + \def\Rm{\reset@font\rmfamily} + \def\It{\reset@font\itshape} + \def\Tt{\reset@font\ttfamily} + \def\Bf{\reset@font\bfseries} \fi\fi \ifx\reset@font\undefined \let\reset@font=\relax \fi +\def\nwbackslash{\char92} +\def\nwlbrace{\char123} +\def\nwrbrace{\char125} \def\noweboptions#1{% \def\@nwoptionlist{#1}% \@for\@nwoption:=\@nwoptionlist\do{% \@ifundefined{nwopt@\@nwoption}{% \@latexerr{There is no such noweb option as '\@nwoption'}\@eha}{% \csname nwopt@\@nwoption\endcsname}}} \codemargin=10pt \advance\codehsize by \codemargin % make room for indentation of code \advance\nwdefspace by \codemargin % and fix adjustment for def/use \def\setcodemargin#1{% \advance\codehsize by -\codemargin % make room for indentation of code \advance\nwdefspace by -\codemargin % and fix adjustment for def/use \codemargin=#1 \advance\codehsize by \codemargin % make room for indentation of code \advance\nwdefspace by \codemargin % and fix adjustment for % def/use } \def\nwopt@shift{% \dimen@=-0.8in \if@twoside % Values for two-sided printing: \advance\evensidemargin by \dimen@ \else % Values for one-sided printing: \advance\evensidemargin by \dimen@ \advance\oddsidemargin by \dimen@ \fi % \advance \marginparwidth -\dimen@ } \let\nwopt@noshift\@empty \def\nwbegincode#1{% \begingroup \topsep \nwcodetopsep \@beginparpenalty \@highpenalty \@endparpenalty -\@highpenalty \@begincode } \def\nwendcode{\endtrivlist \endgroup \filbreak} % keeps code on 1 page \newenvironment{webcode}{% \@begincode }{% \endtrivlist} +\newdimen\@nwbegincodelinewidth \def\@begincode{% + \@nwbegincodelinewidth=\linewidth \trivlist \item[]% \leftskip\@totalleftmargin \advance\leftskip\codemargin \rightskip\hsize \advance\rightskip -\codehsize \parskip\z@ \parindent\z@ \parfillskip\@flushglue \linewidth\codehsize \@@par \def\par{\leavevmode\null \@@par \penalty\nwcodepenalty}% \obeylines + \nowebsize \setupcode \@noligs \ifx\verbatim@nolig@list\undefined\else \let\do=\nw@makeother \verbatim@nolig@list \do@noligs\` \fi \setupcode \frenchspacing \@vobeyspaces - \nowebsize \setupcode \let\maybehbox\mbox } \newskip\nwcodetopsep \nwcodetopsep = 3pt plus 1.2pt minus 1pt \let\nowebsize=\normalsize \def\nwopt@tinycode{\let\nowebsize=\tiny} \def\nwopt@footnotesizecode{\let\nowebsize=\footnotesize} \def\nwopt@scriptsizecode{\let\nowebsize=\scriptsize} \def\nwopt@smallcode{\let\nowebsize=\small} \def\nwopt@normalsizecode{\let\nowebsize=\normalsize} \def\nwopt@largecode{\let\nowebsize=\large} \def\nwopt@Largecode{\let\nowebsize=\Large} \def\nwopt@LARGEcode{\let\nowebsize=\LARGE} \def\nwopt@hugecode{\let\nowebsize=\huge} \def\nwopt@Hugecode{\let\nowebsize=\Huge} \newcount\nwcodepenalty \nwcodepenalty=\@highpenalty \def\nw@makeother#1{\catcode`#1=12 } \def\nwbegindocs#1{\ifvmode\noindent\fi} \let\nwenddocs=\relax \let\nwdocspar=\filbreak \def\@nwsemifilbreak#1{\vskip0pt plus#1\penalty-200\vskip0pt plus -#1} \newdimen\nwbreakcodespace \nwbreakcodespace=0.2in % by default, leave no more than this on a page \def\nwopt@breakcode{% \def\nwdocspar{\@nwsemifilbreak{0.2in}}% \def\nwendcode{\endtrivlist\endgroup} % ditches filbreak } \raggedbottom \def\code{\leavevmode\begingroup\setupcode\@vobeyspaces\obeylines} \let\edoc=\endgroup \newdimen\@original@textwidth \def\ps@noweb{% \@original@textwidth=\textwidth \let\@mkboth\@gobbletwo \def\@oddfoot{}\def\@evenfoot{}% No feet. \if@twoside % If two-sided printing. \def\@evenhead{\hbox to \@original@textwidth{% \Rm \thepage\qquad{\Tt\leftmark}\hfil\today}}% Left heading. \def\@oddhead{\hbox to \@original@textwidth{% \Rm \today\hfil{\Tt\leftmark}\qquad\thepage}}% Right heading. \else % If one-sided printing. \def\@oddhead{\hbox to \@original@textwidth{% \Rm \today\hfil{\Tt\leftmark}\qquad\thepage}}% Right heading. \let\@evenhead\@oddhead \fi \let\chaptermark\@gobble \let\sectionmark\@gobble \let\subsectionmark\@gobble \let\subsubsectionmark\@gobble \let\paragraphmark\@gobble \let\subparagraphmark\@gobble \def\nwfilename{\begingroup\let\do\@makeother\dospecials \catcode`\{=1 \catcode`\}=2 \nw@filename} \def\nw@filename##1{\endgroup\markboth{##1}{##1}\let\nw@filename=\nw@laterfilename}% } \def\nw@laterfilename#1{\endgroup\clearpage \markboth{#1}{#1}} \let\nwfilename=\@gobble \def\nwcodecomment#1{\@@par\penalty\nwcodepenalty \if@firstnwcodecomment \vskip\nwcodecommentsep\penalty\nwcodepenalty\@firstnwcodecommentfalse \fi% \hspace{-\codemargin}{% \rightskip=0pt plus1in \interlinepenalty\nwcodepenalty \let\\\relax\footnotesize\Rm #1\@@par\penalty\nwcodepenalty}} \def\@nwalsodefined#1{\nwcodecomment{\@nwlangdepdef\ \nwpageprep\ \@pagesl{#1}.}} \def\@nwused#1{\nwcodecomment{\@nwlangdepcud\ \nwpageprep\ \@pagesl{#1}.}} \def\@nwnotused#1{\nwcodecomment{\@nwlangdeprtc.}} \def\nwoutput#1{\nwcodecomment{\@nwlangdepcwf\ {\Tt \@stripstar#1*\stripped}.}} \def\@stripstar#1*#2\stripped{#1} \newcommand{\nwprevdefptr}[1]{% \mbox{$\mathord{\triangleleft}\,\mathord{\mbox{\subpageref{#1}}}$}} \newcommand{\nwnextdefptr}[1]{% \mbox{$\mathord{\mbox{\subpageref{#1}}}\,\mathord{\triangleright}$}} \newcommand{\@nwprevnextdefs}[2]{% {\nwtagstyle \ifx\relax#1\else ~~\nwprevdefptr{#1}\fi \ifx\relax#2\else ~~\nwnextdefptr{#2}\fi}} \newcommand{\@nwusesondefline}[1]{{\nwtagstyle~~(\@pagenumsl{#1})}} \newcommand{\@nwstartdeflinemarkup}{\nobreak\hskip 1.5em plus 1fill\nobreak} \newcommand{\@nwenddeflinemarkup}{\nobreak\hskip \nwdefspace minus\nwdefspace\nobreak} \def\nwopt@longxref{% \let\nwalsodefined\@nwalsodefined \let\nwused\@nwused \let\nwnotused\@nwnotused \let\nwprevnextdefs\@gobbletwo \let\nwusesondefline\@gobble \let\nwstartdeflinemarkup\relax \let\nwenddeflinemarkup\relax } \def\nwopt@shortxref{% \let\nwalsodefined\@gobble \let\nwused\@gobble \let\nwnotused\@gobble \let\nwprevnextdefs\@nwprevnextdefs \let\nwusesondefline\@nwusesondefline \let\nwstartdeflinemarkup\@nwstartdeflinemarkup \let\nwenddeflinemarkup\@nwenddeflinemarkup } \def\nwopt@noxref{% \let\nwalsodefined\@gobble \let\nwused\@gobble \let\nwnotused\@gobble \let\nwprevnextdefs\@gobbletwo \let\nwusesondefline\@gobble \let\nwstartdeflinemarkup\relax \let\nwenddeflinemarkup\relax } \nwopt@shortxref % to hell with backward compatibility! \newskip\nwcodecommentsep \nwcodecommentsep=3pt plus 1pt minus 1pt \newif\if@firstnwcodecomment\@firstnwcodecommenttrue \newcount\@nwlopage\newcount\@nwhipage % range lo..hi-1 \newcount\@nwlosub % subpage of lo \newcount\@nwhisub % subpage of hi \def\@nwfirstpage#1#2#3{% subpage page xref-tag \@nwlopage=#2 \@nwlosub=#1 \def\@nwloxreftag{#3}% \advance\@nwpagecount by \@ne \@nwhipage=\@nwlopage\advance\@nwhipage by \@ne } \def\@nwnextpage#1#2#3{% subpage page xref-tag \ifnum\@nwhipage=#2 \advance\@nwhipage by \@ne \advance\@nwpagecount by \@ne \@nwhisub=#1 \def\@nwhixreftag{#3}\else \ifnum#2<\@nwlopage \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\@nwfirstpage{#1}{#2}{#3}\else \ifnum#2>\@nwhipage \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\@nwfirstpage{#1}{#2}{#3}\else \@nwlosub=0 \@nwhisub=0 \fi\fi\fi } \newcount\@nwpagetemp \newcount\@nwpagecount \def\@nwfirstpagel#1{% label \@ifundefined{r@#1}{\@warning{Reference `#1' on page \thepage \space undefined}% - \nwix@cons\nw@pages{\\{\bf ??}}}{% + \nwix@cons\nw@pages{\\{\bfseries ??}}}{% \edef\@tempa{\noexpand\@nwfirstpage\subpagepair{#1}{#1}}\@tempa}} \def\@nwnextpagel#1{% label \@ifundefined{r@#1}{\@warning{Reference `#1' on page \thepage \space undefined}% - \nwix@cons\nw@pages{\\{\bf ??}}}{% + \nwix@cons\nw@pages{\\{\bfseries ??}}}{% \edef\@tempa{\noexpand\@nwnextpage\subpagepair{#1}{#1}}\@tempa}} \def\@pagesl#1{% list of labels \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\@nwfirstpagel{##1}\let\\=\@nwnextpagel}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\def\\##1{\@nwhyperpagenum##1}% \ifnum\@nwpagecount=1 \nwpageword \else \nwpagesword\fi~\commafy{\nw@pages}} \def\@nwhyperpagenum#1#2{\nwhyperreference{#2}{#1}} \def\@pagenumsl#1{% list of labels -- doesn't include word `pages', commas, or `and' \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\@nwfirstpagel{##1}\let\\=\@nwnextpagel}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa% \def\\##1{\@nwhyperpagenum##1\let\\=\@nwpagenumslrest}\nw@pages} \def\@nwpagenumslrest#1{~\@nwhyperpagenum#1} \def\subpages#1{% list of {{subpage}{page}} \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\edef\@tempa{\noexpand\@nwfirstpage##1{}}\@tempa \def\\####1{\edef\@tempa{\noexpand\@nwnextpage####1}\@tempa}}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\def\\##1{\@firstoftwo##1}% \ifnum\@nwpagecount=1 \nwpageword \else \nwpagesword\fi~\commafy{\nw@pages}} \def\@nwaddrange{\advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa} \def\nwpageword{\@nwlangdepchk} % chunk, was page \def\nwpagesword{\@nwlangdepchks} % chunk, was page \def\nwpageprep{\@nwlangdepin} % in, was on \newcommand\nw@genericref[2]{% what to do, name of ref \expandafter\nw@g@nericref\csname r@#2\endcsname#1{#2}} \newcommand\nw@g@nericref[3]{% control sequence, what to do, name \ifx#1\relax \ref{#3}% trigger the standard `undefined ref' mechanisms \else \expandafter#2#1.\\% \fi} \def\nw@selectone#1#2#3\\{#1} \def\nw@selecttwo#1#2#3\\{#2} \def\nw@selectonetwo#1#2#3\\{{#1}{#2}} \newcommand{\subpageref}[1]{% \nwhyperreference{#1}{\nw@genericref\@subpageref{#1}}} \def\@subpageref#1#2#3\\{% \@ifundefined{2on#2}{#2}{\nwthepagenum{#1}{#2}}} \newcommand{\subpagepair}[1]{% % produces {subpage}{page} \@ifundefined{r@#1}% {{0}{0}}% {\nw@genericref\@subpagepair{#1}}} \def\@subpagepair#1#2#3\\{% \@ifundefined{2on#2}{{0}{#2}}{{#1}{#2}}} \newcommand{\sublabel}[1]{% + \leavevmode % needed to make \@bsphack work \@bsphack \nwblindhyperanchor{#1}% \if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newsublabel{#1}{{}{\thepage}}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand{\nosublabel}[1]{% \@bsphack\if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newlabel{#1}{{0}{\thepage}}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand\newsublabel{% \nw@settrailers \global\let\newsublabel\@newsublabel \@newsublabel} \newcommand{\@newsublabel}[2]{% \edef\this@page{\@cdr#2\@nil}% \ifx\this@page\last@page\else \sub@page=\z@ \fi \edef\last@page{\this@page} \advance\sub@page by \@ne \ifnum\sub@page=\tw@ \global\@namedef{2on\this@page}{}% \fi \pendingsublabel{#1}% \edef\@tempa##1{\noexpand\newlabel{##1}% {{\number\sub@page}{\this@page}\nw@labeltrailers}}% \pending@sublabels \def\pending@sublabels{}} \newcommand\nw@settrailers{% -- won't work on first run \@ifpackageloaded{nameref}% {\gdef\nw@labeltrailers{{}{}{}}}% {\gdef\nw@labeltrailers{}}} \renewcommand\nw@settrailers{% \@ifundefined{@secondoffive}% {\gdef\nw@labeltrailers{}}% {\gdef\nw@labeltrailers{{}{}{}}}} \newcommand{\nextchunklabel}[1]{% \nwblindhyperanchor{#1}% % looks slightly bogus --- nr \@bsphack\if@filesw {\let\thepage\relax \edef\@tempa{\write\@auxout{\string\pendingsublabel{#1}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand\pendingsublabel[1]{% \def\@tempa{\noexpand\@tempa}% \edef\pending@sublabels{\noexpand\@tempa{#1}\pending@sublabels}} \def\pending@sublabels{} \def\last@page{\relax} \newcount\sub@page \def\@alphasubpagenum#1#2{#2\ifnum#1=0 \else\@alph{#1}\fi} \def\@nosubpagenum#1#2{#2} \def\@numsubpagenum#1#2{#2\ifnum#1=0 \else.\@arabic{#1}\fi} \def\nwopt@nosubpage{\let\nwthepagenum=\@nosubpagenum\nwopt@nomargintag} \def\nwopt@numsubpage{\let\nwthepagenum=\@numsubpagenum} \def\nwopt@alphasubpage{\let\nwthepagenum=\@alphasubpagenum} \nwopt@alphasubpage \newcount\@nwalph@n \let\@nwalph@d\@tempcnta \let\@nwalph@bound\@tempcntb \def\@nwlongalph#1{{% \@nwalph@n=#1\advance\@nwalph@n by-1 \@nwalph@bound=26 \loop\ifnum\@nwalph@n<\@nwalph@bound\else \advance\@nwalph@n by -\@nwalph@bound \multiply\@nwalph@bound by 26 \repeat \loop\ifnum\@nwalph@bound>1 \divide\@nwalph@bound by 26 \@nwalph@d=\@nwalph@n\divide\@nwalph@d by \@nwalph@bound % d := d * bound ; n -:= d; d := d / bound --- saves a temporary \multiply\@nwalph@d by \@nwalph@bound \advance\@nwalph@n by -\@nwalph@d \divide\@nwalph@d by \@nwalph@bound \advance\@nwalph@d by 1 \@alph{\@nwalph@d}% \repeat }} \newcount\nw@chunkcount \nw@chunkcount=\@ne \newcommand{\weblabel}[1]{% \@bsphack \nwblindhyperanchor{#1}% \if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newsublabel{#1}{{}{\number\nw@chunkcount}}}}% \expandafter}\@tempa \global\advance\nw@chunkcount by \@ne \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \def\nwopt@webnumbering{% \let\sublabel=\weblabel \def\nwpageword{chunk}\def\nwpagesword{chunks}% \def\nwpageprep{in}} % \nwindexdefn{printable name}{identifying label}{label of chunk} % \nwindexuse{printable name}{identifying label}{label of chunk} \def\nwindexdefn#1#2#3{\@auxix{\protect\nwixd}{#2}{#3}} \def\nwindexuse#1#2#3{\@auxix{\protect\nwixu}{#2}{#3}} \def\@auxix#1#2#3{% {marker}{id label}{subpage label} \@bsphack\if@filesw {\let\nwixd\relax\let\nwixu\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string\nwixadd{#1}{#2}{#3}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} % \nwixadd{marker}{idlabel}{subpage label} \def\nwixadd#1#2#3{% \@ifundefined{nwixl@#2}% {\global\@namedef{nwixl@#2}{#1{#3}}}% {\expandafter\nwix@cons\csname nwixl@#2\endcsname{#1{#3}}}} \def\@nwsubscriptident#1#2{\mbox{$\mbox{#1}_{\mathrm{\subpageref{#2}}}$}} \def\@nwnosubscriptident#1#2{#1} \def\@nwhyperident#1#2{\leavevmode\nwhyperreference{#2}{#1}} \def\nwopt@subscriptidents{% \let\nwlinkedidentq\@nwsubscriptident \let\nwlinkedidentc\@nwsubscriptident } \def\nwopt@nosubscriptidents{% \let\nwlinkedidentq\@nwnosubscriptident \let\nwlinkedidentc\@nwnosubscriptident } \def\nwopt@hyperidents{% \let\nwlinkedidentq\@nwhyperident \let\nwlinkedidentc\@nwhyperident } \def\nwopt@nohyperidents{% \let\nwlinkedidentq\@nwnosubscriptident \let\nwlinkedidentc\@nwnosubscriptident } \def\nwopt@subscriptquotedidents{% \let\nwlinkedidentq\@nwsubscriptident } \def\nwopt@nosubscriptquotedidents{% \let\nwlinkedidentq\@nwnosubscriptident } \def\nwopt@hyperquotedidents{% \let\nwlinkedidentq\@nwhyperident } \def\nwopt@nohyperquotedidents{% \let\nwlinkedidentq\@nwnosubscriptident } \nwopt@hyperidents \newcount\@commacount \def\commafy#1{% {\nwix@listcount{#1}\@commacount=\nwix@counter \let\@comma@each=\\% \ifcase\@commacount\let\\=\@comma@each\or\let\\=\@comma@each\or \def\\{\def\\{ \@nwlangdepand\ \@comma@each}\@comma@each}\else \def\\{\def\\{, % \advance\@commacount by \m@ne \ifnum\@commacount=1 \@nwlangdepand~\fi\@comma@each}\@comma@each}\fi #1}} \def\nwix@cons#1#2{% {list}{\marker{element}} {\toks0=\expandafter{#1}\def\@tempa{#2}\toks2=\expandafter{\@tempa}% \xdef#1{\the\toks0 \the\toks2 }}} \def\nwix@uses#1{% {label} \def\nwixu{\\}\let\nwixd\@gobble\@nameuse{nwixl@#1}} \def\nwix@defs#1{% {label} \def\nwixd{\\}\let\nwixu\@gobble\@nameuse{nwixl@#1}} \newcount\nwix@counter \def\nwix@listcount#1{% {list with \\} {\count@=0 \def\\##1{\advance\count@ by \@ne }% #1\global\nwix@counter=\count@ }} \def\nwix@usecount#1{\nwix@listcount{\nwix@uses{#1}}} \def\nwix@defcount#1{\nwix@listcount{\nwix@defs{#1}}} \def\nwix@id@defs#1{% index pair {{\Tt \@car#1\@nil}% \def\\##1{\nwix@defs@space\subpageref{##1}}\nwix@defs{\@cdr#1\@nil}}} % useful above to change ~ into something that can break % this option is undocumented because I think breakdefs is always right \def\nwopt@breakdefs{\def\nwix@defs@space{\penalty200\ }} \def\nwopt@nobreakdefs{\def\nwix@defs@space{~}} % old code \nwopt@breakdefs \def\nwidentuses#1{% list of index pairs \nwcodecomment{\@nwlangdepuss\ \let\\=\nwix@id@defs\commafy{#1}.}} \def\nwix@totaluses#1{% list of index pairs {\count@=0 \def\\##1{\nwix@usecount{\@cdr##1\@nil}\advance\count@ by\nwix@counter}% #1\global\nwix@counter\count@ }} \def\nwix@id@uses#1#2{% {ident}{label} \nwix@usecount{#2}\ifnum\nwix@counter>0 {\advance\leftskip by \codemargin \nwcodecomment{{\Tt #1}, \@nwlangdepusd\ \nwpageprep\ \@pagesl{\nwix@uses{#2}}.}}% \else \ifnw@hideunuseddefs\else {\advance\leftskip by \codemargin \nwcodecomment{{\Tt #1}, \@nwlangdepnvu.}}% \fi \fi} \def\nwidentdefs#1{% list of index pairs \ifnw@hideunuseddefs\nwix@totaluses{#1}\else\nwix@listcount{#1}\fi \ifnum\nwix@counter>0 \nwcodecomment{\@nwlangdepdfs:}% {\def\\##1{\nwix@id@uses ##1}#1}% \fi} \newif\ifnw@hideunuseddefs\nw@hideunuseddefsfalse \def\nwopt@hideunuseddefs{\nw@hideunuseddefstrue} \def\nwopt@noidentxref{% \let\nwidentdefs\@gobble \let\nwidentuses\@gobble} \def\nw@underlinedefs{% {list with \nwixd, \nwixu} \let\\=\relax\def\nw@comma{, } \def\nwixd##1{\\\underline{\subpageref{##1}}\let\\\nw@comma}% \def\nwixu##1{\\\subpageref{##1}\let\\\nw@comma}} \def\nw@indexline#1#2{% {\indent {\Tt #1}: \nw@underlinedefs\@nameuse{nwixl@#2}\par}} \newenvironment{thenowebindex}{\parindent=-10pt \parskip=\z@ \advance\leftskip by 10pt \advance\rightskip by 0pt plus1in\par\@afterindenttrue \def\\##1{\nw@indexline##1}}{} \def\nowebindex{% \@ifundefined{nwixs@i}% {\@warning{The \string\nowebindex\space is empty}}% {\begin{thenowebindex}\@nameuse{nwixs@i}\end{thenowebindex}}} \def\nowebindex@external{% {\let\nwixadds@c=\@gobble \def\nwixadds@i##1{\nw@indexline##1}% \def\nwixaddsx##1##2{\@nameuse{nwixadds@##1}{##2}}% \begin{thenowebindex}\@input{\jobname.nwi}\end{thenowebindex}}} \def\nwixlogsorted#1#2{% list data \@bsphack\if@filesw \toks0={#2}\immediate\write\@auxout{\string\nwixadds{#1}{\the\toks0}} \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \def\nwixadds#1#2{% \@ifundefined{nwixs@#1}% {\global\@namedef{nwixs@#1}{\\{#2}}}% {\expandafter\nwix@cons\csname nwixs@#1\endcsname{\\{#2}}}} \let\nwixaddsx=\@gobbletwo \def\nwopt@externalindex{% \ifx\nwixadds\@gobbletwo % already called \else \let\nwixaddsx=\nwixadds \let\nwixadds=\@gobbletwo \let\nowebindex=\nowebindex@external \let\nowebchunks=\nowebchunks@external \fi} \def\nowebchunks{% \@ifundefined{nwixs@c}% {\@warning{The are no \string\nowebchunks}}% {\begin{thenowebchunks}\@nameuse{nwixs@c}\end{thenowebchunks}}} \def\nowebchunks@external{% {\let\nwixadds@i=\@gobble \def\nwixadds@c##1{\nw@onechunk##1}% \def\nwixaddsx##1##2{\@nameuse{nwixadds@##1}{##2}}% \begin{thenowebchunks}\@input{\jobname.nwi}\end{thenowebchunks}}} \@namedef{r@nw@notdef}{{0}{(\@nwlangdepnvd)}} \def\nw@chunkunderlinedefs{% {list of labels with \nwixd, \nwixu} \let\\=\relax\def\nw@comma{, } \def\nwixd##1{\\\underline{\subpageref{##1}}\let\\\nw@comma}% \def\nwixu##1{\\\subpageref{##1}\let\\\nw@comma}} \def\nw@onechunk#1#2#3{% {name}{label of first definition}{list with \nwixd, \nwixu} \@ifundefined{r@#2}{}{% \indent\LA #1~{\nwtagstyle\subpageref{#2}}\RA \if@nwlongchunks{~\nw@chunkunderlinedefs#3}\fi\par}} \newenvironment{thenowebchunks}{\vskip3pt \parskip=\z@\parindent=-10pt \advance\leftskip by 10pt \advance\rightskip by 0pt plus10pt \@afterindenttrue \def\\##1{\nw@onechunk##1}}{} \newif\if@nwlongchunks \@nwlongchunksfalse \let\nwopt@longchunks\@nwlongchunkstrue \newcommand\@nw@hyper@ref{\hyperreference} % naras \newcommand\@nw@hyper@anc{\blindhyperanchor} % naras \newcommand\@nw@hyperref@ref[2]{\hyperlink{noweb.#1}{#2}} % nr \newcommand\@nw@hyperref@anc[1]{\hypertarget{noweb.#1}{\relax}} % nr %%\renewcommand\@nw@hyperref@ref[2]{{#2}} % nr %%\renewcommand\@nw@hyperref@anc[1]{} % nr \newcommand\nwhyperreference{% \@ifundefined{hyperlink} {\@ifundefined{hyperreference} {\global\let\nwhyperreference\@gobble} {\global\let\nwhyperreference\@nw@hyper@ref}} {\global\let\nwhyperreference\@nw@hyperref@ref}% \nwhyperreference } \newcommand\nwblindhyperanchor{% \@ifundefined{hyperlink} {\@ifundefined{hyperreference} {\global\let\nwblindhyperanchor\@gobble} {\global\let\nwblindhyperanchor\@nw@hyper@anc}} {\global\let\nwblindhyperanchor\@nw@hyperref@anc}% \nwblindhyperanchor } \newcommand\nwanchorto{% \begingroup\let\do\@makeother\dospecials \catcode`\{=1 \catcode`\}=2 \nw@anchorto} \newcommand\nw@anchorto[1]{\endgroup\def\nw@next{#1}\nw@anchortofin} \newcommand\nw@anchortofin[1]{#1\footnote{See URL \texttt{\nw@next}.}} \let\nwanchorname\@gobble \newif\ifhtml \htmlfalse \let\nwixident=\relax -\def\nwbackslash{\char92} -\def\nwlbrace{\char123} -\def\nwrbrace{\char125} \def\nwopt@english{% \def\@nwlangdepdef{This definition is continued}% \def\@nwlangdepcud{This code is used}% \def\@nwlangdeprtc{Root chunk (not used in this document)}% \def\@nwlangdepcwf{This code is written to file}% \def\@nwlangdepchk{chunk}% \def\@nwlangdepchks{chunks}% \def\@nwlangdepin{in}% \def\@nwlangdepand{and}% \def\@nwlangdepuss{Uses}% \def\@nwlangdepusd{used}% \def\@nwlangdepnvu{never used}% \def\@nwlangdepdfs{Defines}% \def\@nwlangdepnvd{never defined}% } \let\nwopt@american\nwopt@english +\def\nwopt@icelandic{% + \def\@nwlangdepdef{This definition is continued}% + \def\@nwlangdepcud{This code is used}% + \def\@nwlangdeprtc{Root chunk (not used in this document)}% + \def\@nwlangdepcwf{This code is written to file}% + \def\@nwlangdepchk{kóða}% + \def\@nwlangdepchks{kóðum}% + \def\@nwlangdepin{í}% + \def\@nwlangdepand{og}% + \def\@nwlangdepuss{Notar}% + \def\@nwlangdepusd{notað}% + \def\@nwlangdepnvu{hvergi notað}% + \def\@nwlangdepdfs{Skilgreinir}% + \def\@nwlangdepnvd{hvergi skilgreint}% +} \def\nwopt@portuges{% \def\@nwlangdepdef{Defini\c{c}\~ao continuada em}% % This definition is continued \def\@nwlangdepcud{C\'odigo usado em}% % This code is used \def\@nwlangdeprtc{Fragmento de topo (sem uso no documento)}% % Root chunk (not used in this document) \def\@nwlangdepcwf{Este c\'odigo foi escrito no ficheiro}% % This code is written to file \def\@nwlangdepchk{fragmento}% % chunk \def\@nwlangdepchks{fragmentos}% % chunks \def\@nwlangdepin{no(s)}% % in \def\@nwlangdepand{e}% % and \def\@nwlangdepuss{Usa}% % Uses \def\@nwlangdepusd{usado}% % used \def\@nwlangdepnvu{nunca usado}% % never used \def\@nwlangdepdfs{Define}% % Defines \def\@nwlangdepnvd{nunca definido}% % never defined } \def\nwopt@frenchb{% - \def\@nwlangdepdef{Cette d\'efinition suit}% + \def\@nwlangdepdef{Suite de la d\'efinition}% % This definition is continued \def\@nwlangdepcud{Ce code est employ\'e}% % This code is used \def\@nwlangdeprtc{Morceau racine (pas employ\'e dans ce document)}% % Root chunk (not used in this document) - \def\@nwlangdepcwf{Ce code est \'ecrit aux fichier}% + \def\@nwlangdepcwf{Ce code est \'ecrit dans le fichier}% % This code is written to file \def\@nwlangdepchk{le morceau}% % chunk \def\@nwlangdepchks{les morceaux}% % chunks \def\@nwlangdepin{dans}% % in \def\@nwlangdepand{et}% % and - \def\@nwlangdepuss{Il emploie}% + \def\@nwlangdepuss{Utilise}% % Uses - \def\@nwlangdepusd{employ\'{e}}% + \def\@nwlangdepusd{utilis\'{e}}% % used \def\@nwlangdepnvu{jamais employ\'{e}}% % never used - \def\@nwlangdepdfs{Il d\'{e}fine}% + \def\@nwlangdepdfs{D\'{e}finit}% % Defines % Cannot use the accent here: \def\@nwlangdepnvd{jamais d\'{e}fini}% \def\@nwlangdepnvd{jamais defini}% % never defined } \let\nwopt@french\nwopt@frenchb \def\nwopt@german{% \def\@nwlangdepdef{Diese Definition wird fortgesetzt}% % This definition is continued \def\@nwlangdepcud{Dieser Code wird benutzt}% % This code is used \def\@nwlangdeprtc{Hauptteil (nicht in diesem Dokument benutzt)}% % Root chunk (not used in this document) - \def\@nwlangdepcwf{Dieser Code schreibt man zum File}% + \def\@nwlangdepcwf{Geh\"ort in die Datei}% % This code is written to file + \def\@nwlangdepchk{Abschnitt}% + % chunk + \def\@nwlangdepchks{den Abschnitten}% + % chunks + \def\@nwlangdepin{in}% + % in + \def\@nwlangdepand{und}% + % and + \def\@nwlangdepuss{Benutzt}% + % Uses + \def\@nwlangdepusd{benutzt}% + % used + \def\@nwlangdepnvu{nicht benutzt}% + % never used + \def\@nwlangdepdfs{Definiert}% + % Defines + \def\@nwlangdepnvd{nicht definiert}% + % never defined +} +\def\nwopt@german{% + \def\@nwlangdepdef{Diese Definition wird fortgesetzt}% + % This definition is continued + \def\@nwlangdepcud{Dieser Code wird benutzt}% + % This code is used + \def\@nwlangdeprtc{Hauptteil (nicht in diesem Dokument benutzt)}% + % Root chunk (not used in this document) + \def\@nwlangdepcwf{Dieser Code erzeugt die Datei} + % This code generates the file \def\@nwlangdepchk{Teil}% % chunk \def\@nwlangdepchks{Teils}% % chunks \def\@nwlangdepin{im}% % in \def\@nwlangdepand{und}% % and \def\@nwlangdepuss{Benutzt}% % Uses \def\@nwlangdepusd{benutzt}% % used \def\@nwlangdepnvu{nicht benutzt}% % never used \def\@nwlangdepdfs{Definiert}% % Defines \def\@nwlangdepnvd{nicht definiert}% % never defined } \let\nwopt@ngerman\nwopt@german \ifx\languagename\undefined % default is English \noweboptions{english} \else \@ifundefined{nwopt@\languagename} {\noweboptions{english}} {\expandafter\noweboptions\expandafter{\languagename}} \fi Index: trunk/vamp/share/doc/noweb.sty =================================================================== --- trunk/vamp/share/doc/noweb.sty (revision 8914) +++ trunk/vamp/share/doc/noweb.sty (revision 8915) @@ -1,927 +1,976 @@ % noweb.sty -- LaTeX support for noweb % DON'T read or edit this file! Use ...noweb-source/tex/support.nw instead. {\obeyspaces\AtBeginDocument{\global\let =\ }} % from texbook, p 381 \def\nwopt@nomargintag{\let\nwmargintag=\@gobble} \def\nwopt@margintag{% \def\nwmargintag##1{\leavevmode\llap{##1\kern\nwmarginglue\kern\codemargin}}} \def\nwopt@margintag{% \def\nwmargintag##1{\leavevmode\kern-\codemargin\nwthemargintag{##1}\kern\codemargin}} \def\nwthemargintag#1{\llap{#1\kern\nwmarginglue}} \nwopt@margintag \newdimen\nwmarginglue \nwmarginglue=0.3in \def\nwtagstyle{\footnotesize\Rm} +\def\nwgitversion{|GITVERSION|} % make \hsize in code sufficient for 88 columns -\setbox0=\hbox{\tt m} +\ifx\ttfamily\undefined + \setbox0=\hbox{\tt m} +\else + \setbox0=\hbox{\ttfamily m} +\fi \newdimen\codehsize \codehsize=91\wd0 % 88 columns wasn't enough; I don't know why \newdimen\codemargin \codemargin=0pt \newdimen\nwdefspace \nwdefspace=\codehsize % need to use \textwidth in {\LaTeX} to handle styles with % non-standard margins (David Bruce). Don't know why we sometimes % wanted \hsize. 27 August 1997. %% \advance\nwdefspace by -\hsize\relax \ifx\textwidth\undefined \advance\nwdefspace by -\hsize\relax \else \advance\nwdefspace by -\textwidth\relax \fi \chardef\other=12 \def\setupcode{% \chardef\\=`\\ \chardef\{=`\{ \chardef\}=`\} \catcode`\$=\other \catcode`\&=\other \catcode`\#=\other \catcode`\%=\other \catcode`\~=\other \catcode`\_=\other \catcode`\^=\other \catcode`\"=\other % fixes problem with german.sty \obeyspaces\Tt } -\let\nwlbrace=\{ -\let\nwrbrace=\} \def\nwendquote{\relax\ifhmode\spacefactor=1000 \fi} {\catcode`\^^M=\active % make CR an active character \gdef\newlines{\catcode`\^^M=\active % make CR an active character \def^^M{\par\startline}}% \gdef\eatline#1^^M{\relax}% } %%% DON'T \gdef^^M{\par\startline}}% in case ^^M appears in a \write \def\startline{\noindent\hskip\parindent\ignorespaces} \def\nwnewline{\ifvmode\else\hfil\break\leavevmode\hbox{}\fi} \def\setupmodname{% \catcode`\$=3 \catcode`\&=4 \catcode`\#=6 \catcode`\%=14 \catcode`\~=13 \catcode`\_=8 \catcode`\^=7 \catcode`\ =10 \catcode`\^^M=5 - \let\{\nwlbrace - \let\}\nwrbrace + \let\{\lbrace + \let\}\rbrace % bad news --- don't know what catcode to give " \Rm} \def\LA{\begingroup\maybehbox\bgroup\setupmodname\It$\langle$} \def\RA{\/$\rangle$\egroup\endgroup} \def\code{\leavevmode\begingroup\setupcode\newlines} \def\edoc{\endgroup} \let\maybehbox\relax \newbox\equivbox \setbox\equivbox=\hbox{$\equiv$} \newbox\plusequivbox \setbox\plusequivbox=\hbox{$\mathord{+}\mathord{\equiv}$} % \moddef can't have an argument because there might be \code...\edoc \def\moddef{\leavevmode\kern-\codemargin\LA} \def\endmoddef{\RA\ifmmode\equiv\else\unhcopy\equivbox\fi \nobreak\hfill\nobreak} \def\plusendmoddef{\RA\ifmmode\mathord{+}\mathord{\equiv}\else\unhcopy\plusequivbox\fi \nobreak\hfill\nobreak} \def\chunklist{% \errhelp{I changed \chunklist to \nowebchunks. I'll try to avoid such incompatible changes in the future.}% \errmessage{Use \string\nowebchunks\space instead of \string\chunklist}} \def\nowebchunks{\message{}} \def\nowebindex{\message{}} % here is support for the new-style (capitalized) font-changing commands % thanks to Dave Love \ifx\documentstyle\undefined \let\Rm=\rm \let\It=\it \let\Tt=\tt % plain \else\ifx\selectfont\undefined \let\Rm=\rm \let\It=\it \let\Tt=\tt % LaTeX OFSS \else % LaTeX NFSS - \def\Rm{\reset@font\rm} - \def\It{\reset@font\it} - \def\Tt{\reset@font\tt} - \def\Bf{\reset@font\bf} + \def\Rm{\reset@font\rmfamily} + \def\It{\reset@font\itshape} + \def\Tt{\reset@font\ttfamily} + \def\Bf{\reset@font\bfseries} \fi\fi \ifx\reset@font\undefined \let\reset@font=\relax \fi +\def\nwbackslash{\char92} +\def\nwlbrace{\char123} +\def\nwrbrace{\char125} \def\noweboptions#1{% \def\@nwoptionlist{#1}% \@for\@nwoption:=\@nwoptionlist\do{% \@ifundefined{nwopt@\@nwoption}{% \@latexerr{There is no such noweb option as '\@nwoption'}\@eha}{% \csname nwopt@\@nwoption\endcsname}}} \codemargin=10pt \advance\codehsize by \codemargin % make room for indentation of code \advance\nwdefspace by \codemargin % and fix adjustment for def/use \def\setcodemargin#1{% \advance\codehsize by -\codemargin % make room for indentation of code \advance\nwdefspace by -\codemargin % and fix adjustment for def/use \codemargin=#1 \advance\codehsize by \codemargin % make room for indentation of code \advance\nwdefspace by \codemargin % and fix adjustment for % def/use } \def\nwopt@shift{% \dimen@=-0.8in \if@twoside % Values for two-sided printing: \advance\evensidemargin by \dimen@ \else % Values for one-sided printing: \advance\evensidemargin by \dimen@ \advance\oddsidemargin by \dimen@ \fi % \advance \marginparwidth -\dimen@ } \let\nwopt@noshift\@empty \def\nwbegincode#1{% \begingroup \topsep \nwcodetopsep \@beginparpenalty \@highpenalty \@endparpenalty -\@highpenalty \@begincode } \def\nwendcode{\endtrivlist \endgroup \filbreak} % keeps code on 1 page \newenvironment{webcode}{% \@begincode }{% \endtrivlist} +\newdimen\@nwbegincodelinewidth \def\@begincode{% + \@nwbegincodelinewidth=\linewidth \trivlist \item[]% \leftskip\@totalleftmargin \advance\leftskip\codemargin \rightskip\hsize \advance\rightskip -\codehsize \parskip\z@ \parindent\z@ \parfillskip\@flushglue \linewidth\codehsize \@@par \def\par{\leavevmode\null \@@par \penalty\nwcodepenalty}% \obeylines + \nowebsize \setupcode \@noligs \ifx\verbatim@nolig@list\undefined\else \let\do=\nw@makeother \verbatim@nolig@list \do@noligs\` \fi \setupcode \frenchspacing \@vobeyspaces - \nowebsize \setupcode \let\maybehbox\mbox } \newskip\nwcodetopsep \nwcodetopsep = 3pt plus 1.2pt minus 1pt \let\nowebsize=\normalsize \def\nwopt@tinycode{\let\nowebsize=\tiny} \def\nwopt@footnotesizecode{\let\nowebsize=\footnotesize} \def\nwopt@scriptsizecode{\let\nowebsize=\scriptsize} \def\nwopt@smallcode{\let\nowebsize=\small} \def\nwopt@normalsizecode{\let\nowebsize=\normalsize} \def\nwopt@largecode{\let\nowebsize=\large} \def\nwopt@Largecode{\let\nowebsize=\Large} \def\nwopt@LARGEcode{\let\nowebsize=\LARGE} \def\nwopt@hugecode{\let\nowebsize=\huge} \def\nwopt@Hugecode{\let\nowebsize=\Huge} \newcount\nwcodepenalty \nwcodepenalty=\@highpenalty \def\nw@makeother#1{\catcode`#1=12 } \def\nwbegindocs#1{\ifvmode\noindent\fi} \let\nwenddocs=\relax \let\nwdocspar=\filbreak \def\@nwsemifilbreak#1{\vskip0pt plus#1\penalty-200\vskip0pt plus -#1} \newdimen\nwbreakcodespace \nwbreakcodespace=0.2in % by default, leave no more than this on a page \def\nwopt@breakcode{% \def\nwdocspar{\@nwsemifilbreak{0.2in}}% \def\nwendcode{\endtrivlist\endgroup} % ditches filbreak } \raggedbottom \def\code{\leavevmode\begingroup\setupcode\@vobeyspaces\obeylines} \let\edoc=\endgroup \newdimen\@original@textwidth \def\ps@noweb{% \@original@textwidth=\textwidth \let\@mkboth\@gobbletwo \def\@oddfoot{}\def\@evenfoot{}% No feet. \if@twoside % If two-sided printing. \def\@evenhead{\hbox to \@original@textwidth{% \Rm \thepage\qquad{\Tt\leftmark}\hfil\today}}% Left heading. \def\@oddhead{\hbox to \@original@textwidth{% \Rm \today\hfil{\Tt\leftmark}\qquad\thepage}}% Right heading. \else % If one-sided printing. \def\@oddhead{\hbox to \@original@textwidth{% \Rm \today\hfil{\Tt\leftmark}\qquad\thepage}}% Right heading. \let\@evenhead\@oddhead \fi \let\chaptermark\@gobble \let\sectionmark\@gobble \let\subsectionmark\@gobble \let\subsubsectionmark\@gobble \let\paragraphmark\@gobble \let\subparagraphmark\@gobble \def\nwfilename{\begingroup\let\do\@makeother\dospecials \catcode`\{=1 \catcode`\}=2 \nw@filename} \def\nw@filename##1{\endgroup\markboth{##1}{##1}\let\nw@filename=\nw@laterfilename}% } \def\nw@laterfilename#1{\endgroup\clearpage \markboth{#1}{#1}} \let\nwfilename=\@gobble \def\nwcodecomment#1{\@@par\penalty\nwcodepenalty \if@firstnwcodecomment \vskip\nwcodecommentsep\penalty\nwcodepenalty\@firstnwcodecommentfalse \fi% \hspace{-\codemargin}{% \rightskip=0pt plus1in \interlinepenalty\nwcodepenalty \let\\\relax\footnotesize\Rm #1\@@par\penalty\nwcodepenalty}} \def\@nwalsodefined#1{\nwcodecomment{\@nwlangdepdef\ \nwpageprep\ \@pagesl{#1}.}} \def\@nwused#1{\nwcodecomment{\@nwlangdepcud\ \nwpageprep\ \@pagesl{#1}.}} \def\@nwnotused#1{\nwcodecomment{\@nwlangdeprtc.}} \def\nwoutput#1{\nwcodecomment{\@nwlangdepcwf\ {\Tt \@stripstar#1*\stripped}.}} \def\@stripstar#1*#2\stripped{#1} \newcommand{\nwprevdefptr}[1]{% \mbox{$\mathord{\triangleleft}\,\mathord{\mbox{\subpageref{#1}}}$}} \newcommand{\nwnextdefptr}[1]{% \mbox{$\mathord{\mbox{\subpageref{#1}}}\,\mathord{\triangleright}$}} \newcommand{\@nwprevnextdefs}[2]{% {\nwtagstyle \ifx\relax#1\else ~~\nwprevdefptr{#1}\fi \ifx\relax#2\else ~~\nwnextdefptr{#2}\fi}} \newcommand{\@nwusesondefline}[1]{{\nwtagstyle~~(\@pagenumsl{#1})}} \newcommand{\@nwstartdeflinemarkup}{\nobreak\hskip 1.5em plus 1fill\nobreak} \newcommand{\@nwenddeflinemarkup}{\nobreak\hskip \nwdefspace minus\nwdefspace\nobreak} \def\nwopt@longxref{% \let\nwalsodefined\@nwalsodefined \let\nwused\@nwused \let\nwnotused\@nwnotused \let\nwprevnextdefs\@gobbletwo \let\nwusesondefline\@gobble \let\nwstartdeflinemarkup\relax \let\nwenddeflinemarkup\relax } \def\nwopt@shortxref{% \let\nwalsodefined\@gobble \let\nwused\@gobble \let\nwnotused\@gobble \let\nwprevnextdefs\@nwprevnextdefs \let\nwusesondefline\@nwusesondefline \let\nwstartdeflinemarkup\@nwstartdeflinemarkup \let\nwenddeflinemarkup\@nwenddeflinemarkup } \def\nwopt@noxref{% \let\nwalsodefined\@gobble \let\nwused\@gobble \let\nwnotused\@gobble \let\nwprevnextdefs\@gobbletwo \let\nwusesondefline\@gobble \let\nwstartdeflinemarkup\relax \let\nwenddeflinemarkup\relax } \nwopt@shortxref % to hell with backward compatibility! \newskip\nwcodecommentsep \nwcodecommentsep=3pt plus 1pt minus 1pt \newif\if@firstnwcodecomment\@firstnwcodecommenttrue \newcount\@nwlopage\newcount\@nwhipage % range lo..hi-1 \newcount\@nwlosub % subpage of lo \newcount\@nwhisub % subpage of hi \def\@nwfirstpage#1#2#3{% subpage page xref-tag \@nwlopage=#2 \@nwlosub=#1 \def\@nwloxreftag{#3}% \advance\@nwpagecount by \@ne \@nwhipage=\@nwlopage\advance\@nwhipage by \@ne } \def\@nwnextpage#1#2#3{% subpage page xref-tag \ifnum\@nwhipage=#2 \advance\@nwhipage by \@ne \advance\@nwpagecount by \@ne \@nwhisub=#1 \def\@nwhixreftag{#3}\else \ifnum#2<\@nwlopage \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\@nwfirstpage{#1}{#2}{#3}\else \ifnum#2>\@nwhipage \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\@nwfirstpage{#1}{#2}{#3}\else \@nwlosub=0 \@nwhisub=0 \fi\fi\fi } \newcount\@nwpagetemp \newcount\@nwpagecount \def\@nwfirstpagel#1{% label \@ifundefined{r@#1}{\@warning{Reference `#1' on page \thepage \space undefined}% - \nwix@cons\nw@pages{\\{\bf ??}}}{% + \nwix@cons\nw@pages{\\{\bfseries ??}}}{% \edef\@tempa{\noexpand\@nwfirstpage\subpagepair{#1}{#1}}\@tempa}} \def\@nwnextpagel#1{% label \@ifundefined{r@#1}{\@warning{Reference `#1' on page \thepage \space undefined}% - \nwix@cons\nw@pages{\\{\bf ??}}}{% + \nwix@cons\nw@pages{\\{\bfseries ??}}}{% \edef\@tempa{\noexpand\@nwnextpage\subpagepair{#1}{#1}}\@tempa}} \def\@pagesl#1{% list of labels \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\@nwfirstpagel{##1}\let\\=\@nwnextpagel}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\def\\##1{\@nwhyperpagenum##1}% \ifnum\@nwpagecount=1 \nwpageword \else \nwpagesword\fi~\commafy{\nw@pages}} \def\@nwhyperpagenum#1#2{\nwhyperreference{#2}{#1}} \def\@pagenumsl#1{% list of labels -- doesn't include word `pages', commas, or `and' \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\@nwfirstpagel{##1}\let\\=\@nwnextpagel}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa% \def\\##1{\@nwhyperpagenum##1\let\\=\@nwpagenumslrest}\nw@pages} \def\@nwpagenumslrest#1{~\@nwhyperpagenum#1} \def\subpages#1{% list of {{subpage}{page}} \gdef\nw@pages{}\@nwpagecount=0 \def\\##1{\edef\@tempa{\noexpand\@nwfirstpage##1{}}\@tempa \def\\####1{\edef\@tempa{\noexpand\@nwnextpage####1}\@tempa}}#1% \advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\def\\##1{\@firstoftwo##1}% \ifnum\@nwpagecount=1 \nwpageword \else \nwpagesword\fi~\commafy{\nw@pages}} \def\@nwaddrange{\advance\@nwhipage by \m@ne \ifnum\@nwhipage=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}}% \else \count@=\@nwhipage \advance\count@ by \m@ne \ifnum\count@=\@nwlopage % consecutive pages \edef\@tempa{\noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% {\@nwloxreftag}}% \noexpand\noexpand\noexpand\\% {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} {\@nwhixreftag}}}% \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else \count@=\@nwlopage \divide\count@ by 100 \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi \multiply\@nwpagetemp by 100 \advance \@nwhipage by -\@nwpagetemp \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% \fi \fi \fi% \fi \fi% \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa} \def\nwpageword{\@nwlangdepchk} % chunk, was page \def\nwpagesword{\@nwlangdepchks} % chunk, was page \def\nwpageprep{\@nwlangdepin} % in, was on \newcommand\nw@genericref[2]{% what to do, name of ref \expandafter\nw@g@nericref\csname r@#2\endcsname#1{#2}} \newcommand\nw@g@nericref[3]{% control sequence, what to do, name \ifx#1\relax \ref{#3}% trigger the standard `undefined ref' mechanisms \else \expandafter#2#1.\\% \fi} \def\nw@selectone#1#2#3\\{#1} \def\nw@selecttwo#1#2#3\\{#2} \def\nw@selectonetwo#1#2#3\\{{#1}{#2}} \newcommand{\subpageref}[1]{% \nwhyperreference{#1}{\nw@genericref\@subpageref{#1}}} \def\@subpageref#1#2#3\\{% \@ifundefined{2on#2}{#2}{\nwthepagenum{#1}{#2}}} \newcommand{\subpagepair}[1]{% % produces {subpage}{page} \@ifundefined{r@#1}% {{0}{0}}% {\nw@genericref\@subpagepair{#1}}} \def\@subpagepair#1#2#3\\{% \@ifundefined{2on#2}{{0}{#2}}{{#1}{#2}}} \newcommand{\sublabel}[1]{% + \leavevmode % needed to make \@bsphack work \@bsphack \nwblindhyperanchor{#1}% \if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newsublabel{#1}{{}{\thepage}}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand{\nosublabel}[1]{% \@bsphack\if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newlabel{#1}{{0}{\thepage}}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand\newsublabel{% \nw@settrailers \global\let\newsublabel\@newsublabel \@newsublabel} \newcommand{\@newsublabel}[2]{% \edef\this@page{\@cdr#2\@nil}% \ifx\this@page\last@page\else \sub@page=\z@ \fi \edef\last@page{\this@page} \advance\sub@page by \@ne \ifnum\sub@page=\tw@ \global\@namedef{2on\this@page}{}% \fi \pendingsublabel{#1}% \edef\@tempa##1{\noexpand\newlabel{##1}% {{\number\sub@page}{\this@page}\nw@labeltrailers}}% \pending@sublabels \def\pending@sublabels{}} \newcommand\nw@settrailers{% -- won't work on first run \@ifpackageloaded{nameref}% {\gdef\nw@labeltrailers{{}{}{}}}% {\gdef\nw@labeltrailers{}}} \renewcommand\nw@settrailers{% \@ifundefined{@secondoffive}% {\gdef\nw@labeltrailers{}}% {\gdef\nw@labeltrailers{{}{}{}}}} \newcommand{\nextchunklabel}[1]{% \nwblindhyperanchor{#1}% % looks slightly bogus --- nr \@bsphack\if@filesw {\let\thepage\relax \edef\@tempa{\write\@auxout{\string\pendingsublabel{#1}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \newcommand\pendingsublabel[1]{% \def\@tempa{\noexpand\@tempa}% \edef\pending@sublabels{\noexpand\@tempa{#1}\pending@sublabels}} \def\pending@sublabels{} \def\last@page{\relax} \newcount\sub@page \def\@alphasubpagenum#1#2{#2\ifnum#1=0 \else\@alph{#1}\fi} \def\@nosubpagenum#1#2{#2} \def\@numsubpagenum#1#2{#2\ifnum#1=0 \else.\@arabic{#1}\fi} \def\nwopt@nosubpage{\let\nwthepagenum=\@nosubpagenum\nwopt@nomargintag} \def\nwopt@numsubpage{\let\nwthepagenum=\@numsubpagenum} \def\nwopt@alphasubpage{\let\nwthepagenum=\@alphasubpagenum} \nwopt@alphasubpage \newcount\@nwalph@n \let\@nwalph@d\@tempcnta \let\@nwalph@bound\@tempcntb \def\@nwlongalph#1{{% \@nwalph@n=#1\advance\@nwalph@n by-1 \@nwalph@bound=26 \loop\ifnum\@nwalph@n<\@nwalph@bound\else \advance\@nwalph@n by -\@nwalph@bound \multiply\@nwalph@bound by 26 \repeat \loop\ifnum\@nwalph@bound>1 \divide\@nwalph@bound by 26 \@nwalph@d=\@nwalph@n\divide\@nwalph@d by \@nwalph@bound % d := d * bound ; n -:= d; d := d / bound --- saves a temporary \multiply\@nwalph@d by \@nwalph@bound \advance\@nwalph@n by -\@nwalph@d \divide\@nwalph@d by \@nwalph@bound \advance\@nwalph@d by 1 \@alph{\@nwalph@d}% \repeat }} \newcount\nw@chunkcount \nw@chunkcount=\@ne \newcommand{\weblabel}[1]{% \@bsphack \nwblindhyperanchor{#1}% \if@filesw {\let\thepage\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string \newsublabel{#1}{{}{\number\nw@chunkcount}}}}% \expandafter}\@tempa \global\advance\nw@chunkcount by \@ne \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \def\nwopt@webnumbering{% \let\sublabel=\weblabel \def\nwpageword{chunk}\def\nwpagesword{chunks}% \def\nwpageprep{in}} % \nwindexdefn{printable name}{identifying label}{label of chunk} % \nwindexuse{printable name}{identifying label}{label of chunk} \def\nwindexdefn#1#2#3{\@auxix{\protect\nwixd}{#2}{#3}} \def\nwindexuse#1#2#3{\@auxix{\protect\nwixu}{#2}{#3}} \def\@auxix#1#2#3{% {marker}{id label}{subpage label} \@bsphack\if@filesw {\let\nwixd\relax\let\nwixu\relax \def\protect{\noexpand\noexpand\noexpand}% \edef\@tempa{\write\@auxout{\string\nwixadd{#1}{#2}{#3}}}% \expandafter}\@tempa \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} % \nwixadd{marker}{idlabel}{subpage label} \def\nwixadd#1#2#3{% \@ifundefined{nwixl@#2}% {\global\@namedef{nwixl@#2}{#1{#3}}}% {\expandafter\nwix@cons\csname nwixl@#2\endcsname{#1{#3}}}} \def\@nwsubscriptident#1#2{\mbox{$\mbox{#1}_{\mathrm{\subpageref{#2}}}$}} \def\@nwnosubscriptident#1#2{#1} \def\@nwhyperident#1#2{\leavevmode\nwhyperreference{#2}{#1}} \def\nwopt@subscriptidents{% \let\nwlinkedidentq\@nwsubscriptident \let\nwlinkedidentc\@nwsubscriptident } \def\nwopt@nosubscriptidents{% \let\nwlinkedidentq\@nwnosubscriptident \let\nwlinkedidentc\@nwnosubscriptident } \def\nwopt@hyperidents{% \let\nwlinkedidentq\@nwhyperident \let\nwlinkedidentc\@nwhyperident } \def\nwopt@nohyperidents{% \let\nwlinkedidentq\@nwnosubscriptident \let\nwlinkedidentc\@nwnosubscriptident } \def\nwopt@subscriptquotedidents{% \let\nwlinkedidentq\@nwsubscriptident } \def\nwopt@nosubscriptquotedidents{% \let\nwlinkedidentq\@nwnosubscriptident } \def\nwopt@hyperquotedidents{% \let\nwlinkedidentq\@nwhyperident } \def\nwopt@nohyperquotedidents{% \let\nwlinkedidentq\@nwnosubscriptident } \nwopt@hyperidents \newcount\@commacount \def\commafy#1{% {\nwix@listcount{#1}\@commacount=\nwix@counter \let\@comma@each=\\% \ifcase\@commacount\let\\=\@comma@each\or\let\\=\@comma@each\or \def\\{\def\\{ \@nwlangdepand\ \@comma@each}\@comma@each}\else \def\\{\def\\{, % \advance\@commacount by \m@ne \ifnum\@commacount=1 \@nwlangdepand~\fi\@comma@each}\@comma@each}\fi #1}} \def\nwix@cons#1#2{% {list}{\marker{element}} {\toks0=\expandafter{#1}\def\@tempa{#2}\toks2=\expandafter{\@tempa}% \xdef#1{\the\toks0 \the\toks2 }}} \def\nwix@uses#1{% {label} \def\nwixu{\\}\let\nwixd\@gobble\@nameuse{nwixl@#1}} \def\nwix@defs#1{% {label} \def\nwixd{\\}\let\nwixu\@gobble\@nameuse{nwixl@#1}} \newcount\nwix@counter \def\nwix@listcount#1{% {list with \\} {\count@=0 \def\\##1{\advance\count@ by \@ne }% #1\global\nwix@counter=\count@ }} \def\nwix@usecount#1{\nwix@listcount{\nwix@uses{#1}}} \def\nwix@defcount#1{\nwix@listcount{\nwix@defs{#1}}} \def\nwix@id@defs#1{% index pair {{\Tt \@car#1\@nil}% \def\\##1{\nwix@defs@space\subpageref{##1}}\nwix@defs{\@cdr#1\@nil}}} % useful above to change ~ into something that can break % this option is undocumented because I think breakdefs is always right \def\nwopt@breakdefs{\def\nwix@defs@space{\penalty200\ }} \def\nwopt@nobreakdefs{\def\nwix@defs@space{~}} % old code \nwopt@breakdefs \def\nwidentuses#1{% list of index pairs \nwcodecomment{\@nwlangdepuss\ \let\\=\nwix@id@defs\commafy{#1}.}} \def\nwix@totaluses#1{% list of index pairs {\count@=0 \def\\##1{\nwix@usecount{\@cdr##1\@nil}\advance\count@ by\nwix@counter}% #1\global\nwix@counter\count@ }} \def\nwix@id@uses#1#2{% {ident}{label} \nwix@usecount{#2}\ifnum\nwix@counter>0 {\advance\leftskip by \codemargin \nwcodecomment{{\Tt #1}, \@nwlangdepusd\ \nwpageprep\ \@pagesl{\nwix@uses{#2}}.}}% \else \ifnw@hideunuseddefs\else {\advance\leftskip by \codemargin \nwcodecomment{{\Tt #1}, \@nwlangdepnvu.}}% \fi \fi} \def\nwidentdefs#1{% list of index pairs \ifnw@hideunuseddefs\nwix@totaluses{#1}\else\nwix@listcount{#1}\fi \ifnum\nwix@counter>0 \nwcodecomment{\@nwlangdepdfs:}% {\def\\##1{\nwix@id@uses ##1}#1}% \fi} \newif\ifnw@hideunuseddefs\nw@hideunuseddefsfalse \def\nwopt@hideunuseddefs{\nw@hideunuseddefstrue} \def\nwopt@noidentxref{% \let\nwidentdefs\@gobble \let\nwidentuses\@gobble} \def\nw@underlinedefs{% {list with \nwixd, \nwixu} \let\\=\relax\def\nw@comma{, } \def\nwixd##1{\\\underline{\subpageref{##1}}\let\\\nw@comma}% \def\nwixu##1{\\\subpageref{##1}\let\\\nw@comma}} \def\nw@indexline#1#2{% {\indent {\Tt #1}: \nw@underlinedefs\@nameuse{nwixl@#2}\par}} \newenvironment{thenowebindex}{\parindent=-10pt \parskip=\z@ \advance\leftskip by 10pt \advance\rightskip by 0pt plus1in\par\@afterindenttrue \def\\##1{\nw@indexline##1}}{} \def\nowebindex{% \@ifundefined{nwixs@i}% {\@warning{The \string\nowebindex\space is empty}}% {\begin{thenowebindex}\@nameuse{nwixs@i}\end{thenowebindex}}} \def\nowebindex@external{% {\let\nwixadds@c=\@gobble \def\nwixadds@i##1{\nw@indexline##1}% \def\nwixaddsx##1##2{\@nameuse{nwixadds@##1}{##2}}% \begin{thenowebindex}\@input{\jobname.nwi}\end{thenowebindex}}} \def\nwixlogsorted#1#2{% list data \@bsphack\if@filesw \toks0={#2}\immediate\write\@auxout{\string\nwixadds{#1}{\the\toks0}} \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} \def\nwixadds#1#2{% \@ifundefined{nwixs@#1}% {\global\@namedef{nwixs@#1}{\\{#2}}}% {\expandafter\nwix@cons\csname nwixs@#1\endcsname{\\{#2}}}} \let\nwixaddsx=\@gobbletwo \def\nwopt@externalindex{% \ifx\nwixadds\@gobbletwo % already called \else \let\nwixaddsx=\nwixadds \let\nwixadds=\@gobbletwo \let\nowebindex=\nowebindex@external \let\nowebchunks=\nowebchunks@external \fi} \def\nowebchunks{% \@ifundefined{nwixs@c}% {\@warning{The are no \string\nowebchunks}}% {\begin{thenowebchunks}\@nameuse{nwixs@c}\end{thenowebchunks}}} \def\nowebchunks@external{% {\let\nwixadds@i=\@gobble \def\nwixadds@c##1{\nw@onechunk##1}% \def\nwixaddsx##1##2{\@nameuse{nwixadds@##1}{##2}}% \begin{thenowebchunks}\@input{\jobname.nwi}\end{thenowebchunks}}} \@namedef{r@nw@notdef}{{0}{(\@nwlangdepnvd)}} \def\nw@chunkunderlinedefs{% {list of labels with \nwixd, \nwixu} \let\\=\relax\def\nw@comma{, } \def\nwixd##1{\\\underline{\subpageref{##1}}\let\\\nw@comma}% \def\nwixu##1{\\\subpageref{##1}\let\\\nw@comma}} \def\nw@onechunk#1#2#3{% {name}{label of first definition}{list with \nwixd, \nwixu} \@ifundefined{r@#2}{}{% \indent\LA #1~{\nwtagstyle\subpageref{#2}}\RA \if@nwlongchunks{~\nw@chunkunderlinedefs#3}\fi\par}} \newenvironment{thenowebchunks}{\vskip3pt \parskip=\z@\parindent=-10pt \advance\leftskip by 10pt \advance\rightskip by 0pt plus10pt \@afterindenttrue \def\\##1{\nw@onechunk##1}}{} \newif\if@nwlongchunks \@nwlongchunksfalse \let\nwopt@longchunks\@nwlongchunkstrue \newcommand\@nw@hyper@ref{\hyperreference} % naras \newcommand\@nw@hyper@anc{\blindhyperanchor} % naras \newcommand\@nw@hyperref@ref[2]{\hyperlink{noweb.#1}{#2}} % nr \newcommand\@nw@hyperref@anc[1]{\hypertarget{noweb.#1}{\relax}} % nr %%\renewcommand\@nw@hyperref@ref[2]{{#2}} % nr %%\renewcommand\@nw@hyperref@anc[1]{} % nr \newcommand\nwhyperreference{% \@ifundefined{hyperlink} {\@ifundefined{hyperreference} {\global\let\nwhyperreference\@gobble} {\global\let\nwhyperreference\@nw@hyper@ref}} {\global\let\nwhyperreference\@nw@hyperref@ref}% \nwhyperreference } \newcommand\nwblindhyperanchor{% \@ifundefined{hyperlink} {\@ifundefined{hyperreference} {\global\let\nwblindhyperanchor\@gobble} {\global\let\nwblindhyperanchor\@nw@hyper@anc}} {\global\let\nwblindhyperanchor\@nw@hyperref@anc}% \nwblindhyperanchor } \newcommand\nwanchorto{% \begingroup\let\do\@makeother\dospecials \catcode`\{=1 \catcode`\}=2 \nw@anchorto} \newcommand\nw@anchorto[1]{\endgroup\def\nw@next{#1}\nw@anchortofin} \newcommand\nw@anchortofin[1]{#1\footnote{See URL \texttt{\nw@next}.}} \let\nwanchorname\@gobble \newif\ifhtml \htmlfalse \let\nwixident=\relax -\def\nwbackslash{\char92} -\def\nwlbrace{\char123} -\def\nwrbrace{\char125} \def\nwopt@english{% \def\@nwlangdepdef{This definition is continued}% \def\@nwlangdepcud{This code is used}% \def\@nwlangdeprtc{Root chunk (not used in this document)}% \def\@nwlangdepcwf{This code is written to file}% \def\@nwlangdepchk{chunk}% \def\@nwlangdepchks{chunks}% \def\@nwlangdepin{in}% \def\@nwlangdepand{and}% \def\@nwlangdepuss{Uses}% \def\@nwlangdepusd{used}% \def\@nwlangdepnvu{never used}% \def\@nwlangdepdfs{Defines}% \def\@nwlangdepnvd{never defined}% } \let\nwopt@american\nwopt@english +\def\nwopt@icelandic{% + \def\@nwlangdepdef{This definition is continued}% + \def\@nwlangdepcud{This code is used}% + \def\@nwlangdeprtc{Root chunk (not used in this document)}% + \def\@nwlangdepcwf{This code is written to file}% + \def\@nwlangdepchk{kóða}% + \def\@nwlangdepchks{kóðum}% + \def\@nwlangdepin{í}% + \def\@nwlangdepand{og}% + \def\@nwlangdepuss{Notar}% + \def\@nwlangdepusd{notað}% + \def\@nwlangdepnvu{hvergi notað}% + \def\@nwlangdepdfs{Skilgreinir}% + \def\@nwlangdepnvd{hvergi skilgreint}% +} \def\nwopt@portuges{% \def\@nwlangdepdef{Defini\c{c}\~ao continuada em}% % This definition is continued \def\@nwlangdepcud{C\'odigo usado em}% % This code is used \def\@nwlangdeprtc{Fragmento de topo (sem uso no documento)}% % Root chunk (not used in this document) \def\@nwlangdepcwf{Este c\'odigo foi escrito no ficheiro}% % This code is written to file \def\@nwlangdepchk{fragmento}% % chunk \def\@nwlangdepchks{fragmentos}% % chunks \def\@nwlangdepin{no(s)}% % in \def\@nwlangdepand{e}% % and \def\@nwlangdepuss{Usa}% % Uses \def\@nwlangdepusd{usado}% % used \def\@nwlangdepnvu{nunca usado}% % never used \def\@nwlangdepdfs{Define}% % Defines \def\@nwlangdepnvd{nunca definido}% % never defined } \def\nwopt@frenchb{% - \def\@nwlangdepdef{Cette d\'efinition suit}% + \def\@nwlangdepdef{Suite de la d\'efinition}% % This definition is continued \def\@nwlangdepcud{Ce code est employ\'e}% % This code is used \def\@nwlangdeprtc{Morceau racine (pas employ\'e dans ce document)}% % Root chunk (not used in this document) - \def\@nwlangdepcwf{Ce code est \'ecrit aux fichier}% + \def\@nwlangdepcwf{Ce code est \'ecrit dans le fichier}% % This code is written to file \def\@nwlangdepchk{le morceau}% % chunk \def\@nwlangdepchks{les morceaux}% % chunks \def\@nwlangdepin{dans}% % in \def\@nwlangdepand{et}% % and - \def\@nwlangdepuss{Il emploie}% + \def\@nwlangdepuss{Utilise}% % Uses - \def\@nwlangdepusd{employ\'{e}}% + \def\@nwlangdepusd{utilis\'{e}}% % used \def\@nwlangdepnvu{jamais employ\'{e}}% % never used - \def\@nwlangdepdfs{Il d\'{e}fine}% + \def\@nwlangdepdfs{D\'{e}finit}% % Defines % Cannot use the accent here: \def\@nwlangdepnvd{jamais d\'{e}fini}% \def\@nwlangdepnvd{jamais defini}% % never defined } \let\nwopt@french\nwopt@frenchb \def\nwopt@german{% \def\@nwlangdepdef{Diese Definition wird fortgesetzt}% % This definition is continued \def\@nwlangdepcud{Dieser Code wird benutzt}% % This code is used \def\@nwlangdeprtc{Hauptteil (nicht in diesem Dokument benutzt)}% % Root chunk (not used in this document) - \def\@nwlangdepcwf{Dieser Code schreibt man zum File}% + \def\@nwlangdepcwf{Geh\"ort in die Datei}% % This code is written to file + \def\@nwlangdepchk{Abschnitt}% + % chunk + \def\@nwlangdepchks{den Abschnitten}% + % chunks + \def\@nwlangdepin{in}% + % in + \def\@nwlangdepand{und}% + % and + \def\@nwlangdepuss{Benutzt}% + % Uses + \def\@nwlangdepusd{benutzt}% + % used + \def\@nwlangdepnvu{nicht benutzt}% + % never used + \def\@nwlangdepdfs{Definiert}% + % Defines + \def\@nwlangdepnvd{nicht definiert}% + % never defined +} +\def\nwopt@german{% + \def\@nwlangdepdef{Diese Definition wird fortgesetzt}% + % This definition is continued + \def\@nwlangdepcud{Dieser Code wird benutzt}% + % This code is used + \def\@nwlangdeprtc{Hauptteil (nicht in diesem Dokument benutzt)}% + % Root chunk (not used in this document) + \def\@nwlangdepcwf{Dieser Code erzeugt die Datei} + % This code generates the file \def\@nwlangdepchk{Teil}% % chunk \def\@nwlangdepchks{Teils}% % chunks \def\@nwlangdepin{im}% % in \def\@nwlangdepand{und}% % and \def\@nwlangdepuss{Benutzt}% % Uses \def\@nwlangdepusd{benutzt}% % used \def\@nwlangdepnvu{nicht benutzt}% % never used \def\@nwlangdepdfs{Definiert}% % Defines \def\@nwlangdepnvd{nicht definiert}% % never defined } \let\nwopt@ngerman\nwopt@german \ifx\languagename\undefined % default is English \noweboptions{english} \else \@ifundefined{nwopt@\languagename} {\noweboptions{english}} {\expandafter\noweboptions\expandafter{\languagename}} \fi Index: trunk/vamp/src/vamp.nw =================================================================== --- trunk/vamp/src/vamp.nw (revision 8914) +++ trunk/vamp/src/vamp.nw (revision 8915) @@ -1,4530 +1,4530 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP main code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The Abstract Datatype \texttt{vamp\_grid}} <<[[vamp.f90]]>>= ! vamp.f90 -- <> @ \begin{dubious} \index{Fortran problem} NAG f95 requires this split. Check with the Fortran community, if it is really necessary, or a bug! The problem is that this split forces us the expose the components of [[vamp_grid]]. \textbf{NB:} with the introduction of [[vamp_equivalences]], this question has (probably) become academic. \end{dubious} <<[[vamp.f90]]>>= module vamp_grid_type use kinds use divisions private <> end module vamp_grid_type @ %def vamp_grid_type @ \begin{dubious} By WK for WHIZARD. \end{dubious} <<[[vamp.f90]]>>= module vamp_equivalences use kinds use divisions use vamp_grid_type !NODEP! implicit none private <> <> <> contains <> end module vamp_equivalences @ %def vamp_equivalences @ <>= type, public :: vamp_equivalence_t integer :: left, right integer, dimension(:), allocatable :: permutation integer, dimension(:), allocatable :: mode end type vamp_equivalence_t @ <>= type, public :: vamp_equivalences_t type(vamp_equivalence_t), dimension(:), allocatable :: eq integer :: n_eq, n_ch integer, dimension(:), allocatable :: pointer logical, dimension(:), allocatable :: independent integer, dimension(:), allocatable :: equivalent_to_ch integer, dimension(:), allocatable :: multiplicity integer, dimension(:), allocatable :: symmetry logical, dimension(:,:), allocatable :: div_is_invariant end type vamp_equivalences_t @ <>= integer, parameter, public :: & VEQ_IDENTITY = 0, VEQ_INVERT = 1, VEQ_SYMMETRIC = 2, VEQ_INVARIANT = 3 @ <>= subroutine vamp_equivalence_init (eq, n_dim) type(vamp_equivalence_t), intent(inout) :: eq integer, intent(in) :: n_dim allocate (eq%permutation(n_dim), eq%mode(n_dim)) end subroutine vamp_equivalence_init @ %def vamp_equivalence_init @ <>= public :: vamp_equivalences_init @ <>= subroutine vamp_equivalences_init (eq, n_eq, n_ch, n_dim) type(vamp_equivalences_t), intent(inout) :: eq integer, intent(in) :: n_eq, n_ch, n_dim integer :: i eq%n_eq = n_eq eq%n_ch = n_ch allocate (eq%eq(n_eq)) allocate (eq%pointer(n_ch+1)) do i=1, n_eq call vamp_equivalence_init (eq%eq(i), n_dim) end do allocate (eq%independent(n_ch), eq%equivalent_to_ch(n_ch)) allocate (eq%multiplicity(n_ch), eq%symmetry(n_ch)) allocate (eq%div_is_invariant(n_ch, n_dim)) eq%independent = .true. eq%equivalent_to_ch = 0 eq%multiplicity = 0 eq%symmetry = 0 eq%div_is_invariant = .false. end subroutine vamp_equivalences_init @ %def vamp_equivalences_init @ <>= subroutine vamp_equivalence_final (eq) type(vamp_equivalence_t), intent(inout) :: eq deallocate (eq%permutation, eq%mode) end subroutine vamp_equivalence_final @ %def vamp_equivalence_final @ <>= public :: vamp_equivalences_final @ <>= subroutine vamp_equivalences_final (eq) type(vamp_equivalences_t), intent(inout) :: eq ! integer :: i ! do i=1, eq%n_eq ! call vamp_equivalence_final (eq%eq(i)) ! end do if (allocated (eq%eq)) deallocate (eq%eq) if (allocated (eq%pointer)) deallocate (eq%pointer) if (allocated (eq%multiplicity)) deallocate (eq%multiplicity) if (allocated (eq%symmetry)) deallocate (eq%symmetry) if (allocated (eq%independent)) deallocate (eq%independent) if (allocated (eq%equivalent_to_ch)) deallocate (eq%equivalent_to_ch) if (allocated (eq%div_is_invariant)) deallocate (eq%div_is_invariant) eq%n_eq = 0 eq%n_ch = 0 end subroutine vamp_equivalences_final @ %def vamp_equivalences_final @ <>= subroutine vamp_equivalence_write (eq, unit) integer, intent(in), optional :: unit integer :: u type(vamp_equivalence_t), intent(in) :: eq u = 6; if (present (unit)) u = unit write (u, "(3x,A,2(1x,I0))") "Equivalent channels:", eq%left, eq%right write (u, "(5x,A,99(1x,I0))") "Permutation:", eq%permutation write (u, "(5x,A,99(1x,I0))") "Mode: ", eq%mode end subroutine vamp_equivalence_write @ %def vamp_equivalence_write @ <>= public :: vamp_equivalences_write @ <>= subroutine vamp_equivalences_write (eq, unit) type(vamp_equivalences_t), intent(in) :: eq integer, intent(in), optional :: unit integer :: u integer :: ch, i u = 6; if (present (unit)) u = unit write (u, "(1x,A)") "Inequivalent channels:" if (allocated (eq%independent)) then do ch=1, eq%n_ch if (eq%independent(ch)) then write (u, "(3x,A,1x,I0,A,4x,A,I0,4x,A,I0,4x,A,999(L1))") & "Channel", ch, ":", & "Mult. = ", eq%multiplicity(ch), & "Symm. = ", eq%symmetry(ch), & "Invar.: ", eq%div_is_invariant(ch,:) end if end do else write (u, "(3x,A)") "[not allocated]" end if write (u, "(1x,A)") "Equivalence list:" if (allocated (eq%eq)) then do i=1, size (eq%eq) call vamp_equivalence_write (eq%eq(i), u) end do else write (u, "(3x,A)") "[not allocated]" end if end subroutine vamp_equivalences_write @ %def vamp_equivalences_write @ <>= public :: vamp_equivalence_set @ <>= subroutine vamp_equivalence_set (eq, i, left, right, perm, mode) type(vamp_equivalences_t), intent(inout) :: eq integer, intent(in) :: i integer, intent(in) :: left, right integer, dimension(:), intent(in) :: perm, mode eq%eq(i)%left = left eq%eq(i)%right = right eq%eq(i)%permutation = perm eq%eq(i)%mode = mode end subroutine vamp_equivalence_set @ %def vamp_equivalence_set @ <>= public :: vamp_equivalences_complete @ <>= subroutine vamp_equivalences_complete (eq) type(vamp_equivalences_t), intent(inout) :: eq integer :: i, ch ch = 0 do i=1, eq%n_eq if (ch /= eq%eq(i)%left) then ch = eq%eq(i)%left eq%pointer(ch) = i end if end do eq%pointer(ch+1) = eq%n_eq + 1 do ch=1, eq%n_ch call set_multiplicities (eq%eq(eq%pointer(ch):eq%pointer(ch+1)-1)) end do ! call write (6, eq) contains subroutine set_multiplicities (eq_ch) type(vamp_equivalence_t), dimension(:), intent(in) :: eq_ch integer :: i if (.not. all(eq_ch%left == ch) .or. eq_ch(1)%right > ch) then do i = 1, size (eq_ch) call vamp_equivalence_write (eq_ch(i)) end do stop "VAMP: Equivalences: Something's wrong with equivalence ordering" end if eq%symmetry(ch) = count (eq_ch%right == ch) if (mod (size(eq_ch), eq%symmetry(ch)) /= 0) then do i = 1, size (eq_ch) call vamp_equivalence_write (eq_ch(i)) end do stop "VAMP: Equivalences: Something's wrong with permutation count" end if eq%multiplicity(ch) = size (eq_ch) / eq%symmetry(ch) eq%independent(ch) = all (eq_ch%right >= ch) eq%equivalent_to_ch(ch) = eq_ch(1)%right eq%div_is_invariant(ch,:) = eq_ch(1)%mode == VEQ_INVARIANT end subroutine set_multiplicities end subroutine vamp_equivalences_complete @ %def vamp_equivalences_complete @ <<[[vamp.f90]]>>= module vamp_rest use kinds use utils use exceptions use divisions use tao_random_numbers use vamp_stat use linalg use iso_fortran_env use vamp_grid_type !NODEP! use vamp_equivalences !NODEP! implicit none private <> <> <> <> <> contains <> end module vamp_rest @ %def vamp_rest @ <<[[vamp.f90]]>>= module vamp use vamp_grid_type !NODEP! use vamp_rest !NODEP! use vamp_equivalences !NODEP! public end module vamp @ %def vamp @ N.B.: In \texttt{Fortran95} we will be able to give default initializations to components of the type. In particular, we can use the [[null ()]] intrinsic to initialize the pointers to a disassociated state. Until then, the user \emph{must} call the initializer [[vamp_create_grid]] himself of herself, because we can't check for the allocation status of the pointers in \texttt{Fortran90} or~\texttt{F}. \index{deficiencies in \protect\texttt{Fortran90} and \protect\texttt{F}} \begin{dubious} Augment this datatype by [[real(kind=default), dimension(2) :: mu_plus, mu_minus]] to record positive and negative weight separately, so that we can estimmate the efficiency for reweighting from indefinite weights to $\{+1,-1\}$. [WK 2015/11/06: done. Those values are recorded but not used inside \texttt{vamp}. They can be retrieved by the caller.] \end{dubious} \begin{dubious} WK 2015/11/06: [[f_min]] and [[f_max]] work with the absolute value of the matrix element, so they record the minimum and maximum absolute value. \end{dubious} <>= type, public :: vamp_grid ! private !: forced by \texttt{use} association in interface type(division_t), dimension(:), pointer :: div => null () real(kind=default), dimension(:,:), pointer :: map => null () real(kind=default), dimension(:), pointer :: mu_x => null () real(kind=default), dimension(:), pointer :: sum_mu_x => null () real(kind=default), dimension(:,:), pointer :: mu_xx => null () real(kind=default), dimension(:,:), pointer :: sum_mu_xx => null () real(kind=default), dimension(2) :: mu real(kind=default), dimension(2) :: mu_plus, mu_minus real(kind=default) :: sum_integral, sum_weights, sum_chi2 real(kind=default) :: calls, dv2g, jacobi real(kind=default) :: f_min, f_max real(kind=default) :: mu_gi, sum_mu_gi integer, dimension(:), pointer :: num_div => null () integer :: num_calls, calls_per_cell logical :: stratified = .true. logical :: all_stratified = .true. logical :: quadrupole = .false. logical :: independent integer :: equivalent_to_ch, multiplicity end type vamp_grid @ %def vamp_grid @ <>= public :: vamp_copy_grid, vamp_delete_grid @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Container for application data} \begin{dubious} By WK for WHIZARD. We define an empty data type that the application can extend according to its needs. The purpose is to hold all sorts of data that are predefined and accessed during the call of the sampling function. The actual interface for the sampling function is PURE. Nevertheless, we can implement side effects via pointer components of a [[vamp_data_t]] extension. \end{dubious} <>= type, public :: vamp_data_t end type vamp_data_t @ %def vamp_data_t @ This is the object to be passed if we want nothing else: <>= type(vamp_data_t), parameter, public :: NO_DATA = vamp_data_t () @ %def NO_DATA @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Initialization} <>= public :: vamp_create_grid, vamp_create_empty_grid @ %def vamp_create_grid vamp_create_empty_grid @ Create a fresh grid for the integration domain \begin{equation} \mathcal{D} = [D_{1,1},D_{2,1}] \times [D_{1,2},D_{2,2}] \times \ldots \times [D_{1,n},D_{2,n}] \end{equation} dropping all accumulated results. This function \emph{must not} be called twice on the first argument, without an intervening [[vamp_delete_grid]]. Iff the second variable is given, it will be the number of sampling points for the call to [[vamp_sample_grid]]. <>= pure subroutine vamp_create_grid & (g, domain, num_calls, num_div, & stratified, quadrupole, covariance, map, exc) type(vamp_grid), intent(inout) :: g real(kind=default), dimension(:,:), intent(in) :: domain integer, intent(in) :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance real(kind=default), dimension(:,:), intent(in), optional :: map type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_create_grid" real(kind=default), dimension(size(domain,dim=2)) :: & x_min, x_max, x_min_true, x_max_true integer :: ndim ndim = size (domain, dim=2) allocate (g%div(ndim), g%num_div(ndim)) x_min = domain(1,:) x_max = domain(2,:) if (present (map)) then allocate (g%map(ndim,ndim)) g%map = map x_min_true = x_min x_max_true = x_max call map_domain (g%map, x_min_true, x_max_true, x_min, x_max) call create_division (g%div, x_min, x_max, x_min_true, x_max_true) else nullify (g%map) call create_division (g%div, x_min, x_max) end if g%num_calls = num_calls if (present (num_div)) then g%num_div = num_div else g%num_div = NUM_DIV_DEFAULT end if g%stratified = .true. g%quadrupole = .false. g%independent = .true. g%equivalent_to_ch = 0 g%multiplicity = 1 nullify (g%mu_x, g%mu_xx, g%sum_mu_x, g%sum_mu_xx) call vamp_discard_integral & (g, num_calls, num_div, stratified, quadrupole, covariance, exc) end subroutine vamp_create_grid @ %def vamp_create_grid @ %def ndim domain dx grid -@ Below, we assume that $[[NUM_DIV_DEFAULT]] \ge 6$, but we will never +@ Below, we assume that $\text{[[NUM_DIV_DEFAULT]]} \ge 6$, but we will never go that low anyway. <>= integer, private, parameter :: NUM_DIV_DEFAULT = 20 @ %def NUM_DIV_DEFAULT @ Given a linear map~$M$, find a domain~$\mathcal{D}_0$ such that \begin{equation} \mathcal{D} \subset M \mathcal{D}_0 \end{equation} <>= private :: map_domain @ If we can assume that~$M$ is orthogonal~$M^{-1}=M^T$, then we just have to rotate~$\mathcal{D}$ and determine the maximal and minimal extension of the corners: \begin{equation} \mathcal{D}_0^T = \overline{\mathcal{D}^T M} \end{equation} The corners are just the powerset of the maximal and minimal extension in each coordinate. It is determined most easily with binary counting: <>= pure subroutine map_domain (map, true_xmin, true_xmax, xmin, xmax) real(kind=default), dimension(:,:), intent(in) :: map real(kind=default), dimension(:), intent(in) :: true_xmin, true_xmax real(kind=default), dimension(:), intent(out) :: xmin, xmax real(kind=default), dimension(2**size(xmin),size(xmin)) :: corners integer, dimension(size(xmin)) :: zero_to_n integer :: j, ndim, perm ndim = size (xmin) zero_to_n = (/ (j, j=0,ndim-1) /) do perm = 1, 2**ndim corners (perm,:) = & merge (true_xmin, true_xmax, btest (perm-1, zero_to_n)) end do corners = matmul (corners, map) xmin = minval (corners, dim=1) xmax = maxval (corners, dim=1) end subroutine map_domain @ %def map_domain @ <>= elemental subroutine vamp_create_empty_grid (g) type(vamp_grid), intent(inout) :: g nullify (g%div, g%num_div, g%map, g%mu_x, g%mu_xx, g%sum_mu_x, g%sum_mu_xx) end subroutine vamp_create_empty_grid @ %def vamp_create_empty_grid @ <>= public :: vamp_discard_integral @ Keep the current optimized grid, but drop the accumulated results for the integral (value and errors). Iff the second variable is given, it will be the new number of sampling points for the next call to [[vamp_sample_grid]]. <>= pure subroutine vamp_discard_integral & (g, num_calls, num_div, stratified, quadrupole, covariance, exc, & & independent, equivalent_to_ch, multiplicity) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance type(exception), intent(inout), optional :: exc logical, intent(in), optional :: independent integer, intent(in), optional :: equivalent_to_ch, multiplicity character(len=*), parameter :: FN = "vamp_discard_integral" g%mu = 0.0 g%mu_plus = 0.0 g%mu_minus = 0.0 g%mu_gi = 0.0 g%sum_integral = 0.0 g%sum_weights = 0.0 g%sum_chi2 = 0.0 g%sum_mu_gi = 0.0 if (associated (g%sum_mu_x)) then g%sum_mu_x = 0.0 g%sum_mu_xx = 0.0 end if call set_grid_options (g, num_calls, num_div, stratified, quadrupole, & independent, equivalent_to_ch, multiplicity) if ((present (num_calls)) & .or. (present (num_div)) & .or. (present (stratified)) & .or. (present (quadrupole)) & .or. (present (covariance))) then call vamp_reshape_grid & (g, g%num_calls, g%num_div, & g%stratified, g%quadrupole, covariance, exc) end if end subroutine vamp_discard_integral @ %def vamp_discard_integral @ %def sum_integral sum_weights sum_chi2 @ <>= private :: set_grid_options @ <>= pure subroutine set_grid_options & (g, num_calls, num_div, stratified, quadrupole, & independent, equivalent_to_ch, multiplicity) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole logical, intent(in), optional :: independent integer, intent(in), optional :: equivalent_to_ch, multiplicity if (present (num_calls)) then g%num_calls = num_calls end if if (present (num_div)) then g%num_div = num_div end if if (present (stratified)) then g%stratified = stratified end if if (present (quadrupole)) then g%quadrupole = quadrupole end if if (present (independent)) then g%independent = independent end if if (present (equivalent_to_ch)) then g%equivalent_to_ch = equivalent_to_ch end if if (present (multiplicity)) then g%multiplicity = multiplicity end if end subroutine set_grid_options @ %def set_grid_options @ %def num_calls num_div stratified quadrupole @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Setting Up the Initial Grid} Keep the current optimized grid and the accumulated results for the integral (value and errors). The second variable will be the new number of sampling points for the next call to [[vamp_sample_grid]]. <>= pure subroutine vamp_reshape_grid_internal & (g, num_calls, num_div, & stratified, quadrupole, covariance, exc, use_variance, & independent, equivalent_to_ch, multiplicity) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance type(exception), intent(inout), optional :: exc logical, intent(in), optional :: use_variance logical, intent(in), optional :: independent integer, intent(in), optional :: equivalent_to_ch, multiplicity integer :: ndim, num_cells integer, dimension(size(g%div)) :: ng character(len=*), parameter :: FN = "vamp_reshape_grid_internal" ndim = size (g%div) call set_grid_options & (g, num_calls, num_div, stratified, quadrupole, & & independent, equivalent_to_ch, multiplicity) <> g%all_stratified = all (stratified_division (g%div)) if (present (covariance)) then ndim = size (g%div) if (covariance .and. (.not. associated (g%mu_x))) then allocate (g%mu_x(ndim), g%mu_xx(ndim,ndim)) allocate (g%sum_mu_x(ndim), g%sum_mu_xx(ndim,ndim)) g%sum_mu_x = 0.0 g%sum_mu_xx = 0.0 else if ((.not. covariance) .and. (associated (g%mu_x))) then deallocate (g%mu_x, g%mu_xx, g%sum_mu_x, g%sum_mu_xx) end if end if end subroutine vamp_reshape_grid_internal @ %def vamp_reshape_grid_internal @ %def stratified @ The [[use_variance]] argument is too dangerous for careless users, because the [[variance]] in the divisions will contain garbage before sampling and after reshaping. Build a fence with another routine. @ <>= private :: vamp_reshape_grid_internal public :: vamp_reshape_grid @ <>= pure subroutine vamp_reshape_grid & (g, num_calls, num_div, stratified, quadrupole, covariance, exc, & independent, equivalent_to_ch, multiplicity) type(vamp_grid), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole, covariance type(exception), intent(inout), optional :: exc logical, intent(in), optional :: independent integer, intent(in), optional :: equivalent_to_ch, multiplicity call vamp_reshape_grid_internal & (g, num_calls, num_div, stratified, quadrupole, covariance, & exc, use_variance = .false., & independent=independent, equivalent_to_ch=equivalent_to_ch, & multiplicity=multiplicity) end subroutine vamp_reshape_grid @ %def vamp_reshape_grid @ \texttt{vegas} operates in three different modes, which are chosen according to explicit user requests and to the relation of the requested number of sampling points to the dimensionality of the integration domain.\par The simplest case is when the user has overwritten the default of stratified sampling with the optional argument [[stratified]] in the call to [[vamp_create_grid]]. Then sample points will be choosen randomly with equal probability in each cell of the adaptive grid, as displayed in figure~\ref{fig:nonstrat}.\par The implementation is actually shared with the stratified case described below, by pretending that there is just a single stratification cell. The number of divisions for the adaptive grid is set to a compile time maximum value.\par If the user has agreed on stratified sampling then there are two cases, depending on the dimensionality of the integration region and the number of sample points. First we determine the number of divisions~$n_g$ (i.\,e.~[[ng]]) of the rigid grid such that there will be two sampling points per cell. \begin{equation} N_{\text{calls}} = 2\cdot (n_g)^{n_{\text{dim}}} \end{equation} The additional optional argument~$\hat n_g$ specifies an anisotropy in the shape \begin{equation} n_{g,j} = \frac{\hat n_{g,j}}{\left(\prod_j\hat n_{g,j}\right)^{1/n_{\text{dim}}}} \left(\frac{N}{2}\right)^{1/n_{\text{dim}}} \end{equation} NB: \begin{equation} \prod_j n_{g,j} = \frac{N}{2} \end{equation} <>= if (g%stratified) then ng = (g%num_calls / 2.0 + 0.25)**(1.0/ndim) ! ng = ng * real (g%num_div, kind=default) & ! / (product (real (g%num_div, kind=default)))**(1.0/ndim) else ng = 1 end if call reshape_division (g%div, g%num_div, ng, use_variance) call clear_integral_and_variance (g%div) num_cells = product (rigid_division (g%div)) g%calls_per_cell = max (g%num_calls / num_cells, 2) g%calls = real (g%calls_per_cell) * real (num_cells) @ %def ng num_cells calls calls_per_cell @ \begin{equation} - [[jacobi]] = J = \frac{\text{Volume}}{N_{\text{calls}}} + \text{[[jacobi]]} = J = \frac{\text{Volume}}{N_{\text{calls}}} \end{equation} and \begin{equation} - [[dv2g]] + \text{[[dv2g]]} = \frac{N_{\text{calls}}^2 \left((\Delta x)^{n_{\text{dim}}}\right)^2} {N_{\text{calls/cell}}^2(N_{\text{calls/cell}}-1)} = \frac{\left(\frac{N_{\text{calls}}}{N_{\text{cells}}}\right)^2} {N_{\text{calls/cell}}^2(N_{\text{calls/cell}}-1)} \end{equation} <>= g%jacobi = product (volume_division (g%div)) / g%calls g%dv2g = (g%calls / num_cells)**2 & / g%calls_per_cell / g%calls_per_cell / (g%calls_per_cell - 1.0) @ %def jacobi dv2g @ <>= call vamp_nullify_f_limits (g) @ When the grid is refined or reshaped, the recorded minimum and maximum of the sampling function should be nullified: @ <>= public :: vamp_nullify_f_limits @ <>= elemental subroutine vamp_nullify_f_limits (g) type(vamp_grid), intent(inout) :: g g%f_min = 1.0 g%f_max = 0.0 end subroutine vamp_nullify_f_limits @ %def vamp_nullify_f_limits @ %def f_min f_max @ <>= public :: vamp_rigid_divisions public :: vamp_get_covariance, vamp_nullify_covariance public :: vamp_get_variance, vamp_nullify_variance @ <>= pure function vamp_rigid_divisions (g) result (ng) type(vamp_grid), intent(in) :: g integer, dimension(size(g%div)) :: ng ng = rigid_division (g%div) end function vamp_rigid_divisions @ %def vamp_rigid_divisions @ <>= pure function vamp_get_covariance (g) result (cov) type(vamp_grid), intent(in) :: g real(kind=default), dimension(size(g%div),size(g%div)) :: cov if (associated (g%mu_x)) then if (abs (g%sum_weights) <= tiny (cov(1,1))) then where (g%sum_mu_xx == 0.0_default) cov = 0.0 elsewhere cov = huge (cov(1,1)) endwhere else cov = g%sum_mu_xx / g%sum_weights & - outer_product (g%sum_mu_x, g%sum_mu_x) / g%sum_weights**2 end if else cov = 0.0 end if end function vamp_get_covariance @ %def vamp_get_covariance @ <>= elemental subroutine vamp_nullify_covariance (g) type(vamp_grid), intent(inout) :: g if (associated (g%mu_x)) then g%sum_mu_x = 0 g%sum_mu_xx = 0 end if end subroutine vamp_nullify_covariance @ %def vamp_nullify_covariance @ <>= elemental function vamp_get_variance (g) result (v) type(vamp_grid), intent(in) :: g real(kind=default) :: v if (abs (g%sum_weights) <= tiny (v)) then if (g%sum_mu_gi == 0.0_default) then v = 0.0 else v = huge (v) end if else v = g%sum_mu_gi / g%sum_weights end if end function vamp_get_variance @ %def vamp_get_variance @ <>= elemental subroutine vamp_nullify_variance (g) type(vamp_grid), intent(inout) :: g g%sum_mu_gi = 0 end subroutine vamp_nullify_variance @ %def vamp_nullify_variance @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Sampling} <>= public :: vamp_sample_grid public :: vamp_sample_grid0 public :: vamp_refine_grid public :: vamp_refine_grids @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Simple Non-Adaptive Sampling: $S_0$} <>= subroutine vamp_sample_grid0 & (rng, g, func, data, channel, weights, grids, exc, & negative_weights) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc <> character(len=*), parameter :: FN = "vamp_sample_grid0" logical, intent(in), optional :: negative_weights <> integer :: ndim logical :: neg_w ndim = size (g%div) neg_w = .false. if (present (negative_weights)) neg_w = negative_weights <> <> loop_over_cells: do <> <> <> end do loop_over_cells <> end subroutine vamp_sample_grid0 @ %def vamp_sample_grid0 @ Count cells like a $n_g$-ary number---i.e.~$(1,\ldots,1,1)$, $(1,\ldots,1,2)$, $\ldots$, $(1,\ldots,1,n_g)$, $(1,\ldots,2,1)$, $\ldots$, $(n_g,\ldots,n_g,n_g-1)$, $(n_g,\ldots,n_g,n_g)$---and terminate when [[all (cell == 1)]] again. <>= do j = ndim, 1, -1 cell(j) = modulo (cell(j), rigid_division (g%div(j))) + 1 if (cell(j) /= 1) then cycle loop_over_cells end if end do exit loop_over_cells @ %def cell @ <>= g%mu = 0.0 g%mu_plus = 0.0 g%mu_minus = 0.0 cell = 1 call clear_integral_and_variance (g%div) if (associated (g%mu_x)) then g%mu_x = 0.0 g%mu_xx = 0.0 end if if (present (channel)) then g%mu_gi = 0.0 end if @ <>= real(kind=default), parameter :: & eps = tiny (1._default) / epsilon (1._default) character(len=6) :: buffer @ <>= integer :: j, k integer, dimension(size(g%div)) :: cell @ %def j k cell @ <>= sum_f = 0.0 sum_f_plus = 0.0 sum_f_minus = 0.0 sum_f2 = 0.0 sum_f2_plus = 0.0 sum_f2_minus = 0.0 do k = 1, g%calls_per_cell <> <<[[f = wgt * func (x, weights, channel)]], iff [[x]] inside [[true_domain]]>> <> end do @ %def sum_f sum_f2 sum_f_plus sum_f_minus @ We are using the generic procedure [[tao_random_number]] from the [[tao_random_numbers]] module for generating an array of uniform deviates. \index{dependences on external modules} \index{deficiencies in \protect\texttt{Fortran90} and \protect\texttt{F}} A better alternative would be to pass the random number generator as an argument to [[vamp_sample_grid]]. Unfortunately, it is not possible to pass \emph{generic} procedures in \texttt{Fortran90}, \texttt{Fortran95}, or \texttt{F}. While we could export a specific procedure from [[tao_random_numbers]], a more serious problem is that we have to pass the state [[rng]] of the random number generator as a [[tao_random_state]] anyway and we have to hardcode the random number generator anyway. <>= call tao_random_number (rng, r) call inject_division (g%div, real (r, kind=default), & cell, x, x_mid, ia, wgts) wgt = g%jacobi * product (wgts) if (associated (g%map)) then x = matmul (g%map, x) end if @ %def r ia wgt wgts x x_mid @ This somewhat contorted nested [[if]] constructs allow to minimize the number of calls to [[func]]. This is useful, since [[func]] is the most expensive part of real world applications. Also [[func]] might be singular outside of [[true_domain]].\par The original \texttt{vegas} used to call [[f = wgt * func (x, wgt)]] below to allow [[func]] to use [[wgt]] (i.e.~$1/p(x)$) for integrating another function at the same time. This form of ``parallelism'' relies on side effects and is therefore impossible with pure functions. Consequently, it is not supported in the current implementation. <<[[f = wgt * func (x, weights, channel)]], iff [[x]] inside [[true_domain]]>>= if (associated (g%map)) then if (all (inside_division (g%div, x))) then f = wgt * func (x, data, weights, channel, grids) else f = 0.0 end if else f = wgt * func (x, data, weights, channel, grids) end if @ %def f @ <>= if (g%f_min > g%f_max) then g%f_min = abs (f) * g%calls g%f_max = abs (f) * g%calls else if (abs (f) * g%calls < g%f_min) then g%f_min = abs (f) * g%calls else if (abs (f) * g%calls > g%f_max) then g%f_max = abs (f) * g%calls end if @ <>= f2 = f * f sum_f = sum_f + f sum_f2 = sum_f2 + f2 if (f > 0) then sum_f_plus = sum_f_plus + f sum_f2_plus = sum_f2_plus + f * f else if (f < 0) then sum_f_minus = sum_f_minus + f sum_f2_minus = sum_f2_minus + f * f end if call record_integral (g%div, ia, f) ! call record_efficiency (g%div, ia, f/g%f_max) if ((associated (g%mu_x)) .and. (.not. g%all_stratified)) then g%mu_x = g%mu_x + x * f g%mu_xx = g%mu_xx + outer_product (x, x) * f end if if (present (channel)) then g%mu_gi = g%mu_gi + f2 end if @ %def f2 sum_f sum_f2 sum_f_plus sum_f_minus sum_f2_plus sum_f2_minus @ <>= real(kind=default) :: wgt, f, f2 real(kind=default) :: sum_f, sum_f2, var_f real(kind=default) :: sum_f_plus, sum_f2_plus, var_f_plus real(kind=default) :: sum_f_minus, sum_f2_minus, var_f_minus real(kind=default), dimension(size(g%div)):: x, x_mid, wgts real(kind=default), dimension(size(g%div)):: r integer, dimension(size(g%div)) :: ia @ %def wgt f f2 @ %def sum_f sum_f2 var_f @ %def sum_f_plus sum_f2_plus var_f_plus @ %def sum_f_minus sum_f2_minus var_f_minus @ %def r x x_mid wgts wgt ia @ \begin{equation} \sigma^2 \cdot N^2_{\text{calls/cell}}(N_{\text{calls/cell}}-1) = \mathop{\textrm{var}}(f) = N^2\sigma^2 \left( \left\langle \frac{f^2}{p} \right\rangle - \langle f \rangle^2 \right) \end{equation} \label{pg:var_f} <>= var_f = sum_f2 * g%calls_per_cell - sum_f**2 var_f_plus = sum_f2_plus * g%calls_per_cell - sum_f_plus**2 var_f_minus = sum_f2_minus * g%calls_per_cell - sum_f_minus**2 if (var_f <= 0.0) then var_f = tiny (1.0_default) end if if (sum_f_plus /= 0 .and. var_f_plus <= 0) then var_f_plus = tiny (1.0_default) end if if (sum_f_minus /= 0 .and. var_f_minus <= 0) then var_f_minus = tiny (1.0_default) end if g%mu = g%mu + (/ sum_f, var_f /) g%mu_plus = g%mu_plus + (/ sum_f_plus, var_f_plus /) g%mu_minus = g%mu_minus + (/ sum_f_minus, var_f_minus /) call record_variance (g%div, ia, var_f) if ((associated (g%mu_x)) .and. g%all_stratified) then if (associated (g%map)) then x_mid = matmul (g%map, x_mid) end if g%mu_x = g%mu_x + x_mid * var_f g%mu_xx = g%mu_xx + outer_product (x_mid, x_mid) * var_f end if @ %def sum_x sum_xx var_f @ \begin{equation} \sigma^2 = \frac{\left(\frac{N_{\text{calls}}}{N_{\text{cells}}}\right)^2}% {N^2_{\text{calls/cell}}(N_{\text{calls/cell}}-1)} \sum_{\text{cells}} \sigma^2_{\text{cell}} \cdot N^2_{\text{calls/cell}}(N_{\text{calls/cell}}-1) \end{equation} where the~$N_{\text{calls}}^2$ cancels the corresponding factor in the Jacobian and the~$N_{\text{cells}}^{-2}$ is the result of stratification. In order to avoid numerical noise for some OS when using 80bit precision, we wrap the numerical resetting into a negative weights-only if-clause. <>= g%mu(2) = g%mu(2) * g%dv2g if (g%mu(2) < eps * max (g%mu(1)**2, 1._default)) then g%mu(2) = eps * max (g%mu(1)**2, 1._default) end if if (neg_w) then g%mu_plus(2) = g%mu_plus(2) * g%dv2g if (g%mu_plus(2) < eps * max (g%mu_plus(1)**2, 1._default)) then g%mu_plus(2) = eps * max (g%mu_plus(1)**2, 1._default) end if g%mu_minus(2) = g%mu_minus(2) * g%dv2g if (g%mu_minus(2) < eps * max (g%mu_minus(1)**2, 1._default)) then g%mu_minus(2) = eps * max (g%mu_minus(1)**2, 1._default) end if end if @ <>= if (g%mu(1)>0) then g%sum_integral = g%sum_integral + g%mu(1) / g%mu(2) g%sum_weights = g%sum_weights + 1.0 / g%mu(2) g%sum_chi2 = g%sum_chi2 + g%mu(1)**2 / g%mu(2) if (associated (g%mu_x)) then if (g%all_stratified) then g%mu_x = g%mu_x / g%mu(2) g%mu_xx = g%mu_xx / g%mu(2) else g%mu_x = g%mu_x / g%mu(1) g%mu_xx = g%mu_xx / g%mu(1) end if g%sum_mu_x = g%sum_mu_x + g%mu_x / g%mu(2) g%sum_mu_xx = g%sum_mu_xx + g%mu_xx / g%mu(2) end if if (present (channel)) then g%sum_mu_gi = g%sum_mu_gi + g%mu_gi / g%mu(2) end if else if (neg_w) then g%sum_integral = g%sum_integral + g%mu(1) / g%mu(2) g%sum_weights = g%sum_weights + 1.0 / g%mu(2) g%sum_chi2 = g%sum_chi2 + g%mu(1)**2 / g%mu(2) if (associated (g%mu_x)) then if (g%all_stratified) then g%mu_x = g%mu_x / g%mu(2) g%mu_xx = g%mu_xx / g%mu(2) else g%mu_x = g%mu_x / g%mu(1) g%mu_xx = g%mu_xx / g%mu(1) end if g%sum_mu_x = g%sum_mu_x + g%mu_x / g%mu(2) g%sum_mu_xx = g%sum_mu_xx + g%mu_xx / g%mu(2) end if if (present (channel)) then g%sum_mu_gi = g%sum_mu_gi + g%mu_gi / g%mu(2) end if else if (present(channel) .and. g%mu(1)==0) then write (buffer, "(I6)") channel call raise_exception (exc, EXC_WARN, "! vamp", & "Function identically zero in channel " // buffer) else if (present(channel) .and. g%mu(1)<0) then write (buffer, "(I6)") channel call raise_exception (exc, EXC_ERROR, "! vamp", & "Negative integral in channel " // buffer) end if g%sum_integral = 0 g%sum_chi2 = 0 g%sum_weights = 0 end if @ %def sum_integral sum_chi2 sum_weights @ <>= if (present (channel) .neqv. present (weights)) then call raise_exception (exc, EXC_FATAL, FN, & "channel and weights required together") return end if @ <>= public :: vamp_probability @ <>= pure function vamp_probability (g, x) result (p) type(vamp_grid), intent(in) :: g real(kind=default), dimension(:), intent(in) :: x real(kind=default) :: p p = product (probability (g%div, x)) end function vamp_probability @ %def vamp_probability @ \begin{dubious} [[%variance]] should be private to [[division]] \end{dubious} <>= subroutine vamp_apply_equivalences (g, eq) type(vamp_grids), intent(inout) :: g type(vamp_equivalences_t), intent(in) :: eq integer :: n_ch, n_dim, nb, i, ch, ch_src, dim, dim_src integer, dimension(:,:), allocatable :: n_bin real(kind=default), dimension(:,:,:), allocatable :: var_tmp n_ch = size (g%grids) if (n_ch == 0) return n_dim = size (g%grids(1)%div) allocate (n_bin(n_ch, n_dim)) do ch = 1, n_ch do dim = 1, n_dim n_bin(ch, dim) = size (g%grids(ch)%div(dim)%variance) end do end do allocate (var_tmp (maxval(n_bin), n_dim, n_ch)) var_tmp = 0 do i=1, eq%n_eq ch = eq%eq(i)%left ch_src = eq%eq(i)%right do dim=1, n_dim nb = n_bin(ch_src, dim) dim_src = eq%eq(i)%permutation(dim) select case (eq%eq(i)%mode(dim)) case (VEQ_IDENTITY) var_tmp(:nb,dim,ch) = var_tmp(:nb,dim,ch) & & + g%grids(ch_src)%div(dim_src)%variance case (VEQ_INVERT) var_tmp(:nb,dim,ch) = var_tmp(:nb,dim,ch) & & + g%grids(ch_src)%div(dim_src)%variance(nb:1:-1) case (VEQ_SYMMETRIC) var_tmp(:nb,dim,ch) = var_tmp(:nb,dim,ch) & & + g%grids(ch_src)%div(dim_src)%variance / 2 & & + g%grids(ch_src)%div(dim_src)%variance(nb:1:-1)/2 case (VEQ_INVARIANT) var_tmp(:nb,dim,ch) = 1 end select end do end do do ch=1, n_ch do dim=1, n_dim g%grids(ch)%div(dim)%variance = var_tmp(:n_bin(ch, dim),dim,ch) end do end do deallocate (var_tmp) deallocate (n_bin) end subroutine vamp_apply_equivalences @ %def vamp_apply_equivalences @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Grid Refinement: $r$} \begin{equation} n_{\text{div},j} \to \frac{Q_j n_{\text{div},j}}{\left(\prod_j Q_j\right)^{1/n_{\text{dim}}}} \end{equation} where \begin{equation} Q_j = \left(\sqrt{\mathop{\textrm{Var}}(\{m\}_j)}\right)^\alpha \end{equation} <>= pure subroutine vamp_refine_grid (g, exc) type(vamp_grid), intent(inout) :: g type(exception), intent(inout), optional :: exc real(kind=default), dimension(size(g%div)) :: quad integer :: ndim if (g%quadrupole) then ndim = size (g%div) quad = (quadrupole_division (g%div))**QUAD_POWER call vamp_reshape_grid_internal & (g, use_variance = .true., exc = exc, & num_div = int (quad / product (quad)**(1.0/ndim) * g%num_div)) else call refine_division (g%div) call vamp_nullify_f_limits (g) end if end subroutine vamp_refine_grid @ %def vamp_refine_grid @ <>= subroutine vamp_refine_grids (g) type(vamp_grids), intent(inout) :: g integer :: ch do ch=1, size(g%grids) call refine_division (g%grids(ch)%div) call vamp_nullify_f_limits (g%grids(ch)) end do end subroutine vamp_refine_grids @ %def vamp_refine_grids @ <>= real(kind=default), private, parameter :: QUAD_POWER = 0.5_default @ %def QUAD_POWER @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Adaptive Sampling: $S_n = S_0(rS_0)^n$} <>= subroutine vamp_sample_grid & (rng, g, func, data, iterations, & integral, std_dev, avg_chi2, accuracy, & channel, weights, grids, exc, history) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 real(kind=default), intent(in), optional :: accuracy integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_sample_grid" real(kind=default) :: local_integral, local_std_dev, local_avg_chi2 integer :: iteration, ndim ndim = size (g%div) iterate: do iteration = 1, iterations call vamp_sample_grid0 & (rng, g, func, data, channel, weights, grids, exc) call vamp_average_iterations & (g, iteration, local_integral, local_std_dev, local_avg_chi2) <> <> if (iteration < iterations) call vamp_refine_grid (g) end do iterate <> end subroutine vamp_sample_grid @ %def local_integral local_std_dev local_avg_chi2 @ %def vamp_sample_grid @ %def func iterations integral std_dev avg_chi2 accuracy @ %def iteration @ Assuming that the iterations have been statistically independent, we can combine them with the usual formulae. \begin{subequations} \begin{align} \bar I &= \sigma_I^2 \sum_i \frac{I_i}{\sigma_i^2} \\ \frac{1}{\sigma_I^2} &= \sum_i \frac{1}{\sigma_i^2} \\ \chi^2 &= \sum_i \frac{(I_i-\bar I)^2}{\sigma_i^2} = \sum_i \frac{I_i^2}{\sigma_i^2} - \bar I \sum_i \frac{I_i}{\sigma_i^2} \end{align} \end{subequations} <>= elemental subroutine vamp_average_iterations_grid & (g, iteration, integral, std_dev, avg_chi2) type(vamp_grid), intent(in) :: g integer, intent(in) :: iteration real(kind=default), intent(out) :: integral, std_dev, avg_chi2 real(kind=default), parameter :: eps = 1000 * epsilon (1._default) if (g%sum_weights>0) then integral = g%sum_integral / g%sum_weights std_dev = sqrt (1.0 / g%sum_weights) avg_chi2 = & max ((g%sum_chi2 - g%sum_integral * integral) / (iteration-0.99), & 0.0_default) if (avg_chi2 < eps * g%sum_chi2) avg_chi2 = 0 else integral = 0 std_dev = 0 avg_chi2 = 0 end if end subroutine vamp_average_iterations_grid @ %def vamp_average_iterations_grid @ <>= public :: vamp_average_iterations private :: vamp_average_iterations_grid @ %def vamp_average_iterations @ <>= interface vamp_average_iterations module procedure vamp_average_iterations_grid end interface @ %def vamp_average_iterations @ Lepage suggests~\cite{Lepage:1978:vegas} to reweight the contributions as in the following improved formulae, which we might implement as an option later. \begin{subequations} \begin{align} \bar I &= \frac{1}{\left(\sum_i\frac{I_i^2}{\sigma_i^2}\right)^2} \sum_i I_i \frac{I_i^2}{\sigma_i^2} \\ \frac{1}{\sigma_I^2} &= \frac{1}{(\bar I)^2} \sum_i \frac{I_i^2}{\sigma_i^2} \\ \chi^2 &= \sum_i \frac{(I_i-\bar I)^2}{(\bar I)^2} \frac{I_i^2}{\sigma_i^2} \end{align} \end{subequations} @ Iff possible, copy the result to the caller's variables: <>= if (present (integral)) then integral = local_integral end if if (present (std_dev)) then std_dev = local_std_dev end if if (present (avg_chi2)) then avg_chi2 = local_avg_chi2 end if @ %def local_integral local_std_dev local_avg_chi2 @ %def integral std_dev avg_chi2 @ <>= if (present (accuracy)) then if (local_std_dev <= accuracy * local_integral) then call raise_exception (exc, EXC_INFO, FN, & "requested accuracy reached") exit iterate end if end if @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Forking and Joining} <>= public :: vamp_fork_grid private :: vamp_fork_grid_single, vamp_fork_grid_multi public :: vamp_join_grid private :: vamp_join_grid_single, vamp_join_grid_multi @ %def vamp_fork_grid vamp_join_grid @ <>= interface vamp_fork_grid module procedure vamp_fork_grid_single, vamp_fork_grid_multi end interface interface vamp_join_grid module procedure vamp_join_grid_single, vamp_join_grid_multi end interface @ %def vamp_fork_grid vamp_join_grid -@ Caveat emptor: splitting divisions can lead to $[[num_div]]<3$ an +@ Caveat emptor: splitting divisions can lead to $\text{[[num_div]]}<3$ an the application must not try to refine such grids before merging them again! [[d == 0]] is special. <>= pure subroutine vamp_fork_grid_single (g, gs, d, exc) type(vamp_grid), intent(in) :: g type(vamp_grid), dimension(:), intent(inout) :: gs integer, intent(in) :: d type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_fork_grid_single" type(division_t), dimension(:), allocatable :: d_tmp integer :: i, j, num_grids, num_div, ndim, num_cells num_grids = size (gs) ndim = size (g%div) <> do j = 1, ndim if (j == d) then <<[[call fork_division (g%div(j), gs%div(j), g%calls_per_cell, ...)]]>> else <<[[call copy_division (gs%div(j), g%div(j))]]>> end if end do if (d == 0) then <> end if <> end subroutine vamp_fork_grid_single @ %def vamp_fork_grid_single @ Divide the sampling points among identical grids <>= if (any (stratified_division (g%div))) then call raise_exception (exc, EXC_FATAL, FN, & "d == 0 incompatiple w/ stratification") else gs(2:)%calls_per_cell = ceiling (real (g%calls_per_cell) / num_grids) gs(1)%calls_per_cell = g%calls_per_cell - sum (gs(2:)%calls_per_cell) end if @ <>= do i = 1, num_grids call copy_array_pointer (gs(i)%num_div, g%num_div) if (associated (g%map)) then call copy_array_pointer (gs(i)%map, g%map) end if if (associated (g%mu_x)) then call create_array_pointer (gs(i)%mu_x, ndim) call create_array_pointer (gs(i)%sum_mu_x, ndim) call create_array_pointer (gs(i)%mu_xx, (/ ndim, ndim /)) call create_array_pointer (gs(i)%sum_mu_xx, (/ ndim, ndim /)) end if end do @ Reset results <>= gs%mu(1) = 0.0 gs%mu(2) = 0.0 gs%mu_plus(1) = 0.0 gs%mu_plus(2) = 0.0 gs%mu_minus(1) = 0.0 gs%mu_minus(2) = 0.0 gs%sum_integral = 0.0 gs%sum_weights = 0.0 gs%sum_chi2 = 0.0 gs%mu_gi = 0.0 gs%sum_mu_gi = 0.0 @ <>= gs%stratified = g%stratified gs%all_stratified = g%all_stratified gs%quadrupole = g%quadrupole @ <>= do i = 1, num_grids num_cells = product (rigid_division (gs(i)%div)) gs(i)%calls = gs(i)%calls_per_cell * num_cells gs(i)%num_calls = gs(i)%calls gs(i)%jacobi = product (volume_division (gs(i)%div)) / gs(i)%calls gs(i)%dv2g = (gs(i)%calls / num_cells)**2 & / gs(i)%calls_per_cell / gs(i)%calls_per_cell / (gs(i)%calls_per_cell - 1.0) end do gs%f_min = g%f_min * (gs%jacobi * gs%calls) / (g%jacobi * g%calls) gs%f_max = g%f_max * (gs%jacobi * gs%calls) / (g%jacobi * g%calls) @ This could be self-explaining, if the standard would allow \ldots. Note that we can get away with copying just the pointers, because [[fork_division]] does the dirty work for the memory management. <<[[call fork_division (g%div(j), gs%div(j), g%calls_per_cell, ...)]]>>= allocate (d_tmp(num_grids)) do i = 1, num_grids d_tmp(i) = gs(i)%div(j) end do call fork_division (g%div(j), d_tmp, g%calls_per_cell, gs%calls_per_cell, exc) do i = 1, num_grids gs(i)%div(j) = d_tmp(i) end do deallocate (d_tmp) <> @ <>= if (present (exc)) then if (exc%level > EXC_WARN) then return end if end if @ We have to do a deep copy ([[gs(i)%div(j) = g%div(j)]] does not suffice), because [[copy_division]] handles the memory management. <<[[call copy_division (gs%div(j), g%div(j))]]>>= do i = 1, num_grids call copy_division (gs(i)%div(j), g%div(j)) end do @ <>= num_div = size (g%div) do i = 1, size (gs) if (associated (gs(i)%div)) then if (size (gs(i)%div) /= num_div) then allocate (gs(i)%div(num_div)) call create_empty_division (gs(i)%div) end if else allocate (gs(i)%div(num_div)) call create_empty_division (gs(i)%div) end if end do @ <>= pure subroutine vamp_join_grid_single (g, gs, d, exc) type(vamp_grid), intent(inout) :: g type(vamp_grid), dimension(:), intent(inout) :: gs integer, intent(in) :: d type(exception), intent(inout), optional :: exc type(division_t), dimension(:), allocatable :: d_tmp integer :: i, j, num_grids num_grids = size (gs) do j = 1, size (g%div) if (j == d) then <<[[call join_division (g%div(j), gs%div(j))]]>> else <<[[call sum_division (g%div(j), gs%div(j))]]>> end if end do <> end subroutine vamp_join_grid_single @ %def vamp_join_grid_single @ <<[[call join_division (g%div(j), gs%div(j))]]>>= allocate (d_tmp(num_grids)) do i = 1, num_grids d_tmp(i) = gs(i)%div(j) end do call join_division (g%div(j), d_tmp, exc) deallocate (d_tmp) <> @ <<[[call sum_division (g%div(j), gs%div(j))]]>>= allocate (d_tmp(num_grids)) do i = 1, num_grids d_tmp(i) = gs(i)%div(j) end do call sum_division (g%div(j), d_tmp) deallocate (d_tmp) @ <>= g%f_min = minval (gs%f_min * (g%jacobi * g%calls) / (gs%jacobi * gs%calls)) g%f_max = maxval (gs%f_max * (g%jacobi * g%calls) / (gs%jacobi * gs%calls)) g%mu(1) = sum (gs%mu(1)) g%mu(2) = sum (gs%mu(2)) g%mu_plus(1) = sum (gs%mu_plus(1)) g%mu_plus(2) = sum (gs%mu_plus(2)) g%mu_minus(1) = sum (gs%mu_minus(1)) g%mu_minus(2) = sum (gs%mu_minus(2)) g%mu_gi = sum (gs%mu_gi) g%sum_mu_gi = g%sum_mu_gi + g%mu_gi / g%mu(2) g%sum_integral = g%sum_integral + g%mu(1) / g%mu(2) g%sum_chi2 = g%sum_chi2 + g%mu(1)**2 / g%mu(2) g%sum_weights = g%sum_weights + 1.0 / g%mu(2) if (associated (g%mu_x)) then do i = 1, num_grids g%mu_x = g%mu_x + gs(i)%mu_x g%mu_xx = g%mu_xx + gs(i)%mu_xx end do g%sum_mu_x = g%sum_mu_x + g%mu_x / g%mu(2) g%sum_mu_xx = g%sum_mu_xx + g%mu_xx / g%mu(2) end if @ The following is made a little bit hairy by the fact that [[vamp_fork_grid]] can't join grids onto a non-existing grid\footnote{It would be possible to make it possible by changing many things under the hood, but it doesn't really make sense, anyway.} therefore we have to keep a tree of joints. Maybe it would be the right thing to handle this tree of joints as a tree with pointers, but since we need the leaves flattened anyway (as food for multiple [[vamp_sample_grid]]) we use a similar storage layout for the joints. <>= type(vamp_grid), dimension(:), allocatable :: gx integer, dimension(:,:), allocatable :: dim ... allocate (gx(vamp_fork_grid_joints (dim))) call vamp_fork_grid (g, gs, gx, dim, exc) ... call vamp_join_grid (g, gs, gx, dim, exc) @ <>= pure recursive subroutine vamp_fork_grid_multi (g, gs, gx, d, exc) type(vamp_grid), intent(in) :: g type(vamp_grid), dimension(:), intent(inout) :: gs, gx integer, dimension(:,:), intent(in) :: d type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_fork_grid_multi" integer :: i, offset, stride, joints_offset, joints_stride select case (size (d, dim=2)) case (0) return case (1) call vamp_fork_grid_single (g, gs, d(1,1), exc) case default offset = 1 stride = product (d(2,2:)) joints_offset = 1 + d(2,1) joints_stride = vamp_fork_grid_joints (d(:,2:)) call vamp_create_empty_grid (gx(1:d(2,1))) call vamp_fork_grid_single (g, gx(1:d(2,1)), d(1,1), exc) do i = 1, d(2,1) call vamp_fork_grid_multi & (gx(i), gs(offset:offset+stride-1), & gx(joints_offset:joints_offset+joints_stride-1), & d(:,2:), exc) offset = offset + stride joints_offset = joints_offset + joints_stride end do end select end subroutine vamp_fork_grid_multi @ %def vamp_fork_grid_multi @ <>= public :: vamp_fork_grid_joints @ \begin{equation} \label{eq:num_joints} \sum_{n=1}^{N-1} \prod_{i_n=1}^{n} d_{i_n} = d_1(1+d_2(1+d_3(1+\ldots(1+d_{N-1})\ldots))) \end{equation} <>= pure function vamp_fork_grid_joints (d) result (s) integer, dimension(:,:), intent(in) :: d integer :: s integer :: i s = 0 do i = size (d, dim=2) - 1, 1, -1 s = (s + 1) * d(2,i) end do end function vamp_fork_grid_joints @ %def vamp_fork_grid_joints @ <>= pure recursive subroutine vamp_join_grid_multi (g, gs, gx, d, exc) type(vamp_grid), intent(inout) :: g type(vamp_grid), dimension(:), intent(inout) :: gs, gx integer, dimension(:,:), intent(in) :: d type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_join_grid_multi" integer :: i, offset, stride, joints_offset, joints_stride select case (size (d, dim=2)) case (0) return case (1) call vamp_join_grid_single (g, gs, d(1,1), exc) case default offset = 1 stride = product (d(2,2:)) joints_offset = 1 + d(2,1) joints_stride = vamp_fork_grid_joints (d(:,2:)) do i = 1, d(2,1) call vamp_join_grid_multi & (gx(i), gs(offset:offset+stride-1), & gx(joints_offset:joints_offset+joints_stride-1), & d(:,2:), exc) offset = offset + stride joints_offset = joints_offset + joints_stride end do call vamp_join_grid_single (g, gx(1:d(2,1)), d(1,1), exc) call vamp_delete_grid (gx(1:d(2,1))) end select end subroutine vamp_join_grid_multi @ %def vamp_join_grid_multi @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Parallel Execution} <>= public :: vamp_sample_grid_parallel public :: vamp_distribute_work @ HPF~\cite{HPF1.1,HPF2.0,Koelbel/etal:1994:HPF}: <>= subroutine vamp_sample_grid_parallel & (rng, g, func, data, iterations, & integral, std_dev, avg_chi2, accuracy, & channel, weights, grids, exc, history) type(tao_random_state), dimension(:), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 real(kind=default), intent(in), optional :: accuracy integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_sample_grid_parallel" real(kind=default) :: local_integral, local_std_dev, local_avg_chi2 type(exception), dimension(size(rng)) :: excs type(vamp_grid), dimension(:), allocatable :: gs, gx !hpf$ processors p(number_of_processors()) !hpf$ distribute gs(cyclic(1)) onto p integer, dimension(:,:), pointer :: d integer :: iteration, i integer :: num_workers nullify (d) call clear_exception (excs) iterate: do iteration = 1, iterations call vamp_distribute_work (size (rng), vamp_rigid_divisions (g), d) num_workers = max (1, product (d(2,:))) if (num_workers > 1) then allocate (gs(num_workers), gx(vamp_fork_grid_joints (d))) call vamp_create_empty_grid (gs) !: \texttt{vamp\_fork\_grid} is certainly not local. Speed freaks might !: want to tune it to the processor topology, but the gain will be small. call vamp_fork_grid (g, gs, gx, d, exc) !hpf$ independent do i = 1, num_workers call vamp_sample_grid0 & (rng(i), gs(i), func, data, & channel, weights, grids, exc) end do <> call vamp_join_grid (g, gs, gx, d, exc) call vamp_delete_grid (gs) deallocate (gs, gx) else call vamp_sample_grid0 & (rng(1), g, func, data, channel, weights, grids, exc) end if <> call vamp_average_iterations & (g, iteration, local_integral, local_std_dev, local_avg_chi2) <> <> if (iteration < iterations) call vamp_refine_grid (g) end do iterate deallocate (d) <> end subroutine vamp_sample_grid_parallel @ %def vamp_sample_grid_parallel @ <>= if ((present (exc)) .and. (any (excs(1:num_workers)%level > 0))) then call gather_exceptions (exc, excs(1:num_workers)) end if @ We could sort~$d$ such that~(\ref{eq:num_joints}) is minimized \index{optimizations not implemented yet} \begin{equation} d_1 \le d_2 \le \ldots \le d_N \end{equation} but the gain will be negligible. <>= pure subroutine vamp_distribute_work (num_workers, ng, d) integer, intent(in) :: num_workers integer, dimension(:), intent(in) :: ng integer, dimension(:,:), pointer :: d integer, dimension(32) :: factors integer :: n, num_factors, i, j integer, dimension(size(ng)) :: num_forks integer :: nfork try: do n = num_workers, 1, -1 call factorize (n, factors, num_factors) num_forks = 1 do i = num_factors, 1, -1 j = sum (maxloc (ng / num_forks)) nfork = num_forks(j) * factors(i) if (nfork <= ng(j)) then num_forks(j) = nfork else cycle try end if end do <> end do try end subroutine vamp_distribute_work @ <>= j = count (num_forks > 1) if (associated (d)) then if (size (d, dim = 2) /= j) then deallocate (d) allocate (d(2,j)) end if else allocate (d(2,j)) end if @ <>= j = 1 do i = 1, size (ng) if (num_forks(i) > 1) then d(:,j) = (/ i, num_forks(i) /) j = j + 1 end if end do return @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Diagnostics} <>= type, public :: vamp_history private real(kind=default) :: & integral, std_dev, avg_integral, avg_std_dev, avg_chi2, f_min, f_max integer :: calls logical :: stratified logical :: verbose type(div_history), dimension(:), pointer :: div => null () end type vamp_history @ %def vamp_history @ <>= if (present (history)) then if (iteration <= size (history)) then call vamp_get_history & (history(iteration), g, local_integral, local_std_dev, & local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp_terminate_history (history(iteration+1:)) end if @ <>= public :: vamp_create_history, vamp_copy_history, vamp_delete_history public :: vamp_terminate_history public :: vamp_get_history, vamp_get_history_single @ <>= interface vamp_get_history module procedure vamp_get_history_single end interface @ <>= elemental subroutine vamp_create_history (h, ndim, verbose) type(vamp_history), intent(out) :: h integer, intent(in), optional :: ndim logical, intent(in), optional :: verbose if (present (verbose)) then h%verbose = verbose else h%verbose = .false. end if h%calls = 0.0 if (h%verbose .and. (present (ndim))) then if (associated (h%div)) then deallocate (h%div) end if allocate (h%div(ndim)) end if end subroutine vamp_create_history @ %def vamp_create_history @ <>= elemental subroutine vamp_terminate_history (h) type(vamp_history), intent(inout) :: h h%calls = 0.0 end subroutine vamp_terminate_history @ %def vamp_terminate_history @ <>= pure subroutine vamp_get_history_single (h, g, integral, std_dev, avg_chi2) type(vamp_history), intent(inout) :: h type(vamp_grid), intent(in) :: g real(kind=default), intent(in) :: integral, std_dev, avg_chi2 h%calls = g%calls h%stratified = g%all_stratified h%integral = g%mu(1) h%std_dev = sqrt (g%mu(2)) h%avg_integral = integral h%avg_std_dev = std_dev h%avg_chi2 = avg_chi2 h%f_min = g%f_min h%f_max = g%f_max if (h%verbose) then <> call copy_history (h%div, summarize_division (g%div)) end if end subroutine vamp_get_history_single @ %def vamp_get_history_single @ <>= if (associated (h%div)) then if (size (h%div) /= size (g%div)) then deallocate (h%div) allocate (h%div(size(g%div))) end if else allocate (h%div(size(g%div))) end if @ <>= public :: vamp_print_history, vamp_write_history private :: vamp_print_one_history, vamp_print_histories ! private :: vamp_write_one_history, vamp_write_histories @ %def vamp_print_history vamp_print_one_history vamp_print_histories @ %def vamp_write_history vamp_write_one_history vamp_write_histories @ <>= interface vamp_print_history module procedure vamp_print_one_history, vamp_print_histories end interface interface vamp_write_history module procedure vamp_write_one_history_unit, vamp_write_histories_unit end interface @ %def vamp_print_history @ %def vamp_write_history @ <>= subroutine vamp_print_one_history (h, tag) type(vamp_history), dimension(:), intent(in) :: h character(len=*), intent(in), optional :: tag type(div_history), dimension(:), allocatable :: h_tmp character(len=BUFFER_SIZE) :: pfx character(len=1) :: s integer :: i, imax, j if (present (tag)) then pfx = tag else pfx = "[vamp]" end if print "(1X,A78)", repeat ("-", 78) print "(1X,A8,1X,A2,A9,A1,1X,A11,1X,8X,1X," & // "1X,A13,1X,8X,1X,A5,1X,A5)", & pfx, "it", "#calls", "", "integral", "average", "chi2", "eff." imax = size (h) iterations: do i = 1, imax if (h(i)%calls <= 0) then imax = i - 1 exit iterations end if ! *JR: Skip zero channel if (h(i)%f_max==0) cycle if (h(i)%stratified) then s = "*" else s = "" end if print "(1X,A8,1X,I2,I9,A1,1X,E11.4,A1,E8.2,A1," & // "1X,E13.6,A1,E8.2,A1,F5.1,1X,F5.3)", pfx, & i, h(i)%calls, s, h(i)%integral, "(", h(i)%std_dev, ")", & h(i)%avg_integral, "(", h(i)%avg_std_dev, ")", h(i)%avg_chi2, & h(i)%integral / h(i)%f_max end do iterations print "(1X,A78)", repeat ("-", 78) if (all (h%verbose) .and. (imax >= 1)) then if (associated (h(1)%div)) then allocate (h_tmp(imax)) dimensions: do j = 1, size (h(1)%div) do i = 1, imax call copy_history (h_tmp(i), h(i)%div(j)) end do if (present (tag)) then write (unit = pfx, fmt = "(A,A1,I2.2)") & trim (tag(1:min(len_trim(tag),8))), "#", j else write (unit = pfx, fmt = "(A,A1,I2.2)") "[vamp]", "#", j end if call print_history (h_tmp, tag = pfx) print "(1X,A78)", repeat ("-", 78) end do dimensions deallocate (h_tmp) end if end if flush (output_unit) end subroutine vamp_print_one_history @ %def vamp_print_one_history @ <>= integer, private, parameter :: BUFFER_SIZE = 50 @ %def BUFFER_SIZE @ <>= subroutine vamp_print_histories (h, tag) type(vamp_history), dimension(:,:), intent(in) :: h character(len=*), intent(in), optional :: tag character(len=BUFFER_SIZE) :: pfx integer :: i print "(1X,A78)", repeat ("=", 78) channels: do i = 1, size (h, dim=2) if (present (tag)) then write (unit = pfx, fmt = "(A4,A1,I3.3)") tag, "#", i else write (unit = pfx, fmt = "(A4,A1,I3.3)") "chan", "#", i end if call vamp_print_one_history (h(:,i), pfx) end do channels print "(1X,A78)", repeat ("=", 78) flush (output_unit) end subroutine vamp_print_histories @ %def vamp_print_histories @ \begin{dubious} WK \end{dubious} <>= subroutine vamp_write_one_history_unit (u, h, tag) integer, intent(in) :: u type(vamp_history), dimension(:), intent(in) :: h character(len=*), intent(in), optional :: tag type(div_history), dimension(:), allocatable :: h_tmp character(len=BUFFER_SIZE) :: pfx character(len=1) :: s integer :: i, imax, j if (present (tag)) then pfx = tag else pfx = "[vamp]" end if write (u, "(1X,A78)") repeat ("-", 78) write (u, "(1X,A8,1X,A2,A9,A1,1X,A11,1X,8X,1X," & // "1X,A13,1X,8X,1X,A5,1X,A5)") & pfx, "it", "#calls", "", "integral", "average", "chi2", "eff." imax = size (h) iterations: do i = 1, imax if (h(i)%calls <= 0) then imax = i - 1 exit iterations end if ! *WK: Skip zero channel if (h(i)%f_max==0) cycle if (h(i)%stratified) then s = "*" else s = "" end if write (u, "(1X,A8,1X,I2,I9,A1,1X,ES11.4,A1,ES8.2,A1," & // "1X,ES13.6,A1,ES8.2,A1,F5.1,1X,F5.3)") pfx, & i, h(i)%calls, s, h(i)%integral, "(", h(i)%std_dev, ")", & h(i)%avg_integral, "(", h(i)%avg_std_dev, ")", h(i)%avg_chi2, & h(i)%integral / h(i)%f_max end do iterations write (u, "(1X,A78)") repeat ("-", 78) if (all (h%verbose) .and. (imax >= 1)) then if (associated (h(1)%div)) then allocate (h_tmp(imax)) dimensions: do j = 1, size (h(1)%div) do i = 1, imax call copy_history (h_tmp(i), h(i)%div(j)) end do if (present (tag)) then write (unit = pfx, fmt = "(A,A1,I2.2)") & trim (tag(1:min(len_trim(tag),8))), "#", j else write (unit = pfx, fmt = "(A,A1,I2.2)") "[vamp]", "#", j end if call write_history (u, h_tmp, tag = pfx) print "(1X,A78)", repeat ("-", 78) end do dimensions deallocate (h_tmp) end if end if flush (u) end subroutine vamp_write_one_history_unit subroutine vamp_write_histories_unit (u, h, tag) integer, intent(in) :: u type(vamp_history), dimension(:,:), intent(in) :: h character(len=*), intent(in), optional :: tag character(len=BUFFER_SIZE) :: pfx integer :: i write (u, "(1X,A78)") repeat ("=", 78) channels: do i = 1, size (h, dim=2) if (present (tag)) then write (unit = pfx, fmt = "(A4,A1,I3.3)") tag, "#", i else write (unit = pfx, fmt = "(A4,A1,I3.3)") "chan", "#", i end if call vamp_write_one_history_unit (u, h(:,i), pfx) end do channels write (u, "(1X,A78)") repeat ("=", 78) flush (u) end subroutine vamp_write_histories_unit @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Multi Channel} \cite{Kleiss/Pittau:1994:multichannel} \begin{subequations} \begin{align} \label{eq:g(x)} g(x) &= \sum_i \alpha_i g_i(x) \\ \label{eq:w(x)} w(x) &= \frac{f(x)}{g(x)} \end{align} \end{subequations} We want to minimize the variance~$W(\alpha)$ with the subsidiary condition~$\sum_i\alpha_i = 1$. We indroduce a Lagrange multiplier~$\lambda$: \begin{equation} \tilde W(\alpha) = W(\alpha) + \lambda \left(\sum_i\alpha_i - 1\right) \end{equation} Therefore\ldots \begin{equation} W_i(\alpha) = -\frac{\partial}{\partial\alpha_i} W(\alpha) = \int\!dx\, g_i(x) (w(x))^2 \approx \left\langle \frac{g_i(x)}{g(x)} (w(x))^2 \right\rangle \end{equation} \begin{dubious} \index{Fortran sucks!} \index{functional programming rules!} Here it \emph{really} hurts that \texttt{Fortran} has no \emph{first-class} functions. The following can be expressed much more elegantly in a functional programming language with \emph{first-class} functions, currying and closures. \texttt{Fortran} makes it extra painful since not even procedure pointers are supported. This puts extra burden on the users of this library. \end{dubious} Note that the components of [[vamp_grids]] are not protected. However, this is not a license for application programs to access it. Only Other libraries (e.g.~for parallel processing, like [[vampi]]) should do so. <>= type, public :: vamp_grids !!! private !: \emph{used by \texttt{vampi}} real(kind=default), dimension(:), pointer :: weights => null () type(vamp_grid), dimension(:), pointer :: grids => null () integer, dimension(:), pointer :: num_calls => null () real(kind=default) :: sum_chi2, sum_integral, sum_weights end type vamp_grids @ %def vamp_grids @ \begin{equation} \label{eq:gophi_i} g\circ\phi_i = \left|\frac{\partial\phi_i}{\partial x}\right|^{-1} \left( \alpha_i g_i + \sum_{\substack{j=1\\j\not=i}}^{N_c} \alpha_j (g_j\circ\pi_{ij}) \left|\frac{\partial\pi_{ij}}{\partial x}\right| \right)\,. \end{equation} <>= public :: vamp_multi_channel, vamp_multi_channel0 @ <>= function vamp_multi_channel & (func, data, phi, ihp, jacobian, x, weights, channel, grids) result (w_x) class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in) :: weights integer, intent(in) :: channel type(vamp_grid), dimension(:), intent(in) :: grids <> <> <> <> real(kind=default) :: w_x integer :: i real(kind=default), dimension(size(x)) :: phi_x real(kind=default), dimension(size(weights)) :: g_phi_x, g_pi_x phi_x = phi (x, channel) do i = 1, size (weights) if (i == channel) then g_pi_x(i) = vamp_probability (grids(i), x) else g_pi_x(i) = vamp_probability (grids(i), ihp (phi_x, i)) end if end do do i = 1, size (weights) g_phi_x(i) = g_pi_x(i) / g_pi_x(channel) * jacobian (phi_x, data, i) end do w_x = func (phi_x, data, weights, channel, grids) & / dot_product (weights, g_phi_x) end function vamp_multi_channel @ %def vamp_multi_channel @ <>= function vamp_multi_channel0 & (func, data, phi, jacobian, x, weights, channel) result (w_x) class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(in) :: weights integer, intent(in) :: channel <> <> <> real(kind=default) :: w_x real(kind=default), dimension(size(x)) :: x_prime real(kind=default), dimension(size(weights)) :: g_phi_x integer :: i x_prime = phi (x, channel) do i = 1, size (weights) g_phi_x(i) = jacobian (x_prime, data, i) end do w_x = func (x_prime, data) / dot_product (weights, g_phi_x) end function vamp_multi_channel0 @ %def vamp_multi_channel0 @ \begin{dubious} WK \end{dubious} <>= public :: vamp_jacobian, vamp_check_jacobian @ <>= pure subroutine vamp_jacobian (phi, channel, x, region, jacobian, delta_x) integer, intent(in) :: channel real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:,:), intent(in) :: region real(kind=default), intent(out) :: jacobian real(kind=default), intent(in), optional :: delta_x interface pure function phi (xi, channel) result (x) use kinds real(kind=default), dimension(:), intent(in) :: xi integer, intent(in) :: channel real(kind=default), dimension(size(xi)) :: x end function phi end interface real(kind=default), dimension(size(x)) :: x_min, x_max real(kind=default), dimension(size(x)) :: x_plus, x_minus real(kind=default), dimension(size(x),size(x)) :: d_phi real(kind=default), parameter :: & dx_default = 10.0_default**(-precision(jacobian)/3) real(kind=default) :: dx integer :: j if (present (delta_x)) then dx = delta_x else dx = dx_default end if x_min = region(1,:) x_max = region(2,:) x_minus = max (x_min, x) x_plus = min (x_max, x) do j = 1, size (x) x_minus(j) = max (x_min(j), x(j) - dx) x_plus(j) = min (x_max(j), x(j) + dx) d_phi(:,j) = (phi (x_plus, channel) - phi (x_minus, channel)) & / (x_plus(j) - x_minus(j)) x_minus(j) = max (x_min(j), x(j)) x_plus(j) = min (x_max(j), x(j)) end do call determinant (d_phi, jacobian) jacobian = abs (jacobian) end subroutine vamp_jacobian @ \begin{equation} g(\phi(x)) = \frac{1}{\left|\frac{\partial\phi}{\partial x}\right|(x)} \end{equation} <>= subroutine vamp_check_jacobian & (rng, n, func, data, phi, channel, region, delta, x_delta) type(tao_random_state), intent(inout) :: rng integer, intent(in) :: n class(vamp_data_t), intent(in) :: data integer, intent(in) :: channel real(kind=default), dimension(:,:), intent(in) :: region real(kind=default), intent(out) :: delta real(kind=default), dimension(:), intent(out), optional :: x_delta <> <> real(kind=default), dimension(size(region,dim=2)) :: x, r real(kind=default) :: jac, d real(kind=default), dimension(0) :: wgts integer :: i delta = 0.0 do i = 1, max (1, n) call tao_random_number (rng, r) x = region(1,:) + (region(2,:) - region(1,:)) * r call vamp_jacobian (phi, channel, x, region, jac) d = func (phi (x, channel), data, wgts, channel) * jac & - 1.0_default if (abs (d) >= abs (delta)) then delta = d if (present (x_delta)) then x_delta = x end if end if end do end subroutine vamp_check_jacobian @ %def vamp_check_jacobian @ This is a subroutine to comply with F's rules, otherwise, we would code it as a function. \index{inconvenient F constraints} <>= private :: numeric_jacobian @ <>= pure subroutine numeric_jacobian (phi, channel, x, region, jacobian, delta_x) integer, intent(in) :: channel real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:,:), intent(in) :: region real(kind=default), intent(out) :: jacobian real(kind=default), intent(in), optional :: delta_x <> real(kind=default), dimension(size(x)) :: x_min, x_max real(kind=default), dimension(size(x)) :: x_plus, x_minus real(kind=default), dimension(size(x),size(x)) :: d_phi real(kind=default), parameter :: & dx_default = 10.0_default**(-precision(jacobian)/3) real(kind=default) :: dx integer :: j if (present (delta_x)) then dx = delta_x else dx = dx_default end if x_min = region(1,:) x_max = region(2,:) x_minus = max (x_min, x) x_plus = min (x_max, x) do j = 1, size (x) x_minus(j) = max (x_min(j), x(j) - dx) x_plus(j) = min (x_max(j), x(j) + dx) d_phi(:,j) = (phi (x_plus, channel) - phi (x_minus, channel)) & / (x_plus(j) - x_minus(j)) x_minus(j) = max (x_min(j), x(j)) x_plus(j) = min (x_max(j), x(j)) end do call determinant (d_phi, jacobian) jacobian = abs (jacobian) end subroutine numeric_jacobian @ %def numeric_jacobian @ <>= public :: vamp_create_grids, vamp_create_empty_grids public :: vamp_copy_grids, vamp_delete_grids @ The rules for optional arguments forces us to handle special cases, because we can't just pass a array section of an optional array as an actual argument (cf.~12.4.1.5(4) in~\cite{Fortran95}) even if the dummy argument is optional itself. <>= pure subroutine vamp_create_grids & (g, domain, num_calls, weights, maps, num_div, & stratified, quadrupole, exc) type(vamp_grids), intent(inout) :: g real(kind=default), dimension(:,:), intent(in) :: domain integer, intent(in) :: num_calls real(kind=default), dimension(:), intent(in) :: weights real(kind=default), dimension(:,:,:), intent(in), optional :: maps integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_create_grids" integer :: ch, nch nch = size (weights) allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) g%weights = weights / sum (weights) g%num_calls = g%weights * num_calls do ch = 1, size (g%grids) if (present (maps)) then call vamp_create_grid & (g%grids(ch), domain, g%num_calls(ch), num_div, & stratified, quadrupole, map = maps(:,:,ch), exc = exc) else call vamp_create_grid & (g%grids(ch), domain, g%num_calls(ch), num_div, & stratified, quadrupole, exc = exc) end if end do g%sum_integral = 0.0 g%sum_chi2 = 0.0 g%sum_weights = 0.0 end subroutine vamp_create_grids @ %def vamp_create_grids @ <>= pure subroutine vamp_create_empty_grids (g) type(vamp_grids), intent(inout) :: g nullify (g%grids, g%weights, g%num_calls) end subroutine vamp_create_empty_grids @ %def vamp_create_empty_grids @ <>= public :: vamp_discard_integrals @ <>= pure subroutine vamp_discard_integrals & (g, num_calls, num_div, stratified, quadrupole, exc, eq) type(vamp_grids), intent(inout) :: g integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc type(vamp_equivalences_t), intent(in), optional :: eq integer :: ch character(len=*), parameter :: FN = "vamp_discard_integrals" g%sum_integral = 0.0 g%sum_weights = 0.0 g%sum_chi2 = 0.0 do ch = 1, size (g%grids) call vamp_discard_integral (g%grids(ch)) end do if (present (num_calls)) then call vamp_reshape_grids & (g, num_calls, num_div, stratified, quadrupole, exc, eq) end if end subroutine vamp_discard_integrals @ %def vamp_discard_integrals @ %def sum_integral sum_weights sum_chi2 @ <>= public :: vamp_update_weights @ We must discard the accumulated integrals, because the weight function~$w=f/\sum_i\alpha_ig_i$ changes: <>= pure subroutine vamp_update_weights & (g, weights, num_calls, num_div, stratified, quadrupole, exc) type(vamp_grids), intent(inout) :: g real(kind=default), dimension(:), intent(in) :: weights integer, intent(in), optional :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "vamp_update_weights" if (sum (weights) > 0) then g%weights = weights / sum (weights) else g%weights = 1._default / size(g%weights) end if if (present (num_calls)) then call vamp_discard_integrals (g, num_calls, num_div, & stratified, quadrupole, exc) else call vamp_discard_integrals (g, sum (g%num_calls), num_div, & stratified, quadrupole, exc) end if end subroutine vamp_update_weights @ %def vamp_update_weights @ <>= public :: vamp_reshape_grids @ <>= pure subroutine vamp_reshape_grids & (g, num_calls, num_div, stratified, quadrupole, exc, eq) type(vamp_grids), intent(inout) :: g integer, intent(in) :: num_calls integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole type(exception), intent(inout), optional :: exc type(vamp_equivalences_t), intent(in), optional :: eq integer, dimension(size(g%grids(1)%num_div)) :: num_div_new integer :: ch character(len=*), parameter :: FN = "vamp_reshape_grids" g%num_calls = g%weights * num_calls do ch = 1, size (g%grids) if (g%num_calls(ch) >= 2) then if (present (eq)) then if (present (num_div)) then num_div_new = num_div else num_div_new = g%grids(ch)%num_div end if where (eq%div_is_invariant(ch,:)) num_div_new = 1 end where call vamp_reshape_grid (g%grids(ch), g%num_calls(ch), & num_div_new, stratified, quadrupole, exc = exc, & independent = eq%independent(ch), & equivalent_to_ch = eq%equivalent_to_ch(ch), & multiplicity = eq%multiplicity(ch)) else call vamp_reshape_grid (g%grids(ch), g%num_calls(ch), & num_div, stratified, quadrupole, exc = exc) end if else g%num_calls(ch) = 0 end if end do end subroutine vamp_reshape_grids @ %def vamp_reshape_grids @ <>= public :: vamp_sample_grids @ Even if [[g%num_calls]] is derived from [[g%weights]], we must \emph{not} use the latter, allow for integer arithmetic in [[g%num_calls]].\par <>= subroutine vamp_sample_grids & (rng, g, func, data, iterations, integral, std_dev, avg_chi2, & accuracy, history, histories, exc, eq, warn_error, negative_weights) type(tao_random_state), intent(inout) :: rng type(vamp_grids), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 real(kind=default), intent(in), optional :: accuracy type(vamp_history), dimension(:), intent(inout), optional :: history type(vamp_history), dimension(:,:), intent(inout), optional :: histories type(exception), intent(inout), optional :: exc type(vamp_equivalences_t), intent(in), optional :: eq logical, intent(in), optional :: warn_error, negative_weights <> integer :: ch, iteration logical :: neg_w type(exception), dimension(size(g%grids)) :: excs logical, dimension(size(g%grids)) :: active real(kind=default), dimension(size(g%grids)) :: weights, integrals, std_devs real(kind=default) :: local_integral, local_std_dev, local_avg_chi2 character(len=*), parameter :: FN = "vamp_sample_grids" integrals = 0 std_devs = 0 neg_w = .false. if (present (negative_weights)) neg_w = negative_weights active = (g%num_calls >= 2) where (active) weights = g%num_calls elsewhere weights = 0.0 endwhere if (sum (weights) /= 0) weights = weights / sum (weights) call clear_exception (excs) iterate: do iteration = 1, iterations do ch = 1, size (g%grids) if (active(ch)) then call vamp_discard_integral (g%grids(ch)) <> else call vamp_nullify_variance (g%grids(ch)) call vamp_nullify_covariance (g%grids(ch)) end if end do if (present(eq)) call vamp_apply_equivalences (g, eq) if (iteration < iterations) then do ch = 1, size (g%grids) active(ch) = (integrals(ch) /= 0) if (active(ch)) then call vamp_refine_grid (g%grids(ch)) end if end do end if if (present (exc) .and. (any (excs%level > 0))) then call gather_exceptions (exc, excs) ! return end if call vamp_reduce_channels (g, integrals, std_devs, active) call vamp_average_iterations & (g, iteration, local_integral, local_std_dev, local_avg_chi2) <> <> end do iterate <> end subroutine vamp_sample_grids @ %def vamp_sample_grids @ We must refine the grids after \emph{all} grids have been sampled, therefore we use [[vamp_sample_grid0]] instead of [[vamp_sample_grid]]: <>= call vamp_sample_grid0 & (rng, g%grids(ch), func, data, & ch, weights, g%grids, excs(ch), neg_w) if (present (exc) .and. present (warn_error)) then if (warn_error) call handle_exception (excs(ch)) end if call vamp_average_iterations & (g%grids(ch), iteration, integrals(ch), std_devs(ch), local_avg_chi2) if (present (histories)) then if (iteration <= ubound (histories, dim=1)) then call vamp_get_history & (histories(iteration,ch), g%grids(ch), & integrals(ch), std_devs(ch), local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp_terminate_history (histories(iteration+1:,ch)) end if @ <>= public :: vamp_reduce_channels @ \begin{subequations} \begin{align} I &= \frac{1}{N} \sum_c N_c I_c \\ \label{eq:multi-sigma} \sigma^2 &= \frac{1}{N^2} \sum_c N_c^2 \sigma_c^2 \\ N & = \sum_c N_c \end{align} \end{subequations} where~(\ref{eq:multi-sigma}) is actually \begin{equation*} \sigma^2 = \frac{1}{N}\left(\mu_2 - \mu_1^1\right) = \frac{1}{N}\left(\frac{1}{N} \sum_c N_c \mu_{2,c} - I^2\right) = \frac{1}{N}\left(\frac{1}{N} \sum_c (N_c^2 \sigma_c^2 + N_c I_c^2) - I^2\right) \end{equation*} but the latter form suffers from numerical instability and~(\ref{eq:multi-sigma}) is thus preferred. <>= pure subroutine vamp_reduce_channels (g, integrals, std_devs, active) type(vamp_grids), intent(inout) :: g real(kind=default), dimension(:), intent(in) :: integrals, std_devs logical, dimension(:), intent(in) :: active real(kind=default) :: this_integral, this_weight, total_calls real(kind=default) :: total_variance if (.not.any(active)) return total_calls = sum (g%num_calls, mask=active) if (total_calls > 0) then this_integral = sum (g%num_calls * integrals, mask=active) / total_calls else this_integral = 0 end if total_variance = sum ((g%num_calls*std_devs)**2, mask=active) if (total_variance > 0) then this_weight = total_calls**2 / total_variance else this_weight = 0 end if g%sum_weights = g%sum_weights + this_weight g%sum_integral = g%sum_integral + this_weight * this_integral g%sum_chi2 = g%sum_chi2 + this_weight * this_integral**2 end subroutine vamp_reduce_channels @ %def vamp_reduce_channels @ <>= public :: vamp_refine_weights @ <>= elemental subroutine vamp_average_iterations_grids & (g, iteration, integral, std_dev, avg_chi2) type(vamp_grids), intent(in) :: g integer, intent(in) :: iteration real(kind=default), intent(out) :: integral, std_dev, avg_chi2 real(kind=default), parameter :: eps = 1000 * epsilon (1._default) if (g%sum_weights>0) then integral = g%sum_integral / g%sum_weights std_dev = sqrt (1.0 / g%sum_weights) avg_chi2 = & max ((g%sum_chi2 - g%sum_integral * integral) / (iteration-0.99), & 0.0_default) if (avg_chi2 < eps * g%sum_chi2) avg_chi2 = 0 else integral = 0 std_dev = 0 avg_chi2 = 0 end if end subroutine vamp_average_iterations_grids @ %def vamp_average_iterations_grids @ <>= private :: vamp_average_iterations_grids @ <>= interface vamp_average_iterations module procedure vamp_average_iterations_grids end interface @ %def vamp_average_iterations @ \begin{equation} \alpha_i \to \alpha_i \sqrt{V_i} \end{equation} <>= pure subroutine vamp_refine_weights (g, power) type(vamp_grids), intent(inout) :: g real(kind=default), intent(in), optional :: power real(kind=default) :: local_power real(kind=default), parameter :: DEFAULT_POWER = 0.5_default if (present (power)) then local_power = power else local_power = DEFAULT_POWER end if call vamp_update_weights & (g, g%weights * vamp_get_variance (g%grids) ** local_power) end subroutine vamp_refine_weights @ %def vamp_refine_weights @ <>= if (present (history)) then if (iteration <= size (history)) then call vamp_get_history & (history(iteration), g, local_integral, local_std_dev, & local_avg_chi2) else call raise_exception (exc, EXC_WARN, FN, "history too short") end if call vamp_terminate_history (history(iteration+1:)) end if @ <>= private :: vamp_get_history_multi @ <>= interface vamp_get_history module procedure vamp_get_history_multi end interface @ <>= pure subroutine vamp_get_history_multi (h, g, integral, std_dev, avg_chi2) type(vamp_history), intent(inout) :: h type(vamp_grids), intent(in) :: g real(kind=default), intent(in) :: integral, std_dev, avg_chi2 h%calls = sum (g%grids%calls) h%stratified = all (g%grids%all_stratified) h%integral = 0.0 h%std_dev = 0.0 h%avg_integral = integral h%avg_std_dev = std_dev h%avg_chi2 = avg_chi2 h%f_min = 0.0 h%f_max = huge (h%f_max) if (h%verbose) then h%verbose = .false. if (associated (h%div)) then deallocate (h%div) end if end if end subroutine vamp_get_history_multi @ %def vamp_get_history_multi @ \begin{dubious} WK \end{dubious} @ <>= public :: vamp_sum_channels @ <>= function vamp_sum_channels (x, weights, func, data, grids) result (g) real(kind=default), dimension(:), intent(in) :: x, weights class(vamp_data_t), intent(in) :: data type(vamp_grid), dimension(:), intent(in), optional :: grids interface function func (xi, data, weights, channel, grids) result (f) use kinds use vamp_grid_type !NODEP! import vamp_data_t real(kind=default), dimension(:), intent(in) :: xi class(vamp_data_t), intent(in) :: data real(kind=default), dimension(:), intent(in), optional :: weights integer, intent(in), optional :: channel type(vamp_grid), dimension(:), intent(in), optional :: grids real(kind=default) :: f end function func end interface real(kind=default) :: g integer :: ch g = 0.0 do ch = 1, size (weights) g = g + weights(ch) * func (x, data, weights, ch, grids) end do end function vamp_sum_channels @ %def vamp_sum_channels @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Mapping} \begin{dubious} \index{unfinished business} This section is still under construction. The basic algorithm is in place, but the heuristics have not be developed yet. \end{dubious} The most naive approach is to use the rotation matrix~$R$ that diagonalizes the covariance~$C$: \begin{equation} R_{ij} = (v_j)_i \end{equation} where \begin{equation} C v_j = \lambda_j v_j \end{equation} with the eigenvalues~$\{\lambda_j\}$ and eigenvectors~$\{v_j\}$. Then \begin{equation} R^T C R = \mathop{\textrm{diag}} (\lambda_1,\ldots) \end{equation} After [[call diagonalize_real_symmetric (cov, evals, evecs)]], we have $\text{[[evals]]}(j)=\lambda_j$ and $\text{[[evecs]]}(\text{[[:]]},j)=v_j$. This is equivalent with $\text{[[evecs]]}(i,j)=R_{ij}$.\par This approach will not work in high dimensions, however. In general,~$R$ will \emph{not} leave most of the axes invariant, even if the covariance matrix is almost isotripic in these directions. I this case the benefit from the rotation is rather small and offset by the negative effects from the misalignment of the integration region.\par A better strategy is to find the axis of the original coordinate system around which a rotation is most beneficial. There are two extreme cases: \begin{itemize} \item ``pancake'': one eigenvalue much smaller than the others \item ``cigar'': one eigenvalue much larger than the others \end{itemize} Actually, instead of rotating around a specfic axis, we can as well diagonalize in a subspace. Empirically, rotation around an axis is better than diagonalizing in a two-dimensional subspace, but diagonalizing in a three-dimensional subspace can be even better. <>= public :: select_rotation_axis public :: select_rotation_subspace @ %def select_rotation_axis @ %def select_rotation_subspace @ <>= if (num_pancake > 0) then print *, "FORCED PANCAKE: ", num_pancake iv = sum (minloc (evals)) else if (num_cigar > 0) then print *, "FORCED CIGAR: ", num_cigar iv = sum (maxloc (evals)) else call more_pancake_than_cigar (evals, like_pancake) if (like_pancake) then iv = sum (minloc (evals)) else iv = sum (maxloc (evals)) end if end if @ %def iv @ <>= subroutine more_pancake_than_cigar (eval, yes_or_no) real(kind=default), dimension(:), intent(in) :: eval logical, intent(out) :: yes_or_no integer, parameter :: N_CL = 2 real(kind=default), dimension(size(eval)) :: evals real(kind=default), dimension(N_CL) :: cluster_pos integer, dimension(N_CL,2) :: clusters evals = eval call sort (evals) call condense (evals, cluster_pos, clusters) print *, clusters(1,2) - clusters(1,1) + 1, "small EVs: ", & evals(clusters(1,1):clusters(1,2)) print *, clusters(2,2) - clusters(2,1) + 1, "large EVs: ", & evals(clusters(2,1):clusters(2,2)) if ((clusters(1,2) - clusters(1,1)) & < (clusters(2,2) - clusters(2,1))) then print *, " => PANCAKE!" yes_or_no = .true. else print *, " => CIGAR!" yes_or_no = .false. end if end subroutine more_pancake_than_cigar @ %def more_pancake_than_cigar @ <>= private :: more_pancake_than_cigar @ %def more_pancake_than_cigar @ In both cases, we can rotate in the plane~$P_{ij}$ closest to eigenvector corresponding to the the singled out eigenvalue. This plane is given by \begin{equation} \max_{i\not= i'} \sqrt{(v_j)_i^2 + (v_j)_{i'}^2} \end{equation} which is simply found by looking for the two largest~$|(v_j)_i|$:\footnote{The [[sum]] intrinsic is a convenient \texttt{Fortran90} trick for turning the rank-one array with one element returned by [[maxloc]] into its value. It has no semantic significance.} <>= abs_evec = abs (evecs(:,iv)) i(1) = sum (maxloc (abs_evec)) abs_evec(i(1)) = -1.0 i(2) = sum (maxloc (abs_evec)) @ %def abs_evec i @ The following is cute, but unfortunately broken, since it fails for dgenerate eigenvalues: <>= abs_evec = abs (evecs(:,iv)) i(1) = sum (maxloc (abs_evec)) i(2) = sum (maxloc (abs_evec, mask = abs_evec < abs_evec(i(1)))) @ %def abs_evec i @ <>= print *, iv, evals(iv), " => ", evecs(:,iv) print *, i(1), abs_evec(i(1)), ", ", i(2), abs_evec(i(2)) print *, i(1), evecs(i(1),iv), ", ", i(2), evecs(i(2),iv) @ <>= cos_theta = evecs(i(1),iv) sin_theta = evecs(i(2),iv) norm = 1.0 / sqrt (cos_theta**2 + sin_theta**2) cos_theta = cos_theta * norm sin_theta = sin_theta * norm @ %def cos_theta sin_theta norm @ \begin{equation} \hat R(\theta;i,j) = \begin{pmatrix} 1 & & & & & & \\ & \ddots & & & & & \\ & & \cos\theta & \cdots & -\sin\theta & & \\ & & \vdots & 1 & \vdots & & \\ & & \sin\theta & \cdots & \cos\theta & & \\ & & & & & \ddots & \\ & & & & & & 1 \end{pmatrix} \end{equation} <>= call unit (r) r(i(1),i) = (/ cos_theta, - sin_theta /) r(i(2),i) = (/ sin_theta, cos_theta /) @ %def r @ <>= subroutine select_rotation_axis (cov, r, pancake, cigar) real(kind=default), dimension(:,:), intent(in) :: cov real(kind=default), dimension(:,:), intent(out) :: r integer, intent(in), optional :: pancake, cigar integer :: num_pancake, num_cigar logical :: like_pancake real(kind=default), dimension(size(cov,dim=1),size(cov,dim=2)) :: evecs real(kind=default), dimension(size(cov,dim=1)) :: evals, abs_evec integer :: iv integer, dimension(2) :: i real(kind=default) :: cos_theta, sin_theta, norm <> call diagonalize_real_symmetric (cov, evals, evecs) <> <> <> <> end subroutine select_rotation_axis @ %def select_rotation_axis @ <>= if (present (pancake)) then num_pancake = pancake else num_pancake = -1 endif if (present (cigar)) then num_cigar = cigar else num_cigar = -1 endif @ Here's a less efficient version that can be easily generalized to more than two dimension, however: <>= subroutine select_subspace_explicit (cov, r, subspace) real(kind=default), dimension(:,:), intent(in) :: cov real(kind=default), dimension(:,:), intent(out) :: r integer, dimension(:), intent(in) :: subspace real(kind=default), dimension(size(subspace)) :: eval_sub real(kind=default), dimension(size(subspace),size(subspace)) :: & cov_sub, evec_sub cov_sub = cov(subspace,subspace) call diagonalize_real_symmetric (cov_sub, eval_sub, evec_sub) call unit (r) r(subspace,subspace) = evec_sub end subroutine select_subspace_explicit @ %def select_subspace_explicit @ <>= subroutine select_subspace_guess (cov, r, ndim, pancake, cigar) real(kind=default), dimension(:,:), intent(in) :: cov real(kind=default), dimension(:,:), intent(out) :: r integer, intent(in) :: ndim integer, intent(in), optional :: pancake, cigar integer :: num_pancake, num_cigar logical :: like_pancake real(kind=default), dimension(size(cov,dim=1),size(cov,dim=2)) :: evecs real(kind=default), dimension(size(cov,dim=1)) :: evals, abs_evec integer :: iv, i integer, dimension(ndim) :: subspace <> call diagonalize_real_symmetric (cov, evals, evecs) <> <> call select_subspace_explicit (cov, r, subspace) end subroutine select_subspace_guess @ %def select_subspace_guess @ <>= abs_evec = abs (evecs(:,iv)) subspace(1) = sum (maxloc (abs_evec)) do i = 2, ndim abs_evec(subspace(i-1)) = -1.0 subspace(i) = sum (maxloc (abs_evec)) end do @ <>= interface select_rotation_subspace module procedure select_subspace_explicit, select_subspace_guess end interface @ %def select_rotation_subspace @ <>= private :: select_subspace_explicit private :: select_subspace_guess @ %def select_subspace_explicit @ %def select_subspace_guess @ <>= public :: vamp_print_covariance @ %def vamp_print_covariance @ <>= subroutine vamp_print_covariance (cov) real(kind=default), dimension(:,:), intent(in) :: cov real(kind=default), dimension(size(cov,dim=1)) :: & evals, abs_evals, tmp real(kind=default), dimension(size(cov,dim=1),size(cov,dim=2)) :: & evecs, abs_evecs integer, dimension(size(cov,dim=1)) :: idx integer :: i, i_max, j i_max = size (evals) call diagonalize_real_symmetric (cov, evals, evecs) call sort (evals, evecs) abs_evals = abs (evals) abs_evecs = abs (evecs) print "(1X,A78)", repeat ("-", 78) print "(1X,A)", "Eigenvalues and eigenvectors:" print "(1X,A78)", repeat ("-", 78) do i = 1, i_max print "(1X,I2,A1,1X,E11.4,1X,A1,10(10(1X,F5.2)/,18X))", & i, ":", evals(i), "|", evecs(:,i) end do print "(1X,A78)", repeat ("-", 78) print "(1X,A)", "Approximate subspaces:" print "(1X,A78)", repeat ("-", 78) do i = 1, i_max idx = (/ (j, j=1,i_max) /) tmp = abs_evecs(:,i) call sort (tmp, idx, reverse = .true.) print "(1X,I2,A1,1X,E11.4,1X,A1,10(1X,I5))", & i, ":", evals(i), "|", idx(1:min(10,size(idx))) print "(17X,A1,10(1X,F5.2))", & "|", evecs(idx(1:min(10,size(idx))),i) end do print "(1X,A78)", repeat ("-", 78) end subroutine vamp_print_covariance @ %def vamp_print_covariance @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Condensing Eigenvalues} In order to decide whether we have a ``pancake'' or a ``cigar'', we have to classify the eiegenvalues of the covariance matrix. We do this by condensing the~$n_{\text{dim}}$ eigenvalues into ~$n_{\text{cl}}\ll n_{\text{dim}}$ clusters. <>= ! private :: condense public :: condense @ The rough description is as follows: in each step, combine the nearst neighbours (according to an approbriate metric) to form a smaller set. This is an extremely simplified, discretized modeling of molecules condensing under the influence of some potential. \begin{dubious} If there's not a clean separation, this algorithm is certainly chaotic and we need to apply some form of damping! \end{dubious} @ <>= cl_pos = x cl_num = size (cl_pos) cl = spread ((/ (i, i=1,cl_num) /), dim = 2, ncopies = 2) @ %def cl_pos cl_num cl @ It appears that the logarithmic metric \begin{subequations} \begin{align} d_0 (x,y) &= \left|\log\left(\frac{x}{y}\right)\right| \\ \intertext{performs better than the linear metric} d_1 (x,y) &= |x-y| \\ \intertext{% since the latter won't separate very small eiegenvalues from the bulk. Another option is} d_\alpha (x,y) &= |x^\alpha-y^\alpha| \end{align} \end{subequations} with~$\alpha\not=1$, in particular~$\alpha\approx-1$. I haven't studied it yet, though. \begin{dubious} \index{more empirical studies helpful} but I should perform more empirical studies to determine whether the logarithmic or the linear metric is more appropriate in realistic cases. \end{dubious} <>= if (linear_metric) then gap = sum (minloc (cl_pos(2:cl_num) - cl_pos(1:cl_num-1))) else gap = sum (minloc (cl_pos(2:cl_num) / cl_pos(1:cl_num-1))) end if wgt0 = cl(gap,2) - cl(gap,1) + 1 wgt1 = cl(gap+1,2) - cl(gap+1,1) + 1 cl_pos(gap) = (wgt0 * cl_pos(gap) + wgt1 * cl_pos(gap+1)) / (wgt0 + wgt1) cl(gap,2) = cl(gap+1,2) @ %def gap wgt0 wgt1 cl_pos cl @ <>= cl_pos(gap+1:cl_num-1) = cl_pos(gap+2:cl_num) cl(gap+1:cl_num-1,:) = cl(gap+2:cl_num,:) @ %def cl_pos cl @ <>= subroutine condense (x, cluster_pos, clusters, linear) real(kind=default), dimension(:), intent(in) :: x real(kind=default), dimension(:), intent(out) :: cluster_pos integer, dimension(:,:), intent(out) :: clusters logical, intent(in), optional :: linear logical :: linear_metric real(kind=default), dimension(size(x)) :: cl_pos real(kind=default) :: wgt0, wgt1 integer :: cl_num integer, dimension(size(x),2) :: cl integer :: i, gap linear_metric = .false. if (present (linear)) then linear_metric = linear end if <> do cl_num = size (cl_pos), size (cluster_pos) + 1, -1 <> print *, cl_num, ": action = ", condense_action (x, cl) end do cluster_pos = cl_pos(1:cl_num) clusters = cl(1:cl_num,:) end subroutine condense @ %def condense @ <>= ! private :: condense_action public :: condense_action @ \begin{equation} S = \sum_{c\in\text{clusters}} \mathop{\textrm{var}}\nolimits^{\frac{\alpha}{2}}(c) \end{equation} <>= function condense_action (positions, clusters) result (s) real(kind=default), dimension(:), intent(in) :: positions integer, dimension(:,:), intent(in) :: clusters real(kind=default) :: s integer :: i integer, parameter :: POWER = 2 s = 0 do i = 1, size (clusters, dim = 1) s = s + standard_deviation (positions(clusters(i,1) & :clusters(i,2))) ** POWER end do end function condense_action @ <<[[ctest.f90]]>>= program ctest use kinds use utils use vamp_stat use tao_random_numbers use vamp implicit none integer, parameter :: N = 16, NC = 2 real(kind=default), dimension(N) :: eval real(kind=default), dimension(NC) :: cluster_pos integer, dimension(NC,2) :: clusters integer :: i call tao_random_number (eval) call sort (eval) print *, eval eval(1:N/2) = 0.95*eval(1:N/2) eval(N/2+1:N) = 1.0 - 0.95*(1.0 - eval(N/2+1:N)) print *, eval call condense (eval, cluster_pos, clusters, linear=.true.) do i = 1, NC print "(I2,A,F5.2,A,I2,A,I2,A,A,F5.2,A,F5.2,A,32F5.2)", & i, ": ", cluster_pos(i), & " [", clusters(i,1), "-", clusters(i,2), "]", & " [", eval(clusters(i,1)), " - ", eval(clusters(i,2)), "]", & eval(clusters(i,1)+1:clusters(i,2)) & - eval(clusters(i,1):clusters(i,2)-1) print *, average (eval(clusters(i,1):clusters(i,2))), "+/-", & standard_deviation (eval(clusters(i,1):clusters(i,2))) end do end program ctest @ %def ctest @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Event Generation} Automagically adaptive tools are not always appropriate for unweighted event generation, but we can give it a try. <>= public :: vamp_next_event @ <>= interface vamp_next_event module procedure vamp_next_event_single, vamp_next_event_multi end interface @ <>= private :: vamp_next_event_single, vamp_next_event_multi @ Both event generation routines operate in two modes, depending on whether the optional argument [[weight]] is present. <>= subroutine vamp_next_event_single & (x, rng, g, func, data, & weight, channel, weights, grids, exc) real(kind=default), dimension(:), intent(out) :: x type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g real(kind=default), intent(out), optional :: weight class(vamp_data_t), intent(in) :: data integer, intent(in), optional :: channel real(kind=default), dimension(:), intent(in), optional :: weights type(vamp_grid), dimension(:), intent(in), optional :: grids type(exception), intent(inout), optional :: exc <> character(len=*), parameter :: FN = "vamp_next_event_single" real(kind=default), dimension(size(g%div)):: wgts real(kind=default), dimension(size(g%div)):: r integer, dimension(size(g%div)):: ia real(kind=default) :: f, wgt real(kind=default) :: r0 rejection: do <> if (present (weight)) then <> else <> end if end do rejection end subroutine vamp_next_event_single @ %def vamp_next_event_single @ <>= call tao_random_number (rng, r) call inject_division_short (g%div, real(r, kind=default), x, ia, wgts) wgt = g%jacobi * product (wgts) wgt = g%calls * wgt !: the calling procedure will divide by \#calls if (associated (g%map)) then x = matmul (g%map, x) end if <<[[f = wgt * func (x, weights, channel)]], iff [[x]] inside [[true_domain]]>> ! call record_efficiency (g%div, ia, f/g%f_max) @ <>= weight = f exit rejection @ <>= if (abs(f) > g%f_max) then g%f_max = f call raise_exception (exc, EXC_WARN, FN, "weight > 1") exit rejection end if call tao_random_number (rng, r0) if (r0 * g%f_max <= abs(f)) then exit rejection end if @ We know that [[g%weights]] are normalized: [[sum (g%weights) == 1.0]]. The basic formula for multi channel sampling is \begin{equation} f(x) = \sum_i \alpha_i g_i(x) w(x) \end{equation} with~$w(x)=f(x)/g(x)=f(x)/\sum_i\alpha_ig_i(x)$ and~$\sum_i\alpha_i=1$. The non-trivial poblem is that the adaptive grid is diferent in each channel, so we can't just reject on~$w(x)$. <>= subroutine vamp_next_event_multi & (x, rng, g, func, data, phi, weight, excess, positive, exc) real(kind=default), dimension(:), intent(out) :: x type(tao_random_state), intent(inout) :: rng type(vamp_grids), intent(inout) :: g class(vamp_data_t), intent(in) :: data real(kind=default), intent(out), optional :: weight real(kind=default), intent(out), optional :: excess logical, intent(out), optional :: positive type(exception), intent(inout), optional :: exc <> <> character(len=*), parameter :: FN = "vamp_next_event_multi" real(kind=default), dimension(size(x)) :: xi real(kind=default) :: r, wgt real(kind=default), dimension(size(g%weights)) :: weights integer :: channel <<[[weights]]: $\alpha_i\to w_{\max,i}\alpha_i$>> rejection: do <>= call tao_random_number (rng, r) select_channel: do channel = 1, size (g%weights) r = r - weights(channel) if (r <= 0.0) then exit select_channel end if end do select_channel channel = min (channel, size (g%weights)) !: for $r=1$ and rounding errors @ <>= weight = wgt * g%weights(channel) / weights(channel) exit rejection @ <>= if (abs (wgt) > g%grids(channel)%f_max) then if (present(excess)) then excess = abs (wgt) / g%grids(channel)%f_max - 1 else call raise_exception (exc, EXC_WARN, FN, "weight > 1") ! print *, "weight > 1 (", wgt/g%grids(channel)%f_max, & ! & ") in channel ", channel end if ! exit rejection else if (present(excess)) excess = 0 end if call tao_random_number (rng, r) if (r * g%grids(channel)%f_max <= abs (wgt)) then if (present (positive)) positive = wgt >= 0 exit rejection end if @ <>= if (wgt > g%grids(channel)%f_max) then g%grids(channel)%f_max = wgt <<[[weights]]: $\alpha_i\to w_{\max,i}\alpha_i$>> call raise_exception (exc, EXC_WARN, FN, "weight > 1") exit rejection end if call tao_random_number (rng, r) if (r * g%grids(channel)%f_max <= wgt) then exit rejection end if @ Using [[vamp_sample_grid (g, ...)]] to warm up the grid~[[g]] has a somewhat subtle problem: the minimum and maximum weights [[g%f_min]] and [[g%f_max]] refer to the grid \emph{before} the final refinement. One could require an additional [[vamp_sample_grid0 (g, ...)]], but users are likely to forget such technical details. A better solution is a wrapper [[vamp_warmup_grid (g, ...)]] that drops the final refinement transparently. <>= public :: vamp_warmup_grid, vamp_warmup_grids @ <>= subroutine vamp_warmup_grid & (rng, g, func, data, iterations, exc, history) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> call vamp_sample_grid & (rng, g, func, data, & iterations - 1, exc = exc, history = history) call vamp_sample_grid0 (rng, g, func, data, exc = exc) end subroutine vamp_warmup_grid @ %def vamp_warmup_grid @ \begin{dubious} \texttt{WHERE ... END WHERE} alert! \end{dubious} <>= subroutine vamp_warmup_grids & (rng, g, func, data, iterations, history, histories, exc) type(tao_random_state), intent(inout) :: rng type(vamp_grids), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, intent(in) :: iterations type(vamp_history), dimension(:), intent(inout), optional :: history type(vamp_history), dimension(:,:), intent(inout), optional :: histories type(exception), intent(inout), optional :: exc <> integer :: ch logical, dimension(size(g%grids)) :: active real(kind=default), dimension(size(g%grids)) :: weights active = (g%num_calls >= 2) where (active) weights = g%num_calls elsewhere weights = 0.0 end where weights = weights / sum (weights) call vamp_sample_grids (rng, g, func, data, iterations - 1, & exc = exc, history = history, histories = histories) do ch = 1, size (g%grids) if (g%grids(ch)%num_calls >= 2) then call vamp_sample_grid0 & (rng, g%grids(ch), func, data, & ch, weights, g%grids, exc = exc) end if end do end subroutine vamp_warmup_grids @ %def vamp_warmup_grids @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Convenience Routines} <>= public :: vamp_integrate private :: vamp_integrate_grid, vamp_integrate_region @ <>= interface vamp_integrate module procedure vamp_integrate_grid, vamp_integrate_region end interface @ <>= subroutine vamp_integrate_grid & (rng, g, func, data, calls, integral, std_dev, avg_chi2, num_div, & stratified, quadrupole, accuracy, exc, history) type(tao_random_state), intent(inout) :: rng type(vamp_grid), intent(inout) :: g class(vamp_data_t), intent(in) :: data integer, dimension(:,:), intent(in) :: calls real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole real(kind=default), intent(in), optional :: accuracy type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_integrate_grid" integer :: step, last_step, it last_step = size (calls, dim = 2) it = 1 do step = 1, last_step - 1 call vamp_discard_integral (g, calls(2,step), num_div, & stratified, quadrupole, exc = exc) call vamp_sample_grid (rng, g, func, data, calls(1,step), & exc = exc, history = history(it:)) <> it = it + calls(1,step) end do call vamp_discard_integral (g, calls(2,last_step), exc = exc) call vamp_sample_grid (rng, g, func, data, calls(1,last_step), & integral, std_dev, avg_chi2, accuracy, exc = exc, & history = history(it:)) end subroutine vamp_integrate_grid @ %def vamp_integrate_grid @ <>= subroutine vamp_integrate_region & (rng, region, func, data, calls, & integral, std_dev, avg_chi2, num_div, & stratified, quadrupole, accuracy, map, covariance, exc, history) type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(:,:), intent(in) :: region class(vamp_data_t), intent(in) :: data integer, dimension(:,:), intent(in) :: calls real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole real(kind=default), intent(in), optional :: accuracy real(kind=default), dimension(:,:), intent(in), optional :: map real(kind=default), dimension(:,:), intent(out), optional :: covariance type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> character(len=*), parameter :: FN = "vamp_integrate_region" type(vamp_grid) :: g call vamp_create_grid & (g, region, calls(2,1), num_div, & stratified, quadrupole, present (covariance), map, exc) call vamp_integrate_grid & (rng, g, func, data, calls, & integral, std_dev, avg_chi2, num_div, & accuracy = accuracy, exc = exc, history = history) if (present (covariance)) then covariance = vamp_get_covariance (g) end if call vamp_delete_grid (g) end subroutine vamp_integrate_region @ %def vamp_integrate_region @ <>= public :: vamp_integratex private :: vamp_integratex_region @ <>= interface vamp_integratex module procedure vamp_integratex_region end interface @ <>= subroutine vamp_integratex_region & (rng, region, func, data, calls, integral, std_dev, avg_chi2, & num_div, stratified, quadrupole, accuracy, pancake, cigar, & exc, history) type(tao_random_state), intent(inout) :: rng real(kind=default), dimension(:,:), intent(in) :: region class(vamp_data_t), intent(in) :: data integer, dimension(:,:,:), intent(in) :: calls real(kind=default), intent(out), optional :: integral, std_dev, avg_chi2 integer, dimension(:), intent(in), optional :: num_div logical, intent(in), optional :: stratified, quadrupole real(kind=default), intent(in), optional :: accuracy integer, intent(in), optional :: pancake, cigar type(exception), intent(inout), optional :: exc type(vamp_history), dimension(:), intent(inout), optional :: history <> real(kind=default), dimension(size(region,dim=2)) :: eval real(kind=default), dimension(size(region,dim=2),size(region,dim=2)) :: evec type(vamp_grid) :: g integer :: step, last_step, it it = 1 call vamp_create_grid & (g, region, calls(2,1,1), num_div, & stratified, quadrupole, covariance = .true., exc = exc) call vamp_integrate_grid & (rng, g, func, data, calls(:,:,1), num_div = num_div, & exc = exc, history = history(it:)) <> it = it + sum (calls(1,:,1)) last_step = size (calls, dim = 3) do step = 2, last_step - 1 call diagonalize_real_symmetric (vamp_get_covariance(g), eval, evec) call sort (eval, evec) call select_rotation_axis (vamp_get_covariance(g), evec, pancake, cigar) call vamp_delete_grid (g) call vamp_create_grid & (g, region, calls(2,1,step), num_div, stratified, quadrupole, & covariance = .true., map = evec, exc = exc) call vamp_integrate_grid & (rng, g, func, data, calls(:,:,step), num_div = num_div, & exc = exc, history = history(it:)) <> it = it + sum (calls(1,:,step)) end do call diagonalize_real_symmetric (vamp_get_covariance(g), eval, evec) call sort (eval, evec) call select_rotation_axis (vamp_get_covariance(g), evec, pancake, cigar) call vamp_delete_grid (g) call vamp_create_grid & (g, region, calls(2,1,last_step), num_div, stratified, quadrupole, & covariance = .true., map = evec, exc = exc) call vamp_integrate_grid & (rng, g, func, data, calls(:,:,last_step), & integral, std_dev, avg_chi2, & num_div = num_div, exc = exc, history = history(it:)) call vamp_delete_grid (g) end subroutine vamp_integratex_region @ %def vamp_integratex_region @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{I/O} <>= public :: vamp_write_grid private :: write_grid_unit, write_grid_name public :: vamp_read_grid private :: read_grid_unit, read_grid_name public :: vamp_write_grids private :: write_grids_unit, write_grids_name public :: vamp_read_grids private :: read_grids_unit, read_grids_name @ <>= public :: vamp_read_grids_raw private :: read_grids_raw_unit, read_grids_raw_name public :: vamp_read_grid_raw private :: read_grid_raw_unit, read_grid_raw_name public :: vamp_write_grids_raw private :: write_grids_raw_unit, write_grids_raw_name public :: vamp_write_grid_raw private :: write_grid_raw_unit, write_grid_raw_name @ <>= interface vamp_write_grid module procedure write_grid_unit, write_grid_name end interface interface vamp_read_grid module procedure read_grid_unit, read_grid_name end interface interface vamp_write_grids module procedure write_grids_unit, write_grids_name end interface interface vamp_read_grids module procedure read_grids_unit, read_grids_name end interface @ %def vamp_write_grids @ %def vamp_read_grids @ %def vamp_write_grid @ %def vamp_read_grid @ <>= interface vamp_write_grid_raw module procedure write_grid_raw_unit, write_grid_raw_name end interface interface vamp_read_grid_raw module procedure read_grid_raw_unit, read_grid_raw_name end interface interface vamp_write_grids_raw module procedure write_grids_raw_unit, write_grids_raw_name end interface interface vamp_read_grids_raw module procedure read_grids_raw_unit, read_grids_raw_name end interface @ %def vamp_write_grids_raw @ %def vamp_read_grids_raw @ %def vamp_write_grid_raw @ %def vamp_read_grid_raw @ <>= subroutine write_grid_unit (g, unit, write_integrals) type(vamp_grid), intent(in) :: g integer, intent(in) :: unit logical, intent(in), optional :: write_integrals integer :: i, j write (unit = unit, fmt = descr_fmt) "begin type(vamp_grid) :: g" write (unit = unit, fmt = integer_fmt) "size (g%div) = ", size (g%div) write (unit = unit, fmt = integer_fmt) "num_calls = ", g%num_calls write (unit = unit, fmt = integer_fmt) "calls_per_cell = ", g%calls_per_cell write (unit = unit, fmt = logical_fmt) "stratified = ", g%stratified write (unit = unit, fmt = logical_fmt) "all_stratified = ", g%all_stratified write (unit = unit, fmt = logical_fmt) "quadrupole = ", g%quadrupole write (unit = unit, fmt = double_fmt) "mu(1) = ", g%mu(1) write (unit = unit, fmt = double_fmt) "mu(2) = ", g%mu(2) write (unit = unit, fmt = double_fmt) "mu_plus(1) = ", g%mu_plus(1) write (unit = unit, fmt = double_fmt) "mu_plus(2) = ", g%mu_plus(2) write (unit = unit, fmt = double_fmt) "mu_minus(1) = ", g%mu_minus(1) write (unit = unit, fmt = double_fmt) "mu_minus(2) = ", g%mu_minus(2) write (unit = unit, fmt = double_fmt) "sum_integral = ", g%sum_integral write (unit = unit, fmt = double_fmt) "sum_weights = ", g%sum_weights write (unit = unit, fmt = double_fmt) "sum_chi2 = ", g%sum_chi2 write (unit = unit, fmt = double_fmt) "calls = ", g%calls write (unit = unit, fmt = double_fmt) "dv2g = ", g%dv2g write (unit = unit, fmt = double_fmt) "jacobi = ", g%jacobi write (unit = unit, fmt = double_fmt) "f_min = ", g%f_min write (unit = unit, fmt = double_fmt) "f_max = ", g%f_max write (unit = unit, fmt = double_fmt) "mu_gi = ", g%mu_gi write (unit = unit, fmt = double_fmt) "sum_mu_gi = ", g%sum_mu_gi write (unit = unit, fmt = descr_fmt) "begin g%num_div" do i = 1, size (g%div) write (unit = unit, fmt = integer_array_fmt) i, g%num_div(i) end do write (unit = unit, fmt = descr_fmt) "end g%num_div" write (unit = unit, fmt = descr_fmt) "begin g%div" do i = 1, size (g%div) call write_division (g%div(i), unit, write_integrals) end do write (unit = unit, fmt = descr_fmt) "end g%div" if (associated (g%map)) then write (unit = unit, fmt = descr_fmt) "begin g%map" do i = 1, size (g%div) do j = 1, size (g%div) write (unit = unit, fmt = double_array2_fmt) i, j, g%map(i,j) end do end do write (unit = unit, fmt = descr_fmt) "end g%map" else write (unit = unit, fmt = descr_fmt) "empty g%map" end if if (associated (g%mu_x)) then write (unit = unit, fmt = descr_fmt) "begin g%mu_x" do i = 1, size (g%div) write (unit = unit, fmt = double_array_fmt) i, g%mu_x(i) write (unit = unit, fmt = double_array_fmt) i, g%sum_mu_x(i) do j = 1, size (g%div) write (unit = unit, fmt = double_array2_fmt) i, j, g%mu_xx(i,j) write (unit = unit, fmt = double_array2_fmt) i, j, g%sum_mu_xx(i,j) end do end do write (unit = unit, fmt = descr_fmt) "end g%mu_x" else write (unit = unit, fmt = descr_fmt) "empty g%mu_x" end if write (unit = unit, fmt = descr_fmt) "end type(vamp_grid)" end subroutine write_grid_unit @ %def write_grid_unit @ <>= character(len=*), parameter, private :: & descr_fmt = "(1x,a)", & integer_fmt = "(1x,a17,1x,i15)", & integer_array_fmt = "(1x,i17,1x,i15)", & logical_fmt = "(1x,a17,1x,l1)", & double_fmt = "(1x,a17,1x,e30.22e4)", & double_array_fmt = "(1x,i17,1x,e30.22e4)", & double_array2_fmt = "(2(1x,i8),1x,e30.22e4)" @ %def descr_fmt integer_fmt integer_array_fmt logical_fmt @ %def double_fmt double_array_fmt double_array2_fmt @ <>= subroutine read_grid_unit (g, unit, read_integrals) type(vamp_grid), intent(inout) :: g integer, intent(in) :: unit logical, intent(in), optional :: read_integrals character(len=*), parameter :: FN = "vamp_read_grid" character(len=80) :: chdum integer :: ndim, i, j, idum, jdum read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = integer_fmt) chdum, ndim <> call create_array_pointer (g%num_div, ndim) read (unit = unit, fmt = integer_fmt) chdum, g%num_calls read (unit = unit, fmt = integer_fmt) chdum, g%calls_per_cell read (unit = unit, fmt = logical_fmt) chdum, g%stratified read (unit = unit, fmt = logical_fmt) chdum, g%all_stratified read (unit = unit, fmt = logical_fmt) chdum, g%quadrupole read (unit = unit, fmt = double_fmt) chdum, g%mu(1) read (unit = unit, fmt = double_fmt) chdum, g%mu(2) read (unit = unit, fmt = double_fmt) chdum, g%mu_plus(1) read (unit = unit, fmt = double_fmt) chdum, g%mu_plus(2) read (unit = unit, fmt = double_fmt) chdum, g%mu_minus(1) read (unit = unit, fmt = double_fmt) chdum, g%mu_minus(2) read (unit = unit, fmt = double_fmt) chdum, g%sum_integral read (unit = unit, fmt = double_fmt) chdum, g%sum_weights read (unit = unit, fmt = double_fmt) chdum, g%sum_chi2 read (unit = unit, fmt = double_fmt) chdum, g%calls read (unit = unit, fmt = double_fmt) chdum, g%dv2g read (unit = unit, fmt = double_fmt) chdum, g%jacobi read (unit = unit, fmt = double_fmt) chdum, g%f_min read (unit = unit, fmt = double_fmt) chdum, g%f_max read (unit = unit, fmt = double_fmt) chdum, g%mu_gi read (unit = unit, fmt = double_fmt) chdum, g%sum_mu_gi read (unit = unit, fmt = descr_fmt) chdum do i = 1, size (g%div) read (unit = unit, fmt = integer_array_fmt) idum, g%num_div(i) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum do i = 1, size (g%div) call read_division (g%div(i), unit, read_integrals) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum if (chdum == "begin g%map") then call create_array_pointer (g%map, (/ ndim, ndim /)) do i = 1, size (g%div) do j = 1, size (g%div) read (unit = unit, fmt = double_array2_fmt) idum, jdum, g%map(i,j) end do end do read (unit = unit, fmt = descr_fmt) chdum else <> end if read (unit = unit, fmt = descr_fmt) chdum if (chdum == "begin g%mu_x") then call create_array_pointer (g%mu_x, ndim ) call create_array_pointer (g%sum_mu_x, ndim) call create_array_pointer (g%mu_xx, (/ ndim, ndim /)) call create_array_pointer (g%sum_mu_xx, (/ ndim, ndim /)) do i = 1, size (g%div) read (unit = unit, fmt = double_array_fmt) idum, jdum, g%mu_x(i) read (unit = unit, fmt = double_array_fmt) idum, jdum, g%sum_mu_x(i) do j = 1, size (g%div) read (unit = unit, fmt = double_array2_fmt) & idum, jdum, g%mu_xx(i,j) read (unit = unit, fmt = double_array2_fmt) & idum, jdum, g%sum_mu_xx(i,j) end do end do read (unit = unit, fmt = descr_fmt) chdum else <> end if read (unit = unit, fmt = descr_fmt) chdum end subroutine read_grid_unit @ %def read_grid_unit @ <>= if (associated (g%div)) then if (size (g%div) /= ndim) then call delete_division (g%div) deallocate (g%div) allocate (g%div(ndim)) call create_empty_division (g%div) end if else allocate (g%div(ndim)) call create_empty_division (g%div) end if @ <>= if (associated (g%map)) then deallocate (g%map) end if @ <>= if (associated (g%mu_x)) then deallocate (g%mu_x) end if if (associated (g%mu_xx)) then deallocate (g%mu_xx) end if if (associated (g%sum_mu_x)) then deallocate (g%sum_mu_x) end if if (associated (g%sum_mu_xx)) then deallocate (g%sum_mu_xx) end if @ <>= subroutine write_grid_name (g, name, write_integrals) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", file = name) call write_grid_unit (g, unit, write_integrals) close (unit = unit) end subroutine write_grid_name @ %def write_grid_name @ <>= subroutine read_grid_name (g, name, read_integrals) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", file = name) call read_grid_unit (g, unit, read_integrals) close (unit = unit) end subroutine read_grid_name @ %def read_grid_name @ <>= subroutine write_grids_unit (g, unit, write_integrals) type(vamp_grids), intent(in) :: g integer, intent(in) :: unit logical, intent(in), optional :: write_integrals integer :: i write (unit = unit, fmt = descr_fmt) "begin type(vamp_grids) :: g" write (unit = unit, fmt = integer_fmt) "size (g%grids) = ", size (g%grids) write (unit = unit, fmt = double_fmt) "sum_integral = ", g%sum_integral write (unit = unit, fmt = double_fmt) "sum_weights = ", g%sum_weights write (unit = unit, fmt = double_fmt) "sum_chi2 = ", g%sum_chi2 write (unit = unit, fmt = descr_fmt) "begin g%weights" do i = 1, size (g%grids) write (unit = unit, fmt = double_array_fmt) i, g%weights(i) end do write (unit = unit, fmt = descr_fmt) "end g%weights" write (unit = unit, fmt = descr_fmt) "begin g%num_calls" do i = 1, size (g%grids) write (unit = unit, fmt = integer_array_fmt) i, g%num_calls(i) end do write (unit = unit, fmt = descr_fmt) "end g%num_calls" write (unit = unit, fmt = descr_fmt) "begin g%grids" do i = 1, size (g%grids) call write_grid_unit (g%grids(i), unit, write_integrals) end do write (unit = unit, fmt = descr_fmt) "end g%grids" write (unit = unit, fmt = descr_fmt) "end type(vamp_grids)" end subroutine write_grids_unit @ %def write_grids_unit @ <>= subroutine read_grids_unit (g, unit, read_integrals) type(vamp_grids), intent(inout) :: g integer, intent(in) :: unit logical, intent(in), optional :: read_integrals character(len=*), parameter :: FN = "vamp_read_grids" character(len=80) :: chdum integer :: i, nch, idum read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = integer_fmt) chdum, nch if (associated (g%grids)) then if (size (g%grids) /= nch) then call vamp_delete_grid (g%grids) deallocate (g%grids, g%weights, g%num_calls) allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if else allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if read (unit = unit, fmt = double_fmt) chdum, g%sum_integral read (unit = unit, fmt = double_fmt) chdum, g%sum_weights read (unit = unit, fmt = double_fmt) chdum, g%sum_chi2 read (unit = unit, fmt = descr_fmt) chdum do i = 1, nch read (unit = unit, fmt = double_array_fmt) idum, g%weights(i) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum do i = 1, nch read (unit = unit, fmt = integer_array_fmt) idum, g%num_calls(i) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum do i = 1, nch call read_grid_unit (g%grids(i), unit, read_integrals) end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum end subroutine read_grids_unit @ %def read_grids_unit @ <>= subroutine write_grids_name (g, name, write_integrals) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", file = name) call write_grids_unit (g, unit, write_integrals) close (unit = unit) end subroutine write_grids_name @ %def write_grids_name @ <>= subroutine read_grids_name (g, name, read_integrals) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", file = name) call read_grids_unit (g, unit, read_integrals) close (unit = unit) end subroutine read_grids_name @ %def read_grids_name @ <>= subroutine write_grid_raw_unit (g, unit, write_integrals) type(vamp_grid), intent(in) :: g integer, intent(in) :: unit logical, intent(in), optional :: write_integrals integer :: i, j write (unit = unit) MAGIC_GRID_BEGIN write (unit = unit) size (g%div) write (unit = unit) g%num_calls write (unit = unit) g%calls_per_cell write (unit = unit) g%stratified write (unit = unit) g%all_stratified write (unit = unit) g%quadrupole write (unit = unit) g%mu(1) write (unit = unit) g%mu(2) write (unit = unit) g%mu_plus(1) write (unit = unit) g%mu_plus(2) write (unit = unit) g%mu_minus(1) write (unit = unit) g%mu_minus(2) write (unit = unit) g%sum_integral write (unit = unit) g%sum_weights write (unit = unit) g%sum_chi2 write (unit = unit) g%calls write (unit = unit) g%dv2g write (unit = unit) g%jacobi write (unit = unit) g%f_min write (unit = unit) g%f_max write (unit = unit) g%mu_gi write (unit = unit) g%sum_mu_gi do i = 1, size (g%div) write (unit = unit) g%num_div(i) end do do i = 1, size (g%div) call write_division_raw (g%div(i), unit, write_integrals) end do if (associated (g%map)) then write (unit = unit) MAGIC_GRID_MAP do i = 1, size (g%div) do j = 1, size (g%div) write (unit = unit) g%map(i,j) end do end do else write (unit = unit) MAGIC_GRID_EMPTY end if if (associated (g%mu_x)) then write (unit = unit) MAGIC_GRID_MU_X do i = 1, size (g%div) write (unit = unit) g%mu_x(i) write (unit = unit) g%sum_mu_x(i) do j = 1, size (g%div) write (unit = unit) g%mu_xx(i,j) write (unit = unit) g%sum_mu_xx(i,j) end do end do else write (unit = unit) MAGIC_GRID_EMPTY end if write (unit = unit) MAGIC_GRID_END end subroutine write_grid_raw_unit @ %def write_grid_raw_unit @ <>= integer, parameter, private :: MAGIC_GRID = 22222222 integer, parameter, private :: MAGIC_GRID_BEGIN = MAGIC_GRID + 1 integer, parameter, private :: MAGIC_GRID_END = MAGIC_GRID + 2 integer, parameter, private :: MAGIC_GRID_EMPTY = MAGIC_GRID + 3 integer, parameter, private :: MAGIC_GRID_MAP = MAGIC_GRID + 4 integer, parameter, private :: MAGIC_GRID_MU_X = MAGIC_GRID + 5 @ <>= subroutine read_grid_raw_unit (g, unit, read_integrals) type(vamp_grid), intent(inout) :: g integer, intent(in) :: unit logical, intent(in), optional :: read_integrals character(len=*), parameter :: FN = "vamp_read_raw_grid" integer :: ndim, i, j, magic read (unit = unit) magic if (magic /= MAGIC_GRID_BEGIN) then print *, FN, " fatal: expecting magic ", MAGIC_GRID_BEGIN, & ", found ", magic stop end if read (unit = unit) ndim <> call create_array_pointer (g%num_div, ndim) read (unit = unit) g%num_calls read (unit = unit) g%calls_per_cell read (unit = unit) g%stratified read (unit = unit) g%all_stratified read (unit = unit) g%quadrupole read (unit = unit) g%mu(1) read (unit = unit) g%mu(2) read (unit = unit) g%mu_plus(1) read (unit = unit) g%mu_plus(2) read (unit = unit) g%mu_minus(1) read (unit = unit) g%mu_minus(2) read (unit = unit) g%sum_integral read (unit = unit) g%sum_weights read (unit = unit) g%sum_chi2 read (unit = unit) g%calls read (unit = unit) g%dv2g read (unit = unit) g%jacobi read (unit = unit) g%f_min read (unit = unit) g%f_max read (unit = unit) g%mu_gi read (unit = unit) g%sum_mu_gi do i = 1, size (g%div) read (unit = unit) g%num_div(i) end do do i = 1, size (g%div) call read_division_raw (g%div(i), unit, read_integrals) end do read (unit = unit) magic if (magic == MAGIC_GRID_MAP) then call create_array_pointer (g%map, (/ ndim, ndim /)) do i = 1, size (g%div) do j = 1, size (g%div) read (unit = unit) g%map(i,j) end do end do else if (magic == MAGIC_GRID_EMPTY) then <> else print *, FN, " fatal: expecting magic ", MAGIC_GRID_EMPTY, & " or ", MAGIC_GRID_MAP, ", found ", magic stop end if read (unit = unit) magic if (magic == MAGIC_GRID_MU_X) then call create_array_pointer (g%mu_x, ndim ) call create_array_pointer (g%sum_mu_x, ndim) call create_array_pointer (g%mu_xx, (/ ndim, ndim /)) call create_array_pointer (g%sum_mu_xx, (/ ndim, ndim /)) do i = 1, size (g%div) read (unit = unit) g%mu_x(i) read (unit = unit) g%sum_mu_x(i) do j = 1, size (g%div) read (unit = unit) g%mu_xx(i,j) read (unit = unit) g%sum_mu_xx(i,j) end do end do else if (magic == MAGIC_GRID_EMPTY) then <> else print *, FN, " fatal: expecting magic ", MAGIC_GRID_EMPTY, & " or ", MAGIC_GRID_MU_X, ", found ", magic stop end if read (unit = unit) magic if (magic /= MAGIC_GRID_END) then print *, FN, " fatal: expecting magic ", MAGIC_GRID_END, & " found ", magic stop end if end subroutine read_grid_raw_unit @ %def read_grid_raw_unit @ <>= subroutine write_grid_raw_name (g, name, write_integrals) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", & form = "unformatted", file = name) call write_grid_raw_unit (g, unit, write_integrals) close (unit = unit) end subroutine write_grid_raw_name @ %def write_grid_raw_name @ <>= subroutine read_grid_raw_name (g, name, read_integrals) type(vamp_grid), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", & form = "unformatted", file = name) call read_grid_raw_unit (g, unit, read_integrals) close (unit = unit) end subroutine read_grid_raw_name @ %def read_grid_raw_name @ <>= subroutine write_grids_raw_unit (g, unit, write_integrals) type(vamp_grids), intent(in) :: g integer, intent(in) :: unit logical, intent(in), optional :: write_integrals integer :: i write (unit = unit) MAGIC_GRIDS_BEGIN write (unit = unit) size (g%grids) write (unit = unit) g%sum_integral write (unit = unit) g%sum_weights write (unit = unit) g%sum_chi2 do i = 1, size (g%grids) write (unit = unit) g%weights(i) end do do i = 1, size (g%grids) write (unit = unit) g%num_calls(i) end do do i = 1, size (g%grids) call write_grid_raw_unit (g%grids(i), unit, write_integrals) end do write (unit = unit) MAGIC_GRIDS_END end subroutine write_grids_raw_unit @ %def write_grids_raw_unit @ <>= integer, parameter, private :: MAGIC_GRIDS = 33333333 integer, parameter, private :: MAGIC_GRIDS_BEGIN = MAGIC_GRIDS + 1 integer, parameter, private :: MAGIC_GRIDS_END = MAGIC_GRIDS + 2 @ <>= subroutine read_grids_raw_unit (g, unit, read_integrals) type(vamp_grids), intent(inout) :: g integer, intent(in) :: unit logical, intent(in), optional :: read_integrals character(len=*), parameter :: FN = "vamp_read_grids_raw" integer :: i, nch, magic read (unit = unit) magic if (magic /= MAGIC_GRIDS_BEGIN) then print *, FN, " fatal: expecting magic ", MAGIC_GRIDS_BEGIN, & " found ", magic stop end if read (unit = unit) nch if (associated (g%grids)) then if (size (g%grids) /= nch) then call vamp_delete_grid (g%grids) deallocate (g%grids, g%weights, g%num_calls) allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if else allocate (g%grids(nch), g%weights(nch), g%num_calls(nch)) call vamp_create_empty_grid (g%grids) end if read (unit = unit) g%sum_integral read (unit = unit) g%sum_weights read (unit = unit) g%sum_chi2 do i = 1, nch read (unit = unit) g%weights(i) end do do i = 1, nch read (unit = unit) g%num_calls(i) end do do i = 1, nch call read_grid_raw_unit (g%grids(i), unit, read_integrals) end do read (unit = unit) magic if (magic /= MAGIC_GRIDS_END) then print *, FN, " fatal: expecting magic ", MAGIC_GRIDS_END, & " found ", magic stop end if end subroutine read_grids_raw_unit @ %def read_grids_raw_unit @ <>= subroutine write_grids_raw_name (g, name, write_integrals) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", & form = "unformatted", file = name) call write_grids_raw_unit (g, unit, write_integrals) close (unit = unit) end subroutine write_grids_raw_name @ %def write_grids_raw_name @ <>= subroutine read_grids_raw_name (g, name, read_integrals) type(vamp_grids), intent(inout) :: g character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", & form = "unformatted", file = name) call read_grids_raw_unit (g, unit, read_integrals) close (unit = unit) end subroutine read_grids_raw_name @ %def read_grids_raw_name @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Marshaling} [WK] Note: [[mu_plus]] and [[mu_minus]] not transferred (hard-coded buffer indices)! <>= public :: vamp_marshal_grid_size, vamp_marshal_grid, vamp_unmarshal_grid @ <>= pure subroutine vamp_marshal_grid (g, ibuf, dbuf) type(vamp_grid), intent(in) :: g integer, dimension(:), intent(inout) :: ibuf real(kind=default), dimension(:), intent(inout) :: dbuf integer :: i, iwords, dwords, iidx, didx, ndim ndim = size (g%div) ibuf(1) = g%num_calls ibuf(2) = g%calls_per_cell ibuf(3) = ndim if (g%stratified) then ibuf(4) = 1 else ibuf(4) = 0 end if if (g%all_stratified) then ibuf(5) = 1 else ibuf(5) = 0 end if if (g%quadrupole) then ibuf(6) = 1 else ibuf(6) = 0 end if dbuf(1:2) = g%mu dbuf(3) = g%sum_integral dbuf(4) = g%sum_weights dbuf(5) = g%sum_chi2 dbuf(6) = g%calls dbuf(7) = g%dv2g dbuf(8) = g%jacobi dbuf(9) = g%f_min dbuf(10) = g%f_max dbuf(11) = g%mu_gi dbuf(12) = g%sum_mu_gi ibuf(7:6+ndim) = g%num_div iidx = 7 + ndim didx = 13 do i = 1, ndim call marshal_division_size (g%div(i), iwords, dwords) ibuf(iidx) = iwords ibuf(iidx+1) = dwords iidx = iidx + 2 call marshal_division (g%div(i), ibuf(iidx:iidx-1+iwords), & dbuf(didx:didx-1+dwords)) iidx = iidx + iwords didx = didx + dwords end do if (associated (g%map)) then ibuf(iidx) = 1 dbuf(didx:didx-1+ndim**2) = reshape (g%map, (/ ndim**2 /)) didx = didx + ndim**2 else ibuf(iidx) = 0 end if iidx = iidx + 1 if (associated (g%mu_x)) then ibuf(iidx) = 1 dbuf(didx:didx-1+ndim) = g%mu_x didx = didx + ndim dbuf(didx:didx-1+ndim) = g%sum_mu_x didx = didx + ndim dbuf(didx:didx-1+ndim**2) = reshape (g%mu_xx, (/ ndim**2 /)) didx = didx + ndim**2 dbuf(didx:didx-1+ndim**2) = reshape (g%sum_mu_xx, (/ ndim**2 /)) didx = didx + ndim**2 else ibuf(iidx) = 0 end if iidx = iidx + 1 end subroutine vamp_marshal_grid @ %def vamp_marshal_grid @ <>= pure subroutine vamp_marshal_grid_size (g, iwords, dwords) type(vamp_grid), intent(in) :: g integer, intent(out) :: iwords, dwords integer :: i, ndim, iw, dw ndim = size (g%div) iwords = 6 + ndim dwords = 12 do i = 1, ndim call marshal_division_size (g%div(i), iw, dw) iwords = iwords + 2 + iw dwords = dwords + dw end do iwords = iwords + 1 if (associated (g%map)) then dwords = dwords + ndim**2 end if iwords = iwords + 1 if (associated (g%mu_x)) then dwords = dwords + 2 * (ndim + ndim**2) end if end subroutine vamp_marshal_grid_size @ %def vamp_marshal_grid_size @ <>= pure subroutine vamp_unmarshal_grid (g, ibuf, dbuf) type(vamp_grid), intent(inout) :: g integer, dimension(:), intent(in) :: ibuf real(kind=default), dimension(:), intent(in) :: dbuf integer :: i, iwords, dwords, iidx, didx, ndim g%num_calls = ibuf(1) g%calls_per_cell = ibuf(2) ndim = ibuf(3) g%stratified = ibuf(4) /= 0 g%all_stratified = ibuf(5) /= 0 g%quadrupole = ibuf(6) /= 0 g%mu = dbuf(1:2) g%sum_integral = dbuf(3) g%sum_weights = dbuf(4) g%sum_chi2 = dbuf(5) g%calls = dbuf(6) g%dv2g = dbuf(7) g%jacobi = dbuf(8) g%f_min = dbuf(9) g%f_max = dbuf(10) g%mu_gi = dbuf(11) g%sum_mu_gi = dbuf(12) call copy_array_pointer (g%num_div, ibuf(7:6+ndim)) <> iidx = 7 + ndim didx = 13 do i = 1, ndim iwords = ibuf(iidx) dwords = ibuf(iidx+1) iidx = iidx + 2 call unmarshal_division (g%div(i), ibuf(iidx:iidx-1+iwords), & dbuf(didx:didx-1+dwords)) iidx = iidx + iwords didx = didx + dwords end do if (ibuf(iidx) > 0) then call copy_array_pointer & (g%map, reshape (dbuf(didx:didx-1+ibuf(iidx)), (/ ndim, ndim /))) didx = didx + ibuf(iidx) else <> end if iidx = iidx + 1 if (ibuf(iidx) > 0) then call copy_array_pointer (g%mu_x, dbuf(didx:didx-1+ndim)) didx = didx + ndim call copy_array_pointer (g%sum_mu_x, dbuf(didx:didx-1+ndim)) didx = didx + ndim call copy_array_pointer & (g%mu_xx, reshape (dbuf(didx:didx-1+ndim**2), (/ ndim, ndim /))) didx = didx + ndim**2 call copy_array_pointer & (g%sum_mu_xx, reshape (dbuf(didx:didx-1+ndim**2), (/ ndim, ndim /))) didx = didx + ndim**2 else <> end if iidx = iidx + 1 end subroutine vamp_unmarshal_grid @ %def vamp_unmarshal_grid @ <>= public :: vamp_marshal_history_size, vamp_marshal_history public :: vamp_unmarshal_history @ <>= pure subroutine vamp_marshal_history (h, ibuf, dbuf) type(vamp_history), intent(in) :: h integer, dimension(:), intent(inout) :: ibuf real(kind=default), dimension(:), intent(inout) :: dbuf integer :: j, ndim, iidx, didx, iwords, dwords if (h%verbose .and. (associated (h%div))) then ndim = size (h%div) else ndim = 0 end if ibuf(1) = ndim ibuf(2) = h%calls if (h%stratified) then ibuf(3) = 1 else ibuf(3) = 0 end if dbuf(1) = h%integral dbuf(2) = h%std_dev dbuf(3) = h%avg_integral dbuf(4) = h%avg_std_dev dbuf(5) = h%avg_chi2 dbuf(6) = h%f_min dbuf(7) = h%f_max iidx = 4 didx = 8 do j = 1, ndim call marshal_div_history_size (h%div(j), iwords, dwords) ibuf(iidx) = iwords ibuf(iidx+1) = dwords iidx = iidx + 2 call marshal_div_history (h%div(j), ibuf(iidx:iidx-1+iwords), & dbuf(didx:didx-1+dwords)) iidx = iidx + iwords didx = didx + dwords end do end subroutine vamp_marshal_history @ %def vamp_marshal_history @ <>= pure subroutine vamp_marshal_history_size (h, iwords, dwords) type(vamp_history), intent(in) :: h integer, intent(out) :: iwords, dwords integer :: i, ndim, iw, dw if (h%verbose .and. (associated (h%div))) then ndim = size (h%div) else ndim = 0 end if iwords = 3 dwords = 7 do i = 1, ndim call marshal_div_history_size (h%div(i), iw, dw) iwords = iwords + 2 + iw dwords = dwords + dw end do end subroutine vamp_marshal_history_size @ %def vamp_marshal_history_size @ <>= pure subroutine vamp_unmarshal_history (h, ibuf, dbuf) type(vamp_history), intent(inout) :: h integer, dimension(:), intent(in) :: ibuf real(kind=default), dimension(:), intent(in) :: dbuf integer :: j, ndim, iidx, didx, iwords, dwords ndim = ibuf(1) h%calls = ibuf(2) h%stratified = ibuf(3) /= 0 h%integral = dbuf(1) h%std_dev = dbuf(2) h%avg_integral = dbuf(3) h%avg_std_dev = dbuf(4) h%avg_chi2 = dbuf(5) h%f_min = dbuf(6) h%f_max = dbuf(7) if (ndim > 0) then if (associated (h%div)) then if (size (h%div) /= ndim) then deallocate (h%div) allocate (h%div(ndim)) end if else allocate (h%div(ndim)) end if iidx = 4 didx = 8 do j = 1, ndim iwords = ibuf(iidx) dwords = ibuf(iidx+1) iidx = iidx + 2 call unmarshal_div_history (h%div(j), ibuf(iidx:iidx-1+iwords), & dbuf(didx:didx-1+dwords)) iidx = iidx + iwords didx = didx + dwords end do end if end subroutine vamp_unmarshal_history @ %def vamp_unmarshal_history @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Boring Copying and Deleting of Objects} <>= elemental subroutine vamp_copy_grid (lhs, rhs) type(vamp_grid), intent(inout) :: lhs type(vamp_grid), intent(in) :: rhs integer :: ndim ndim = size (rhs%div) lhs%mu = rhs%mu lhs%mu_plus = rhs%mu_plus lhs%mu_minus = rhs%mu_minus lhs%sum_integral = rhs%sum_integral lhs%sum_weights = rhs%sum_weights lhs%sum_chi2 = rhs%sum_chi2 lhs%calls = rhs%calls lhs%num_calls = rhs%num_calls call copy_array_pointer (lhs%num_div, rhs%num_div) lhs%dv2g = rhs%dv2g lhs%jacobi = rhs%jacobi lhs%f_min = rhs%f_min lhs%f_max = rhs%f_max lhs%mu_gi = rhs%mu_gi lhs%sum_mu_gi = rhs%sum_mu_gi lhs%calls_per_cell = rhs%calls_per_cell lhs%stratified = rhs%stratified lhs%all_stratified = rhs%all_stratified lhs%quadrupole = rhs%quadrupole if (associated (lhs%div)) then if (size (lhs%div) /= ndim) then call delete_division (lhs%div) deallocate (lhs%div) allocate (lhs%div(ndim)) end if else allocate (lhs%div(ndim)) end if call copy_division (lhs%div, rhs%div) if (associated (rhs%map)) then call copy_array_pointer (lhs%map, rhs%map) else if (associated (lhs%map)) then deallocate (lhs%map) end if if (associated (rhs%mu_x)) then call copy_array_pointer (lhs%mu_x, rhs%mu_x) call copy_array_pointer (lhs%mu_xx, rhs%mu_xx) call copy_array_pointer (lhs%sum_mu_x, rhs%sum_mu_x) call copy_array_pointer (lhs%sum_mu_xx, rhs%sum_mu_xx) else if (associated (lhs%mu_x)) then deallocate (lhs%mu_x, lhs%mu_xx, lhs%sum_mu_x, lhs%sum_mu_xx) end if end subroutine vamp_copy_grid @ %def vamp_copy_grid @ <>= elemental subroutine vamp_delete_grid (g) type(vamp_grid), intent(inout) :: g if (associated (g%div)) then call delete_division (g%div) deallocate (g%div, g%num_div) end if if (associated (g%map)) then deallocate (g%map) end if if (associated (g%mu_x)) then deallocate (g%mu_x, g%mu_xx, g%sum_mu_x, g%sum_mu_xx) end if end subroutine vamp_delete_grid @ %def vamp_delete_grid @ <>= elemental subroutine vamp_copy_grids (lhs, rhs) type(vamp_grids), intent(inout) :: lhs type(vamp_grids), intent(in) :: rhs integer :: nch nch = size (rhs%grids) lhs%sum_integral = rhs%sum_integral lhs%sum_chi2 = rhs%sum_chi2 lhs%sum_weights = rhs%sum_weights if (associated (lhs%grids)) then if (size (lhs%grids) /= nch) then deallocate (lhs%grids) allocate (lhs%grids(nch)) call vamp_create_empty_grid (lhs%grids(nch)) end if else allocate (lhs%grids(nch)) call vamp_create_empty_grid (lhs%grids(nch)) end if call vamp_copy_grid (lhs%grids, rhs%grids) call copy_array_pointer (lhs%weights, rhs%weights) call copy_array_pointer (lhs%num_calls, rhs%num_calls) end subroutine vamp_copy_grids @ %def vamp_copy_grids @ <>= elemental subroutine vamp_delete_grids (g) type(vamp_grids), intent(inout) :: g if (associated (g%grids)) then call vamp_delete_grid (g%grids) deallocate (g%weights, g%grids, g%num_calls) end if end subroutine vamp_delete_grids @ %def vamp_delete_grids @ <>= elemental subroutine vamp_copy_history (lhs, rhs) type(vamp_history), intent(inout) :: lhs type(vamp_history), intent(in) :: rhs lhs%calls = rhs%calls lhs%stratified = rhs%stratified lhs%verbose = rhs%verbose lhs%integral = rhs%integral lhs%std_dev = rhs%std_dev lhs%avg_integral = rhs%avg_integral lhs%avg_std_dev = rhs%avg_std_dev lhs%avg_chi2 = rhs%avg_chi2 lhs%f_min = rhs%f_min lhs%f_max = rhs%f_max if (rhs%verbose) then if (associated (lhs%div)) then if (size (lhs%div) /= size (rhs%div)) then deallocate (lhs%div) allocate (lhs%div(size(rhs%div))) end if else allocate (lhs%div(size(rhs%div))) end if call copy_history (lhs%div, rhs%div) end if end subroutine vamp_copy_history @ %def vamp_copy_history @ <>= elemental subroutine vamp_delete_history (h) type(vamp_history), intent(inout) :: h if (associated (h%div)) then deallocate (h%div) end if end subroutine vamp_delete_history @ %def vamp_delete_history @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/divisions.nw =================================================================== --- trunk/vamp/src/divisions.nw (revision 8914) +++ trunk/vamp/src/divisions.nw (revision 8915) @@ -1,1674 +1,1674 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP divisions code as NOWEB source @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Implementation} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The Abstract Datatype \texttt{division}} <<[[divisions.f90]]>>= ! divisions.f90 -- <> module divisions use kinds use exceptions use vamp_stat use utils use iso_fortran_env implicit none private <> <> <> <> <> contains <> end module divisions @ \begin{dubious} [[vamp_apply_equivalences]] from [[vamp]] accesses [[%variance]] \ldots \end{dubious} <>= type, public :: division_t ! private !!! Avoiding a g95 bug real(kind=default), dimension(:), pointer :: x => null () real(kind=default), dimension(:), pointer :: integral => null () real(kind=default), dimension(:), pointer & :: variance => null () ! public :: variance => null () ! real(kind=default), dimension(:), pointer :: efficiency => null () real(kind=default) :: x_min, x_max real(kind=default) :: x_min_true, x_max_true real(kind=default) :: dx, dxg integer :: ng = 0 logical :: stratified = .true. end type division_t @ %def division_t @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Creation, Manipulation \&\ Injection} <>= public :: create_division, create_empty_division public :: copy_division, delete_division public :: set_rigid_division, reshape_division @ <>= elemental subroutine create_division & (d, x_min, x_max, x_min_true, x_max_true) type(division_t), intent(out) :: d real(kind=default), intent(in) :: x_min, x_max real(kind=default), intent(in), optional :: x_min_true, x_max_true allocate (d%x(0:1), d%integral(1), d%variance(1)) ! allocate (d%efficiency(1)) d%x(0) = 0.0 d%x(1) = 1.0 d%x_min = x_min d%x_max = x_max d%dx = d%x_max - d%x_min d%stratified = .false. d%ng = 1 d%dxg = 1.0 / d%ng if (present (x_min_true)) then d%x_min_true = x_min_true else d%x_min_true = x_min end if if (present (x_max_true)) then d%x_max_true = x_max_true else d%x_max_true = x_max end if end subroutine create_division @ %def create_division @ <>= elemental subroutine create_empty_division (d) type(division_t), intent(out) :: d nullify (d%x, d%integral, d%variance) ! nullify (d%efficiency) end subroutine create_empty_division @ %def create_empty_division @ <>= elemental subroutine set_rigid_division (d, ng) type(division_t), intent(inout) :: d integer, intent(in) :: ng d%stratified = ng > 1 d%ng = ng d%dxg = real (ubound (d%x, dim=1), kind=default) / d%ng end subroutine set_rigid_division @ %def set_rigid_division @ \begin{equation} - [[dxg]] = \frac{n_{\text{div}}}{n_g} + \text{[[dxg]]} = \frac{n_{\text{div}}}{n_g} \end{equation} -such that $0 < [[cell]]\cdot[[dxg]] < n_{\text{div}}$ +such that $0 < \text{[[cell]]}\cdot\text{[[dxg]]} < n_{\text{div}}$ <>= elemental subroutine reshape_division (d, max_num_div, ng, use_variance) type(division_t), intent(inout) :: d integer, intent(in) :: max_num_div integer, intent(in), optional :: ng logical, intent(in), optional :: use_variance real(kind=default), dimension(:), allocatable :: old_x, m integer :: num_div, equ_per_adap if (present (ng)) then if (max_num_div > 1) then d%stratified = ng > 1 else d%stratified = .false. end if else d%stratified = .false. end if if (d%stratified) then d%ng = ng <> else num_div = max_num_div d%ng = 1 end if d%dxg = real (num_div, kind=default) / d%ng allocate (old_x(0:ubound(d%x,dim=1)), m(ubound(d%x,dim=1))) old_x = d%x <> <> d%x = rebin (m, old_x, num_div) deallocate (old_x, m) end subroutine reshape_division @ %def reshape_division @ <>= if (present (use_variance)) then if (use_variance) then m = rebinning_weights (d%variance) else m = 1.0 end if else m = 1.0 end if @ %def m @ <>= if (ubound (d%x, dim=1) /= num_div) then deallocate (d%x, d%integral, d%variance) ! deallocate (d%efficiency) allocate (d%x(0:num_div), d%integral(num_div), d%variance(num_div)) ! allocate (d%efficiency(num_div)) end if @ \begin{empcmds} vardef layout = pair ul, ur, ll, lr; ypart (ul) = ypart (ur); ypart (ll) = ypart (lr); xpart (ul) = xpart (ll); xpart (ur) = xpart (lr); numeric weight_width, weight_dist; weight_width = 0.1w; weight_dist = 0.05w; ll = (.1w,.1w); ur = (w-weight_width-weight_dist,h-weight_width-weight_dist); numeric equ_div, adap_div, rx, ry, rxp, rxm, ryp, rym; equ_div = 3; adap_div = 8; rx = 5.2; ry = 3.6; rxp = ceiling rx; rxm = floor rx; ryp = ceiling ry; rym = floor ry; numeric pi; pi = 180; vardef adap_fct_x (expr x) = (x + sind(2*x*pi)/8) enddef; vardef weight_x (expr x) = (1 + 2*sind(1*x*pi)**2) / 3 enddef; vardef adap_fct_y (expr x) = (x + sind(4*x*pi)/16) enddef; vardef weight_y (expr x) = (1 + 2*sind(2*x*pi)**2) / 3 enddef; vardef grid_pos (expr i, j) = (adap_fct_y(j/adap_div))[(adap_fct_x(i/adap_div))[ll,lr], (adap_fct_x(i/adap_div))[ul,ur]] enddef; vardef grid_square (expr i, j) = grid_pos (i,j) -- grid_pos (i+1,j) -- grid_pos (i+1,j+1) -- grid_pos (i,j+1) -- cycle enddef; enddef; vardef decoration = fill (lr shifted (weight_y(0)*(weight_width,0)) for y = .1 step .1 until 1.01: .. y[lr,ur] shifted (weight_y(y)*(weight_width,0)) endfor -- ur -- lr -- cycle) shifted (weight_dist,0) withcolor 0.7white; fill (ul shifted (weight_x(0)*(0,weight_width)) for x = .1 step .1 until 1.01: .. x[ul,ur] shifted (weight_x(x)*(0,weight_width)) endfor -- ur -- ul -- cycle) shifted (0,weight_dist) withcolor 0.7white; picture px, py; px = btex $p_1(x_1)$ etex; py = btex $p_2(x_2)$ etex; label.top (image (unfill bbox px; draw px), .5[ul,ur] shifted (0,weight_dist)); label.rt (image (unfill bbox py; draw py), .75[lr,ur] shifted (weight_dist,0)); label.lrt (btex \texttt{domain(1,1)} etex, ll); label.bot (btex $x_1$ etex, .5[ll,lr]); label.llft (btex \texttt{domain(2,1)} etex, lr); label.ulft (btex \texttt{domain(1,2)} etex, ll); label.lft (btex $x_2$ etex, .5[ll,ul]); label.llft (btex \texttt{domain(2,2)} etex, ul); enddef; \end{empcmds} \begin{figure} \begin{center} \begin{emp}(90,70) layout; fill grid_square (rxm,rym) withcolor 0.7white; pickup pencircle scaled .7pt; for i = 0 upto adap_div: draw grid_pos(i,0) -- grid_pos(i,adap_div); draw grid_pos(0,i) -- grid_pos(adap_div,i); endfor pickup pencircle scaled 2pt; drawdot grid_pos(rx,ry); decoration; \end{emp} \end{center} \caption{\label{fig:nonstrat}% \texttt{vegas} grid structure for non-stratified sampling. N.B.: the grid and the weight functions~$p_{1,2}$ are only in qualitative agreement.} \end{figure} \begin{figure} \begin{center} \begin{emp}(90,70) layout; vardef grid_sub_pos (expr i, di, j, dj) = (dj/equ_div)[(di/equ_div)[grid_pos(i,j),grid_pos(i+1,j)], (di/equ_div)[grid_pos(i,j+1),grid_pos(i+1,j+1)]] enddef; vardef grid_sub_square (expr i, di, j, dj) = grid_sub_pos (i,di,j,dj) -- grid_sub_pos (i,di+1,j,dj) -- grid_sub_pos (i,di+1,j,dj+1) -- grid_sub_pos (i,di,j,dj+1) -- cycle enddef; fill grid_square (rxm,rym) withcolor 0.8white; fill grid_sub_square (rxm,0,rym,1) withcolor 0.6white; pickup pencircle scaled .7pt; for i = 0 upto adap_div: draw grid_pos(i,0) -- grid_pos(i,adap_div); draw grid_pos(0,i) -- grid_pos(adap_div,i); endfor pickup pencircle scaled .5pt; for i = 0 upto (adap_div-1): for j = 1 upto (equ_div-1): draw grid_sub_pos(i,j,0,0) -- grid_sub_pos(i,j,adap_div,0) dashed evenly; draw grid_sub_pos(0,0,i,j) -- grid_sub_pos(adap_div,0,i,j) dashed evenly; endfor endfor pickup pencircle scaled 2pt; drawdot grid_pos(rx,ry); decoration; \end{emp} \end{center} \caption{\label{fig:strat}% \texttt{vegas} grid structure for genuinely stratified sampling, which is used in low dimensions. N.B.: the grid and the weight functions~$p_{1,2}$ are only in qualitative agreement.} \end{figure} Genuinely stratified sampling will superimpose an equidistant grid on the adaptive grid, as shown in figure~\ref{fig:strat}. \begin{table} \begin{center} \begin{tabular}{c|c} $n_{\text{dim}}$ & $N_{\text{calls}}^{\max}(n_g=25)$\\\hline 2 & $1\cdot10^{3}$ \\ 3 & $3\cdot10^{4}$ \\ 4 & $8\cdot10^{5}$ \\ 5 & $2\cdot10^{7}$ \\ 6 & $5\cdot10^{8}$ \end{tabular} \end{center} \caption{\label{tab:dimen}% To stratify or not to stratify.} \end{table} Obviously, this is only possible when the number of cells of the stratification grid is large enough, specifically when $n_g \ge n_{\text{div}}^{\min} = n_{\text{div}}^{\max}/2 = 25$). This condition can be met by a high number of sampling points or by a low dimensionality of the integration region (cf.~table~\ref{tab:dimen}).\par @ For a low number of sampling points and high dimensions, genuinely stratified sampling is impossible, because we would have to reduce the number~$n_{\text{div}}$ of adaptive divisions too far. Instead, we keep [[stratified]] false which will tell the integration routine not to concentrate the grid in the regions where the contribution to the error is largest, but to use importance sampling, i.\,e.~concentrating the grid in the regions where the contribution to the value is largest.\par In this case, the rigid grid is much coarser than the adaptive grid and furthermore, the boundaries of the cells overlap in general. The interplay of the two grids during the sampling process is shown in figure~\ref{fig:grids}.\par @ First we determine the (integer) number~$k$ of equidistant divisions of an adaptive cell for at most~$n_{\text{div}}^{\max}$ divisions of the adaptive grid \begin{subequations} \begin{equation} k = \left\lfloor \frac{n_g}{n_{\text{div}}^{\max}} \right\rfloor + 1 \end{equation} and the corresponding number~$n_{\text{div}}$ of adaptive divisions \begin{equation} n_{\text{div}} = \left\lfloor \frac{n_g}{k} \right\rfloor \end{equation} Finally, adjust~$n_g$ to an exact multiple of~$n_{\text{div}}$ \begin{equation} n_g = k \cdot n_{\text{div}} \end{equation} \end{subequations} <>= if (d%ng >= max_num_div / 2) then d%stratified = .true. equ_per_adap = d%ng / max_num_div + 1 num_div = d%ng / equ_per_adap if (num_div < 2) then d%stratified = .false. num_div = 2 d%ng = 1 else if (mod (num_div,2) == 1) then num_div = num_div - 1 d%ng = equ_per_adap * num_div else d%ng = equ_per_adap * num_div end if else d%stratified = .false. num_div = max_num_div d%ng = 1 end if @ %def num_div ng @ Figure~\ref{fig:grids} on page~\pageref{fig:grids} is a one-dimensional illustration of the sampling algorithm. In each cell of the rigid equidistant grid, two random points are selected (or $N_{\text{calls}}$ in the not stratified case). For each point, the corresponding cell and relative coordinate in the adaptive grid is found, \emph{as if the adaptive grid was equidistant} (upper arrow). Then this point is mapped according to the adapted grid (lower arrow) and the proper Jacobians are applied to the weight. \begin{equation} \prod_{j=1}^n \,(x^j_i-x^j_{i-1}) \cdot N^n = \text{Vol}(\text{cell}') \cdot \frac{1}{\text{Vol}(\text{cell})} = \frac{1}{p(x^j_i)} \end{equation} \begin{figure} \begin{center} \begin{emp}(120,30) pseudo (.3w, .8w, .1h, .8h, 0, 8, 8, 0, 12, 12, 5.2, true, true); \end{emp} \end{center} \caption{\label{fig:grids}% One-dimensional illustration of the \texttt{vegas} grid structure for pseudo stratified sampling, which is used in high dimensions.} \end{figure} <>= public :: inject_division, inject_division_short @ %def inject_division inject_division_short @ <>= elemental subroutine inject_division (d, r, cell, x, x_mid, idx, wgt) type(division_t), intent(in) :: d real(kind=default), intent(in) :: r integer, intent(in) :: cell real(kind=default), intent(out) :: x, x_mid integer, intent(out) :: idx real(kind=default), intent(out) :: wgt real(kind=default) :: delta_x, xi integer :: i xi = (cell - r) * d%dxg + 1.0 <> idx = i x_mid = d%x_min + 0.5 * (d%x(i-1) + d%x(i)) * d%dx end subroutine inject_division @ %def inject_division @ <>= i = max (min (int (xi), ubound (d%x, dim=1)), 1) delta_x = d%x(i) - d%x(i-1) x = d%x_min + (d%x(i-1) + (xi - i) * delta_x) * d%dx wgt = delta_x * ubound (d%x, dim=1) @ <>= elemental subroutine inject_division_short (d, r, x, idx, wgt) type(division_t), intent(in) :: d real(kind=default), intent(in) :: r integer, intent(out) :: idx real(kind=default), intent(out) :: x, wgt real(kind=default) :: delta_x, xi integer :: i xi = r * ubound (d%x, dim=1) + 1.0 <> idx = i end subroutine inject_division_short @ %def inject_division_short @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Grid Refinement} <>= public :: record_integral, record_variance, clear_integral_and_variance ! public :: record_efficiency @ <>= elemental subroutine record_integral (d, i, f) type(division_t), intent(inout) :: d integer, intent(in) :: i real(kind=default), intent(in) :: f d%integral(i) = d%integral(i) + f if (.not. d%stratified) then d%variance(i) = d%variance(i) + f*f end if end subroutine record_integral @ %def record_integral @ <>= elemental subroutine record_variance (d, i, var_f) type(division_t), intent(inout) :: d integer, intent(in) :: i real(kind=default), intent(in) :: var_f if (d%stratified) then d%variance(i) = d%variance(i) + var_f end if end subroutine record_variance @ %def record_variance @ <>= elemental subroutine record_efficiency (d, i, eff) type(division_t), intent(inout) :: d integer, intent(in) :: i real(kind=default), intent(in) :: eff ! d%efficiency(i) = d%efficiency(i) + eff end subroutine record_efficiency @ %def record_efficiency @ <>= elemental subroutine clear_integral_and_variance (d) type(division_t), intent(inout) :: d d%integral = 0.0 d%variance = 0.0 ! d%efficiency = 0.0 end subroutine clear_integral_and_variance @ %def clear_integral_and_variance @ <>= public :: refine_division @ <>= elemental subroutine refine_division (d) type(division_t), intent(inout) :: d character(len=*), parameter :: FN = "refine_division" d%x = rebin (rebinning_weights (d%variance), d%x, size (d%variance)) end subroutine refine_division @ %def refine_division @ Smooth the $d_i = \bar f_i \Delta x_i$ \begin{equation} \begin{aligned} d_1 &\to \frac{1}{2}(d_1+d_2) \\ d_2 &\to \frac{1}{3}(d_1+d_2+d_3) \\ &\ldots\\ d_{n-1} &\to \frac{1}{3}(d_{n-2}+d_{n-1}+d_n) \\ d_n &\to \frac{1}{2}(d_{n-1}+d_n) \end{aligned} \end{equation} -As long as the initial $[[num_div]] \ge 6$, -we know that $[[num_div]] \ge 3$. +As long as the initial $\text{[[num_div]]} \ge 6$, +we know that $\text{[[num_div]]} \ge 3$. @ <>= integer, private, parameter :: MIN_NUM_DIV = 3 @ %def MIN_NUM_DIV @ Here the \texttt{Fortran90} array notation really shines, but we have to handle the cases $\text{[[nd]]}\le2$ specially, because the [[quadrupole]] option can lead to small [[nd]]s. The equivalent \texttt{Fortran77} code~\cite{Lepage:1980:vegas} is orders of magnitude less obvious~\footnote{Some old timers call this a feature, however.} Also protect against vanishing~$d_i$ that will blow up the logarithm. \begin{equation} m_i = \left( \frac{\frac{\bar f_i \Delta x_i}{\sum_j\bar f_j \Delta x_j}-1} {\ln\left(\frac{\bar f_i \Delta x_i}{\sum_j\bar f_j \Delta x_j}\right)} \right)^\alpha \end{equation} <>= pure function rebinning_weights (d) result (m) real(kind=default), dimension(:), intent(in) :: d real(kind=default), dimension(size(d)) :: m real(kind=default), dimension(size(d)) :: smooth_d real(kind=default), parameter :: ALPHA = 1.5 integer :: nd <> nd = size (d) if (nd > 2) then smooth_d(1) = (d(1) + d(2)) / 2.0 smooth_d(2:nd-1) = (d(1:nd-2) + d(2:nd-1) + d(3:nd)) / 3.0 smooth_d(nd) = (d(nd-1) + d(nd)) / 2.0 else smooth_d = d end if if (all (smooth_d < tiny (1.0_default))) then m = 1.0_default else smooth_d = smooth_d / sum (smooth_d) where (smooth_d < tiny (1.0_default)) smooth_d = tiny (1.0_default) end where where (smooth_d /= 1._default) m = ((smooth_d - 1.0) / (log (smooth_d)))**ALPHA elsewhere m = 1.0_default endwhere end if end function rebinning_weights @ %def rebinning_weights @ <>= private :: rebinning_weights @ \begin{dubious} \index{system dependencies} \index{IEEE hacks} The [[NaN]] test is probably not portable: \end{dubious} <>= if (any (d /= d)) then m = 1.0 return end if @ Take a binning~[[x]] and return a new binning with [[num_div]] bins with the [[m]] homogeneously distributed: <>= pure function rebin (m, x, num_div) result (x_new) real(kind=default), dimension(:), intent(in) :: m real(kind=default), dimension(0:), intent(in) :: x integer, intent(in) :: num_div real(kind=default), dimension(0:num_div) :: x_new integer :: i, k real(kind=default) :: step, delta step = sum (m) / num_div k = 0 delta = 0.0 x_new(0) = x(0) do i = 1, num_div - 1 <> <> end do x_new(num_div) = 1.0 end function rebin @ %def rebin @ %def k delta x_new @ <>= private :: rebin @ \begin{figure} \begin{center} \begin{empgraph}(70,30) randomseed := 720.251; pickup pencircle scaled 0.7pt; path m[], g[]; numeric pi; pi = 180; numeric dx; dx = 0.05; numeric dg; dg = -0.04; vardef adap_fct (expr x) = (x + sind(4*x*pi)/16) enddef; autogrid (,); frame.bot; setrange (0, 0, 1, 1.2); for x = 0 step dx until 1+dx/2: numeric r; r = 1 + normaldeviate/10; augment.m[x] (adap_fct (x), r); augment.m[x] (adap_fct (x+dx), r); augment.m[x] (adap_fct (x+dx), 0); augment.m[x] (adap_fct (x), 0); augment.g[x] (adap_fct (x), 0); augment.g[x] (adap_fct (x), dg); endfor for x = 0 step dx until 1-dx/2: gfill m[x] -- cycle withcolor 0.7white; gdraw m[x] -- cycle; endfor for x = 0 step dx until 1+dx/2: gdraw g[x]; endfor glabel.bot (btex $x_0$ etex, (adap_fct (0*dx), dg)); glabel.bot (btex $x_1$ etex, (adap_fct (1*dx), dg)); glabel.bot (btex $x_2$ etex, (adap_fct (2*dx), dg)); glabel.bot (btex $x_{n-1}$ etex, (adap_fct (1-dx), dg)); glabel.bot (btex $x_n$ etex, (adap_fct (1), dg)); glabel.lft (btex $\displaystyle \bar f_i\approx\frac{m_i}{\Delta x_i}$ etex, OUT); \end{empgraph} \end{center} \caption{\label{fig:rebin}% Typical weights used in the rebinning algorithm.} \end{figure} We increment~$k$ until another $\Delta$ (a.\,k.\,a.~[[step]]) of the integral has been accumulated (cf.~figure~\ref{fig:rebin}). The mismatch will be corrected below. <>= do if (step <= delta) then exit end if k = k + 1 delta = delta + m(k) end do delta = delta - step @ %def k delta @ <>= x_new(i) = x(k) - (x(k) - x(k-1)) * delta / m(k) @ %def x_new @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Probability Density} <>= public :: probability @ \begin{equation} \xi = \frac{x-x_{\min}}{x_{\max}-x_{\min}} \in [0,1] \end{equation} and \begin{equation} \int_{x_{\min}}^{x_{\max}}\!\textrm{d}x\; p(x) = 1 \end{equation} <>= elemental function probability (d, x) result (p) type(division_t), intent(in) :: d real(kind=default), intent(in) :: x real(kind=default) :: p real(kind=default) :: xi integer :: hi, mid, lo xi = (x - d%x_min) / d%dx if ((xi >= 0) .and. (xi <= 1)) then lo = lbound (d%x, dim=1) hi = ubound (d%x, dim=1) bracket: do if (lo >= hi - 1) then p = 1.0 / (ubound (d%x, dim=1) * d%dx * (d%x(hi) - d%x(hi-1))) return end if mid = (hi + lo) / 2 if (xi > d%x(mid)) then lo = mid else hi = mid end if end do bracket else p = 0 end if end function probability @ %def probability @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Quadrupole} <>= public :: quadrupole_division @ <>= elemental function quadrupole_division (d) result (q) type(division_t), intent(in) :: d real(kind=default) :: q !!! q = value_spread_percent (rebinning_weights (d%variance)) q = standard_deviation_percent (rebinning_weights (d%variance)) end function quadrupole_division @ %def quadrupole_division @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Forking and Joining} The goal is to split a division in such a way, that we can later sample the pieces separately and combine the results. <>= public :: fork_division, join_division, sum_division @ \begin{dubious} - Caveat emptor: splitting divisions can lead to $[[num_div]]<3$ and + Caveat emptor: splitting divisions can lead to $\text{[[num_div]]}<3$ and the application \emph{must not} try to refine such grids before merging them again! \end{dubious} <>= pure subroutine fork_division (d, ds, sum_calls, num_calls, exc) type(division_t), intent(in) :: d type(division_t), dimension(:), intent(inout) :: ds integer, intent(in) :: sum_calls integer, dimension(:), intent(inout) :: num_calls type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "fork_division" integer, dimension(size(ds)) :: n0, n1 integer, dimension(0:size(ds)) :: n, ds_ng integer :: i, j, num_div, num_forks, nx real(kind=default), dimension(:), allocatable :: d_x, d_integral, d_variance ! real(kind=default), dimension(:), allocatable :: d_efficiency num_div = ubound (d%x, dim=1) num_forks = size (ds) if (d%ng == 1) then <> else if (num_div >= num_forks) then if (modulo (d%ng, num_div) == 0) then <> else <> end if else if (present (exc)) then call raise_exception (exc, EXC_FATAL, FN, "internal error") end if num_calls = 0 end if end subroutine fork_division @ %def fork_division @ <>= pure subroutine join_division (d, ds, exc) type(division_t), intent(inout) :: d type(division_t), dimension(:), intent(in) :: ds type(exception), intent(inout), optional :: exc character(len=*), parameter :: FN = "join_division" integer, dimension(size(ds)) :: n0, n1 integer, dimension(0:size(ds)) :: n, ds_ng integer :: i, j, num_div, num_forks, nx real(kind=default), dimension(:), allocatable :: d_x, d_integral, d_variance ! real(kind=default), dimension(:), allocatable :: d_efficiency num_div = ubound (d%x, dim=1) num_forks = size (ds) if (d%ng == 1) then <> else if (num_div >= num_forks) then if (modulo (d%ng, num_div) == 0) then <> else <> end if else if (present (exc)) then call raise_exception (exc, EXC_FATAL, FN, "internal error") end if end if end subroutine join_division @ %def join_division @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Importance Sampling} Importance sampling ([[d%ng == 1]]) is trivial, since we can just sample [[size(ds)]] copies of the same grid with (almost) the same number of points <>= if (d%stratified) then call raise_exception (exc, EXC_FATAL, FN, & "ng == 1 incompatiple w/ stratification") else call copy_division (ds, d) num_calls(2:) = ceiling (real (sum_calls) / num_forks) num_calls(1) = sum_calls - sum (num_calls(2:)) end if @ and sum up the results in the end: <>= call sum_division (d, ds) @ Note, however, that this is only legitimate as long as [[d%ng == 1]] implies [[d%stratified == .false.]], because otherwise the sampling code would be incorrect (cf.~[[var_f]] on page~\pageref{pg:var_f}). @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Stratified Sampling} For stratified sampling, we have to work a little harder, because there are just two points per cell and we have to slice along the lines of the stratification grid. Actually, we are slicing along the adaptive grid, since it has a reasonable size. Slicing along the stratification grid could be done using the method below. However, in this case \emph{very} large adaptive grids would be shipped from one process to the other and the comunication costs will outweigh the gains fom paralell processing. <>= n = (num_div * (/ (j, j=0,num_forks) /)) / num_forks n0(1:num_forks) = n(0:num_forks-1) n1(1:num_forks) = n(1:num_forks) @ <>= <> do i = 1, num_forks call copy_array_pointer (ds(i)%x, d%x(n0(i):n1(i)), lb = 0) call copy_array_pointer (ds(i)%integral, d%integral(n0(i)+1:n1(i))) call copy_array_pointer (ds(i)%variance, d%variance(n0(i)+1:n1(i))) ! call copy_array_pointer (ds(i)%efficiency, d%efficiency(n0(i)+1:n1(i))) ds(i)%x = (ds(i)%x - ds(i)%x(0)) / (d%x(n1(i)) - d%x(n0(i))) end do ds%x_min = d%x_min + d%dx * d%x(n0) ds%x_max = d%x_min + d%dx * d%x(n1) ds%dx = ds%x_max - ds%x_min ds%x_min_true = d%x_min_true ds%x_max_true = d%x_max_true ds%stratified = d%stratified ds%ng = (d%ng * (n1 - n0)) / num_div num_calls = sum_calls !: this is a misnomer, it remains ``calls per cell'' here ds%dxg = real (n1 - n0, kind=default) / ds%ng @ Joining is the exact inverse, but we're only interested in [[d%integral]] and [[d%variance]] for the grid refinement: <>= <> do i = 1, num_forks d%integral(n0(i)+1:n1(i)) = ds(i)%integral d%variance(n0(i)+1:n1(i)) = ds(i)%variance ! d%efficiency(n0(i)+1:n1(i)) = ds(i)%efficiency end do @ @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Pseudo Stratified Sampling} \begin{figure} \begin{center} \begin{emp}(120,90) pseudo (.3w, .8w, .7h, .9h, 0, 8, 8, 0, 12, 12, 5.2, true, true); % lcm (lcm (3, 8) / 3, 12) pseudo (.3w, .8w, .4h, .6h, 0, 8, 8, 0, 24, 24, 5.2*2, false, true); % forks pseudo (.2w, .7w, .1h, .3h, 0, 2, 8, 0, 6, 24, 5.2*2, false, false); pseudo (.3w, .8w, .1h, .3h, 2, 5, 8, 6, 15, 24, 5.2*2, false, true); pseudo (.4w, .9w, .1h, .3h, 5, 8, 8, 15, 24, 24, 5.2*2, false, false); label.urt (btex \texttt{ds(1)} etex, (.2w, 0)); label.top (btex \texttt{ds(2)} etex, (.5w, 0)); label.ulft (btex \texttt{ds(3)} etex, (.9w, 0)); \end{emp} \end{center} \caption{\label{fig:grids-split}% Forking one dimension~\texttt{d} of a grid into three parts \texttt{ds(1)}, \texttt{ds(2)}, and~\texttt{ds(3)}. The picture illustrates the most complex case of pseudo stratified sampling (cf.~fig.~\ref{fig:grids}).} \end{figure} The coarsest grid covering the division of~$n_g$ bins into~$n_f$ forks has $n_g / \mathop{\textrm{gcd}}(n_f,n_g) = \mathop{\textrm{lcm}}(n_f,n_g) / n_f$ bins per fork. Therefore, we need \begin{equation} \mathop{\textrm{lcm}} \left( \frac{\mathop{\textrm{lcm}}(n_f,n_g)}{n_f}, n_x \right) \end{equation} divisions of the adaptive grid (if~$n_x$ is the number of bins in the original adaptive grid).\par @ Life would be much easier, if we knew that~$n_f$ divides~$n_g$. However, this is hard to maintain in real life applications. We can try to achieve this if possible, but the algorithms must be prepared to handle the general case. <>= nx = lcm (d%ng / gcd (num_forks, d%ng), num_div) ds_ng = (d%ng * (/ (j, j=0,num_forks) /)) / num_forks n = (nx * ds_ng) / d%ng n0(1:num_forks) = n(0:num_forks-1) n1(1:num_forks) = n(1:num_forks) @ <>= <> allocate (d_x(0:nx), d_integral(nx), d_variance(nx)) ! allocate (d_efficiency(nx)) call subdivide (d_x, d%x) call distribute (d_integral, d%integral) call distribute (d_variance, d%variance) ! call distribute (d_efficiency, d%efficiency) do i = 1, num_forks call copy_array_pointer (ds(i)%x, d_x(n0(i):n1(i)), lb = 0) call copy_array_pointer (ds(i)%integral, d_integral(n0(i)+1:n1(i))) call copy_array_pointer (ds(i)%variance, d_variance(n0(i)+1:n1(i))) ! call copy_array_pointer (ds(i)%efficiency, d_efficiency(n0(i)+1:n1(i))) ds(i)%x = (ds(i)%x - ds(i)%x(0)) / (d_x(n1(i)) - d_x(n0(i))) end do ds%x_min = d%x_min + d%dx * d_x(n0) ds%x_max = d%x_min + d%dx * d_x(n1) ds%dx = ds%x_max - ds%x_min ds%x_min_true = d%x_min_true ds%x_max_true = d%x_max_true ds%stratified = d%stratified ds%ng = ds_ng(1:num_forks) - ds_ng(0:num_forks-1) num_calls = sum_calls !: this is a misnomer, it remains ``calls per cell'' here ds%dxg = real (n1 - n0, kind=default) / ds%ng deallocate (d_x, d_integral, d_variance) ! deallocate (d_efficiency) @ <>= <> allocate (d_x(0:nx), d_integral(nx), d_variance(nx)) ! allocate (d_efficiency(nx)) do i = 1, num_forks d_integral(n0(i)+1:n1(i)) = ds(i)%integral d_variance(n0(i)+1:n1(i)) = ds(i)%variance ! d_efficiency(n0(i)+1:n1(i)) = ds(i)%efficiency end do call collect (d%integral, d_integral) call collect (d%variance, d_variance) ! call collect (d%efficiency, d_efficiency) deallocate (d_x, d_integral, d_variance) ! deallocate (d_efficiency) @ <>= private :: subdivide private :: distribute private :: collect @ <>= pure subroutine subdivide (x, x0) real(kind=default), dimension(0:), intent(inout) :: x real(kind=default), dimension(0:), intent(in) :: x0 integer :: i, n, n0 n0 = ubound (x0, dim=1) n = ubound (x, dim=1) / n0 x(0) = x0(0) do i = 1, n x(i::n) = x0(0:n0-1) * real (n - i) / n + x0(1:n0) * real (i) / n end do end subroutine subdivide @ %def subdivide @ <>= pure subroutine distribute (x, x0) real(kind=default), dimension(:), intent(inout) :: x real(kind=default), dimension(:), intent(in) :: x0 integer :: i, n n = ubound (x, dim=1) / ubound (x0, dim=1) do i = 1, n x(i::n) = x0 / n end do end subroutine distribute @ %def distribute @ <>= pure subroutine collect (x0, x) real(kind=default), dimension(:), intent(inout) :: x0 real(kind=default), dimension(:), intent(in) :: x integer :: i, n, n0 n0 = ubound (x0, dim=1) n = ubound (x, dim=1) / n0 do i = 1, n0 x0(i) = sum (x((i-1)*n+1:i*n)) end do end subroutine collect @ %def collect @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsubsection{Trivia} <>= pure subroutine sum_division (d, ds) type(division_t), intent(inout) :: d type(division_t), dimension(:), intent(in) :: ds integer :: i d%integral = 0.0 d%variance = 0.0 ! d%efficiency = 0.0 do i = 1, size (ds) d%integral = d%integral + ds(i)%integral d%variance = d%variance + ds(i)%variance ! d%efficiency = d%efficiency + ds(i)%efficiency end do end subroutine sum_division @ %def sum_division @ <>= public :: debug_division public :: dump_division @ <>= subroutine debug_division (d, prefix) type(division_t), intent(in) :: d character(len=*), intent(in) :: prefix print "(1x,a,2(a,1x,i3,1x,f10.7))", prefix, ": d%x: ", & lbound(d%x,dim=1), d%x(lbound(d%x,dim=1)), & " ... ", & ubound(d%x,dim=1), d%x(ubound(d%x,dim=1)) print "(1x,a,2(a,1x,i3,1x,f10.7))", prefix, ": d%i: ", & lbound(d%integral,dim=1), d%integral(lbound(d%integral,dim=1)), & " ... ", & ubound(d%integral,dim=1), d%integral(ubound(d%integral,dim=1)) print "(1x,a,2(a,1x,i3,1x,f10.7))", prefix, ": d%v: ", & lbound(d%variance,dim=1), d%variance(lbound(d%variance,dim=1)), & " ... ", & ubound(d%variance,dim=1), d%variance(ubound(d%variance,dim=1)) ! print "(1x,a,2(a,1x,i3,1x,f10.7))", prefix, ": d%e: ", & ! lbound(d%efficiency,dim=1), d%efficiency(lbound(d%efficiency,dim=1)), & ! " ... ", & ! ubound(d%efficiency,dim=1), d%efficiency(ubound(d%efficiency,dim=1)) end subroutine debug_division @ %def debug_division @ <>= subroutine dump_division (d, prefix) type(division_t), intent(in) :: d character(len=*), intent(in) :: prefix ! print "(2(1x,a),100(1x,f10.7))", prefix, ":x: ", d%x print "(2(1x,a),100(1x,f10.7))", prefix, ":x: ", d%x(1:) print "(2(1x,a),100(1x,e10.3))", prefix, ":i: ", d%integral print "(2(1x,a),100(1x,e10.3))", prefix, ":v: ", d%variance ! print "(2(1x,a),100(1x,e10.3))", prefix, ":e: ", d%efficiency end subroutine dump_division @ %def dump_division @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Inquiry} Trivial, but necessary for making [[divisions]] an abstract data type: <>= public :: inside_division, stratified_division public :: volume_division, rigid_division, adaptive_division @ <>= elemental function inside_division (d, x) result (theta) type(division_t), intent(in) :: d real(kind=default), intent(in) :: x logical :: theta theta = (x >= d%x_min_true) .and. (x <= d%x_max_true) end function inside_division @ %def inside_division @ <>= elemental function stratified_division (d) result (yorn) type(division_t), intent(in) :: d logical :: yorn yorn = d%stratified end function stratified_division @ %def stratified_division @ <>= elemental function volume_division (d) result (vol) type(division_t), intent(in) :: d real(kind=default) :: vol vol = d%dx end function volume_division @ %def volume_division @ <>= elemental function rigid_division (d) result (n) type(division_t), intent(in) :: d integer :: n n = d%ng end function rigid_division @ %def rigid_division @ <>= elemental function adaptive_division (d) result (n) type(division_t), intent(in) :: d integer :: n n = ubound (d%x, dim=1) end function adaptive_division @ %def adaptive_division @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Diagnostics} <>= type, public :: div_history private logical :: stratified integer :: ng, num_div real(kind=default) :: x_min, x_max, x_min_true, x_max_true real(kind=default) :: & spread_f_p, stddev_f_p, spread_p, stddev_p, spread_m, stddev_m end type div_history @ %def div_history @ <>= public :: copy_history, summarize_division @ <>= elemental function summarize_division (d) result (s) type(division_t), intent(in) :: d type(div_history) :: s real(kind=default), dimension(:), allocatable :: p, m allocate (p(ubound(d%x,dim=1)), m(ubound(d%x,dim=1))) p = probabilities (d%x) m = rebinning_weights (d%variance) s%ng = d%ng s%num_div = ubound (d%x, dim=1) s%stratified = d%stratified s%x_min = d%x_min s%x_max = d%x_max s%x_min_true = d%x_min_true s%x_max_true = d%x_max_true s%spread_f_p = value_spread_percent (d%integral) s%stddev_f_p = standard_deviation_percent (d%integral) s%spread_p = value_spread_percent (p) s%stddev_p = standard_deviation_percent (p) s%spread_m = value_spread_percent (m) s%stddev_m = standard_deviation_percent (m) deallocate (p, m) end function summarize_division @ %def summarize_division @ <>= private :: probabilities @ <>= pure function probabilities (x) result (p) real(kind=default), dimension(0:), intent(in) :: x real(kind=default), dimension(ubound(x,dim=1)) :: p integer :: num_div num_div = ubound (x, dim=1) p = 1.0 / (x(1:num_div) - x(0:num_div-1)) p = p / sum(p) end function probabilities @ %def probabilities @ <>= subroutine print_history (h, tag) type(div_history), dimension(:), intent(in) :: h character(len=*), intent(in), optional :: tag call write_history (output_unit, h, tag) flush (output_unit) end subroutine print_history @ <>= subroutine write_history (u, h, tag) integer, intent(in) :: u type(div_history), dimension(:), intent(in) :: h character(len=*), intent(in), optional :: tag character(len=BUFFER_SIZE) :: pfx character(len=1) :: s integer :: i if (present (tag)) then pfx = tag else pfx = "[vamp]" end if if ((minval (h%x_min) == maxval (h%x_min)) & .and. (minval (h%x_max) == maxval (h%x_max))) then write (u, "(1X,A11,1X,2X,1X,2(ES10.3,A4,ES10.3,A7))") pfx, & h(1)%x_min, " <= ", h(1)%x_min_true, & " < x < ", h(1)%x_max_true, " <= ", h(1)%x_max else do i = 1, size (h) write (u, "(1X,A11,1X,I2,1X,2(ES10.3,A4,ES10.3,A7))") pfx, & i, h(i)%x_min, " <= ", h(i)%x_min_true, & " < x < ", h(i)%x_max_true, " <= ", h(i)%x_max end do end if write (u, "(1X,A11,1X,A2,2(1X,A3),A1,6(1X,A8))") pfx, & "it", "nd", "ng", "", & "spr(f/p)", "dev(f/p)", "spr(m)", "dev(m)", "spr(p)", "dev(p)" iterations: do i = 1, size (h) if (h(i)%stratified) then s = "*" else s = "" end if write (u, "(1X,A11,1X,I2,2(1X,I3),A1,6(1X,F7.2,A1))") pfx, & i, h(i)%num_div, h(i)%ng, s, & h(i)%spread_f_p, "%", h(i)%stddev_f_p, "%", & h(i)%spread_m, "%", h(i)%stddev_m, "%", & h(i)%spread_p, "%", h(i)%stddev_p, "%" end do iterations flush (u) end subroutine write_history @ %def print_history @ <>= integer, private, parameter :: BUFFER_SIZE = 50 @ %def BUFFER_SIZE @ <>= public :: print_history, write_history @ %def print_history, write_history @ <>= public :: division_x, division_integral public :: division_variance, division_efficiency @ <>= pure subroutine division_x (x, d) real(kind=default), dimension(:), pointer :: x type(division_t), intent(in) :: d call copy_array_pointer (x, d%x, 0) end subroutine division_x @ %def division_x @ <>= pure subroutine division_integral (integral, d) real(kind=default), dimension(:), pointer :: integral type(division_t), intent(in) :: d call copy_array_pointer (integral, d%integral) end subroutine division_integral @ %def division_integral @ <>= pure subroutine division_variance (variance, d) real(kind=default), dimension(:), pointer :: variance type(division_t), intent(in) :: d call copy_array_pointer (variance, d%variance, 0) end subroutine division_variance @ %def division_variance @ <>= pure subroutine division_efficiency (eff, d) real(kind=default), dimension(:), pointer :: eff type(division_t), intent(in) :: d call copy_array_pointer (eff, d%efficiency, 0) end subroutine division_efficiency @ %def division_efficiency @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{I/O} <>= public :: write_division private :: write_division_unit, write_division_name public :: read_division private :: read_division_unit, read_division_name public :: write_division_raw private :: write_division_raw_unit, write_division_raw_name public :: read_division_raw private :: read_division_raw_unit, read_division_raw_name @ <>= interface write_division module procedure write_division_unit, write_division_name end interface interface read_division module procedure read_division_unit, read_division_name end interface interface write_division_raw module procedure write_division_raw_unit, write_division_raw_name end interface interface read_division_raw module procedure read_division_raw_unit, read_division_raw_name end interface @ %def write_division write_division_raw @ %def read_division read_division_raw @ It makes no sense to read or write [[d%integral]], [[d%variance]], and [[d%efficiency]], because they are only used during sampling. <>= subroutine write_division_unit (d, unit, write_integrals) type(division_t), intent(in) :: d integer, intent(in) :: unit logical, intent(in), optional :: write_integrals logical :: write_integrals0 integer :: i write_integrals0 = .false. if (present(write_integrals)) write_integrals0 = write_integrals write (unit = unit, fmt = descr_fmt) "begin type(division_t) :: d" write (unit = unit, fmt = integer_fmt) "ubound(d%x,1) = ", ubound (d%x, dim=1) write (unit = unit, fmt = integer_fmt) "d%ng = ", d%ng write (unit = unit, fmt = logical_fmt) "d%stratified = ", d%stratified write (unit = unit, fmt = double_fmt) "d%dx = ", d%dx write (unit = unit, fmt = double_fmt) "d%dxg = ", d%dxg write (unit = unit, fmt = double_fmt) "d%x_min = ", d%x_min write (unit = unit, fmt = double_fmt) "d%x_max = ", d%x_max write (unit = unit, fmt = double_fmt) "d%x_min_true = ", d%x_min_true write (unit = unit, fmt = double_fmt) "d%x_max_true = ", d%x_max_true write (unit = unit, fmt = descr_fmt) "begin d%x" do i = 0, ubound (d%x, dim=1) if (write_integrals0 .and. i/=0) then write (unit = unit, fmt = double_array_fmt) & i, d%x(i), d%integral(i), d%variance(i) else write (unit = unit, fmt = double_array_fmt) i, d%x(i) end if end do write (unit = unit, fmt = descr_fmt) "end d%x" write (unit = unit, fmt = descr_fmt) "end type(division_t)" end subroutine write_division_unit @ %def write_division_unit @ <>= character(len=*), parameter, private :: & descr_fmt = "(1x,a)", & integer_fmt = "(1x,a15,1x,i15)", & logical_fmt = "(1x,a15,1x,l1)", & double_fmt = "(1x,a15,1x,e30.22)", & double_array_fmt = "(1x,i15,1x,3(e30.22))" @ %def descr_fmt integer_fmt logical_fmt double_fmt double_array_fmt @ <>= subroutine read_division_unit (d, unit, read_integrals) type(division_t), intent(inout) :: d integer, intent(in) :: unit logical, intent(in), optional :: read_integrals logical :: read_integrals0 integer :: i, idum, num_div character(len=80) :: chdum read_integrals0 = .false. if (present(read_integrals)) read_integrals0 = read_integrals read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = integer_fmt) chdum, num_div <> read (unit = unit, fmt = integer_fmt) chdum, d%ng read (unit = unit, fmt = logical_fmt) chdum, d%stratified read (unit = unit, fmt = double_fmt) chdum, d%dx read (unit = unit, fmt = double_fmt) chdum, d%dxg read (unit = unit, fmt = double_fmt) chdum, d%x_min read (unit = unit, fmt = double_fmt) chdum, d%x_max read (unit = unit, fmt = double_fmt) chdum, d%x_min_true read (unit = unit, fmt = double_fmt) chdum, d%x_max_true read (unit = unit, fmt = descr_fmt) chdum do i = 0, ubound (d%x, dim=1) if (read_integrals0 .and. i/=0) then read (unit = unit, fmt = double_array_fmt) & & idum, d%x(i), d%integral(i), d%variance(i) else read (unit = unit, fmt = double_array_fmt) idum, d%x(i) end if end do read (unit = unit, fmt = descr_fmt) chdum read (unit = unit, fmt = descr_fmt) chdum if (.not.read_integrals0) then d%integral = 0.0 d%variance = 0.0 ! d%efficiency = 0.0 end if end subroutine read_division_unit @ %def read_division_unit @ \begin{dubious} What happened to [[d%efficiency]]? \end{dubious} <>= if (associated (d%x)) then if (ubound (d%x, dim=1) /= num_div) then deallocate (d%x, d%integral, d%variance) ! deallocate (d%efficiency) allocate (d%x(0:num_div), d%integral(num_div), d%variance(num_div)) ! allocate (d%efficiency(num_div)) end if else allocate (d%x(0:num_div), d%integral(num_div), d%variance(num_div)) ! allocate (d%efficiency(num_div)) end if @ <>= subroutine write_division_name (d, name, write_integrals) type(division_t), intent(in) :: d character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", file = name) call write_division_unit (d, unit, write_integrals) close (unit = unit) end subroutine write_division_name @ %def write_division_name @ <>= subroutine read_division_name (d, name, read_integrals) type(division_t), intent(inout) :: d character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", file = name) call read_division_unit (d, unit, read_integrals) close (unit = unit) end subroutine read_division_name @ %def read_division_name @ <>= subroutine write_division_raw_unit (d, unit, write_integrals) type(division_t), intent(in) :: d integer, intent(in) :: unit logical, intent(in), optional :: write_integrals logical :: write_integrals0 integer :: i write_integrals0 = .false. if (present(write_integrals)) write_integrals0 = write_integrals write (unit = unit) MAGIC_DIVISION_BEGIN write (unit = unit) ubound (d%x, dim=1) write (unit = unit) d%ng write (unit = unit) d%stratified write (unit = unit) d%dx write (unit = unit) d%dxg write (unit = unit) d%x_min write (unit = unit) d%x_max write (unit = unit) d%x_min_true write (unit = unit) d%x_max_true do i = 0, ubound (d%x, dim=1) if (write_integrals0 .and. i/=0) then write (unit = unit) d%x(i), d%integral(i), d%variance(i) else write (unit = unit) d%x(i) end if end do write (unit = unit) MAGIC_DIVISION_END end subroutine write_division_raw_unit @ %def write_division_raw_unit @ <>= integer, parameter, private :: MAGIC_DIVISION = 11111111 integer, parameter, private :: MAGIC_DIVISION_BEGIN = MAGIC_DIVISION + 1 integer, parameter, private :: MAGIC_DIVISION_END = MAGIC_DIVISION + 2 @ <>= subroutine read_division_raw_unit (d, unit, read_integrals) type(division_t), intent(inout) :: d integer, intent(in) :: unit logical, intent(in), optional :: read_integrals logical :: read_integrals0 integer :: i, num_div, magic character(len=*), parameter :: FN = "read_division_raw_unit" read_integrals0 = .false. if (present(read_integrals)) read_integrals0 = read_integrals read (unit = unit) magic if (magic /= MAGIC_DIVISION_BEGIN) then print *, FN, " fatal: expecting magic ", MAGIC_DIVISION_BEGIN, & ", found ", magic stop end if read (unit = unit) num_div <> read (unit = unit) d%ng read (unit = unit) d%stratified read (unit = unit) d%dx read (unit = unit) d%dxg read (unit = unit) d%x_min read (unit = unit) d%x_max read (unit = unit) d%x_min_true read (unit = unit) d%x_max_true do i = 0, ubound (d%x, dim=1) if (read_integrals0 .and. i/=0) then read (unit = unit) d%x(i), d%integral(i), d%variance(i) else read (unit = unit) d%x(i) end if end do if (.not.read_integrals0) then d%integral = 0.0 d%variance = 0.0 ! d%efficiency = 0.0 end if read (unit = unit) magic if (magic /= MAGIC_DIVISION_END) then print *, FN, " fatal: expecting magic ", MAGIC_DIVISION_END, & ", found ", magic stop end if end subroutine read_division_raw_unit @ %def read_division_raw_unit @ <>= subroutine write_division_raw_name (d, name, write_integrals) type(division_t), intent(in) :: d character(len=*), intent(in) :: name logical, intent(in), optional :: write_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", & form = "unformatted", file = name) call write_division_unit (d, unit, write_integrals) close (unit = unit) end subroutine write_division_raw_name @ %def write_division_raw_name @ <>= subroutine read_division_raw_name (d, name, read_integrals) type(division_t), intent(inout) :: d character(len=*), intent(in) :: name logical, intent(in), optional :: read_integrals integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", & form = "unformatted", file = name) call read_division_unit (d, unit, read_integrals) close (unit = unit) end subroutine read_division_raw_name @ %def read_division_raw_name @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Marshaling} Note that we can not use the~[[transfer]] intrinsic function for marshalling types that contain pointers that substitute for allocatable array components. [[transfer]] will copy the pointers in this case and not where they point to! <>= public :: marshal_division_size, marshal_division, unmarshal_division @ <>= pure subroutine marshal_division (d, ibuf, dbuf) type(division_t), intent(in) :: d integer, dimension(:), intent(inout) :: ibuf real(kind=default), dimension(:), intent(inout) :: dbuf integer :: num_div num_div = ubound (d%x, dim=1) ibuf(1) = d%ng ibuf(2) = num_div if (d%stratified) then ibuf(3) = 1 else ibuf(3) = 0 end if dbuf(1) = d%x_min dbuf(2) = d%x_max dbuf(3) = d%x_min_true dbuf(4) = d%x_max_true dbuf(5) = d%dx dbuf(6) = d%dxg dbuf(7:7+num_div) = d%x dbuf(8+ num_div:7+2*num_div) = d%integral dbuf(8+2*num_div:7+3*num_div) = d%variance ! dbuf(8+3*num_div:7+4*num_div) = d%efficiency end subroutine marshal_division @ %def marshal_division @ <>= pure subroutine marshal_division_size (d, iwords, dwords) type(division_t), intent(in) :: d integer, intent(out) :: iwords, dwords iwords = 3 dwords = 7 + 3 * ubound (d%x, dim=1) ! dwords = 7 + 4 * ubound (d%x, dim=1) end subroutine marshal_division_size @ %def marshal_division_size @ <>= pure subroutine unmarshal_division (d, ibuf, dbuf) type(division_t), intent(inout) :: d integer, dimension(:), intent(in) :: ibuf real(kind=default), dimension(:), intent(in) :: dbuf integer :: num_div d%ng = ibuf(1) num_div = ibuf(2) d%stratified = ibuf(3) /= 0 d%x_min = dbuf(1) d%x_max = dbuf(2) d%x_min_true = dbuf(3) d%x_max_true = dbuf(4) d%dx = dbuf(5) d%dxg = dbuf(6) <> d%x = dbuf(7:7+num_div) d%integral = dbuf(8+ num_div:7+2*num_div) d%variance = dbuf(8+2*num_div:7+3*num_div) ! d%efficiency = dbuf(8+3*num_div:7+4*num_div) end subroutine unmarshal_division @ %def unmarshal_division @ <>= public :: marshal_div_history_size, marshal_div_history, unmarshal_div_history @ <>= pure subroutine marshal_div_history (h, ibuf, dbuf) type(div_history), intent(in) :: h integer, dimension(:), intent(inout) :: ibuf real(kind=default), dimension(:), intent(inout) :: dbuf ibuf(1) = h%ng ibuf(2) = h%num_div if (h%stratified) then ibuf(3) = 1 else ibuf(3) = 0 end if dbuf(1) = h%x_min dbuf(2) = h%x_max dbuf(3) = h%x_min_true dbuf(4) = h%x_max_true dbuf(5) = h%spread_f_p dbuf(6) = h%stddev_f_p dbuf(7) = h%spread_p dbuf(8) = h%stddev_p dbuf(9) = h%spread_m dbuf(10) = h%stddev_m end subroutine marshal_div_history @ %def marshal_div_history @ <>= pure subroutine marshal_div_history_size (h, iwords, dwords) type(div_history), intent(in) :: h integer, intent(out) :: iwords, dwords iwords = 3 dwords = 10 end subroutine marshal_div_history_size @ %def marshal_div_history_size @ <>= pure subroutine unmarshal_div_history (h, ibuf, dbuf) type(div_history), intent(inout) :: h integer, dimension(:), intent(in) :: ibuf real(kind=default), dimension(:), intent(in) :: dbuf h%ng = ibuf(1) h%num_div = ibuf(2) h%stratified = ibuf(3) /= 0 h%x_min = dbuf(1) h%x_max = dbuf(2) h%x_min_true = dbuf(3) h%x_max_true = dbuf(4) h%spread_f_p = dbuf(5) h%stddev_f_p = dbuf(6) h%spread_p = dbuf(7) h%stddev_p = dbuf(8) h%spread_m = dbuf(9) h%stddev_m = dbuf(10) end subroutine unmarshal_div_history @ %def unmarshal_div_history @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Boring Copying and Deleting of Objects} <>= elemental subroutine copy_division (lhs, rhs) type(division_t), intent(inout) :: lhs type(division_t), intent(in) :: rhs if (associated (rhs%x)) then call copy_array_pointer (lhs%x, rhs%x, lb = 0) else if (associated (lhs%x)) then deallocate (lhs%x) end if if (associated (rhs%integral)) then call copy_array_pointer (lhs%integral, rhs%integral) else if (associated (lhs%integral)) then deallocate (lhs%integral) end if if (associated (rhs%variance)) then call copy_array_pointer (lhs%variance, rhs%variance) else if (associated (lhs%variance)) then deallocate (lhs%variance) end if ! if (associated (rhs%efficiency)) then ! call copy_array_pointer (lhs%efficiency, rhs%efficiency) ! else if (associated (lhs%efficiency)) then ! deallocate (lhs%efficiency) ! end if lhs%dx = rhs%dx lhs%dxg = rhs%dxg lhs%x_min = rhs%x_min lhs%x_max = rhs%x_max lhs%x_min_true = rhs%x_min_true lhs%x_max_true = rhs%x_max_true lhs%ng = rhs%ng lhs%stratified = rhs%stratified end subroutine copy_division @ %def copy_division @ <>= elemental subroutine delete_division (d) type(division_t), intent(inout) :: d if (associated (d%x)) then deallocate (d%x, d%integral, d%variance) ! deallocate (d%efficiency) end if end subroutine delete_division @ %def delete_division @ <>= elemental subroutine copy_history (lhs, rhs) type(div_history), intent(out) :: lhs type(div_history), intent(in) :: rhs lhs%stratified = rhs%stratified lhs%ng = rhs%ng lhs%num_div = rhs%num_div lhs%x_min = rhs%x_min lhs%x_max = rhs%x_max lhs%x_min_true = rhs%x_min_true lhs%x_max_true = rhs%x_max_true lhs%spread_f_p = rhs%spread_f_p lhs%stddev_f_p = rhs%stddev_f_p lhs%spread_p = rhs%spread_p lhs%stddev_p = rhs%stddev_p lhs%spread_m = rhs%spread_m lhs%stddev_m = rhs%stddev_m end subroutine copy_history @ %def copy_history @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: trunk/vamp/src/tao_random_numbers.nw =================================================================== --- trunk/vamp/src/tao_random_numbers.nw (revision 8914) +++ trunk/vamp/src/tao_random_numbers.nw (revision 8915) @@ -1,1661 +1,1661 @@ % tao_random_numbers.nw -- -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % VAMP tao_random_numbers code as NOWEB source %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \newcommand{\modpoly}{% \;(\text{modulo } z^K+z^L+1)} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{The Art Of Random Numbers} Volume two of Donald E.~Knuth' \textit{The Art of Computer Programming}~\cite{Knuth:1997:TAOCP2} has always been celebrated as a prime reference for random number generation. Recently, the third edition has been published and it contains a gem of a \emph{portable} random number generator. It generates 30-bit integers with the following desirable properties \begin{itemize} \item they pass all the tests from George Marsaglia's ``diehard'' suite of tests for random number generators~\cite{Marsaglia:1996:CD} (but see~\cite{Knuth:1997:TAOCP2} for a caveat regarding the ``birthday-spacing'' test) \item they can be generated with portable signed 32-bit arithmetic (Fortran can't do unsigned arithmetic) \item it is faster than other lagged Fibonacci generators \item it can create at least $2^{30}-2$ independent sequences \end{itemize} We implement the improved versions available as FORTRAN77 code from \begin{verbatim} http://www-cs-faculty.stanford.edu/~uno/programs.html#rng \end{verbatim} that contain a streamlined seeding alorithm with better independence of substreams. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Application Program Interface} A function returning single reals and integers. Note that the static version without the [[tao_random_state]] argument does not require initialization. It will behave as if [[call tao_random_seed(0)]] had been executed. On the other hand, the parallelizable version with the explicit [[tao_random_state]] will fail if none of the [[tao_random_create]] have been called for the state. (This is a deficiency of Fortran90 that can be fixed in Fortran95). \index{deficiencies of Fortran90 that have been fixed in Fortran95} <>= call tao_random_number (r) call tao_random_number (s, r) @ The state of the random number generator comes in two variaties: buffered and raw. The former is much more efficient, but it can be beneficial to flush the buffers and to pass only the raw state in order to save of interprocess communication~(IPC) costs. <>= type(tao_random_state) :: s type(tao_random_raw_state) :: rs @ Subroutines filling arrays of reals and integers: <>= call tao_random_number (a, num = n) call tao_random_number (s, a, num = n) @ Subroutine for changing the seed: <>= call tao_random_seed (seed = seed) call tao_random_seed (s, seed = seed) @ Subroutine for changing the luxury. Per default, use all random numbers: <>= call tao_random_luxury () call tao_random_luxury (s) @ With an integer argument, use the first~[[n]] of each fill of the buffer: <>= call tao_random_luxury (n) call tao_random_luxury (s, n) @ With a floating point argument, use that fraction of each fill of the buffer: <>= call tao_random_luxury (x) call tao_random_luxury (s, x) @ Create a [[tao_random_state]] <>= call tao_random_create (s, seed, buffer_size = buffer_size) call tao_random_create (s, raw_state, buffer_size = buffer_size) call tao_random_create (s, state) @ Create a [[tao_random_raw_state]] <>= call tao_random_create (rs, seed) call tao_random_create (rs, raw_state) call tao_random_create (rs, state) @ Destroy a [[tao_random_state]] or [[tao_random_raw_state]] <>= call tao_random_destroy (s) @ Copy [[tao_random_state]] and [[tao_random_raw_state]] in all four combinations <>= call tao_random_copy (lhs, rhs) lhs = rhs @ <>= call tao_random_flush (s) @ <>= call tao_random_read (s, unit) call tao_random_write (s, unit) @ <>= call tao_random_test (name = name) @ Here is a sample application of random number states: <>= subroutine threads (args, y, state) real, dimension(:), intent(in) :: args real, dimension(:), intent(out) :: y type(tao_random_state) :: state integer :: seed type(tao_random_raw_state), dimension(size(y)) :: states integer :: s call tao_random_number (state, seed) call tao_random_create (states, (/ (s, s=seed,size(y)-1) /)) y = thread (args, states) end function thread @ In this example, we could equivalently pass an integer seed, instead of [[raw_state]]. But in more complicated cases it can be beneficial to have the option of reusing [[raw_state]] in the calling routine. <>= elemental function thread (arg, raw_state) result (y) real, dimension, intent(in) :: arg type(tao_random_raw_state) :: raw_state real :: y type(tao_random_state) :: state real :: r call tao_random_create (state, raw_state) do ... call tao_random_number (state, r) ... end do end function thread @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Low Level Routines} Here the low level routines are \emph{much} more interesting than the high level routines. The latter contain a lot of duplication (made necessary by Fortran's lack of parametric polymorphism) and consist mostly of bookkeeping. We wil therefore start with the former. @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Generation of 30-bit Random Numbers} The generator is a subtractive lagged Fibonacci \begin{equation} \label{eq:tao30} X_j = (X_{j-K} - X_{j-L}) \mod 2^{30} \end{equation} with lags~$K=100$ and~$L=37$. <>= integer, parameter, private :: K = 100, L = 37 @ %def K L @ Other good choices for~$K$ and~$L$ are (cf.~\cite{Knuth:1997:TAOCP2}, table~1 in section~3.2.2, p.~29) <>= integer, parameter, private :: K = 55, L = 24 integer, parameter, private :: K = 89, L = 38 integer, parameter, private :: K = 100, L = 37 integer, parameter, private :: K = 127, L = 30 integer, parameter, private :: K = 258, L = 83 integer, parameter, private :: K = 378, L = 107 integer, parameter, private :: K = 607, L = 273 @ A modulus of $2^{30}$ is the largest we can handle in \emph{portable} (i.e.~\emph{signed}) 32-bit arithmetic <>= integer(kind=tao_i32), parameter, private :: M = 2**30 @ %def M @ [[generate]] fills the array $a_1,\ldots,a_n$ with random integers $0 \le a_i < 2^{30}$. We \emph{must} have at least~$n \ge K$. Higher values don't change the results, but make [[generate]] more efficient (about a factor of two, asymptotically). For~$K=100$, DEK recommends~$n \ge 1000$. Best results are obtained using the first~100 random numbers out of~1009. Let's therefore use~1009 as a default buffer size. The user can [[call tao_random_luxury (100)]] him/herself: <>= integer, parameter, private :: DEFAULT_BUFFER_SIZE = 1009 @ %def DEFAULT_BUFFER_SIZE @ Since users are not expected to call [[generate]] directly, we do \emph{not} check for $n \ge K$ and assume that the caller knows what (s)he's doing \ldots <>= pure subroutine generate (a, state) integer(kind=tao_i32), dimension(:), intent(inout) :: a, state integer :: j, n n = size (a) <> end subroutine generate @ %def generate @ <>= private :: generate @ [[state(1:K)]] is already set up properly: <>= a(1:K) = state(1:K) @ The remaining $n-K$ random numbers can be gotten directly from the recursion~(\ref{eq:tao30}). Note that Fortran90's [[modulo]] intrinsic does the right thing, since it guarantees (unlike -Fortran77's [[mod]]) that~$0\le[[modulo]](a,m)0$). +Fortran77's [[mod]]) that~$0\le\text{[[modulo]]}(a,m)0$). <>= do j = K+1, n a(j) = modulo (a(j-K) - a(j-L), M) end do @ Do the recursion~(\ref{eq:tao30}) $K$ more times to prepare [[state(1:K)]] for the next invokation of [[generate]]. <>= state(1:L) = modulo (a(n+1-K:n+L-K) - a(n+1-L:n), M) do j = L+1, K state(j) = modulo (a(n+j-K) - state(j-L), M) end do @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Initialization of 30-bit Random Numbers} The non-trivial and most beautiful part is the algorithm to initialize the random number generator state [[state]] with the first $K$~numbers. I haven't studied algebra over finite fields in sufficient depth to consider the mathematics behind it straightforward. The commentary below is rather verbose and reflects my understanding of DEK's rather terse remarks (solution to exercise~3.6-9~\cite{Knuth:1997:TAOCP2}). <>= subroutine seed_static (seed) integer, optional, intent(in) :: seed call seed_stateless (s_state, seed) s_virginal = .false. s_last = size (s_buffer) end subroutine seed_static @ %def seed_static s_last s_virginal @ The static version of [[tao_random_raw_state]]: <>= integer(kind=tao_i32), dimension(K), save, private :: s_state logical, save, private :: s_virginal = .true. @ %def s_state s_virginal @ <>= elemental subroutine seed_raw_state (s, seed) type(tao_random_raw_state), intent(inout) :: s integer, optional, intent(in) :: seed call seed_stateless (s%x, seed) end subroutine seed_raw_state @ %def seed_raw_state @ <>= elemental subroutine seed_state (s, seed) type(tao_random_state), intent(inout) :: s integer, optional, intent(in) :: seed call seed_raw_state (s%state, seed) s%last = size (s%buffer) end subroutine seed_state @ %def seed_state @ This incarnation of the procedure is [[pure]]. <>= pure subroutine seed_stateless (state, seed) integer(kind=tao_i32), dimension(:), intent(out) :: state integer, optional, intent(in) :: seed <> integer :: seed_value, j, s, t integer(kind=tao_i32), dimension(2*K-1) :: x <> <> <> do <<$p(z)\to p(z)^2 \modpoly$>> <<$p(z)\to zp(z) \modpoly$>> - <> + <> end do <> <> end subroutine seed_stateless @ %def seed_stateless @ Any default will do <>= integer, parameter :: DEFAULT_SEED = 0 @ %def DEFAULT_SEED @ These must not be changed: <>= integer, parameter :: MAX_SEED = 2**30 - 3 integer, parameter :: TT = 70 @ %def MAX_SEED TT @ <>= if (present (seed)) then seed_value = modulo (seed, MAX_SEED + 1) else seed_value = DEFAULT_SEED end if @ %def seed_value @ Fill the array $x_1,\ldots,x_K$ with even integers, shifted cyclically by 29 bits. <>= s = seed_value - modulo (seed_value, 2) + 2 do j = 1, K x(j) = s s = 2*s if (s >= M) then s = s - M + 2 end if end do x(K+1:2*K-1) = 0 @ Make $x_2$ (and only $x_2$) odd: <>= x(2) = x(2) + 1 @ <>= s = seed_value t = TT - 1 @ Consider the polynomial \begin{equation} p(z) = \sum_{n=1}^K x_n z^{n-1} = x_Kz^{K-1} + \ldots + x_2 z + x_1 \end{equation} We have $p(z)^2 = p(z^2) \mod 2$ because cross terms have an even coefficient and $x_n^2 = x_n \mod 2$. Therefore we can square the polynomial by shifting the coefficients. The coefficients for $n>K$ will be reduced. <<$p(z)\to p(z)^2 \modpoly$>>= x(3:2*K-1:2) = x(2:K) x(2:2*K-2:2) = 0 @ Let's return to the coefficients for $n>K$ generated by the shifting above. Subtract $z^n(z^K + z^L + 1)=z^nz^K(1 + z^{-(K-L)} + z^{-K})$. The coefficient of $z^nz^K$ is left alone, because it doesn't belong to $p(z)$ anyway. <<$p(z)\to p(z)^2 \modpoly$>>= do j = 2*K-1, K+1, -1 x(j-(K-L)) = modulo (x(j-(K-L))-x(j), M) x(j-K)=modulo (x(j-K)-x(j), M) end do @ <<$p(z)\to zp(z) \modpoly$>>= if (modulo (s, 2) == 1) then x(2:K+1) = x(1:K) x(1) = x(K+1) x(L+1) = modulo (x(L+1) - x(K+1), M) end if @ -<>= +<>= if (s /= 0) then s = s / 2 else t = t - 1 end if if (t <= 0) then exit end if @ <>= state(1:K-L) = x(L+1:K) state(K-L+1:K) = x(1:L) @ <>= do j = 1, 10 call generate (x, state) end do @ <>= interface tao_random_seed module procedure <> end interface @ %def tao_random_seed @ <>= private :: <> @ <>= seed_static, seed_state, seed_raw_state @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Generation of 52-bit Random Numbers} \begin{equation} \label{eq:tao52} X_j = (X_{j-K} + X_{j-L}) \mod 1 \end{equation} <>= real(kind=tao_r64), parameter, private :: M = 1.0_tao_r64 @ %def M @ The state of the internal routines <>= real(kind=tao_r64), dimension(K), save, private :: s_state logical, save, private :: s_virginal = .true. @ %def s_state s_virginal @ <>= pure subroutine generate (a, state) real(kind=tao_r64), dimension(:), intent(inout) :: a real(kind=tao_r64), dimension(:), intent(inout) :: state integer :: j, n n = size (a) <> end subroutine generate @ %def generate @ That's almost identical to the 30-bit version, except that the relative sign is flipped: <>= a(1:K) = state(1:K) do j = K+1, n a(j) = modulo (a(j-K) + a(j-L), M) end do state(1:L) = modulo (a(n+1-K:n+L-K) + a(n+1-L:n), M) do j = L+1, K state(j) = modulo (a(n+j-K) + state(j-L), M) end do @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Initialization of 52-bit Random Numbers} This incarnation of the procedure is [[pure]]. <>= pure subroutine seed_stateless (state, seed) real(kind=tao_r64), dimension(:), intent(out) :: state integer, optional, intent(in) :: seed <> <> <> <> <> do <<52-bit $p(z)\to p(z)^2 \modpoly$>> <<52-bit $p(z)\to zp(z) \modpoly$>> - <> + <> end do <> <> end subroutine seed_stateless @ %def seed_stateless @ <>= private :: seed_stateless @ <>= real(kind=tao_r64), parameter :: ULP = 2.0_tao_r64**(-52) @ %def ULP @ <>= real(kind=tao_r64), dimension(2*K-1) :: x real(kind=tao_r64) :: ss integer :: seed_value, t, s, j @ %def x ss seed_value t s j @ <>= ss = 2*ULP * (seed_value + 2) do j = 1, K x(j) = ss ss = 2*ss if (ss >= 1) then ss = ss - 1 + 2*ULP end if end do x(K+1:2*K-1) = 0.0 @ <>= x(2) = x(2) + ULP @ <<52-bit $p(z)\to p(z)^2 \modpoly$>>= x(3:2*K-1:2) = x(2:K) x(2:2*K-2:2) = 0 @ This works because [[2*K-1]] is odd <<52-bit $p(z)\to p(z)^2 \modpoly$>>= do j = 2*K-1, K+1, -1 x(j-(K-L)) = modulo (x(j-(K-L)) + x(j), M) x(j-K) = modulo (x(j-K) + x(j), M) end do @ <<52-bit $p(z)\to zp(z) \modpoly$>>= if (modulo (s, 2) == 1) THEN x(2:K+1) = x(1:K) x(1) = x(K+1) x(L+1) = modulo (x(L+1) + x(K+1), M) end if @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The State} <>= type, public :: tao_random_raw_state private integer(kind=tao_i32), dimension(K) :: x end type tao_random_raw_state @ %def tao_random_raw_state @ <>= type, public :: tao_random_state private type(tao_random_raw_state) :: state integer(kind=tao_i32), dimension(:), pointer :: buffer => null () integer :: buffer_end, last end type tao_random_state @ %def tao_random_state @ <>= type, public :: tao_random_raw_state private real(kind=tao_r64), dimension(K) :: x end type tao_random_raw_state @ %def tao_random_raw_state @ <>= type, public :: tao_random_state private type(tao_random_raw_state) :: state real(kind=tao_r64), dimension(:), pointer :: buffer => null () integer :: buffer_end, last end type tao_random_state @ %def tao_random_state @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Creation} <>= interface tao_random_create module procedure <> end interface @ %def tao_random_create @ <>= private :: <> @ <>= create_state_from_seed, create_raw_state_from_seed, & create_state_from_state, create_raw_state_from_state, & create_state_from_raw_state, create_raw_state_from_raw_st @ There are no procedures for copying the state of the static generator to or from an explicit [[tao_random_state]]. Users needing this functionality can be expected to handle explicit states anyway. Since the direction of the copying can not be obvious from the type of the argument, such functions would spoil the simplicity of the generic procedure interface. <>= elemental subroutine create_state_from_seed (s, seed, buffer_size) type(tao_random_state), intent(out) :: s integer, intent(in) :: seed integer, intent(in), optional :: buffer_size call create_raw_state_from_seed (s%state, seed) if (present (buffer_size)) then s%buffer_end = max (buffer_size, K) else s%buffer_end = DEFAULT_BUFFER_SIZE end if allocate (s%buffer(s%buffer_end)) call tao_random_flush (s) end subroutine create_state_from_seed @ %def create_state_from_seed @ <>= elemental subroutine create_state_from_state (s, state) type(tao_random_state), intent(out) :: s type(tao_random_state), intent(in) :: state call create_raw_state_from_raw_st (s%state, state%state) allocate (s%buffer(size(state%buffer))) call tao_random_copy (s, state) end subroutine create_state_from_state @ %def create_state_from_state @ <>= elemental subroutine create_state_from_raw_state & (s, raw_state, buffer_size) type(tao_random_state), intent(out) :: s type(tao_random_raw_state), intent(in) :: raw_state integer, intent(in), optional :: buffer_size call create_raw_state_from_raw_st (s%state, raw_state) if (present (buffer_size)) then s%buffer_end = max (buffer_size, K) else s%buffer_end = DEFAULT_BUFFER_SIZE end if allocate (s%buffer(s%buffer_end)) call tao_random_flush (s) end subroutine create_state_from_raw_state @ %def create_state_from_raw_state @ <>= elemental subroutine create_raw_state_from_seed (s, seed) type(tao_random_raw_state), intent(out) :: s integer, intent(in) :: seed call seed_raw_state (s, seed) end subroutine create_raw_state_from_seed @ %def create_raw_state_from_seed @ <>= elemental subroutine create_raw_state_from_state (s, state) type(tao_random_raw_state), intent(out) :: s type(tao_random_state), intent(in) :: state call copy_state_to_raw_state (s, state) end subroutine create_raw_state_from_state @ %def create_raw_state_from_state @ <>= elemental subroutine create_raw_state_from_raw_st (s, raw_state) type(tao_random_raw_state), intent(out) :: s type(tao_random_raw_state), intent(in) :: raw_state call copy_raw_state (s, raw_state) end subroutine create_raw_state_from_raw_st @ %def create_raw_state_from_raw_st @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Destruction} @ <>= interface tao_random_destroy module procedure destroy_state, destroy_raw_state end interface @ %def tao_random_destroy @ <>= private :: destroy_state, destroy_raw_state @ <>= elemental subroutine destroy_state (s) type(tao_random_state), intent(inout) :: s deallocate (s%buffer) end subroutine destroy_state @ %def destroy_state @ Currently, this is a no-op, but we might need a non-trivial destruction method in the future <>= elemental subroutine destroy_raw_state (s) type(tao_random_raw_state), intent(inout) :: s end subroutine destroy_raw_state @ %def destroy_raw_state @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Copying} <>= interface tao_random_copy module procedure <> end interface @ %def tao_random_copy @ <>= interface assignment(=) module procedure <> end interface @ <>= public :: assignment(=) private :: <> @ <>= copy_state, copy_raw_state, & copy_raw_state_to_state, copy_state_to_raw_state @ <>= elemental subroutine copy_state (lhs, rhs) type(tao_random_state), intent(inout) :: lhs type(tao_random_state), intent(in) :: rhs call copy_raw_state (lhs%state, rhs%state) if (size (lhs%buffer) /= size (rhs%buffer)) then deallocate (lhs%buffer) allocate (lhs%buffer(size(rhs%buffer))) end if lhs%buffer = rhs%buffer lhs%buffer_end = rhs%buffer_end lhs%last = rhs%last end subroutine copy_state @ %def copy_state @ <>= elemental subroutine copy_raw_state (lhs, rhs) type(tao_random_raw_state), intent(out) :: lhs type(tao_random_raw_state), intent(in) :: rhs lhs%x = rhs%x end subroutine copy_raw_state @ %def copy_raw_state @ <>= elemental subroutine copy_raw_state_to_state (lhs, rhs) type(tao_random_state), intent(inout) :: lhs type(tao_random_raw_state), intent(in) :: rhs call copy_raw_state (lhs%state, rhs) call tao_random_flush (lhs) end subroutine copy_raw_state_to_state @ %def copy_raw_state_to_state @ <>= elemental subroutine copy_state_to_raw_state (lhs, rhs) type(tao_random_raw_state), intent(out) :: lhs type(tao_random_state), intent(in) :: rhs call copy_raw_state (lhs, rhs%state) end subroutine copy_state_to_raw_state @ %def copy_state_to_raw_state @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Flushing} <>= elemental subroutine tao_random_flush (s) type(tao_random_state), intent(inout) :: s s%last = size (s%buffer) end subroutine tao_random_flush @ %def tao_random_flush @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Input and Output} <>= interface tao_random_write module procedure & write_state_unit, write_state_name, & write_raw_state_unit, write_raw_state_name end interface @ %def tao_random_write @ <>= private :: write_state_unit, write_state_name private :: write_raw_state_unit, write_raw_state_name @ <>= interface tao_random_read module procedure & read_state_unit, read_state_name, & read_raw_state_unit, read_raw_state_name end interface @ %def tao_random_read @ <>= private :: read_state_unit, read_state_name private :: read_raw_state_unit, read_raw_state_name @ <>= subroutine write_state_unit (s, unit) type(tao_random_state), intent(in) :: s integer, intent(in) :: unit write (unit = unit, fmt = *) "BEGIN TAO_RANDOM_STATE" call write_raw_state_unit (s%state, unit) write (unit = unit, fmt = "(2(1x,a16,1x,i10/),1x,a16,1x,i10)") & "BUFFER_SIZE", size (s%buffer), & "BUFFER_END", s%buffer_end, & "LAST", s%last write (unit = unit, fmt = *) "BEGIN BUFFER" call write_state_array (s%buffer, unit) write (unit = unit, fmt = *) "END BUFFER" write (unit = unit, fmt = *) "END TAO_RANDOM_STATE" end subroutine write_state_unit @ %def write_state_unit @ <>= subroutine read_state_unit (s, unit) type(tao_random_state), intent(inout) :: s integer, intent(in) :: unit integer :: buffer_size read (unit = unit, fmt = *) call read_raw_state_unit (s%state, unit) read (unit = unit, fmt = "(2(1x,16x,1x,i10/),1x,16x,1x,i10)") & buffer_size, s%buffer_end, s%last read (unit = unit, fmt = *) if (buffer_size /= size (s%buffer)) then deallocate (s%buffer) allocate (s%buffer(buffer_size)) end if call read_state_array (s%buffer, unit) read (unit = unit, fmt = *) read (unit = unit, fmt = *) end subroutine read_state_unit @ %def read_state_unit @ <>= subroutine write_raw_state_unit (s, unit) type(tao_random_raw_state), intent(in) :: s integer, intent(in) :: unit write (unit = unit, fmt = *) "BEGIN TAO_RANDOM_RAW_STATE" call write_state_array (s%x, unit) write (unit = unit, fmt = *) "END TAO_RANDOM_RAW_STATE" end subroutine write_raw_state_unit @ %def write_raw_state_unit @ <>= subroutine read_raw_state_unit (s, unit) type(tao_random_raw_state), intent(inout) :: s integer, intent(in) :: unit read (unit = unit, fmt = *) call read_state_array (s%x, unit) read (unit = unit, fmt = *) end subroutine read_raw_state_unit @ %def read_raw_state_unit @ <>= subroutine write_state_array (a, unit) integer(kind=tao_i32), dimension(:), intent(in) :: a integer, intent(in) :: unit integer :: i do i = 1, size (a) write (unit = unit, fmt = "(1x,i10,1x,i10)") i, a(i) end do end subroutine write_state_array @ %def write_state_array @ <>= private :: write_state_array @ <>= subroutine read_state_array (a, unit) integer(kind=tao_i32), dimension(:), intent(inout) :: a integer, intent(in) :: unit integer :: i, idum do i = 1, size (a) read (unit = unit, fmt = *) idum, a(i) end do end subroutine read_state_array @ %def read_state_array @ <>= private :: read_state_array @ Reading and writing 52-bit floating point numbers accurately is beyond most Fortran runtime libraries. Their job is simplified considerably if we rescale by~$2^{52}$ before writing. Then the temptation to truncate will not be as overwhelming as before \ldots <>= subroutine write_state_array (a, unit) real(kind=tao_r64), dimension(:), intent(in) :: a integer, intent(in) :: unit integer :: i do i = 1, size (a) write (unit = unit, fmt = "(1x,i10,1x,f30.0)") i, 2.0_tao_r64**52 * a(i) end do end subroutine write_state_array @ %def write_state_array @ <>= private :: write_state_array @ <>= subroutine read_state_array (a, unit) real(kind=tao_r64), dimension(:), intent(inout) :: a integer, intent(in) :: unit real(kind=tao_r64) :: x integer :: i, idum do i = 1, size (a) read (unit = unit, fmt = *) idum, x a(i) = 2.0_tao_r64**(-52) * x end do end subroutine read_state_array @ %def read_state_array @ <>= private :: read_state_array @ <>= subroutine find_free_unit (u, iostat) integer, intent(out) :: u integer, intent(out), optional :: iostat logical :: exists, is_open integer :: i, status do i = MIN_UNIT, MAX_UNIT inquire (unit = i, exist = exists, opened = is_open, & iostat = status) if (status == 0) then if (exists .and. .not. is_open) then u = i if (present (iostat)) then iostat = 0 end if return end if end if end do if (present (iostat)) then iostat = -1 end if u = -1 end subroutine find_free_unit @ \index{system dependencies} <>= integer, parameter, private :: MIN_UNIT = 11, MAX_UNIT = 99 @ %def MIN_UNIT MAX_UNIT @ <>= private :: find_free_unit @ <>= subroutine write_state_name (s, name) type(tao_random_state), intent(in) :: s character(len=*), intent(in) :: name integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", file = name) call write_state_unit (s, unit) close (unit = unit) end subroutine write_state_name @ %def write_state_name @ <>= subroutine write_raw_state_name (s, name) type(tao_random_raw_state), intent(in) :: s character(len=*), intent(in) :: name integer :: unit call find_free_unit (unit) open (unit = unit, action = "write", status = "replace", file = name) call write_raw_state_unit (s, unit) close (unit = unit) end subroutine write_raw_state_name @ %def write_raw_state_name @ <>= subroutine read_state_name (s, name) type(tao_random_state), intent(inout) :: s character(len=*), intent(in) :: name integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", file = name) call read_state_unit (s, unit) close (unit = unit) end subroutine read_state_name @ %def read_state_name @ <>= subroutine read_raw_state_name (s, name) type(tao_random_raw_state), intent(inout) :: s character(len=*), intent(in) :: name integer :: unit call find_free_unit (unit) open (unit = unit, action = "read", status = "old", file = name) call read_raw_state_unit (s, unit) close (unit = unit) end subroutine read_raw_state_name @ %def read_raw_state_name @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Marshaling and Unmarshaling} Note that we can not use the~[[transfer]] intrinsic function for marshalling types that contain pointers that substitute for allocatable array components. [[transfer]] will copy the pointers in this case and not where they point to! <>= interface tao_random_marshal_size module procedure marshal_state_size, marshal_raw_state_size end interface interface tao_random_marshal module procedure marshal_state, marshal_raw_state end interface interface tao_random_unmarshal module procedure unmarshal_state, unmarshal_raw_state end interface @ %def tao_random_marshal_size @ %def tao_random_marshal @ %def tao_random_unmarshal @ <>= public :: tao_random_marshal private :: marshal_state, marshal_raw_state public :: tao_random_marshal_size private :: marshal_state_size, marshal_raw_state_size public :: tao_random_unmarshal private :: unmarshal_state, unmarshal_raw_state @ <>= pure subroutine marshal_state (s, ibuf, dbuf) type(tao_random_state), intent(in) :: s integer, dimension(:), intent(inout) :: ibuf real(kind=tao_r64), dimension(:), intent(inout) :: dbuf integer :: buf_size buf_size = size (s%buffer) ibuf(1) = s%buffer_end ibuf(2) = s%last ibuf(3) = buf_size ibuf(4:3+buf_size) = s%buffer call marshal_raw_state (s%state, ibuf(4+buf_size:), dbuf) end subroutine marshal_state @ %def marshal_state @ <>= pure subroutine marshal_state_size (s, iwords, dwords) type(tao_random_state), intent(in) :: s integer, intent(out) :: iwords, dwords call marshal_raw_state_size (s%state, iwords, dwords) iwords = iwords + 3 + size (s%buffer) end subroutine marshal_state_size @ %def marshal_state_size @ <>= pure subroutine unmarshal_state (s, ibuf, dbuf) type(tao_random_state), intent(inout) :: s integer, dimension(:), intent(in) :: ibuf real(kind=tao_r64), dimension(:), intent(in) :: dbuf integer :: buf_size s%buffer_end = ibuf(1) s%last = ibuf(2) buf_size = ibuf(3) s%buffer = ibuf(4:3+buf_size) call unmarshal_raw_state (s%state, ibuf(4+buf_size:), dbuf) end subroutine unmarshal_state @ %def marshal_state @ <>= pure subroutine marshal_raw_state (s, ibuf, dbuf) type(tao_random_raw_state), intent(in) :: s integer, dimension(:), intent(inout) :: ibuf real(kind=tao_r64), dimension(:), intent(inout) :: dbuf ibuf(1) = size (s%x) ibuf(2:1+size(s%x)) = s%x end subroutine marshal_raw_state @ %def marshal_raw_state @ <>= pure subroutine marshal_raw_state_size (s, iwords, dwords) type(tao_random_raw_state), intent(in) :: s integer, intent(out) :: iwords, dwords iwords = 1 + size (s%x) dwords = 0 end subroutine marshal_raw_state_size @ %def marshal_raw_state_size @ <>= pure subroutine unmarshal_raw_state (s, ibuf, dbuf) type(tao_random_raw_state), intent(inout) :: s integer, dimension(:), intent(in) :: ibuf real(kind=tao_r64), dimension(:), intent(in) :: dbuf integer :: buf_size buf_size = ibuf(1) s%x = ibuf(2:1+buf_size) end subroutine unmarshal_raw_state @ %def marshal_raw_state @ <>= pure subroutine marshal_state (s, ibuf, dbuf) type(tao_random_state), intent(in) :: s integer, dimension(:), intent(inout) :: ibuf real(kind=tao_r64), dimension(:), intent(inout) :: dbuf integer :: buf_size buf_size = size (s%buffer) ibuf(1) = s%buffer_end ibuf(2) = s%last ibuf(3) = buf_size dbuf(1:buf_size) = s%buffer call marshal_raw_state (s%state, ibuf(4:), dbuf(buf_size+1:)) end subroutine marshal_state @ %def marshal_state @ <>= pure subroutine marshal_state_size (s, iwords, dwords) type(tao_random_state), intent(in) :: s integer, intent(out) :: iwords, dwords call marshal_raw_state_size (s%state, iwords, dwords) iwords = iwords + 3 dwords = dwords + size(s%buffer) end subroutine marshal_state_size @ %def marshal_state_size @ <>= pure subroutine unmarshal_state (s, ibuf, dbuf) type(tao_random_state), intent(inout) :: s integer, dimension(:), intent(in) :: ibuf real(kind=tao_r64), dimension(:), intent(in) :: dbuf integer :: buf_size s%buffer_end = ibuf(1) s%last = ibuf(2) buf_size = ibuf(3) s%buffer = dbuf(1:buf_size) call unmarshal_raw_state (s%state, ibuf(4:), dbuf(buf_size+1:)) end subroutine unmarshal_state @ %def unmarshal_state @ <>= pure subroutine marshal_raw_state (s, ibuf, dbuf) type(tao_random_raw_state), intent(in) :: s integer, dimension(:), intent(inout) :: ibuf real(kind=tao_r64), dimension(:), intent(inout) :: dbuf ibuf(1) = size (s%x) dbuf(1:size(s%x)) = s%x end subroutine marshal_raw_state @ %def marshal_raw_state @ <>= pure subroutine marshal_raw_state_size (s, iwords, dwords) type(tao_random_raw_state), intent(in) :: s integer, intent(out) :: iwords, dwords iwords = 1 dwords = size (s%x) end subroutine marshal_raw_state_size @ %def marshal_raw_state_size @ <>= pure subroutine unmarshal_raw_state (s, ibuf, dbuf) type(tao_random_raw_state), intent(inout) :: s integer, dimension(:), intent(in) :: ibuf real(kind=tao_r64), dimension(:), intent(in) :: dbuf integer :: buf_size buf_size = ibuf(1) s%x = dbuf(1:buf_size) end subroutine unmarshal_raw_state @ %def unmarshal_raw_state @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{High Level Routines} <<[[tao_random_numbers.f90]]>>= ! tao_random_numbers.f90 -- <> module tao_random_numbers use kinds implicit none integer, parameter, private :: tao_i32 = selected_int_kind (9) integer, parameter, private :: tao_r64 = selected_real_kind (15) <> <> <> <> <> <> <> <> contains <> <> end module tao_random_numbers @ %def tao_random_numbers @ <<[[tao52_random_numbers.f90]]>>= ! tao52_random_numbers.f90 -- <> module tao52_random_numbers use kinds implicit none integer, parameter, private :: tao_i32 = selected_int_kind (9) integer, parameter, private :: tao_r64 = selected_real_kind (15) <> <> <> <> <> <> <> <> contains <> <> end module tao52_random_numbers @ %def tao52_random_numbers @ Ten functions are exported <>= public :: tao_random_number public :: tao_random_seed public :: tao_random_create public :: tao_random_destroy public :: tao_random_copy public :: tao_random_read public :: tao_random_write public :: tao_random_flush ! public :: tao_random_luxury public :: tao_random_test @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Single Random Numbers} A random integer $r$ with $0 \le r < 2^{30} = 1073741824$: <>= pure subroutine integer_stateless & (state, buffer, buffer_end, last, r) integer(kind=tao_i32), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last integer, intent(out) :: r integer, parameter :: NORM = 1 <> end subroutine integer_stateless @ %def integer_stateless @ <>= <> r = NORM * buffer(last) @ The low level routine [[generate]] will fill an array $a_1,\ldots,a_n$, which will be consumed and refilled like an input buffer. We need at least $n \ge K$ for the call to [[generate]]. <>= integer(kind=tao_i32), dimension(DEFAULT_BUFFER_SIZE), save, private :: s_buffer integer, save, private :: s_buffer_end = size (s_buffer) integer, save, private :: s_last = size (s_buffer) @ %def s_buffer s_buffer_end s_last @ Increment the index [[last]] and reload the array [[buffer]], iff this buffer is exhausted. Throughout these routines, [[last]] will point to random number that has just been consumed. For the array filling routines below, this is simpler than pointing to the next waiting number. <>= last = last + 1 if (last > buffer_end) then call generate (buffer, state) last = 1 end if @ A random real $r \in [0,1)$. This is almost identical to [[tao_random_integer]], but we duplicate the code to avoid the function call overhead for speed. <>= pure subroutine real_stateless (state, buffer, buffer_end, last, r) integer(kind=tao_i32), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last real(kind=default), intent(out) :: r real(kind=default), parameter :: NORM = 1.0_default / M <> end subroutine real_stateless @ %def real_stateless @ A random real $r \in [0,1)$. <>= pure subroutine real_stateless (state, buffer, buffer_end, last, r) real(kind=tao_r64), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last real(kind=default), intent(out) :: r integer, parameter :: NORM = 1 <> end subroutine real_stateless @ %def real_stateless @ The low level routine [[generate]] will fill an array $a_1,\ldots,a_N$, which will be consumed and refilled like an input buffer. <>= real(kind=tao_r64), dimension(DEFAULT_BUFFER_SIZE), save, private :: s_buffer integer, save, private :: s_buffer_end = size (s_buffer) integer, save, private :: s_last = size (s_buffer) @ %def s_buffer buffer_end last @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Arrays of Random Numbers} Fill the array $j_1,\ldots,j_\nu$ with random integers $0 \le j_i < 2^{30} = 1073741824$. This has to be done such that the underlying array length in [[generate]] is transparent to the user. At the same time we want to avoid the overhead of calling [[tao_random_real]] $\nu$ times. <>= pure subroutine integer_array_stateless & (state, buffer, buffer_end, last, v, num) integer(kind=tao_i32), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last integer, dimension(:), intent(out) :: v integer, optional, intent(in) :: num integer, parameter :: NORM = 1 <> end subroutine integer_array_stateless @ %def integer_array_stateless @ <>= integer :: nu, done, todo, chunk <> <> v(1:chunk) = NORM * buffer(last+1:last+chunk) do <> <> v(done+1:done+chunk) = NORM * buffer(1:chunk) end do @ <>= if (present (num)) then nu = num else nu = size (v) end if @ [[last]] is used as an offset into the buffer [[buffer]], as usual. [[done]] is an offset into the target. We still have to process all [[nu]] numbers. The first chunk can only use what's left in the buffer. <>= if (last >= buffer_end) then call generate (buffer, state) last = 0 end if done = 0 todo = nu chunk = min (todo, buffer_end - last) @ This logic is a bit weird, but after the first chunk, [[todo]] will either vanish (in which case we're done) or we have consumed all of the buffer and must reload. In any case we can pretend that the next chunk can use the whole buffer. <>= last = last + chunk done = done + chunk todo = todo - chunk chunk = min (todo, buffer_end) @ <>= if (chunk <= 0) then exit end if call generate (buffer, state) last = 0 @ <>= pure subroutine real_array_stateless & (state, buffer, buffer_end, last, v, num) integer(kind=tao_i32), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last real(kind=default), dimension(:), intent(out) :: v integer, optional, intent(in) :: num real(kind=default), parameter :: NORM = 1.0_default / M <> end subroutine real_array_stateless @ %def real_array_stateless @ Fill the array $v_1,\ldots,v_\nu$ with uniform deviates $v_i \in [0,1)$. <>= pure subroutine real_array_stateless & (state, buffer, buffer_end, last, v, num) real(kind=tao_r64), dimension(:), intent(inout) :: state, buffer integer, intent(in) :: buffer_end integer, intent(inout) :: last real(kind=default), dimension(:), intent(out) :: v integer, optional, intent(in) :: num integer, parameter :: NORM = 1 <> end subroutine real_array_stateless @ %def real_array_stateless @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Procedures With Explicit \texttt{tao\_random\_state}} Unfortunately, this is very boring, but Fortran's lack of parametric polymorphism forces this duplication on us: <>= elemental subroutine integer_state (s, r) type(tao_random_state), intent(inout) :: s integer, intent(out) :: r call integer_stateless (s%state%x, s%buffer, s%buffer_end, s%last, r) end subroutine integer_state @ %def integer_state @ <>= elemental subroutine real_state (s, r) type(tao_random_state), intent(inout) :: s real(kind=default), intent(out) :: r call real_stateless (s%state%x, s%buffer, s%buffer_end, s%last, r) end subroutine real_state @ %def real_state @ <>= elemental subroutine real_state (s, r) type(tao_random_state), intent(inout) :: s real(kind=default), intent(out) :: r call real_stateless (s%state%x, s%buffer, s%buffer_end, s%last, r) end subroutine real_state @ %def real_state @ <>= pure subroutine integer_array_state (s, v, num) type(tao_random_state), intent(inout) :: s integer, dimension(:), intent(out) :: v integer, optional, intent(in) :: num call integer_array_stateless & (s%state%x, s%buffer, s%buffer_end, s%last, v, num) end subroutine integer_array_state @ %def integer_array_state @ <>= pure subroutine real_array_state (s, v, num) type(tao_random_state), intent(inout) :: s real(kind=default), dimension(:), intent(out) :: v integer, optional, intent(in) :: num call real_array_stateless & (s%state%x, s%buffer, s%buffer_end, s%last, v, num) end subroutine real_array_state @ %def real_array_state @ <>= pure subroutine real_array_state (s, v, num) type(tao_random_state), intent(inout) :: s real(kind=default), dimension(:), intent(out) :: v integer, optional, intent(in) :: num call real_array_stateless & (s%state%x, s%buffer, s%buffer_end, s%last, v, num) end subroutine real_array_state @ %def real_array_state @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Static Procedures} First make sure that [[tao_random_seed]] has been called to initialize the generator state: <>= if (s_virginal) then call tao_random_seed () end if @ <>= subroutine integer_static (r) integer, intent(out) :: r <> call integer_stateless (s_state, s_buffer, s_buffer_end, s_last, r) end subroutine integer_static @ %def integer_static @ <>= subroutine real_static (r) real(kind=default), intent(out) :: r <> call real_stateless (s_state, s_buffer, s_buffer_end, s_last, r) end subroutine real_static @ %def real_static @ <>= subroutine real_static (r) real(kind=default), intent(out) :: r <> call real_stateless (s_state, s_buffer, s_buffer_end, s_last, r) end subroutine real_static @ %def real_static @ <>= subroutine integer_array_static (v, num) integer, dimension(:), intent(out) :: v integer, optional, intent(in) :: num <> call integer_array_stateless & (s_state, s_buffer, s_buffer_end, s_last, v, num) end subroutine integer_array_static @ %def integer_array_static @ <>= subroutine real_array_static (v, num) real(kind=default), dimension(:), intent(out) :: v integer, optional, intent(in) :: num <> call real_array_stateless & (s_state, s_buffer, s_buffer_end, s_last, v, num) end subroutine real_array_static @ %def real_array_static @ <>= subroutine real_array_static (v, num) real(kind=default), dimension(:), intent(out) :: v integer, optional, intent(in) :: num <> call real_array_stateless & (s_state, s_buffer, s_buffer_end, s_last, v, num) end subroutine real_array_static @ %def real_array_static @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Generic Procedures} <>= interface tao_random_number module procedure <> end interface @ %def tao_random_number @ <>= integer_static, integer_state, & integer_array_static, integer_array_state, & real_static, real_state, real_array_static, real_array_state @ These are not exported <>= private :: & integer_stateless, integer_array_stateless, & real_stateless, real_array_stateless @ <>= private :: <> @ <>= interface tao_random_number module procedure <> end interface @ <>= real_static, real_state, real_array_static, real_array_state @ Thes are not exported <>= private :: real_stateless, real_array_stateless @ <>= private :: <> @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Luxury} <>= pure subroutine luxury_stateless & (buffer_size, buffer_end, last, consumption) integer, intent(in) :: buffer_size integer, intent(inout) :: buffer_end integer, intent(inout) :: last integer, intent(in) :: consumption if (consumption >= 1 .and. consumption <= buffer_size) then buffer_end = consumption last = min (last, buffer_end) else !!! print *, "tao_random_luxury: ", "invalid consumption ", & !!! consumption, ", not in [ 1,", buffer_size, "]." buffer_end = buffer_size end if end subroutine luxury_stateless @ %def luxury_stateless @ <>= elemental subroutine luxury_state (s) type(tao_random_state), intent(inout) :: s call luxury_state_integer (s, size (s%buffer)) end subroutine luxury_state @ %def luxury_state @ <>= elemental subroutine luxury_state_integer (s, consumption) type(tao_random_state), intent(inout) :: s integer, intent(in) :: consumption call luxury_stateless (size (s%buffer), s%buffer_end, s%last, consumption) end subroutine luxury_state_integer @ %def luxury_state_integer @ <>= elemental subroutine luxury_state_real (s, consumption) type(tao_random_state), intent(inout) :: s real(kind=default), intent(in) :: consumption call luxury_state_integer (s, int (consumption * size (s%buffer))) end subroutine luxury_state_real @ %def luxury_state_real @ <>= subroutine luxury_static () <> call luxury_static_integer (size (s_buffer)) end subroutine luxury_static @ %def luxury_static @ <>= subroutine luxury_static_integer (consumption) integer, intent(in) :: consumption <> call luxury_stateless (size (s_buffer), s_buffer_end, s_last, consumption) end subroutine luxury_static_integer @ %def luxury_static_integer @ <>= subroutine luxury_static_real (consumption) real(kind=default), intent(in) :: consumption <> call luxury_static_integer (int (consumption * size (s_buffer))) end subroutine luxury_static_real @ %def luxury_static_real @ <>= interface tao_random_luxury module procedure <> end interface @ %def tao_random_luxury @ <>= private :: luxury_stateless @ <>= private :: <> @ <>= luxury_static, luxury_state, & luxury_static_integer, luxury_state_integer, & luxury_static_real, luxury_state_real @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Testing} @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{30-bit} <>= subroutine tao_random_test (name) character(len=*), optional, intent(in) :: name character (len = *), parameter :: & OK = "(1x,i10,' is ok.')", & NOT_OK = "(1x,i10,' is not ok, (expected ',i10,')!')" <> integer, parameter :: & A_2027082 = 995235265 integer, dimension(N) :: a type(tao_random_state) :: s, t integer, dimension(:), allocatable :: ibuf real(kind=tao_r64), dimension(:), allocatable :: dbuf integer :: i, ibuf_size, dbuf_size print *, "testing the 30-bit tao_random_numbers ..." <> <> end subroutine tao_random_test @ %def tao_random_test @ <>= integer, parameter :: & SEED = 310952, & N = 2009, M = 1009, & N_SHORT = 1984 @ DEK's ``official'' test expects~$a_{1009\cdot2009+1}=a_{2027082}=995235265$: <>= ! call tao_random_luxury () call tao_random_seed (SEED) do i = 1, N+1 call tao_random_number (a, M) end do -<> +<> @ -<>= +<>= if (a(1) == A_2027082) then print OK, a(1) else print NOT_OK, a(1), A_2027082 stop 1 end if @ Deja vu all over again, but 2027081 is factored the other way around this time <>= call tao_random_seed (SEED) do i = 1, M+1 call tao_random_number (a) end do -<> +<> @ Now checkpoint the random number generator after~$N_{\text{short}}\cdot M$ numbers <>= print *, "testing the stateless stuff ..." call tao_random_create (s, SEED) do i = 1, N_SHORT call tao_random_number (s, a, M) end do call tao_random_create (t, s) do i = 1, N+1 - N_SHORT call tao_random_number (s, a, M) end do -<> +<> @ and restart the saved generator <>= do i = 1, N+1 - N_SHORT call tao_random_number (t, a, M) end do -<> +<> @ The same story again, but this time saving the copy to a file <>= if (present (name)) then print *, "testing I/O ..." call tao_random_seed (s, SEED) do i = 1, N_SHORT call tao_random_number (s, a, M) end do call tao_random_write (s, name) do i = 1, N+1 - N_SHORT call tao_random_number (s, a, M) end do - <> + <> call tao_random_read (s, name) do i = 1, N+1 - N_SHORT call tao_random_number (s, a, M) end do - <> + <> end if @ And finally using marshaling/unmarshaling: <>= print *, "testing marshaling/unmarshaling ..." call tao_random_seed (s, SEED) do i = 1, N_SHORT call tao_random_number (s, a, M) end do call tao_random_marshal_size (s, ibuf_size, dbuf_size) allocate (ibuf(ibuf_size), dbuf(dbuf_size)) call tao_random_marshal (s, ibuf, dbuf) do i = 1, N+1 - N_SHORT call tao_random_number (s, a, M) end do -<> +<> call tao_random_unmarshal (s, ibuf, dbuf) do i = 1, N+1 - N_SHORT call tao_random_number (s, a, M) end do -<> +<> @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{52-bit} DEK's ``official'' test expects~$x_{1009\cdot2009+1}=x_{2027082}=0.36410514377569680455$: <>= subroutine tao_random_test (name) character(len=*), optional, intent(in) :: name character(len=*), parameter :: & OK = "(1x,f22.20,' is ok.')", & NOT_OK = "(1x,f22.20,' is not ok, (A_2027082 ',f22.20,')!')" <> real(kind=default), parameter :: & A_2027082 = 0.36410514377569680455_tao_r64 real(kind=default), dimension(N) :: a type(tao_random_state) :: s, t integer, dimension(:), allocatable :: ibuf real(kind=tao_r64), dimension(:), allocatable :: dbuf integer :: i, ibuf_size, dbuf_size print *, "testing the 52-bit tao_random_numbers ..." <> <> end subroutine tao_random_test @ %def tao_random_test @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \subsection{Test Program} <<[[tao_test.f90]]>>= program tao_test use tao_random_numbers, only: test30 => tao_random_test use tao52_random_numbers, only: test52 => tao_random_test implicit none call test30 ("tmp.tao") call test52 ("tmp.tao") stop 0 end program tao_test @ %def tao_test @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%