Index: trunk/circe1/share/doc/Makefile.am =================================================================== --- trunk/circe1/share/doc/Makefile.am (revision 8883) +++ trunk/circe1/share/doc/Makefile.am (revision 8884) @@ -1,318 +1,318 @@ # Makefile.am -- ######################################################################## # # Copyright (C) 1999-2023 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD 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. # # WHIZARD 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. # ######################################################################## CIRCE1_VER = 1 CIRCE1_REV = 0 WEBS = \ prelude.nw \ circe1.nw minuit.nw postlude.nw if DISTRIBUTION PDFS = circe1.pdf else PDFS = endif PICTURES_PDF = \ figures1.pdf fit11.pdf fit12.pdf \ fit21.pdf fit22.pdf fit13.pdf \ fit23.pdf fit15.pdf fit25.pdf \ dist78.pdf LATEX_STYLES = \ noweb.sty thohacks.sty thopp.sty -TEX_FLAGS = "$$TEXINPUTS:$(top_srcdir)/circe1/share/doc" -MP_FLAGS = "$$MPINPUTS:$(top_srcdir)/circe1/share/doc" +TEX_FLAGS = "$(top_srcdir)/circe1/share/doc:$$TEXINPUTS" +MP_FLAGS = "$(top_srcdir)/circe1/share/doc:$$MPINPUTS" MP4_FILES = \ circemacs.mp4 dist.mp4 fit.mp4 graphx.mp EXTRA_DIST = \ tex-comments.sh \ $(PICTURES_PDF) \ $(LATEX_STYLES) \ $(MP4_FILES) dist_doc_DATA = $(PDFS) if NOWEB_AVAILABLE pdf-local: circe1.pdf endif VPATH = $(srcdir):$(top_builddir)/circe1/src:$(top_srcdir)/circe1/src if NOWEB_AVAILABLE circe1.tex: $(WEBS) @if $(AM_V_P); then :; else echo " NOWEAVE " $@; fi $(AM_V_at)$(NOWEAVE) -filter ./tex-comments -delay -index \ `for i in $^; do case $$i in *.nw) echo $$i;; esac done` \ > $@ circe1.tex: tex-comments endif NOWEB_AVAILABLE .mp4.mp: circemacs.mp4 @if $(AM_V_P); then :; else echo " M4 " $@; fi $(AM_V_at)$(M4) -I$(top_srcdir)/circe1/share/doc $< >$@ ######################################################################## # Old targets for the fit plots ######################################################################## fit.mp dist.mp: circemacs.mp4 fit.11: fit.mp TEX=$(LATEX) TEXINPUTS=$(TEX_FLAGS) $(MPOST) $< ######################################################################## # The distribution plots for the write-up ######################################################################## dist.1: dist.mp \ de-sband.dat dg-sband.dat de-tesla.dat dg-tesla.dat \ de-xband.dat dg-xband.dat de-sbandt.dat dg-sbandt.dat \ de-teslat.dat dg-teslat.dat de-xbandt.dat dg-xbandt.dat \ de-tesla3.dat dg-tesla3.dat de-tesla8.dat dg-tesla8.dat \ de-sband-ee.dat dg-sband-ee.dat de-tesla-ee.dat dg-tesla-ee.dat \ de-xband-ee.dat dg-xband-ee.dat de-sbandt-ee.dat dg-sbandt-ee.dat \ de-teslat-ee.dat dg-teslat-ee.dat de-xbandt-ee.dat dg-xbandt-ee.dat @if $(AM_V_P); then TEX=$(LATEX) TEXINPUTS=$(TEX_FLAGS) \ MPINPUTS=$(MP_FLAGS) $(MPOST) $<; else \ echo " METAPOST " $@; TEX=$(LATEX) TEXINPUTS=$(TEX_FLAGS) \ MPINPUTS=$(MP_FLAGS) $(MPOST) $< >/dev/null; fi ######################################################################## # Generating CIRCE data ######################################################################## de-sband.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 500.0 1 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-sband.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 500.0 1 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-tesla.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 500.0 2 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-tesla.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 500.0 2 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-xband.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 500.0 3 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-xband.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 500.0 3 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-sbandt.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 1000.0 1 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-sbandt.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 1000.0 1 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-teslat.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 1000.0 2 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-teslat.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 1000.0 2 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-xbandt.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 1000.0 3 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-xbandt.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 1000.0 3 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-tesla3.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 350.0 2 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-tesla3.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 350.0 2 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-tesla8.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 800.0 2 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-tesla8.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 800.0 2 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-sband-ee.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 500.0 4 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-sband-ee.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 500.0 4 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-tesla-ee.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 500.0 5 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-tesla-ee.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 500.0 5 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-xband-ee.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 500.0 6 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-xband-ee.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 500.0 6 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-sbandt-ee.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 1000.0 4 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-sbandt-ee.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 1000.0 4 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-teslat-ee.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 1000.0 5 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-teslat-ee.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 1000.0 5 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) de-xbandt-ee.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 11 11 1000.0 6 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) dg-xbandt-ee.dat: $(top_builddir)/circe1/tools/circe1_plot @if $(AM_V_P); then :; else echo " PLOT " $@; fi $(AM_V_at)echo 1 0.001 1.0 50 -1.0 22 11 1000.0 6 $(CIRCE1_VER) $(CIRCE1_REV) | $(CPLOT) CPLOT = $(top_builddir)/circe1/tools/circe1_plot | $(GREP) -v circe1: | $(SED) 's/E/e/g' > $@ tex-comments: tex-comments.sh cp $< $@ chmod +x $@ SUFFIXES = .tex .pdf if DISTRIBUTION if PDFLATEX_AVAILABLE if CONTEXT_AVAILABLE .tex.pdf: @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; else \ echo " PDFLATEX " $<; TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; fi if MAKEINDEX_AVAILABLE @if $(AM_V_P); then $(MAKEINDEX) -o $*.ind $*.idx; else \ echo " MAKEINDEX " $*.ind $*.idx; $(MAKEINDEX) -q -o $*.ind $*.idx; fi endif MAKEINDEX_AVAILABLE @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; else \ echo " PDFLATEX " $<; TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; fi @if $(AM_V_P); then \ if grep -s 'Rerun to get cross-references right.' $*.log; then \ TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; \ fi; else \ if grep -s 'Rerun to get cross-references right.' $*.log >/dev/null; then \ echo " PDFLATEX " $< "(for cross-references)"; \ TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; \ fi; \ fi endif CONTEXT_AVAILABLE endif PDFLATEX_AVAILABLE endif DISTRIBUTION if DISTRIBUTION if CONTEXT_AVAILABLE if PDFLATEX_AVAILABLE if !NOWEB_AVAILABLE circe1.pdf: $(PICTURES_PDF) dist.1 else NOWEB_AVAILABLE circe1.pdf: $(PICTURES_PDF) dist.1 circe1.tex endif NOWEB_AVAILABLE endif PDFLATEX_AVAILABLE endif CONTEXT_AVAILABLE endif DISTRIBUTION ######################################################################## ## Cleanup tasks mostlyclean-latex: -rm -f *.data *.mpx *.[1-9] *.t[1-9] circe*.mp preview*.mp \ circe1.tex *.out *.log *.aux *.idx *.ilg *.ind *.toc \ $(PICTURES_PDF) tex-comments circe1_plot *.dat dist.mp \ fit.mp dist.11 dist.12 dist.13 dist.14 -test "$(srcdir)" != "." && rm -f $(PDFS) clean-latex: maintainer-clean-latex: -rm -f $(PDFS) if NOWEB_AVAILABLE mostlyclean-circe1: -test "$(srcdir)" != "." && rm -f $(PDFS) maintainer-clean-circe1: else mostlyclean-circe1: maintainer-clean-circe1: endif .PHONY: mostlyclean-latex clean-latex maintainer-clean-latex .PHONY: mostlyclean-circe1 maintainer-clean-circe1 ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets mostlyclean-local: mostlyclean-latex mostlyclean-circe1 clean-local: clean-latex maintainer-clean-local: maintainer-clean-backup \ maintainer-clean-circe1 maintainer-clean-latex if !DISTRIBUTION install-data-hook: -$(INSTALL) -m 644 circe1.pdf $(DESTDIR)$(datarootdir)/doc/circe1 uninstall-hook: -rm -f $(DESTDIR)/$(datarootdir)/doc/circe1/circe1.pdf endif ######################################################################## ## The End. ######################################################################## Index: trunk/circe2/share/doc/Makefile.am =================================================================== --- trunk/circe2/share/doc/Makefile.am (revision 8883) +++ trunk/circe2/share/doc/Makefile.am (revision 8884) @@ -1,237 +1,237 @@ # Makefile.am -- ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2023 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD 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. # # WHIZARD 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. # ######################################################################## DISTCLEANFILES = include $(top_srcdir)/circe2/src/Makefile.sources VPATH = $(srcdir):$(top_builddir)/circe2/src:$(srcdir):$(top_srcdir)/circe2/src WEBS = prelude.nw circe2.nw postlude.nw if DISTRIBUTION PDFS = circe2.pdf else PDFS = endif LATEX_STYLES = \ emp.sty noweb.sty thohacks.sty thopp.sty ocamlweb.sty -TEX_FLAGS = "$$TEXINPUTS:$(top_srcdir)/circe2/share/doc" -MP_FLAGS = "$$MPINPUTS:$(top_srcdir)/circe2/share/doc" +TEX_FLAGS = "$(top_srcdir)/circe2/share/doc:$$TEXINPUTS" +MP_FLAGS = "$(top_srcdir)/circe2/share/doc:$$MPINPUTS" CIRCE2_HISTOS = \ x.20.histo x.20m.histo x.20q.histo x.20qm.histo x.input.histo \ z.20.histo z.20m2.histo z.20m.histo z.20q.histo z.20qm.histo \ z.50m2.histo z.input.histo \ z_low.20.histo z_low.20m2.histo z_low.20m.histo z_low.20q.histo \ z_low.20qm.histo z_low.50.histo z_low.50m2.histo z_low.50q.histo \ z_low.input.histo CIRCE2_HISTOSDATA = $(CIRCE2_HISTOS:.histo=.data) DISTCLEANFILES += $(CIRCE2_HISTOS) EXTRA_DIST = \ tex-comments.sh \ $(LATEX_STYLES) \ $(CIRCE2_HISTOSDATA) if DISTRIBUTION dist_doc_DATA = $(PDFS) endif if NOWEB_AVAILABLE pdf-local: circe2.pdf endif if NOWEB_AVAILABLE circe2.tex: $(WEBS) @if $(AM_V_P); then :; else echo " NOWEAVE " $@; fi $(AM_V_at)$(NOWEAVE) -filter ./tex-comments -delay -index \ `for i in $^; do case $$i in *.nw) echo $$i;; esac done` \ > $@ circe2.tex: tex-comments endif NOWEB_AVAILABLE tex-comments: tex-comments.sh cp $< $@ chmod +x $@ .data.histo: @if $(AM_V_P); then :; else echo " CP " $@; fi $(AM_V_at)cp $< $@ # preview.pdf: vegas.data vamp.data # vegas.data: vegas.d # cp $< $@ # # vamp.data: vamp.d # cp $< $@ SUFFIXES = \ .mly .mll .ml .implementation .mli .interface \ .data .histo .tex .pdf \ .nw .dvi .eps .ps if !NOWEB_AVAILABLE circe2.pdf: else NOWEB_AVAILABLE circe2.pdf: $(CIRCE2_INTERFACE) $(CIRCE2_IMPLEMENTATION) \ $(CIRCE2TOOL_IMPLEMENTATION) circe2.tex \ index.tex $(CIRCE2_HISTOS) if DISTRIBUTION if OCAMLWEB_AVAILABLE .mll.implementation: @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb --no-index $< >$@ .mly.implementation: @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb --no-index $< >$@ .ml.implementation: @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb --no-index $< >$@ .mli.interface: @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb --no-index $< >$@ index.tex: $(CIRCE2_CAML) $(CIRCE2_DERIVED) @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb $^ | \ sed -n '/\\ocwbeginindex{}/,/\\ocwendindex{}/p' >$@ endif OCAMLWEB_AVAILABLE endif DISTRIBUTION endif NOWEB_AVAILABLE MPOST_LATEX = TEX=$(LATEX) TEXINPUTS=$(TEX_FLAGS) $(MPOST) if DISTRIBUTION if PDFLATEX_AVAILABLE if CONTEXT_AVAILABLE .tex.pdf: @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; else \ echo " PDFLATEX " $<; TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; fi if MAKEINDEX_AVAILABLE @if $(AM_V_P); then $(MAKEINDEX) -o $*.ind $*.idx; else \ echo " MAKEINDEX " $*.ind $*.idx; $(MAKEINDEX) -q -o $*.ind $*.idx; fi endif MAKEINDEX_AVAILABLE if MPOST_AVAILABLE @if $(AM_V_P); then test -r $*.mp && $(MPOST_LATEX) $*; else \ echo " METAPOST " $*.mp; test -r $*.mp && $(MPOST_LATEX) $* >/dev/null; fi endif MPOST_AVAILABLE @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; else \ echo " PDFLATEX " $<; TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; fi @if $(AM_V_P); then \ if grep -s 'Rerun to get cross-references right.' $*.log; then \ TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; \ fi; else \ if grep -s 'Rerun to get cross-references right.' $*.log >/dev/null; then \ echo " PDFLATEX " $< "(for cross-references)"; \ TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; \ fi; \ fi endif CONTEXT_AVAILABLE endif PDFLATEX_AVAILABLE endif DISTRIBUTION ## Cleanup tasks mostlyclean-latex: -rm -f *.mpx *.[1-9]* *.t[1-9]* circe*.mp preview*.mp \ *.out *.log *.aux *.idx *.ilg *.ind tex-comments *.toc \ circe2.tex clean-latex: maintainer-clean-latex: -rm $(PDFS) if NOWEB_AVAILABLE if OCAMLWEB_AVAILABLE mostlyclean-circe2: -test "$(srcdir)" != "." && rm -f $(PDFS) maintainer-clean-circe2: else mostlyclean-circe2: maintainer-clean-circe2: endif endif .PHONY: mostlyclean-latex clean-latex maintainer-clean-latex .PHONY: mostlyclean-circe2 maintainer-clean-circe2 if OCAMLWEB_AVAILABLE mostlyclean-caml: -rm -f *.interface *.implementation index.tex else mostlyclean-caml: endif clean-caml: if OCAMLWEB_AVAILABLE maintainer-clean-caml: -rm -f *.interface *.implementation index.tex else maintainer-clean-caml: endif .PHONY: mostlyclean-caml clean-caml maintainer-clean-caml ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets mostlyclean-local: mostlyclean-latex mostlyclean-circe2 \ mostlyclean-caml clean-local: clean-latex clean-caml maintainer-clean-local: maintainer-clean-latex maintainer-clean-circe2 \ maintainer-clean-caml maintainer-clean-backup if !DISTRIBUTION install-data-hook: -$(INSTALL) -m 644 circe2.pdf $(DESTDIR)$(datarootdir)/doc/circe2 uninstall-hook: -rm -f $(DESTDIR)/$(datarootdir)/doc/circe2/circe2.pdf endif ######################################################################## ## The End. ######################################################################## Index: trunk/src/types/types.nw =================================================================== --- trunk/src/types/types.nw (revision 8883) +++ trunk/src/types/types.nw (revision 8884) @@ -1,9251 +1,9251 @@ %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: common types and objects %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Sindarin Built-In Types} \includemodulegraph{types} Here, we define a couple of types and objects which are useful both internally for \whizard, and visible to the user, so they correspond to Sindarin types. \begin{description} \item[particle\_specifiers] Expressions for particles and particle alternatives, involving particle names. \item[pdg\_arrays] Integer (PDG) codes for particles. Useful for particle aliases (e.g., 'quark' for $u,d,s$ etc.). \item[jets] Define (pseudo)jets as objects. Functional only if the [[fastjet]] library is linked. (This may change in the future.) \item[subevents] Particle collections built from event records, for use in analysis and other Sindarin expressions \item[analysis] Observables, histograms, and plots. \end{description} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Particle Specifiers} In this module we introduce a type for specifying a particle or particle alternative. In addition to the particle specifiers (strings separated by colons), the type contains an optional flag [[polarized]] and a string [[decay]]. If the [[polarized]] flag is set, particle polarization information should be kept when generating events for this process. If the [[decay]] string is set, it is the ID of a decay process which should be applied to this particle when generating events. In input/output form, the [[polarized]] flag is indicated by an asterisk [[(*)]] in brackets, and the [[decay]] is indicated by its ID in brackets. The [[read]] and [[write]] procedures in this module are not type-bound but generic procedures which handle scalar and array arguments. <<[[particle_specifiers.f90]]>>= <> module particle_specifiers <> <> <> <> <> interface <> end interface contains <> end module particle_specifiers @ %def particle_specifiers @ <<[[particle_specifiers_sub.f90]]>>= <> submodule (particle_specifiers) particle_specifiers_s use io_units use diagnostics implicit none contains <> end submodule particle_specifiers_s @ %def particle_specifiers_s @ \subsection{Base type} This is an abstract type which can hold a single particle or an expression. <>= type, abstract :: prt_spec_expr_t contains <> end type prt_spec_expr_t @ %def prt_expr_t @ Output, as a string. <>= procedure (prt_spec_expr_to_string), deferred :: to_string <>= abstract interface function prt_spec_expr_to_string (object) result (string) import class(prt_spec_expr_t), intent(in) :: object type(string_t) :: string end function prt_spec_expr_to_string end interface @ %def prt_spec_expr_to_string @ Call an [[expand]] method for all enclosed subexpressions (before handling the current expression). <>= procedure (prt_spec_expr_expand_sub), deferred :: expand_sub <>= abstract interface subroutine prt_spec_expr_expand_sub (object) import class(prt_spec_expr_t), intent(inout) :: object end subroutine prt_spec_expr_expand_sub end interface @ %def prt_spec_expr_expand_sub @ \subsection{Wrapper type} This wrapper can hold a particle expression of any kind. We need it so we can make variadic arrays. <>= public :: prt_expr_t <>= type :: prt_expr_t class(prt_spec_expr_t), allocatable :: x contains <> end type prt_expr_t @ %def prt_expr_t @ Output as a string: delegate. <>= procedure :: to_string => prt_expr_to_string <>= recursive module function prt_expr_to_string (object) result (string) class(prt_expr_t), intent(in) :: object type(string_t) :: string end function prt_expr_to_string <>= recursive module function prt_expr_to_string (object) result (string) class(prt_expr_t), intent(in) :: object type(string_t) :: string if (allocated (object%x)) then string = object%x%to_string () else string = "" end if end function prt_expr_to_string @ %def prt_expr_to_string @ Allocate the expression as a particle specifier and copy the value. Due to compiler bugs in gfortran 7-9 not in submodule. <>= procedure :: init_spec => prt_expr_init_spec <>= subroutine prt_expr_init_spec (object, spec) class(prt_expr_t), intent(out) :: object type(prt_spec_t), intent(in) :: spec allocate (prt_spec_t :: object%x) select type (x => object%x) type is (prt_spec_t) x = spec end select end subroutine prt_expr_init_spec @ %def prt_expr_init_spec @ Allocate as a list/sum and allocate for a given length Due to compiler bugs in gfortran 7-9 not in submodule. <>= procedure :: init_list => prt_expr_init_list procedure :: init_sum => prt_expr_init_sum <>= subroutine prt_expr_init_list (object, n) class(prt_expr_t), intent(out) :: object integer, intent(in) :: n allocate (prt_spec_list_t :: object%x) select type (x => object%x) type is (prt_spec_list_t) allocate (x%expr (n)) end select end subroutine prt_expr_init_list subroutine prt_expr_init_sum (object, n) class(prt_expr_t), intent(out) :: object integer, intent(in) :: n allocate (prt_spec_sum_t :: object%x) select type (x => object%x) type is (prt_spec_sum_t) allocate (x%expr (n)) end select end subroutine prt_expr_init_sum @ %def prt_expr_init_list @ %def prt_expr_init_sum @ Return the number of terms. This is unity, except if the expression is a sum. <>= procedure :: get_n_terms => prt_expr_get_n_terms <>= module function prt_expr_get_n_terms (object) result (n) class(prt_expr_t), intent(in) :: object integer :: n end function prt_expr_get_n_terms <>= module function prt_expr_get_n_terms (object) result (n) class(prt_expr_t), intent(in) :: object integer :: n if (allocated (object%x)) then select type (x => object%x) type is (prt_spec_sum_t) n = size (x%expr) class default n = 1 end select else n = 0 end if end function prt_expr_get_n_terms @ %def prt_expr_get_n_terms @ Transform one of the terms, as returned by the previous method, to an array of particle specifiers. The array has more than one entry if the selected term is a list. This makes sense only if the expression has been completely expanded, so the list contains only atoms. <>= procedure :: term_to_array => prt_expr_term_to_array <>= recursive module subroutine prt_expr_term_to_array (object, array, i) class(prt_expr_t), intent(in) :: object type(prt_spec_t), dimension(:), intent(inout), allocatable :: array integer, intent(in) :: i end subroutine prt_expr_term_to_array <>= recursive module subroutine prt_expr_term_to_array (object, array, i) class(prt_expr_t), intent(in) :: object type(prt_spec_t), dimension(:), intent(inout), allocatable :: array integer, intent(in) :: i integer :: j if (allocated (array)) deallocate (array) select type (x => object%x) type is (prt_spec_t) allocate (array (1)) array(1) = x type is (prt_spec_list_t) allocate (array (size (x%expr))) do j = 1, size (array) select type (y => x%expr(j)%x) type is (prt_spec_t) array(j) = y end select end do type is (prt_spec_sum_t) call x%expr(i)%term_to_array (array, 1) end select end subroutine prt_expr_term_to_array @ %def prt_expr_term_to_array @ \subsection{The atomic type} The trivial case is a single particle, including optional decay and polarization attributes. \subsubsection{Definition} The particle is unstable if the [[decay]] array is allocated. The [[polarized]] flag and decays may not be set simultaneously. <>= public :: prt_spec_t <>= type, extends (prt_spec_expr_t) :: prt_spec_t private type(string_t) :: name logical :: polarized = .false. type(string_t), dimension(:), allocatable :: decay contains <> end type prt_spec_t @ %def prt_spec_t @ \subsubsection{I/O} Output. Old-style subroutines. <>= public :: prt_spec_write <>= interface prt_spec_write module procedure prt_spec_write1 module procedure prt_spec_write2 end interface prt_spec_write <>= module subroutine prt_spec_write1 (object, unit, advance) type(prt_spec_t), intent(in) :: object integer, intent(in), optional :: unit character(len=*), intent(in), optional :: advance end subroutine prt_spec_write1 <>= module subroutine prt_spec_write1 (object, unit, advance) type(prt_spec_t), intent(in) :: object integer, intent(in), optional :: unit character(len=*), intent(in), optional :: advance character(3) :: adv integer :: u u = given_output_unit (unit) adv = "yes"; if (present (advance)) adv = advance write (u, "(A)", advance = adv) char (object%to_string ()) end subroutine prt_spec_write1 @ %def prt_spec_write1 @ Write an array as a list of particle specifiers. <>= module subroutine prt_spec_write2 (prt_spec, unit, advance) type(prt_spec_t), dimension(:), intent(in) :: prt_spec integer, intent(in), optional :: unit character(len=*), intent(in), optional :: advance end subroutine prt_spec_write2 <>= module subroutine prt_spec_write2 (prt_spec, unit, advance) type(prt_spec_t), dimension(:), intent(in) :: prt_spec integer, intent(in), optional :: unit character(len=*), intent(in), optional :: advance character(3) :: adv integer :: u, i u = given_output_unit (unit) adv = "yes"; if (present (advance)) adv = advance do i = 1, size (prt_spec) if (i > 1) write (u, "(A)", advance="no") ", " call prt_spec_write (prt_spec(i), u, advance="no") end do write (u, "(A)", advance = adv) end subroutine prt_spec_write2 @ %def prt_spec_write2 @ Read. Input may be string or array of strings. <>= public :: prt_spec_read <>= interface prt_spec_read module procedure prt_spec_read1 module procedure prt_spec_read2 end interface prt_spec_read @ Read a single particle specifier <>= pure module subroutine prt_spec_read1 (prt_spec, string) type(prt_spec_t), intent(out) :: prt_spec type(string_t), intent(in) :: string end subroutine prt_spec_read1 <>= pure module subroutine prt_spec_read1 (prt_spec, string) type(prt_spec_t), intent(out) :: prt_spec type(string_t), intent(in) :: string type(string_t) :: arg, buffer integer :: b1, b2, c, n, i b1 = scan (string, "(") b2 = scan (string, ")") if (b1 == 0) then prt_spec%name = trim (adjustl (string)) else prt_spec%name = trim (adjustl (extract (string, 1, b1-1))) arg = trim (adjustl (extract (string, b1+1, b2-1))) if (arg == "*") then prt_spec%polarized = .true. else n = 0 buffer = arg do if (verify (buffer, " ") == 0) exit n = n + 1 c = scan (buffer, "+") if (c == 0) exit buffer = extract (buffer, c+1) end do allocate (prt_spec%decay (n)) buffer = arg do i = 1, n c = scan (buffer, "+") if (c == 0) c = len (buffer) + 1 prt_spec%decay(i) = trim (adjustl (extract (buffer, 1, c-1))) buffer = extract (buffer, c+1) end do end if end if end subroutine prt_spec_read1 @ %def prt_spec_read1 @ Read a particle specifier array, given as a single string. The array is allocated to the correct size. <>= pure module subroutine prt_spec_read2 (prt_spec, string) type(prt_spec_t), dimension(:), intent(out), allocatable :: prt_spec type(string_t), intent(in) :: string end subroutine prt_spec_read2 <>= pure module subroutine prt_spec_read2 (prt_spec, string) type(prt_spec_t), dimension(:), intent(out), allocatable :: prt_spec type(string_t), intent(in) :: string type(string_t) :: buffer integer :: c, i, n n = 0 buffer = string do n = n + 1 c = scan (buffer, ",") if (c == 0) exit buffer = extract (buffer, c+1) end do allocate (prt_spec (n)) buffer = string do i = 1, size (prt_spec) c = scan (buffer, ",") if (c == 0) c = len (buffer) + 1 call prt_spec_read (prt_spec(i), & trim (adjustl (extract (buffer, 1, c-1)))) buffer = extract (buffer, c+1) end do end subroutine prt_spec_read2 @ %def prt_spec_read2 @ \subsubsection{Constructor} Initialize a particle specifier. <>= public :: new_prt_spec <>= interface new_prt_spec module procedure new_prt_spec_ module procedure new_prt_spec_polarized module procedure new_prt_spec_unstable end interface new_prt_spec <>= elemental module function new_prt_spec_ (name) result (prt_spec) type(string_t), intent(in) :: name type(prt_spec_t) :: prt_spec end function new_prt_spec_ elemental module function new_prt_spec_polarized (name, polarized) result (prt_spec) type(string_t), intent(in) :: name logical, intent(in) :: polarized type(prt_spec_t) :: prt_spec end function new_prt_spec_polarized pure module function new_prt_spec_unstable (name, decay) result (prt_spec) type(string_t), intent(in) :: name type(string_t), dimension(:), intent(in) :: decay type(prt_spec_t) :: prt_spec end function new_prt_spec_unstable <>= elemental module function new_prt_spec_ (name) result (prt_spec) type(string_t), intent(in) :: name type(prt_spec_t) :: prt_spec prt_spec%name = name end function new_prt_spec_ elemental module function new_prt_spec_polarized (name, polarized) result (prt_spec) type(string_t), intent(in) :: name logical, intent(in) :: polarized type(prt_spec_t) :: prt_spec prt_spec%name = name prt_spec%polarized = polarized end function new_prt_spec_polarized pure module function new_prt_spec_unstable (name, decay) result (prt_spec) type(string_t), intent(in) :: name type(string_t), dimension(:), intent(in) :: decay type(prt_spec_t) :: prt_spec prt_spec%name = name allocate (prt_spec%decay (size (decay))) prt_spec%decay = decay end function new_prt_spec_unstable @ %def new_prt_spec @ \subsubsection{Access Methods} Return the particle name without qualifiers <>= procedure :: get_name => prt_spec_get_name <>= elemental module function prt_spec_get_name (prt_spec) result (name) class(prt_spec_t), intent(in) :: prt_spec type(string_t) :: name end function prt_spec_get_name <>= elemental module function prt_spec_get_name (prt_spec) result (name) class(prt_spec_t), intent(in) :: prt_spec type(string_t) :: name name = prt_spec%name end function prt_spec_get_name @ %def prt_spec_get_name @ Return the name with qualifiers <>= procedure :: to_string => prt_spec_to_string <>= module function prt_spec_to_string (object) result (string) class(prt_spec_t), intent(in) :: object type(string_t) :: string end function prt_spec_to_string <>= module function prt_spec_to_string (object) result (string) class(prt_spec_t), intent(in) :: object type(string_t) :: string integer :: i string = object%name if (allocated (object%decay)) then string = string // "(" do i = 1, size (object%decay) if (i > 1) string = string // " + " string = string // object%decay(i) end do string = string // ")" else if (object%polarized) then string = string // "(*)" end if end function prt_spec_to_string @ %def prt_spec_to_string @ Return the polarization flag <>= procedure :: is_polarized => prt_spec_is_polarized <>= elemental module function prt_spec_is_polarized (prt_spec) result (flag) class(prt_spec_t), intent(in) :: prt_spec logical :: flag end function prt_spec_is_polarized <>= elemental module function prt_spec_is_polarized (prt_spec) result (flag) class(prt_spec_t), intent(in) :: prt_spec logical :: flag flag = prt_spec%polarized end function prt_spec_is_polarized @ %def prt_spec_is_polarized @ The particle is unstable if there is a decay array. <>= procedure :: is_unstable => prt_spec_is_unstable <>= elemental module function prt_spec_is_unstable (prt_spec) result (flag) class(prt_spec_t), intent(in) :: prt_spec logical :: flag end function prt_spec_is_unstable <>= elemental module function prt_spec_is_unstable (prt_spec) result (flag) class(prt_spec_t), intent(in) :: prt_spec logical :: flag flag = allocated (prt_spec%decay) end function prt_spec_is_unstable @ %def prt_spec_is_unstable @ Return the number of decay channels <>= procedure :: get_n_decays => prt_spec_get_n_decays <>= elemental module function prt_spec_get_n_decays (prt_spec) result (n) class(prt_spec_t), intent(in) :: prt_spec integer :: n end function prt_spec_get_n_decays <>= elemental module function prt_spec_get_n_decays (prt_spec) result (n) class(prt_spec_t), intent(in) :: prt_spec integer :: n if (allocated (prt_spec%decay)) then n = size (prt_spec%decay) else n = 0 end if end function prt_spec_get_n_decays @ %def prt_spec_get_n_decays @ Return the decay channels <>= procedure :: get_decays => prt_spec_get_decays <>= module subroutine prt_spec_get_decays (prt_spec, decay) class(prt_spec_t), intent(in) :: prt_spec type(string_t), dimension(:), allocatable, intent(out) :: decay end subroutine prt_spec_get_decays <>= module subroutine prt_spec_get_decays (prt_spec, decay) class(prt_spec_t), intent(in) :: prt_spec type(string_t), dimension(:), allocatable, intent(out) :: decay if (allocated (prt_spec%decay)) then allocate (decay (size (prt_spec%decay))) decay = prt_spec%decay else allocate (decay (0)) end if end subroutine prt_spec_get_decays @ %def prt_spec_get_decays @ \subsubsection{Miscellaneous} There is nothing to expand here: <>= procedure :: expand_sub => prt_spec_expand_sub <>= module subroutine prt_spec_expand_sub (object) class(prt_spec_t), intent(inout) :: object end subroutine prt_spec_expand_sub <>= module subroutine prt_spec_expand_sub (object) class(prt_spec_t), intent(inout) :: object end subroutine prt_spec_expand_sub @ %def prt_spec_expand_sub @ \subsection{List} A list of particle specifiers, indicating, e.g., the final state of a process. <>= public :: prt_spec_list_t <>= type, extends (prt_spec_expr_t) :: prt_spec_list_t type(prt_expr_t), dimension(:), allocatable :: expr contains <> end type prt_spec_list_t @ %def prt_spec_list_t @ Output: Concatenate the components. Insert brackets if the component is also a list. The components of the [[expr]] array, if any, should all be filled. <>= procedure :: to_string => prt_spec_list_to_string <>= recursive module function prt_spec_list_to_string (object) result (string) class(prt_spec_list_t), intent(in) :: object type(string_t) :: string end function prt_spec_list_to_string <>= recursive module function prt_spec_list_to_string (object) result (string) class(prt_spec_list_t), intent(in) :: object type(string_t) :: string integer :: i string = "" if (allocated (object%expr)) then do i = 1, size (object%expr) if (i > 1) string = string // ", " select type (x => object%expr(i)%x) type is (prt_spec_list_t) string = string // "(" // x%to_string () // ")" class default string = string // x%to_string () end select end do end if end function prt_spec_list_to_string @ %def prt_spec_list_to_string @ Flatten: if there is a subexpression which is also a list, include the components as direct members of the current list. <>= procedure :: flatten => prt_spec_list_flatten <>= module subroutine prt_spec_list_flatten (object) class(prt_spec_list_t), intent(inout) :: object end subroutine prt_spec_list_flatten <>= module subroutine prt_spec_list_flatten (object) class(prt_spec_list_t), intent(inout) :: object type(prt_expr_t), dimension(:), allocatable :: tmp_expr integer :: i, n_flat, i_flat n_flat = 0 do i = 1, size (object%expr) select type (y => object%expr(i)%x) type is (prt_spec_list_t) n_flat = n_flat + size (y%expr) class default n_flat = n_flat + 1 end select end do if (n_flat > size (object%expr)) then allocate (tmp_expr (n_flat)) i_flat = 0 do i = 1, size (object%expr) select type (y => object%expr(i)%x) type is (prt_spec_list_t) tmp_expr (i_flat + 1 : i_flat + size (y%expr)) = y%expr i_flat = i_flat + size (y%expr) class default tmp_expr (i_flat + 1) = object%expr(i) i_flat = i_flat + 1 end select end do end if if (allocated (tmp_expr)) & call move_alloc (from = tmp_expr, to = object%expr) end subroutine prt_spec_list_flatten @ %def prt_spec_list_flatten @ Convert a list of sums into a sum of lists. (Subexpressions which are not sums are left untouched.) Due to compiler bug in gfortran 7-9 not in submodule. <>= subroutine distribute_prt_spec_list (object) class(prt_spec_expr_t), intent(inout), allocatable :: object class(prt_spec_expr_t), allocatable :: new_object integer, dimension(:), allocatable :: n, ii integer :: k, n_expr, n_terms, i_term select type (object) type is (prt_spec_list_t) n_expr = size (object%expr) allocate (n (n_expr), source = 1) allocate (ii (n_expr), source = 1) do k = 1, size (object%expr) select type (y => object%expr(k)%x) type is (prt_spec_sum_t) n(k) = size (y%expr) end select end do n_terms = product (n) if (n_terms > 1) then allocate (prt_spec_sum_t :: new_object) select type (new_object) type is (prt_spec_sum_t) allocate (new_object%expr (n_terms)) do i_term = 1, n_terms allocate (prt_spec_list_t :: new_object%expr(i_term)%x) select type (x => new_object%expr(i_term)%x) type is (prt_spec_list_t) allocate (x%expr (n_expr)) do k = 1, n_expr select type (y => object%expr(k)%x) type is (prt_spec_sum_t) x%expr(k) = y%expr(ii(k)) class default x%expr(k) = object%expr(k) end select end do end select INCR_INDEX: do k = n_expr, 1, -1 if (ii(k) < n(k)) then ii(k) = ii(k) + 1 exit INCR_INDEX else ii(k) = 1 end if end do INCR_INDEX end do end select end if end select if (allocated (new_object)) call move_alloc (from = new_object, to = object) end subroutine distribute_prt_spec_list @ %def distribute_prt_spec_list @ Apply [[expand]] to all components of the list. <>= procedure :: expand_sub => prt_spec_list_expand_sub <>= recursive module subroutine prt_spec_list_expand_sub (object) class(prt_spec_list_t), intent(inout) :: object end subroutine prt_spec_list_expand_sub <>= recursive module subroutine prt_spec_list_expand_sub (object) class(prt_spec_list_t), intent(inout) :: object integer :: i if (allocated (object%expr)) then do i = 1, size (object%expr) call object%expr(i)%expand () end do end if end subroutine prt_spec_list_expand_sub @ %def prt_spec_list_expand_sub @ \subsection{Sum} A sum of particle specifiers, indicating, e.g., a sum of final states. <>= public :: prt_spec_sum_t <>= type, extends (prt_spec_expr_t) :: prt_spec_sum_t type(prt_expr_t), dimension(:), allocatable :: expr contains <> end type prt_spec_sum_t @ %def prt_spec_sum_t @ Output: Concatenate the components. Insert brackets if the component is a list or also a sum. The components of the [[expr]] array, if any, should all be filled. <>= procedure :: to_string => prt_spec_sum_to_string <>= recursive module function prt_spec_sum_to_string (object) result (string) class(prt_spec_sum_t), intent(in) :: object type(string_t) :: string end function prt_spec_sum_to_string <>= recursive module function prt_spec_sum_to_string (object) result (string) class(prt_spec_sum_t), intent(in) :: object type(string_t) :: string integer :: i string = "" if (allocated (object%expr)) then do i = 1, size (object%expr) if (i > 1) string = string // " + " select type (x => object%expr(i)%x) type is (prt_spec_list_t) string = string // "(" // x%to_string () // ")" type is (prt_spec_sum_t) string = string // "(" // x%to_string () // ")" class default string = string // x%to_string () end select end do end if end function prt_spec_sum_to_string @ %def prt_spec_sum_to_string @ Flatten: if there is a subexpression which is also a sum, include the components as direct members of the current sum. This is identical to [[prt_spec_list_flatten]] above, except for the type. <>= procedure :: flatten => prt_spec_sum_flatten <>= module subroutine prt_spec_sum_flatten (object) class(prt_spec_sum_t), intent(inout) :: object end subroutine prt_spec_sum_flatten <>= module subroutine prt_spec_sum_flatten (object) class(prt_spec_sum_t), intent(inout) :: object type(prt_expr_t), dimension(:), allocatable :: tmp_expr integer :: i, n_flat, i_flat n_flat = 0 do i = 1, size (object%expr) select type (y => object%expr(i)%x) type is (prt_spec_sum_t) n_flat = n_flat + size (y%expr) class default n_flat = n_flat + 1 end select end do if (n_flat > size (object%expr)) then allocate (tmp_expr (n_flat)) i_flat = 0 do i = 1, size (object%expr) select type (y => object%expr(i)%x) type is (prt_spec_sum_t) tmp_expr (i_flat + 1 : i_flat + size (y%expr)) = y%expr i_flat = i_flat + size (y%expr) class default tmp_expr (i_flat + 1) = object%expr(i) i_flat = i_flat + 1 end select end do end if if (allocated (tmp_expr)) & call move_alloc (from = tmp_expr, to = object%expr) end subroutine prt_spec_sum_flatten @ %def prt_spec_sum_flatten @ Apply [[expand]] to all terms in the sum. <>= procedure :: expand_sub => prt_spec_sum_expand_sub <>= recursive module subroutine prt_spec_sum_expand_sub (object) class(prt_spec_sum_t), intent(inout) :: object end subroutine prt_spec_sum_expand_sub <>= recursive module subroutine prt_spec_sum_expand_sub (object) class(prt_spec_sum_t), intent(inout) :: object integer :: i if (allocated (object%expr)) then do i = 1, size (object%expr) call object%expr(i)%expand () end do end if end subroutine prt_spec_sum_expand_sub @ %def prt_spec_sum_expand_sub @ \subsection{Expression Expansion} The [[expand]] method transforms each particle specifier expression into a sum of lists, according to the rules \begin{align} a, (b, c) &\to a, b, c \\ a + (b + c) &\to a + b + c \\ a, b + c &\to (a, b) + (a, c) \end{align} Note that the precedence of comma and plus are opposite to this expansion, so the parentheses in the final expression are necessary. We assume that subexpressions are filled, i.e., arrays are allocated. Do to compiler bug in gfortran 7-9 not in submodule. <>= procedure :: expand => prt_expr_expand <>= recursive subroutine prt_expr_expand (expr) class(prt_expr_t), intent(inout) :: expr if (allocated (expr%x)) then call distribute_prt_spec_list (expr%x) call expr%x%expand_sub () select type (x => expr%x) type is (prt_spec_list_t) call x%flatten () type is (prt_spec_sum_t) call x%flatten () end select end if end subroutine prt_expr_expand @ %def prt_expr_expand @ \subsection{Unit Tests} Test module, followed by the corresponding implementation module. <<[[particle_specifiers_ut.f90]]>>= <> module particle_specifiers_ut use unit_tests use particle_specifiers_uti <> <> contains <> end module particle_specifiers_ut @ %def particle_specifiers_ut @ <<[[particle_specifiers_uti.f90]]>>= <> module particle_specifiers_uti <> use particle_specifiers <> <> contains <> end module particle_specifiers_uti @ %def particle_specifiers_ut @ API: driver for the unit tests below. <>= public :: particle_specifiers_test <>= subroutine particle_specifiers_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine particle_specifiers_test @ %def particle_specifiers_test @ \subsubsection{Particle specifier array} Define, read and write an array of particle specifiers. <>= call test (particle_specifiers_1, "particle_specifiers_1", & "Handle particle specifiers", & u, results) <>= public :: particle_specifiers_1 <>= subroutine particle_specifiers_1 (u) integer, intent(in) :: u type(prt_spec_t), dimension(:), allocatable :: prt_spec type(string_t), dimension(:), allocatable :: decay type(string_t), dimension(0) :: no_decay integer :: i, j write (u, "(A)") "* Test output: particle_specifiers_1" write (u, "(A)") "* Purpose: Read and write a particle specifier array" write (u, "(A)") allocate (prt_spec (5)) prt_spec = [ & new_prt_spec (var_str ("a")), & new_prt_spec (var_str ("b"), .true.), & new_prt_spec (var_str ("c"), [var_str ("dec1")]), & new_prt_spec (var_str ("d"), [var_str ("dec1"), var_str ("dec2")]), & new_prt_spec (var_str ("e"), no_decay) & ] do i = 1, size (prt_spec) write (u, "(A)") char (prt_spec(i)%to_string ()) end do write (u, "(A)") call prt_spec_read (prt_spec, & var_str (" a, b( *), c( dec1), d (dec1 + dec2 ), e()")) call prt_spec_write (prt_spec, u) do i = 1, size (prt_spec) write (u, "(A)") write (u, "(A,A)") char (prt_spec(i)%get_name ()), ":" write (u, "(A,L1)") "polarized = ", prt_spec(i)%is_polarized () write (u, "(A,L1)") "unstable = ", prt_spec(i)%is_unstable () write (u, "(A,I0)") "n_decays = ", prt_spec(i)%get_n_decays () call prt_spec(i)%get_decays (decay) write (u, "(A)", advance="no") "decays =" do j = 1, size (decay) write (u, "(1x,A)", advance="no") char (decay(j)) end do write (u, "(A)") end do write (u, "(A)") write (u, "(A)") "* Test output end: particle_specifiers_1" end subroutine particle_specifiers_1 @ %def particle_specifiers_1 @ \subsubsection{Particle specifier expressions} Nested expressions (only basic particles, no decay specs). <>= call test (particle_specifiers_2, "particle_specifiers_2", & "Particle specifier expressions", & u, results) <>= public :: particle_specifiers_2 <>= subroutine particle_specifiers_2 (u) integer, intent(in) :: u type(prt_spec_t) :: a, b, c, d, e, f type(prt_expr_t) :: pe1, pe2, pe3 type(prt_expr_t) :: pe4, pe5, pe6, pe7, pe8, pe9 integer :: i type(prt_spec_t), dimension(:), allocatable :: pa write (u, "(A)") "* Test output: particle_specifiers_2" write (u, "(A)") "* Purpose: Create and display particle expressions" write (u, "(A)") write (u, "(A)") "* Basic expressions" write (u, *) a = new_prt_spec (var_str ("a")) b = new_prt_spec (var_str ("b")) c = new_prt_spec (var_str ("c")) d = new_prt_spec (var_str ("d")) e = new_prt_spec (var_str ("e")) f = new_prt_spec (var_str ("f")) call pe1%init_spec (a) write (u, "(A)") char (pe1%to_string ()) call pe2%init_sum (2) select type (x => pe2%x) type is (prt_spec_sum_t) call x%expr(1)%init_spec (a) call x%expr(2)%init_spec (b) end select write (u, "(A)") char (pe2%to_string ()) call pe3%init_list (2) select type (x => pe3%x) type is (prt_spec_list_t) call x%expr(1)%init_spec (a) call x%expr(2)%init_spec (b) end select write (u, "(A)") char (pe3%to_string ()) write (u, *) write (u, "(A)") "* Nested expressions" write (u, *) call pe4%init_list (2) select type (x => pe4%x) type is (prt_spec_list_t) call x%expr(1)%init_sum (2) select type (y => x%expr(1)%x) type is (prt_spec_sum_t) call y%expr(1)%init_spec (a) call y%expr(2)%init_spec (b) end select call x%expr(2)%init_spec (c) end select write (u, "(A)") char (pe4%to_string ()) call pe5%init_list (2) select type (x => pe5%x) type is (prt_spec_list_t) call x%expr(1)%init_list (2) select type (y => x%expr(1)%x) type is (prt_spec_list_t) call y%expr(1)%init_spec (a) call y%expr(2)%init_spec (b) end select call x%expr(2)%init_spec (c) end select write (u, "(A)") char (pe5%to_string ()) call pe6%init_sum (2) select type (x => pe6%x) type is (prt_spec_sum_t) call x%expr(1)%init_spec (a) call x%expr(2)%init_sum (2) select type (y => x%expr(2)%x) type is (prt_spec_sum_t) call y%expr(1)%init_spec (b) call y%expr(2)%init_spec (c) end select end select write (u, "(A)") char (pe6%to_string ()) call pe7%init_list (2) select type (x => pe7%x) type is (prt_spec_list_t) call x%expr(1)%init_sum (2) select type (y => x%expr(1)%x) type is (prt_spec_sum_t) call y%expr(1)%init_spec (a) call y%expr(2)%init_list (2) select type (z => y%expr(2)%x) type is (prt_spec_list_t) call z%expr(1)%init_spec (b) call z%expr(2)%init_spec (c) end select end select call x%expr(2)%init_spec (d) end select write (u, "(A)") char (pe7%to_string ()) call pe8%init_sum (2) select type (x => pe8%x) type is (prt_spec_sum_t) call x%expr(1)%init_list (2) select type (y => x%expr(1)%x) type is (prt_spec_list_t) call y%expr(1)%init_spec (a) call y%expr(2)%init_spec (b) end select call x%expr(2)%init_list (2) select type (y => x%expr(2)%x) type is (prt_spec_list_t) call y%expr(1)%init_spec (c) call y%expr(2)%init_spec (d) end select end select write (u, "(A)") char (pe8%to_string ()) call pe9%init_list (3) select type (x => pe9%x) type is (prt_spec_list_t) call x%expr(1)%init_sum (2) select type (y => x%expr(1)%x) type is (prt_spec_sum_t) call y%expr(1)%init_spec (a) call y%expr(2)%init_spec (b) end select call x%expr(2)%init_spec (c) call x%expr(3)%init_sum (3) select type (y => x%expr(3)%x) type is (prt_spec_sum_t) call y%expr(1)%init_spec (d) call y%expr(2)%init_spec (e) call y%expr(3)%init_spec (f) end select end select write (u, "(A)") char (pe9%to_string ()) write (u, *) write (u, "(A)") "* Expand as sum" write (u, *) call pe1%expand () write (u, "(A)") char (pe1%to_string ()) call pe4%expand () write (u, "(A)") char (pe4%to_string ()) call pe5%expand () write (u, "(A)") char (pe5%to_string ()) call pe6%expand () write (u, "(A)") char (pe6%to_string ()) call pe7%expand () write (u, "(A)") char (pe7%to_string ()) call pe8%expand () write (u, "(A)") char (pe8%to_string ()) call pe9%expand () write (u, "(A)") char (pe9%to_string ()) write (u, *) write (u, "(A)") "* Transform to arrays:" write (u, "(A)") "* Atomic specifier" do i = 1, pe1%get_n_terms () call pe1%term_to_array (pa, i) call prt_spec_write (pa, u) end do write (u, *) write (u, "(A)") "* List" do i = 1, pe5%get_n_terms () call pe5%term_to_array (pa, i) call prt_spec_write (pa, u) end do write (u, *) write (u, "(A)") "* Sum of atoms" do i = 1, pe6%get_n_terms () call pe6%term_to_array (pa, i) call prt_spec_write (pa, u) end do write (u, *) write (u, "(A)") "* Sum of lists" do i = 1, pe9%get_n_terms () call pe9%term_to_array (pa, i) call prt_spec_write (pa, u) end do write (u, "(A)") write (u, "(A)") "* Test output end: particle_specifiers_2" end subroutine particle_specifiers_2 @ %def particle_specifiers_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{PDG arrays} For defining aliases, we introduce a special type which holds a set of (integer) PDG codes. <<[[pdg_arrays.f90]]>>= <> module pdg_arrays <> <> <> <> interface <> end interface end module pdg_arrays @ %def pdg_arrays @ <<[[pdg_arrays_sub.f90]]>>= <> submodule (pdg_arrays) pdg_arrays_s use io_units use sorting use physics_defs implicit none contains <> end submodule pdg_arrays_s @ %def pdg_arrays_s @ \subsection{Type definition} Using an allocatable array eliminates the need for initializer and/or finalizer. <>= public :: pdg_array_t <>= type :: pdg_array_t private integer, dimension(:), allocatable :: pdg contains <> end type pdg_array_t @ %def pdg_array_t @ Output. <>= procedure :: write => pdg_array_write <>= module subroutine pdg_array_write (aval, unit) class(pdg_array_t), intent(in) :: aval integer, intent(in), optional :: unit end subroutine pdg_array_write <>= module subroutine pdg_array_write (aval, unit) class(pdg_array_t), intent(in) :: aval integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(A)", advance="no") "PDG(" if (allocated (aval%pdg)) then do i = 1, size (aval%pdg) if (i > 1) write (u, "(A)", advance="no") ", " write (u, "(I0)", advance="no") aval%pdg(i) end do end if write (u, "(A)", advance="no") ")" end subroutine pdg_array_write @ %def pdg_array_write @ <>= public :: pdg_array_write_set <>= module subroutine pdg_array_write_set (aval, unit) type(pdg_array_t), intent(in), dimension(:) :: aval integer, intent(in), optional :: unit end subroutine pdg_array_write_set <>= module subroutine pdg_array_write_set (aval, unit) type(pdg_array_t), intent(in), dimension(:) :: aval integer, intent(in), optional :: unit integer :: i do i = 1, size (aval) call aval(i)%write (unit) print *, '' end do end subroutine pdg_array_write_set @ %def pdg_array_write_set @ \subsection{Basic operations} Assignment. We define assignment from and to an integer array. Note that the integer array, if it is the l.h.s., must be declared allocatable by the caller. <>= public :: assignment(=) <>= interface assignment(=) module procedure pdg_array_from_int_array module procedure pdg_array_from_int module procedure int_array_from_pdg_array end interface <>= module subroutine pdg_array_from_int_array (aval, iarray) type(pdg_array_t), intent(out) :: aval integer, dimension(:), intent(in) :: iarray end subroutine pdg_array_from_int_array elemental module subroutine pdg_array_from_int (aval, int) type(pdg_array_t), intent(out) :: aval integer, intent(in) :: int end subroutine pdg_array_from_int module subroutine int_array_from_pdg_array (iarray, aval) integer, dimension(:), allocatable, intent(out) :: iarray type(pdg_array_t), intent(in) :: aval end subroutine int_array_from_pdg_array <>= module subroutine pdg_array_from_int_array (aval, iarray) type(pdg_array_t), intent(out) :: aval integer, dimension(:), intent(in) :: iarray allocate (aval%pdg (size (iarray))) aval%pdg = iarray end subroutine pdg_array_from_int_array elemental module subroutine pdg_array_from_int (aval, int) type(pdg_array_t), intent(out) :: aval integer, intent(in) :: int allocate (aval%pdg (1)) aval%pdg = int end subroutine pdg_array_from_int module subroutine int_array_from_pdg_array (iarray, aval) integer, dimension(:), allocatable, intent(out) :: iarray type(pdg_array_t), intent(in) :: aval if (allocated (aval%pdg)) then allocate (iarray (size (aval%pdg))) iarray = aval%pdg else allocate (iarray (0)) end if end subroutine int_array_from_pdg_array @ %def pdg_array_from_int_array pdg_array_from_int int_array_from_pdg_array @ Allocate space for a PDG array <>= procedure :: init => pdg_array_init <>= module subroutine pdg_array_init (aval, n_elements) class(pdg_array_t), intent(inout) :: aval integer, intent(in) :: n_elements end subroutine pdg_array_init <>= module subroutine pdg_array_init (aval, n_elements) class(pdg_array_t), intent(inout) :: aval integer, intent(in) :: n_elements allocate(aval%pdg(n_elements)) end subroutine pdg_array_init @ %def pdg_array_init @ Deallocate a previously allocated pdg array <>= procedure :: delete => pdg_array_delete <>= module subroutine pdg_array_delete (aval) class(pdg_array_t), intent(inout) :: aval end subroutine pdg_array_delete <>= module subroutine pdg_array_delete (aval) class(pdg_array_t), intent(inout) :: aval if (allocated (aval%pdg)) deallocate (aval%pdg) end subroutine pdg_array_delete @ %def pdg_array_delete @ Merge two pdg arrays, i.e. append a particle string to another leaving out doublettes <>= procedure :: merge => pdg_array_merge <>= module subroutine pdg_array_merge (aval1, aval2) class(pdg_array_t), intent(inout) :: aval1 type(pdg_array_t), intent(in) :: aval2 end subroutine pdg_array_merge <>= module subroutine pdg_array_merge (aval1, aval2) class(pdg_array_t), intent(inout) :: aval1 type(pdg_array_t), intent(in) :: aval2 type(pdg_array_t) :: aval if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then if (.not. any (aval1%pdg == aval2%pdg)) aval = aval1 // aval2 else if (allocated (aval1%pdg)) then aval = aval1 else if (allocated (aval2%pdg)) then aval = aval2 end if call pdg_array_delete (aval1) call pdg_array_from_int_array (aval1, aval%pdg) end subroutine pdg_array_merge @ %def pdg_array_merge @ Length of the array. <>= procedure :: get_length => pdg_array_get_length <>= elemental module function pdg_array_get_length (aval) result (n) class(pdg_array_t), intent(in) :: aval integer :: n end function pdg_array_get_length <>= elemental module function pdg_array_get_length (aval) result (n) class(pdg_array_t), intent(in) :: aval integer :: n if (allocated (aval%pdg)) then n = size (aval%pdg) else n = 0 end if end function pdg_array_get_length @ %def pdg_array_get_length @ Return the element with index i. <>= procedure :: get => pdg_array_get <>= elemental module function pdg_array_get (aval, i) result (pdg) class(pdg_array_t), intent(in) :: aval integer, intent(in), optional :: i integer :: pdg end function pdg_array_get <>= elemental module function pdg_array_get (aval, i) result (pdg) class(pdg_array_t), intent(in) :: aval integer, intent(in), optional :: i integer :: pdg if (present (i)) then pdg = aval%pdg(i) else pdg = aval%pdg(1) end if end function pdg_array_get @ %def pdg_array_get @ Explicitly set the element with index i. <>= procedure :: set => pdg_array_set <>= module subroutine pdg_array_set (aval, i, pdg) class(pdg_array_t), intent(inout) :: aval integer, intent(in) :: i integer, intent(in) :: pdg end subroutine pdg_array_set <>= module subroutine pdg_array_set (aval, i, pdg) class(pdg_array_t), intent(inout) :: aval integer, intent(in) :: i integer, intent(in) :: pdg aval%pdg(i) = pdg end subroutine pdg_array_set @ %def pdg_array_set @ <>= procedure :: add => pdg_array_add <>= module function pdg_array_add (aval, aval_add) result (aval_out) type(pdg_array_t) :: aval_out class(pdg_array_t), intent(in) :: aval type(pdg_array_t), intent(in) :: aval_add end function pdg_array_add <>= module function pdg_array_add (aval, aval_add) result (aval_out) type(pdg_array_t) :: aval_out class(pdg_array_t), intent(in) :: aval type(pdg_array_t), intent(in) :: aval_add integer :: n, n_add, i n = size (aval%pdg) n_add = size (aval_add%pdg) allocate (aval_out%pdg (n + n_add)) aval_out%pdg(1:n) = aval%pdg do i = 1, n_add aval_out%pdg(n+i) = aval_add%pdg(i) end do end function pdg_array_add @ %def pdg_array_add @ Replace element with index [[i]] by a new array of elements. <>= procedure :: replace => pdg_array_replace <>= module function pdg_array_replace (aval, i, pdg_new) result (aval_new) class(pdg_array_t), intent(in) :: aval integer, intent(in) :: i integer, dimension(:), intent(in) :: pdg_new type(pdg_array_t) :: aval_new end function pdg_array_replace <>= module function pdg_array_replace (aval, i, pdg_new) result (aval_new) class(pdg_array_t), intent(in) :: aval integer, intent(in) :: i integer, dimension(:), intent(in) :: pdg_new type(pdg_array_t) :: aval_new integer :: n, l n = size (aval%pdg) l = size (pdg_new) allocate (aval_new%pdg (n + l - 1)) aval_new%pdg(:i-1) = aval%pdg(:i-1) aval_new%pdg(i:i+l-1) = pdg_new aval_new%pdg(i+l:) = aval%pdg(i+1:) end function pdg_array_replace @ %def pdg_array_replace @ Concatenate two PDG arrays <>= public :: operator(//) <>= interface operator(//) module procedure concat_pdg_arrays end interface <>= module function concat_pdg_arrays (aval1, aval2) result (aval) type(pdg_array_t) :: aval type(pdg_array_t), intent(in) :: aval1, aval2 end function concat_pdg_arrays <>= module function concat_pdg_arrays (aval1, aval2) result (aval) type(pdg_array_t) :: aval type(pdg_array_t), intent(in) :: aval1, aval2 integer :: n1, n2 if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then n1 = size (aval1%pdg) n2 = size (aval2%pdg) allocate (aval%pdg (n1 + n2)) aval%pdg(:n1) = aval1%pdg aval%pdg(n1+1:) = aval2%pdg else if (allocated (aval1%pdg)) then aval = aval1 else if (allocated (aval2%pdg)) then aval = aval2 end if end function concat_pdg_arrays @ %def concat_pdg_arrays @ \subsection{Matching} A PDG array matches a given PDG code if the code is present within the array. If either one is zero (UNDEFINED), the match also succeeds. <>= public :: operator(.match.) <>= interface operator(.match.) module procedure pdg_array_match_integer module procedure pdg_array_match_pdg_array end interface @ %def .match. @ Match a single code against the array. <>= elemental module function pdg_array_match_integer (aval, pdg) result (flag) logical :: flag type(pdg_array_t), intent(in) :: aval integer, intent(in) :: pdg end function pdg_array_match_integer <>= elemental module function pdg_array_match_integer (aval, pdg) result (flag) logical :: flag type(pdg_array_t), intent(in) :: aval integer, intent(in) :: pdg if (allocated (aval%pdg)) then flag = pdg == UNDEFINED & .or. any (aval%pdg == UNDEFINED) & .or. any (aval%pdg == pdg) else flag = .false. end if end function pdg_array_match_integer @ %def pdg_array_match_integer @ Check if the pdg-number corresponds to a quark <>= public :: is_quark <>= elemental module function is_quark (pdg_nr) logical :: is_quark integer, intent(in) :: pdg_nr end function is_quark <>= elemental module function is_quark (pdg_nr) logical :: is_quark integer, intent(in) :: pdg_nr if (abs (pdg_nr) >= 1 .and. abs (pdg_nr) <= 6) then is_quark = .true. else is_quark = .false. end if end function is_quark @ %def is_quark @ Check if pdg-number corresponds to a gluon <>= public :: is_gluon <>= elemental module function is_gluon (pdg_nr) logical :: is_gluon integer, intent(in) :: pdg_nr end function is_gluon <>= elemental module function is_gluon (pdg_nr) logical :: is_gluon integer, intent(in) :: pdg_nr if (pdg_nr == GLUON) then is_gluon = .true. else is_gluon = .false. end if end function is_gluon @ %def is_gluon @ Check if pdg-number corresponds to a photon <>= public :: is_photon <>= elemental module function is_photon (pdg_nr) logical :: is_photon integer, intent(in) :: pdg_nr end function is_photon <>= elemental module function is_photon (pdg_nr) logical :: is_photon integer, intent(in) :: pdg_nr if (pdg_nr == PHOTON) then is_photon = .true. else is_photon = .false. end if end function is_photon @ %def is_photon @ Check if pdg-number corresponds to a colored particle <>= public :: is_colored <>= elemental module function is_colored (pdg_nr) logical :: is_colored integer, intent(in) :: pdg_nr end function is_colored <>= elemental module function is_colored (pdg_nr) logical :: is_colored integer, intent(in) :: pdg_nr is_colored = is_quark (pdg_nr) .or. is_gluon (pdg_nr) end function is_colored @ %def is_colored @ Check if the pdg-number corresponds to a lepton <>= public :: is_lepton <>= elemental module function is_lepton (pdg_nr) logical :: is_lepton integer, intent(in) :: pdg_nr end function is_lepton <>= elemental module function is_lepton (pdg_nr) logical :: is_lepton integer, intent(in) :: pdg_nr if (abs (pdg_nr) >= ELECTRON .and. & abs (pdg_nr) <= TAU_NEUTRINO) then is_lepton = .true. else is_lepton = .false. end if end function is_lepton @ %def is_lepton @ @ Check if the pdg-number corresponds to a charged lepton <>= public :: is_charged_lepton <>= elemental module function is_charged_lepton (pdg_nr) logical :: is_charged_lepton integer, intent(in) :: pdg_nr end function is_charged_lepton <>= elemental module function is_charged_lepton (pdg_nr) logical :: is_charged_lepton integer, intent(in) :: pdg_nr if (abs (pdg_nr) == ELECTRON .or. & abs (pdg_nr) == MUON .or. & abs (pdg_nr) == TAU) then is_charged_lepton = .true. else is_charged_lepton = .false. end if end function is_charged_lepton @ %def is_charged_lepton @ <>= public :: is_fermion <>= elemental module function is_fermion (pdg_nr) logical :: is_fermion integer, intent(in) :: pdg_nr end function is_fermion <>= elemental module function is_fermion (pdg_nr) logical :: is_fermion integer, intent(in) :: pdg_nr is_fermion = is_lepton(pdg_nr) .or. is_quark(pdg_nr) end function is_fermion @ %def is_fermion @ Check if the pdg-number corresponds to a massless vector boson <>= public :: is_massless_vector <>= elemental module function is_massless_vector (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_massless_vector end function is_massless_vector <>= elemental module function is_massless_vector (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_massless_vector if (pdg_nr == GLUON .or. pdg_nr == PHOTON) then is_massless_vector = .true. else is_massless_vector = .false. end if end function is_massless_vector @ %def is_massless_vector @ Check if pdg-number corresponds to a massive vector boson <>= public :: is_massive_vector <>= elemental module function is_massive_vector (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_massive_vector end function is_massive_vector <>= elemental module function is_massive_vector (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_massive_vector if (abs (pdg_nr) == Z_BOSON .or. abs (pdg_nr) == W_BOSON) then is_massive_vector = .true. else is_massive_vector = .false. end if end function is_massive_vector @ %def is massive_vector @ Check if pdg-number corresponds to a vector boson <>= public :: is_vector <>= elemental module function is_vector (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_vector end function is_vector <>= elemental module function is_vector (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_vector if (is_massless_vector (pdg_nr) .or. is_massive_vector (pdg_nr)) then is_vector = .true. else is_vector = .false. end if end function is_vector @ %def is vector @ Check if particle is elementary. <>= public :: is_elementary <>= elemental module function is_elementary (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_elementary end function is_elementary <>= elemental module function is_elementary (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_elementary if (is_vector (pdg_nr) .or. is_fermion (pdg_nr) .or. pdg_nr == 25) then is_elementary = .true. else is_elementary = .false. end if end function is_elementary @ %def is_elementary @ Check if particle is an EW boson or scalar. <>= public :: is_ew_boson_scalar <>= elemental module function is_ew_boson_scalar (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_ew_boson_scalar end function is_ew_boson_scalar <>= elemental module function is_ew_boson_scalar (pdg_nr) integer, intent(in) :: pdg_nr logical :: is_ew_boson_scalar if (is_photon (pdg_nr) .or. is_massive_vector (pdg_nr) .or. pdg_nr == 25) then is_ew_boson_scalar = .true. else is_ew_boson_scalar = .false. end if end function is_ew_boson_scalar @ %def is_ew_boson_scalar @ Check if particle is strongly interacting <>= procedure :: has_colored_particles => pdg_array_has_colored_particles <>= module function pdg_array_has_colored_particles (pdg) result (colored) class(pdg_array_t), intent(in) :: pdg logical :: colored end function pdg_array_has_colored_particles <>= module function pdg_array_has_colored_particles (pdg) result (colored) class(pdg_array_t), intent(in) :: pdg logical :: colored integer :: i, pdg_nr colored = .false. do i = 1, size (pdg%pdg) pdg_nr = pdg%pdg(i) if (is_quark (pdg_nr) .or. is_gluon (pdg_nr)) then colored = .true. exit end if end do end function pdg_array_has_colored_particles @ %def pdg_array_has_colored_particles This function is a convenience function for the determination of possible compatibility of flavor structures of processes with certain orders of QCD and QED/EW coupling constants. It assumes the Standard Model (SM) as underlying physics model. The function is based on a naive counting of external particles which are connected to the process by the specific kind of couplings depending on the underlying theory (QCD and/or QED/EW) of which the corresponding particle is a part of. It is constructed in a way that the exclusion of coupling power combinations is well-defined. <>= public :: query_coupling_powers <>= module function query_coupling_powers (flv, a_power, as_power) result (valid) integer, intent(in), dimension(:) :: flv integer, intent(in) :: a_power, as_power logical :: valid end function query_coupling_powers <>= module function query_coupling_powers (flv, a_power, as_power) result (valid) integer, intent(in), dimension(:) :: flv integer, dimension(:, :), allocatable :: power_pair_array integer, dimension(2) :: power_pair_ref integer, intent(in) :: a_power, as_power integer :: i, n_legs, n_gluons, n_quarks, n_gamWZH, n_leptons logical, dimension(:), allocatable :: pairs_included logical :: valid integer :: n_bound power_pair_ref = [a_power, as_power] n_legs = size (flv) allocate (power_pair_array (2, n_legs - 1)) do i = 1, n_legs - 1 power_pair_array (1, i) = n_legs - 1 - i power_pair_array (2, i) = i - 1 end do allocate (pairs_included (n_legs - 1)) pairs_included = .true. n_gluons = count (is_gluon (flv)) n_gamWZH = count (is_ew_boson_scalar (flv)) n_quarks = count (is_quark (flv)) n_leptons = count (is_lepton (flv)) if (n_gluons >= 1 .and. n_gluons <= 3) then do i = 1, n_gluons pairs_included (i) = .false. end do else if (n_gluons > 2 .and. n_quarks <= 2 .and. n_gluons + n_quarks == n_legs) then do i = 1, n_legs - 2 pairs_included (i) = .false. end do end if n_bound = 0 if (n_gamWZH + n_leptons == n_legs) then n_bound = n_gamWZH + n_leptons - 2 else if (n_quarks == 2 .and. n_leptons + n_quarks + n_gamWZH == n_legs) then n_bound = n_legs - 2 else if (n_gamWZH + n_leptons > 0) then n_bound = n_leptons/2 + n_gamWZH end if if (n_bound > 0) then do i = 1, n_bound pairs_included (n_legs - i) = .false. end do end if if (n_quarks == 4 .and. .not. qcd_ew_interferences (flv)) then do i = 1, 2 pairs_included (n_legs - i) = .false. end do end if valid = .false. do i = 1, n_legs - 1 if (all (power_pair_array (:, i) == power_pair_ref) .and. pairs_included (i)) then valid = .true. exit end if end do end function query_coupling_powers @ %def query_coupling_powers This functions checks if there is a flavor structure which possibly can induce QCD-EW interference amplitudes. It evaluates to [[true]] if there are at least 2 quark pairs whereby the quarks of at least one quark pair must have the same flavor. <>= public :: qcd_ew_interferences <>= module function qcd_ew_interferences (flv) result (valid) integer, intent(in), dimension(:) :: flv logical :: valid end function qcd_ew_interferences <>= module function qcd_ew_interferences (flv) result (valid) integer, intent(in), dimension(:) :: flv integer :: i, n_pairs logical :: valid, qqbar_pair n_pairs = 0 valid = .false. qqbar_pair = .false. if (count (is_quark (flv)) >= 4) then do i = DOWN_Q, TOP_Q qqbar_pair = count (abs (flv) == i) >= 2 if (qqbar_pair) n_pairs = n_pairs + 1 if (n_pairs > 0) then valid = .true. exit end if end do end if end function qcd_ew_interferences @ %def qcd_ew_interferences @ Assign equivalent cut expression class to PDG code. <>= public :: flv_eqv_expr_class <>= module function flv_eqv_expr_class (flv) result (assign_qgA) integer, intent(in) :: flv logical, dimension(3) :: assign_qgA end function flv_eqv_expr_class <>= module function flv_eqv_expr_class (flv) result (assign_qgA) integer, intent(in) :: flv logical, dimension(3) :: assign_qgA assign_qgA = [is_quark (flv), is_gluon (flv), is_photon (flv)] end function flv_eqv_expr_class @ %def flv_eqv_expr_class @ Match two arrays. Succeeds if any pair of entries matches. <>= module function pdg_array_match_pdg_array (aval1, aval2) result (flag) logical :: flag type(pdg_array_t), intent(in) :: aval1, aval2 end function pdg_array_match_pdg_array <>= module function pdg_array_match_pdg_array (aval1, aval2) result (flag) logical :: flag type(pdg_array_t), intent(in) :: aval1, aval2 if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then flag = any (aval1 .match. aval2%pdg) else flag = .false. end if end function pdg_array_match_pdg_array @ %def pdg_array_match_pdg_array @ Comparison. Here, we take the PDG arrays as-is, assuming that they are sorted. The ordering is a bit odd: first, we look only at the absolute values of the PDG codes. If they all match, the particle comes before the antiparticle, scanning from left to right. <>= public :: operator(<) public :: operator(>) public :: operator(<=) public :: operator(>=) public :: operator(==) public :: operator(/=) <>= interface operator(<) module procedure pdg_array_lt end interface interface operator(>) module procedure pdg_array_gt end interface interface operator(<=) module procedure pdg_array_le end interface interface operator(>=) module procedure pdg_array_ge end interface interface operator(==) module procedure pdg_array_eq end interface interface operator(/=) module procedure pdg_array_ne end interface <>= elemental module function pdg_array_lt (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag end function pdg_array_lt elemental module function pdg_array_gt (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag end function pdg_array_gt elemental module function pdg_array_le (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag end function pdg_array_le elemental module function pdg_array_ge (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag end function pdg_array_ge elemental module function pdg_array_eq (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag end function pdg_array_eq elemental module function pdg_array_ne (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag end function pdg_array_ne <>= elemental module function pdg_array_lt (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag integer :: i if (size (aval1%pdg) /= size (aval2%pdg)) then flag = size (aval1%pdg) < size (aval2%pdg) else do i = 1, size (aval1%pdg) if (abs (aval1%pdg(i)) /= abs (aval2%pdg(i))) then flag = abs (aval1%pdg(i)) < abs (aval2%pdg(i)) return end if end do do i = 1, size (aval1%pdg) if (aval1%pdg(i) /= aval2%pdg(i)) then flag = aval1%pdg(i) > aval2%pdg(i) return end if end do flag = .false. end if end function pdg_array_lt elemental module function pdg_array_gt (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag flag = .not. (aval1 < aval2 .or. aval1 == aval2) end function pdg_array_gt elemental module function pdg_array_le (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag flag = aval1 < aval2 .or. aval1 == aval2 end function pdg_array_le elemental module function pdg_array_ge (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag flag = .not. (aval1 < aval2) end function pdg_array_ge elemental module function pdg_array_eq (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag if (size (aval1%pdg) /= size (aval2%pdg)) then flag = .false. else flag = all (aval1%pdg == aval2%pdg) end if end function pdg_array_eq elemental module function pdg_array_ne (aval1, aval2) result (flag) type(pdg_array_t), intent(in) :: aval1, aval2 logical :: flag flag = .not. (aval1 == aval2) end function pdg_array_ne @ Equivalence. Two PDG arrays are equivalent if either one contains [[UNDEFINED]] or if each element of array 1 is present in array 2, and vice versa. <>= public :: operator(.eqv.) public :: operator(.neqv.) <>= interface operator(.eqv.) module procedure pdg_array_equivalent end interface interface operator(.neqv.) module procedure pdg_array_inequivalent end interface <>= elemental module function pdg_array_equivalent (aval1, aval2) result (eq) logical :: eq type(pdg_array_t), intent(in) :: aval1, aval2 end function pdg_array_equivalent elemental module function pdg_array_inequivalent (aval1, aval2) result (neq) logical :: neq type(pdg_array_t), intent(in) :: aval1, aval2 end function pdg_array_inequivalent <>= elemental module function pdg_array_equivalent (aval1, aval2) result (eq) logical :: eq type(pdg_array_t), intent(in) :: aval1, aval2 logical, dimension(:), allocatable :: match1, match2 integer :: i if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then eq = any (aval1%pdg == UNDEFINED) & .or. any (aval2%pdg == UNDEFINED) if (.not. eq) then allocate (match1 (size (aval1%pdg))) allocate (match2 (size (aval2%pdg))) match1 = .false. match2 = .false. do i = 1, size (aval1%pdg) match2 = match2 .or. aval1%pdg(i) == aval2%pdg end do do i = 1, size (aval2%pdg) match1 = match1 .or. aval2%pdg(i) == aval1%pdg end do eq = all (match1) .and. all (match2) end if else eq = .false. end if end function pdg_array_equivalent elemental module function pdg_array_inequivalent (aval1, aval2) result (neq) logical :: neq type(pdg_array_t), intent(in) :: aval1, aval2 neq = .not. pdg_array_equivalent (aval1, aval2) end function pdg_array_inequivalent @ %def pdg_array_equivalent @ \subsection{Sorting} Sort a PDG array by absolute value, particle before antiparticle. After sorting, we eliminate double entries. <>= public :: sort_abs <>= interface sort_abs module procedure pdg_array_sort_abs end interface <>= procedure :: sort_abs => pdg_array_sort_abs <>= module function pdg_array_sort_abs (aval1, unique) result (aval2) class(pdg_array_t), intent(in) :: aval1 logical, intent(in), optional :: unique type(pdg_array_t) :: aval2 end function pdg_array_sort_abs <>= module function pdg_array_sort_abs (aval1, unique) result (aval2) class(pdg_array_t), intent(in) :: aval1 logical, intent(in), optional :: unique type(pdg_array_t) :: aval2 integer, dimension(:), allocatable :: tmp logical, dimension(:), allocatable :: mask integer :: i, n logical :: uni uni = .false.; if (present (unique)) uni = unique n = size (aval1%pdg) if (uni) then allocate (tmp (n), mask(n)) tmp = sort_abs (aval1%pdg) mask(1) = .true. do i = 2, n mask(i) = tmp(i) /= tmp(i-1) end do allocate (aval2%pdg (count (mask))) aval2%pdg = pack (tmp, mask) else allocate (aval2%pdg (n)) aval2%pdg = sort_abs (aval1%pdg) end if end function pdg_array_sort_abs @ %def sort_abs @ <>= procedure :: intersect => pdg_array_intersect <>= module function pdg_array_intersect (aval1, match) result (aval2) class(pdg_array_t), intent(in) :: aval1 integer, dimension(:) :: match type(pdg_array_t) :: aval2 end function pdg_array_intersect <>= module function pdg_array_intersect (aval1, match) result (aval2) class(pdg_array_t), intent(in) :: aval1 integer, dimension(:) :: match type(pdg_array_t) :: aval2 integer, dimension(:), allocatable :: isec integer :: i isec = pack (aval1%pdg, [(any(aval1%pdg(i) == match), i=1,size(aval1%pdg))]) call pdg_array_from_int_array (aval2, isec) end function pdg_array_intersect @ %def pdg_array_intersect @ <>= procedure :: search_for_particle => pdg_array_search_for_particle <>= elemental module function pdg_array_search_for_particle (pdg, i_part) result (found) class(pdg_array_t), intent(in) :: pdg integer, intent(in) :: i_part logical :: found end function pdg_array_search_for_particle <>= elemental module function pdg_array_search_for_particle (pdg, i_part) result (found) class(pdg_array_t), intent(in) :: pdg integer, intent(in) :: i_part logical :: found found = any (pdg%pdg == i_part) end function pdg_array_search_for_particle @ %def pdg_array_search_for_particle @ <>= procedure :: invert => pdg_array_invert <>= module function pdg_array_invert (pdg) result (pdg_inverse) class(pdg_array_t), intent(in) :: pdg type(pdg_array_t) :: pdg_inverse end function pdg_array_invert <>= module function pdg_array_invert (pdg) result (pdg_inverse) class(pdg_array_t), intent(in) :: pdg type(pdg_array_t) :: pdg_inverse integer :: i, n n = size (pdg%pdg) allocate (pdg_inverse%pdg (n)) do i = 1, n select case (pdg%pdg(i)) case (GLUON, PHOTON, Z_BOSON, 25) pdg_inverse%pdg(i) = pdg%pdg(i) case default pdg_inverse%pdg(i) = -pdg%pdg(i) end select end do end function pdg_array_invert @ %def pdg_array_invert @ \subsection{PDG array list} A PDG array list, or PDG list, is an array of PDG-array objects with some convenience methods. <>= public :: pdg_list_t <>= type :: pdg_list_t type(pdg_array_t), dimension(:), allocatable :: a contains <> end type pdg_list_t @ %def pdg_list_t @ Output, as a comma-separated list without advancing I/O. <>= procedure :: write => pdg_list_write <>= module subroutine pdg_list_write (object, unit) class(pdg_list_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine pdg_list_write <>= module subroutine pdg_list_write (object, unit) class(pdg_list_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) if (allocated (object%a)) then do i = 1, size (object%a) if (i > 1) write (u, "(A)", advance="no") ", " call object%a(i)%write (u) end do end if end subroutine pdg_list_write @ %def pdg_list_write @ Initialize for a certain size. The entries are initially empty PDG arrays. <>= generic :: init => pdg_list_init_size procedure, private :: pdg_list_init_size <>= module subroutine pdg_list_init_size (pl, n) class(pdg_list_t), intent(out) :: pl integer, intent(in) :: n end subroutine pdg_list_init_size <>= module subroutine pdg_list_init_size (pl, n) class(pdg_list_t), intent(out) :: pl integer, intent(in) :: n allocate (pl%a (n)) end subroutine pdg_list_init_size @ %def pdg_list_init_size @ Initialize with a definite array of PDG codes. That is, each entry in the list becomes a single-particle PDG array. <>= generic :: init => pdg_list_init_int_array procedure, private :: pdg_list_init_int_array <>= module subroutine pdg_list_init_int_array (pl, pdg) class(pdg_list_t), intent(out) :: pl integer, dimension(:), intent(in) :: pdg end subroutine pdg_list_init_int_array <>= module subroutine pdg_list_init_int_array (pl, pdg) class(pdg_list_t), intent(out) :: pl integer, dimension(:), intent(in) :: pdg integer :: i allocate (pl%a (size (pdg))) do i = 1, size (pdg) call pdg_array_from_int (pl%a(i), pdg(i)) end do end subroutine pdg_list_init_int_array @ %def pdg_list_init_array @ Set one of the entries. No bounds-check. <>= generic :: set => pdg_list_set_int generic :: set => pdg_list_set_int_array generic :: set => pdg_list_set_pdg_array procedure, private :: pdg_list_set_int procedure, private :: pdg_list_set_int_array procedure, private :: pdg_list_set_pdg_array <>= module subroutine pdg_list_set_int (pl, i, pdg) class(pdg_list_t), intent(inout) :: pl integer, intent(in) :: i integer, intent(in) :: pdg end subroutine pdg_list_set_int module subroutine pdg_list_set_int_array (pl, i, pdg) class(pdg_list_t), intent(inout) :: pl integer, intent(in) :: i integer, dimension(:), intent(in) :: pdg end subroutine pdg_list_set_int_array module subroutine pdg_list_set_pdg_array (pl, i, pa) class(pdg_list_t), intent(inout) :: pl integer, intent(in) :: i type(pdg_array_t), intent(in) :: pa end subroutine pdg_list_set_pdg_array <>= module subroutine pdg_list_set_int (pl, i, pdg) class(pdg_list_t), intent(inout) :: pl integer, intent(in) :: i integer, intent(in) :: pdg call pdg_array_from_int (pl%a(i), pdg) end subroutine pdg_list_set_int module subroutine pdg_list_set_int_array (pl, i, pdg) class(pdg_list_t), intent(inout) :: pl integer, intent(in) :: i integer, dimension(:), intent(in) :: pdg call pdg_array_from_int_array (pl%a(i), pdg) end subroutine pdg_list_set_int_array module subroutine pdg_list_set_pdg_array (pl, i, pa) class(pdg_list_t), intent(inout) :: pl integer, intent(in) :: i type(pdg_array_t), intent(in) :: pa pl%a(i) = pa end subroutine pdg_list_set_pdg_array @ %def pdg_list_set @ Array size, not the length of individual entries <>= procedure :: get_size => pdg_list_get_size <>= module function pdg_list_get_size (pl) result (n) class(pdg_list_t), intent(in) :: pl integer :: n end function pdg_list_get_size <>= module function pdg_list_get_size (pl) result (n) class(pdg_list_t), intent(in) :: pl integer :: n if (allocated (pl%a)) then n = size (pl%a) else n = 0 end if end function pdg_list_get_size @ %def pdg_list_get_size @ Return an entry, as a PDG array. <>= procedure :: get => pdg_list_get <>= module function pdg_list_get (pl, i) result (pa) type(pdg_array_t) :: pa class(pdg_list_t), intent(in) :: pl integer, intent(in) :: i end function pdg_list_get <>= module function pdg_list_get (pl, i) result (pa) type(pdg_array_t) :: pa class(pdg_list_t), intent(in) :: pl integer, intent(in) :: i pa = pl%a(i) end function pdg_list_get @ %def pdg_list_get @ Check if the list entries are all either mutually disjoint or identical. The individual entries (PDG arrays) should already be sorted, so we can test for equality. <>= procedure :: is_regular => pdg_list_is_regular <>= module function pdg_list_is_regular (pl) result (flag) class(pdg_list_t), intent(in) :: pl logical :: flag end function pdg_list_is_regular <>= module function pdg_list_is_regular (pl) result (flag) class(pdg_list_t), intent(in) :: pl logical :: flag integer :: i, j, s s = pl%get_size () flag = .true. do i = 1, s do j = i + 1, s if (pl%a(i) .match. pl%a(j)) then if (pl%a(i) /= pl%a(j)) then flag = .false. return end if end if end do end do end function pdg_list_is_regular @ %def pdg_list_is_regular @ Sort the list. First, each entry gets sorted, including elimination of doublers. Then, we sort the list, using the first member of each PDG array as the marker. No removal of doublers at this stage. If [[n_in]] is supplied, we do not reorder the first [[n_in]] particle entries. <>= procedure :: sort_abs => pdg_list_sort_abs <>= module function pdg_list_sort_abs (pl, n_in) result (pl_sorted) class(pdg_list_t), intent(in) :: pl integer, intent(in), optional :: n_in type(pdg_list_t) :: pl_sorted end function pdg_list_sort_abs <>= module function pdg_list_sort_abs (pl, n_in) result (pl_sorted) class(pdg_list_t), intent(in) :: pl integer, intent(in), optional :: n_in type(pdg_list_t) :: pl_sorted type(pdg_array_t), dimension(:), allocatable :: pa integer, dimension(:), allocatable :: pdg, map integer :: i, n0 call pl_sorted%init (pl%get_size ()) if (allocated (pl%a)) then allocate (pa (size (pl%a))) do i = 1, size (pl%a) pa(i) = pl%a(i)%sort_abs (unique = .true.) end do allocate (pdg (size (pa)), source = 0) do i = 1, size (pa) if (allocated (pa(i)%pdg)) then if (size (pa(i)%pdg) > 0) then pdg(i) = pa(i)%pdg(1) end if end if end do if (present (n_in)) then n0 = n_in else n0 = 0 end if allocate (map (size (pdg))) map(:n0) = [(i, i = 1, n0)] map(n0+1:) = n0 + order_abs (pdg(n0+1:)) do i = 1, size (pa) call pl_sorted%set (i, pa(map(i))) end do end if end function pdg_list_sort_abs @ %def pdg_list_sort_abs @ Compare sorted lists: equality. The result is undefined if some entries are not allocated. <>= generic :: operator (==) => pdg_list_eq procedure, private :: pdg_list_eq <>= module function pdg_list_eq (pl1, pl2) result (flag) class(pdg_list_t), intent(in) :: pl1, pl2 logical :: flag end function pdg_list_eq <>= module function pdg_list_eq (pl1, pl2) result (flag) class(pdg_list_t), intent(in) :: pl1, pl2 logical :: flag integer :: i flag = .false. if (allocated (pl1%a) .and. allocated (pl2%a)) then if (size (pl1%a) == size (pl2%a)) then do i = 1, size (pl1%a) associate (a1 => pl1%a(i), a2 => pl2%a(i)) if (allocated (a1%pdg) .and. allocated (a2%pdg)) then if (size (a1%pdg) == size (a2%pdg)) then if (size (a1%pdg) > 0) then if (a1%pdg(1) /= a2%pdg(1)) return end if else return end if else return end if end associate end do flag = .true. end if end if end function pdg_list_eq @ %def pdg_list_eq @ Compare sorted lists. The result is undefined if some entries are not allocated. The ordering is quite complicated. First, a shorter list comes before a longer list. Comparing entry by entry, a shorter entry comes first. Next, we check the first PDG code within corresponding entries. This is compared by absolute value. If equal, particle comes before antiparticle. Finally, if all is equal, the result is false. <>= generic :: operator (<) => pdg_list_lt procedure, private :: pdg_list_lt <>= module function pdg_list_lt (pl1, pl2) result (flag) class(pdg_list_t), intent(in) :: pl1, pl2 logical :: flag end function pdg_list_lt <>= module function pdg_list_lt (pl1, pl2) result (flag) class(pdg_list_t), intent(in) :: pl1, pl2 logical :: flag integer :: i flag = .false. if (allocated (pl1%a) .and. allocated (pl2%a)) then if (size (pl1%a) < size (pl2%a)) then flag = .true.; return else if (size (pl1%a) > size (pl2%a)) then return else do i = 1, size (pl1%a) associate (a1 => pl1%a(i), a2 => pl2%a(i)) if (allocated (a1%pdg) .and. allocated (a2%pdg)) then if (size (a1%pdg) < size (a2%pdg)) then flag = .true.; return else if (size (a1%pdg) > size (a2%pdg)) then return else if (size (a1%pdg) > 0) then if (abs (a1%pdg(1)) < abs (a2%pdg(1))) then flag = .true.; return else if (abs (a1%pdg(1)) > abs (a2%pdg(1))) then return else if (a1%pdg(1) > 0 .and. a2%pdg(1) < 0) then flag = .true.; return else if (a1%pdg(1) < 0 .and. a2%pdg(1) > 0) then return end if end if end if else return end if end associate end do flag = .false. end if end if end function pdg_list_lt @ %def pdg_list_lt @ Replace an entry. In the result, the entry [[#i]] is replaced by the contents of the second argument. The result is not sorted. If [[n_in]] is also set and [[i]] is less or equal to [[n_in]], replace [[#i]] only by the first entry of [[pl_insert]], and insert the remainder after entry [[n_in]]. <>= procedure :: replace => pdg_list_replace <>= module function pdg_list_replace (pl, i, pl_insert, n_in) result (pl_out) type(pdg_list_t) :: pl_out class(pdg_list_t), intent(in) :: pl integer, intent(in) :: i class(pdg_list_t), intent(in) :: pl_insert integer, intent(in), optional :: n_in end function pdg_list_replace <>= module function pdg_list_replace (pl, i, pl_insert, n_in) result (pl_out) type(pdg_list_t) :: pl_out class(pdg_list_t), intent(in) :: pl integer, intent(in) :: i class(pdg_list_t), intent(in) :: pl_insert integer, intent(in), optional :: n_in integer :: n, n_insert, n_out, k n = pl%get_size () n_insert = pl_insert%get_size () n_out = n + n_insert - 1 call pl_out%init (n_out) ! if (allocated (pl%a)) then do k = 1, i - 1 pl_out%a(k) = pl%a(k) end do ! end if if (present (n_in)) then pl_out%a(i) = pl_insert%a(1) do k = i + 1, n_in pl_out%a(k) = pl%a(k) end do do k = 1, n_insert - 1 pl_out%a(n_in+k) = pl_insert%a(1+k) end do do k = 1, n - n_in pl_out%a(n_in+k+n_insert-1) = pl%a(n_in+k) end do else ! if (allocated (pl_insert%a)) then do k = 1, n_insert pl_out%a(i-1+k) = pl_insert%a(k) end do ! end if ! if (allocated (pl%a)) then do k = 1, n - i pl_out%a(i+n_insert-1+k) = pl%a(i+k) end do end if ! end if end function pdg_list_replace @ %def pdg_list_replace @ <>= procedure :: fusion => pdg_list_fusion <>= module function pdg_list_fusion (pl, pl_insert, i, check_if_existing) result (pl_out) type(pdg_list_t) :: pl_out class(pdg_list_t), intent(in) :: pl type(pdg_list_t), intent(in) :: pl_insert integer, intent(in) :: i logical, intent(in) :: check_if_existing end function pdg_list_fusion <>= module function pdg_list_fusion (pl, pl_insert, i, check_if_existing) result (pl_out) type(pdg_list_t) :: pl_out class(pdg_list_t), intent(in) :: pl type(pdg_list_t), intent(in) :: pl_insert integer, intent(in) :: i logical, intent(in) :: check_if_existing integer :: n, n_insert, k, n_out logical :: new_pdg n = pl%get_size () n_insert = pl_insert%get_size () new_pdg = .not. check_if_existing .or. & (.not. any (pl%search_for_particle (pl_insert%a(1)%pdg))) call pl_out%init (n + n_insert - 1) do k = 1, n if (new_pdg .and. k == i) then pl_out%a(k) = pl%a(k)%add (pl_insert%a(1)) else pl_out%a(k) = pl%a(k) end if end do do k = n + 1, n + n_insert - 1 pl_out%a(k) = pl_insert%a(k-n) end do end function pdg_list_fusion @ %def pdg_list_fusion @ <>= procedure :: get_pdg_sizes => pdg_list_get_pdg_sizes <>= module function pdg_list_get_pdg_sizes (pl) result (i_size) integer, dimension(:), allocatable :: i_size class(pdg_list_t), intent(in) :: pl end function pdg_list_get_pdg_sizes <>= module function pdg_list_get_pdg_sizes (pl) result (i_size) integer, dimension(:), allocatable :: i_size class(pdg_list_t), intent(in) :: pl integer :: i, n n = pl%get_size () allocate (i_size (n)) do i = 1, n i_size(i) = size (pl%a(i)%pdg) end do end function pdg_list_get_pdg_sizes @ %def pdg_list_get_pdg_sizes @ Replace the entries of [[pl]] by the matching entries of [[pl_match]], one by one. This is done in-place. If there is no match, return failure. <>= procedure :: match_replace => pdg_list_match_replace <>= module subroutine pdg_list_match_replace (pl, pl_match, success) class(pdg_list_t), intent(inout) :: pl class(pdg_list_t), intent(in) :: pl_match logical, intent(out) :: success end subroutine pdg_list_match_replace <>= module subroutine pdg_list_match_replace (pl, pl_match, success) class(pdg_list_t), intent(inout) :: pl class(pdg_list_t), intent(in) :: pl_match logical, intent(out) :: success integer :: i, j success = .true. SCAN_ENTRIES: do i = 1, size (pl%a) do j = 1, size (pl_match%a) if (pl%a(i) .match. pl_match%a(j)) then pl%a(i) = pl_match%a(j) cycle SCAN_ENTRIES end if end do success = .false. return end do SCAN_ENTRIES end subroutine pdg_list_match_replace @ %def pdg_list_match_replace @ Just check if a PDG array matches any entry in the PDG list. The second version returns the position of the match within the list. An optional mask indicates the list elements that should be checked. <>= generic :: operator (.match.) => pdg_list_match_pdg_array procedure, private :: pdg_list_match_pdg_array procedure :: find_match => pdg_list_find_match_pdg_array <>= module function pdg_list_match_pdg_array (pl, pa) result (flag) class(pdg_list_t), intent(in) :: pl type(pdg_array_t), intent(in) :: pa logical :: flag end function pdg_list_match_pdg_array module function pdg_list_find_match_pdg_array (pl, pa, mask) result (i) class(pdg_list_t), intent(in) :: pl type(pdg_array_t), intent(in) :: pa logical, dimension(:), intent(in), optional :: mask integer :: i end function pdg_list_find_match_pdg_array <>= module function pdg_list_match_pdg_array (pl, pa) result (flag) class(pdg_list_t), intent(in) :: pl type(pdg_array_t), intent(in) :: pa logical :: flag flag = pl%find_match (pa) /= 0 end function pdg_list_match_pdg_array module function pdg_list_find_match_pdg_array (pl, pa, mask) result (i) class(pdg_list_t), intent(in) :: pl type(pdg_array_t), intent(in) :: pa logical, dimension(:), intent(in), optional :: mask integer :: i do i = 1, size (pl%a) if (present (mask)) then if (.not. mask(i)) cycle end if if (pl%a(i) .match. pa) return end do i = 0 end function pdg_list_find_match_pdg_array @ %def pdg_list_match_pdg_array @ %def pdg_list_find_match_pdg_array @ Some old compilers have problems with allocatable arrays as intent(out) or as function result, so be conservative here: <>= procedure :: create_pdg_array => pdg_list_create_pdg_array <>= module subroutine pdg_list_create_pdg_array (pl, pdg) class(pdg_list_t), intent(in) :: pl type(pdg_array_t), dimension(:), intent(inout), allocatable :: pdg end subroutine pdg_list_create_pdg_array <>= module subroutine pdg_list_create_pdg_array (pl, pdg) class(pdg_list_t), intent(in) :: pl type(pdg_array_t), dimension(:), intent(inout), allocatable :: pdg integer :: n_elements integer :: i associate (a => pl%a) n_elements = size (a) if (allocated (pdg)) deallocate (pdg) allocate (pdg (n_elements)) do i = 1, n_elements pdg(i) = a(i) end do end associate end subroutine pdg_list_create_pdg_array @ %def pdg_list_create_pdg_array @ <>= procedure :: create_antiparticles => pdg_list_create_antiparticles <>= module subroutine pdg_list_create_antiparticles (pl, pl_anti, n_new_particles) class(pdg_list_t), intent(in) :: pl type(pdg_list_t), intent(out) :: pl_anti integer, intent(out) :: n_new_particles end subroutine pdg_list_create_antiparticles <>= module subroutine pdg_list_create_antiparticles (pl, pl_anti, n_new_particles) class(pdg_list_t), intent(in) :: pl type(pdg_list_t), intent(out) :: pl_anti integer, intent(out) :: n_new_particles type(pdg_list_t) :: pl_inverse integer :: i, n integer :: n_identical logical, dimension(:), allocatable :: collect n = pl%get_size (); n_identical = 0 allocate (collect (n)); collect = .true. call pl_inverse%init (n) do i = 1, n pl_inverse%a(i) = pl%a(i)%invert() end do do i = 1, n if (any (pl_inverse%a(i) == pl%a)) then collect(i) = .false. n_identical = n_identical + 1 end if end do n_new_particles = n - n_identical if (n_new_particles > 0) then call pl_anti%init (n_new_particles) do i = 1, n if (collect (i)) pl_anti%a(i) = pl_inverse%a(i) end do end if end subroutine pdg_list_create_antiparticles @ %def pdg_list_create_antiparticles @ <>= procedure :: search_for_particle => pdg_list_search_for_particle <>= elemental module function pdg_list_search_for_particle (pl, i_part) result (found) logical :: found class(pdg_list_t), intent(in) :: pl integer, intent(in) :: i_part end function pdg_list_search_for_particle <>= elemental module function pdg_list_search_for_particle (pl, i_part) result (found) logical :: found class(pdg_list_t), intent(in) :: pl integer, intent(in) :: i_part integer :: i_pl do i_pl = 1, size (pl%a) found = pl%a(i_pl)%search_for_particle (i_part) if (found) return end do end function pdg_list_search_for_particle @ %def pdg_list_search_for_particle @ <>= procedure :: contains_colored_particles => pdg_list_contains_colored_particles <>= module function pdg_list_contains_colored_particles (pl) result (colored) class(pdg_list_t), intent(in) :: pl logical :: colored end function pdg_list_contains_colored_particles <>= module function pdg_list_contains_colored_particles (pl) result (colored) class(pdg_list_t), intent(in) :: pl logical :: colored integer :: i colored = .false. do i = 1, size (pl%a) if (pl%a(i)%has_colored_particles()) then colored = .true. exit end if end do end function pdg_list_contains_colored_particles @ %def pdg_list_contains_colored_particles @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[pdg_arrays_ut.f90]]>>= <> module pdg_arrays_ut use unit_tests use pdg_arrays_uti <> <> contains <> end module pdg_arrays_ut @ %def pdg_arrays_ut @ <<[[pdg_arrays_uti.f90]]>>= <> module pdg_arrays_uti use pdg_arrays <> <> contains <> end module pdg_arrays_uti @ %def pdg_arrays_ut @ API: driver for the unit tests below. <>= public :: pdg_arrays_test <>= subroutine pdg_arrays_test (u, results) integer, intent(in) :: u type (test_results_t), intent(inout) :: results <> end subroutine pdg_arrays_test @ %def pdg_arrays_test @ Basic functionality. <>= call test (pdg_arrays_1, "pdg_arrays_1", & "create and sort PDG array", & u, results) <>= public :: pdg_arrays_1 <>= subroutine pdg_arrays_1 (u) integer, intent(in) :: u type(pdg_array_t) :: pa, pa1, pa2, pa3, pa4, pa5, pa6 integer, dimension(:), allocatable :: pdg write (u, "(A)") "* Test output: pdg_arrays_1" write (u, "(A)") "* Purpose: create and sort PDG arrays" write (u, "(A)") write (u, "(A)") "* Assignment" write (u, "(A)") call pa%write (u) write (u, *) write (u, "(A,I0)") "length = ", pa%get_length () pdg = pa write (u, "(A,3(1x,I0))") "contents = ", pdg write (u, *) pa = 1 call pa%write (u) write (u, *) write (u, "(A,I0)") "length = ", pa%get_length () pdg = pa write (u, "(A,3(1x,I0))") "contents = ", pdg write (u, *) pa = [1, 2, 3] call pa%write (u) write (u, *) write (u, "(A,I0)") "length = ", pa%get_length () pdg = pa write (u, "(A,3(1x,I0))") "contents = ", pdg write (u, "(A,I0)") "element #2 = ", pa%get (2) write (u, *) write (u, "(A)") "* Replace" write (u, *) pa = pa%replace (2, [-5, 5, -7]) call pa%write (u) write (u, *) write (u, *) write (u, "(A)") "* Sort" write (u, *) pa = [1, -7, 3, -5, 5, 3] call pa%write (u) write (u, *) pa1 = pa%sort_abs () pa2 = pa%sort_abs (unique = .true.) call pa1%write (u) write (u, *) call pa2%write (u) write (u, *) write (u, *) write (u, "(A)") "* Compare" write (u, *) pa1 = [1, 3] pa2 = [1, 2, -2] pa3 = [1, 2, 4] pa4 = [1, 2, 4] pa5 = [1, 2, -4] pa6 = [1, 2, -3] write (u, "(A,6(1x,L1))") "< ", & pa1 < pa2, pa2 < pa3, pa3 < pa4, pa4 < pa5, pa5 < pa6, pa6 < pa1 write (u, "(A,6(1x,L1))") "> ", & pa1 > pa2, pa2 > pa3, pa3 > pa4, pa4 > pa5, pa5 > pa6, pa6 > pa1 write (u, "(A,6(1x,L1))") "<=", & pa1 <= pa2, pa2 <= pa3, pa3 <= pa4, pa4 <= pa5, pa5 <= pa6, pa6 <= pa1 write (u, "(A,6(1x,L1))") ">=", & pa1 >= pa2, pa2 >= pa3, pa3 >= pa4, pa4 >= pa5, pa5 >= pa6, pa6 >= pa1 write (u, "(A,6(1x,L1))") "==", & pa1 == pa2, pa2 == pa3, pa3 == pa4, pa4 == pa5, pa5 == pa6, pa6 == pa1 write (u, "(A,6(1x,L1))") "/=", & pa1 /= pa2, pa2 /= pa3, pa3 /= pa4, pa4 /= pa5, pa5 /= pa6, pa6 /= pa1 write (u, *) pa1 = [0] pa2 = [1, 2] pa3 = [1, -2] write (u, "(A,6(1x,L1))") "eqv ", & pa1 .eqv. pa1, pa1 .eqv. pa2, & pa2 .eqv. pa2, pa2 .eqv. pa3 write (u, "(A,6(1x,L1))") "neqv", & pa1 .neqv. pa1, pa1 .neqv. pa2, & pa2 .neqv. pa2, pa2 .neqv. pa3 write (u, *) write (u, "(A,6(1x,L1))") "match", & pa1 .match. 0, pa1 .match. 1, & pa2 .match. 0, pa2 .match. 1, pa2 .match. 3 write (u, "(A)") write (u, "(A)") "* Test output end: pdg_arrays_1" end subroutine pdg_arrays_1 @ %def pdg_arrays_1 @ PDG array list, i.e., arrays of arrays. <>= call test (pdg_arrays_2, "pdg_arrays_2", & "create and sort PDG lists", & u, results) <>= public :: pdg_arrays_2 <>= subroutine pdg_arrays_2 (u) integer, intent(in) :: u type(pdg_array_t) :: pa type(pdg_list_t) :: pl, pl1 write (u, "(A)") "* Test output: pdg_arrays_2" write (u, "(A)") "* Purpose: create and sort PDG lists" write (u, "(A)") write (u, "(A)") "* Assignment" write (u, "(A)") call pl%init (3) call pl%set (1, 42) call pl%set (2, [3, 2]) pa = [5, -5] call pl%set (3, pa) call pl%write (u) write (u, *) write (u, "(A,I0)") "size = ", pl%get_size () write (u, "(A)") write (u, "(A)") "* Sort" write (u, "(A)") pl = pl%sort_abs () call pl%write (u) write (u, *) write (u, "(A)") write (u, "(A)") "* Extract item #3" write (u, "(A)") pa = pl%get (3) call pa%write (u) write (u, *) write (u, "(A)") write (u, "(A)") "* Replace item #3" write (u, "(A)") call pl1%init (2) call pl1%set (1, [2, 4]) call pl1%set (2, -7) pl = pl%replace (3, pl1) call pl%write (u) write (u, *) write (u, "(A)") write (u, "(A)") "* Test output end: pdg_arrays_2" end subroutine pdg_arrays_2 @ %def pdg_arrays_2 @ Check if a (sorted) PDG array lists is regular. The entries (PDG arrays) must not overlap, unless they are identical. <>= call test (pdg_arrays_3, "pdg_arrays_3", & "check PDG lists", & u, results) <>= public :: pdg_arrays_3 <>= subroutine pdg_arrays_3 (u) integer, intent(in) :: u type(pdg_list_t) :: pl write (u, "(A)") "* Test output: pdg_arrays_3" write (u, "(A)") "* Purpose: check for regular PDG lists" write (u, "(A)") write (u, "(A)") "* Regular list" write (u, "(A)") call pl%init (4) call pl%set (1, [1, 2]) call pl%set (2, [1, 2]) call pl%set (3, [5, -5]) call pl%set (4, 42) call pl%write (u) write (u, *) write (u, "(L1)") pl%is_regular () write (u, "(A)") write (u, "(A)") "* Irregular list" write (u, "(A)") call pl%init (4) call pl%set (1, [1, 2]) call pl%set (2, [1, 2]) call pl%set (3, [2, 5, -5]) call pl%set (4, 42) call pl%write (u) write (u, *) write (u, "(L1)") pl%is_regular () write (u, "(A)") write (u, "(A)") "* Test output end: pdg_arrays_3" end subroutine pdg_arrays_3 @ %def pdg_arrays_3 @ Compare PDG array lists. The lists must be regular, i.e., sorted and with non-overlapping (or identical) entries. <>= call test (pdg_arrays_4, "pdg_arrays_4", & "compare PDG lists", & u, results) <>= public :: pdg_arrays_4 <>= subroutine pdg_arrays_4 (u) integer, intent(in) :: u type(pdg_list_t) :: pl1, pl2, pl3 write (u, "(A)") "* Test output: pdg_arrays_4" write (u, "(A)") "* Purpose: check for regular PDG lists" write (u, "(A)") write (u, "(A)") "* Create lists" write (u, "(A)") call pl1%init (4) call pl1%set (1, [1, 2]) call pl1%set (2, [1, 2]) call pl1%set (3, [5, -5]) call pl1%set (4, 42) write (u, "(I1,1x)", advance = "no") 1 call pl1%write (u) write (u, *) call pl2%init (2) call pl2%set (1, 3) call pl2%set (2, [5, -5]) write (u, "(I1,1x)", advance = "no") 2 call pl2%write (u) write (u, *) call pl3%init (2) call pl3%set (1, 4) call pl3%set (2, [5, -5]) write (u, "(I1,1x)", advance = "no") 3 call pl3%write (u) write (u, *) write (u, "(A)") write (u, "(A)") "* a == b" write (u, "(A)") write (u, "(2x,A)") "123" write (u, *) write (u, "(I1,1x,4L1)") 1, pl1 == pl1, pl1 == pl2, pl1 == pl3 write (u, "(I1,1x,4L1)") 2, pl2 == pl1, pl2 == pl2, pl2 == pl3 write (u, "(I1,1x,4L1)") 3, pl3 == pl1, pl3 == pl2, pl3 == pl3 write (u, "(A)") write (u, "(A)") "* a < b" write (u, "(A)") write (u, "(2x,A)") "123" write (u, *) write (u, "(I1,1x,4L1)") 1, pl1 < pl1, pl1 < pl2, pl1 < pl3 write (u, "(I1,1x,4L1)") 2, pl2 < pl1, pl2 < pl2, pl2 < pl3 write (u, "(I1,1x,4L1)") 3, pl3 < pl1, pl3 < pl2, pl3 < pl3 write (u, "(A)") write (u, "(A)") "* Test output end: pdg_arrays_4" end subroutine pdg_arrays_4 @ %def pdg_arrays_4 @ Match-replace: translate all entries in the first list into the matching entries of the second list, if there is a match. <>= call test (pdg_arrays_5, "pdg_arrays_5", & "match PDG lists", & u, results) <>= public :: pdg_arrays_5 <>= subroutine pdg_arrays_5 (u) integer, intent(in) :: u type(pdg_list_t) :: pl1, pl2, pl3 logical :: success write (u, "(A)") "* Test output: pdg_arrays_5" write (u, "(A)") "* Purpose: match-replace" write (u, "(A)") write (u, "(A)") "* Create lists" write (u, "(A)") call pl1%init (2) call pl1%set (1, [1, 2]) call pl1%set (2, 42) call pl1%write (u) write (u, *) call pl3%init (2) call pl3%set (1, [42, -42]) call pl3%set (2, [1, 2, 3, 4]) call pl1%match_replace (pl3, success) call pl3%write (u) write (u, "(1x,A,1x,L1,':',1x)", advance="no") "=>", success call pl1%write (u) write (u, *) write (u, *) call pl2%init (2) call pl2%set (1, 9) call pl2%set (2, 42) call pl2%write (u) write (u, *) call pl2%match_replace (pl3, success) call pl3%write (u) write (u, "(1x,A,1x,L1,':',1x)", advance="no") "=>", success call pl2%write (u) write (u, *) write (u, "(A)") write (u, "(A)") "* Test output end: pdg_arrays_5" end subroutine pdg_arrays_5 @ %def pdg_arrays_5 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Jets} The FastJet library is linked externally, if available. The wrapper code is also in a separate directory. Here, we define \whizard-specific procedures and tests. <<[[jets.f90]]>>= <> module jets use fastjet !NODEP! <> <> contains <> end module jets @ %def jets @ \subsection{Re-exported symbols} We use this module as a proxy for the FastJet interface, therefore we re-export some symbols. <>= public :: fastjet_available public :: fastjet_init public :: jet_definition_t public :: pseudojet_t public :: pseudojet_vector_t public :: cluster_sequence_t public :: assignment (=) @ %def jet_definition_t pseudojet_t pseudojet_vector_t cluster_sequence_t @ The initialization routine prints the banner. <>= subroutine fastjet_init () call print_banner () end subroutine fastjet_init @ %def fastjet_init @ The jet algorithm codes (actually, integers) <>= public :: kt_algorithm public :: cambridge_algorithm public :: antikt_algorithm public :: genkt_algorithm public :: cambridge_for_passive_algorithm public :: genkt_for_passive_algorithm public :: ee_kt_algorithm public :: ee_genkt_algorithm public :: plugin_algorithm public :: undefined_jet_algorithm @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[jets_ut.f90]]>>= <> module jets_ut use unit_tests use jets_uti <> <> contains <> end module jets_ut @ %def jets_ut @ <<[[jets_uti.f90]]>>= <> module jets_uti <> use fastjet !NODEP! use jets <> <> contains <> end module jets_uti @ %def jets_ut @ API: driver for the unit tests below. <>= public :: jets_test <>= subroutine jets_test (u, results) integer, intent(in) :: u type (test_results_t), intent(inout) :: results <> end subroutine jets_test @ %def jets_test @ This test is actually the minimal example from the FastJet manual, translated to Fortran. Note that FastJet creates pseudojet vectors, which we mirror in the [[pseudojet_vector_t]], but immediately assign to pseudojet arrays. Without automatic finalization available in the compilers, we should avoid this in actual code and rather introduce intermediate variables for those objects, which we can finalize explicitly. <>= call test (jets_1, "jets_1", & "basic FastJet functionality", & u, results) <>= public :: jets_1 <>= subroutine jets_1 (u) integer, intent(in) :: u type(pseudojet_t), dimension(:), allocatable :: prt, jets, constituents type(jet_definition_t) :: jet_def type(cluster_sequence_t) :: cs integer, parameter :: dp = default integer :: i, j write (u, "(A)") "* Test output: jets_1" write (u, "(A)") "* Purpose: test basic FastJet functionality" write (u, "(A)") write (u, "(A)") "* Print banner" call print_banner () write (u, *) write (u, "(A)") "* Prepare input particles" allocate (prt (3)) call prt(1)%init ( 99._dp, 0.1_dp, 0._dp, 100._dp) call prt(2)%init ( 4._dp,-0.1_dp, 0._dp, 5._dp) call prt(3)%init (-99._dp, 0._dp, 0._dp, 99._dp) write (u, *) write (u, "(A)") "* Define jet algorithm" call jet_def%init (antikt_algorithm, 0.7_dp) write (u, *) write (u, "(A)") "* Cluster particles according to jet algorithm" write (u, *) write (u, "(A,A)") "Clustering with ", jet_def%description () call cs%init (pseudojet_vector (prt), jet_def) write (u, *) write (u, "(A)") "* Sort output jets" jets = sorted_by_pt (cs%inclusive_jets ()) write (u, *) write (u, "(A)") "* Print jet observables and constituents" write (u, *) write (u, "(4x,3(7x,A3))") "pt", "y", "phi" do i = 1, size (jets) write (u, "(A,1x,I0,A,3(1x,F9.5))") & "jet", i, ":", jets(i)%perp (), jets(i)%rap (), jets(i)%phi () constituents = jets(i)%constituents () do j = 1, size (constituents) write (u, "(4x,A,1x,I0,A,F9.5)") & "constituent", j, "'s pt:", constituents(j)%perp () end do do j = 1, size (constituents) call constituents(j)%final () end do end do write (u, *) write (u, "(A)") "* Cleanup" do i = 1, size (prt) call prt(i)%final () end do do i = 1, size (jets) call jets(i)%final () end do call jet_def%final () call cs%final () write (u, "(A)") write (u, "(A)") "* Test output end: jets_1" end subroutine jets_1 @ %def jets_1 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Subevents} The purpose of subevents is to store the relevant part of the physical event (either partonic or hadronic), and to hold particle selections and combinations which are constructed in cut or analysis expressions. <<[[subevents.f90]]>>= <> module subevents use, intrinsic :: iso_c_binding !NODEP! <> use numeric_utils, only: pacify use c_particles use lorentz use pdg_arrays use jets <> <> <> <> <> interface <> end interface end module subevents @ %def subevents @ <<[[subevents_sub.f90]]>>= <> submodule (subevents) subevents_s use io_units use format_defs, only: FMT_14, FMT_19 use format_utils, only: pac_fmt use physics_defs use sorting implicit none contains <> end submodule subevents_s @ %def subevents_s @ \subsection{Particles} For the purpose of this module, a particle has a type which can indicate a beam, incoming, outgoing, or composite particle, flavor and helicity codes (integer, undefined for composite), four-momentum and invariant mass squared. (Other particles types are used in extended event types, but also defined here.) Furthermore, each particle has an allocatable array of ancestors -- particle indices which indicate the building blocks of a composite particle. For an incoming/outgoing particle, the array contains only the index of the particle itself. For incoming particles, the momentum is inverted before storing it in the particle object. <>= integer, parameter, public :: PRT_UNDEFINED = 0 integer, parameter, public :: PRT_BEAM = -9 integer, parameter, public :: PRT_INCOMING = 1 integer, parameter, public :: PRT_OUTGOING = 2 integer, parameter, public :: PRT_COMPOSITE = 3 integer, parameter, public :: PRT_VIRTUAL = 4 integer, parameter, public :: PRT_RESONANT = 5 integer, parameter, public :: PRT_BEAM_REMNANT = 9 @ %def PRT_UNDEFINED PRT_BEAM @ %def PRT_INCOMING PRT_OUTGOING PRT_COMPOSITE @ %def PRT_COMPOSITE PRT_VIRTUAL PRT_RESONANT @ %def PRT_BEAM_REMNANT @ \subsubsection{The type} We initialize only the type here and mark as unpolarized. The initializers below do the rest. The logicals [[is_b_jet]] and [[is_c_jet]] are true only if [[prt_t]] comes out of the [[subevt_cluster]] routine and fulfils the correct flavor content. <>= public :: prt_t <>= type :: prt_t private integer :: type = PRT_UNDEFINED integer :: pdg logical :: polarized = .false. logical :: colorized = .false. logical :: clustered = .false. logical :: is_b_jet = .false. logical :: is_c_jet = .false. integer :: h type(vector4_t) :: p real(default) :: p2 integer, dimension(:), allocatable :: src integer, dimension(:), allocatable :: col integer, dimension(:), allocatable :: acl end type prt_t @ %def prt_t @ Initializers. Polarization is set separately. Finalizers are not needed. <>= subroutine prt_init_beam (prt, pdg, p, p2, src) type(prt_t), intent(out) :: prt integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in) :: src prt%type = PRT_BEAM call prt_set (prt, pdg, - p, p2, src) end subroutine prt_init_beam subroutine prt_init_incoming (prt, pdg, p, p2, src) type(prt_t), intent(out) :: prt integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in) :: src prt%type = PRT_INCOMING call prt_set (prt, pdg, - p, p2, src) end subroutine prt_init_incoming subroutine prt_init_outgoing (prt, pdg, p, p2, src) type(prt_t), intent(out) :: prt integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in) :: src prt%type = PRT_OUTGOING call prt_set (prt, pdg, p, p2, src) end subroutine prt_init_outgoing subroutine prt_init_composite (prt, p, src) type(prt_t), intent(out) :: prt type(vector4_t), intent(in) :: p integer, dimension(:), intent(in) :: src prt%type = PRT_COMPOSITE call prt_set (prt, 0, p, p**2, src) end subroutine prt_init_composite @ %def prt_init_beam prt_init_incoming prt_init_outgoing prt_init_composite @ This version is for temporary particle objects, so the [[src]] array is not set. <>= public :: prt_init_combine <>= module subroutine prt_init_combine (prt, prt1, prt2) type(prt_t), intent(out) :: prt type(prt_t), intent(in) :: prt1, prt2 end subroutine prt_init_combine <>= module subroutine prt_init_combine (prt, prt1, prt2) type(prt_t), intent(out) :: prt type(prt_t), intent(in) :: prt1, prt2 type(vector4_t) :: p integer, dimension(0) :: src prt%type = PRT_COMPOSITE p = prt1%p + prt2%p call prt_set (prt, 0, p, p**2, src) end subroutine prt_init_combine @ %def prt_init_combine @ Init from a pseudojet object. <>= subroutine prt_init_pseudojet (prt, jet, src, pdg, is_b_jet, is_c_jet) type(prt_t), intent(out) :: prt type(pseudojet_t), intent(in) :: jet integer, dimension(:), intent(in) :: src integer, intent(in) :: pdg logical, intent(in) :: is_b_jet, is_c_jet type(vector4_t) :: p prt%type = PRT_COMPOSITE p = vector4_moving (jet%e(), & vector3_moving ([jet%px(), jet%py(), jet%pz()])) call prt_set (prt, pdg, p, p**2, src) prt%is_b_jet = is_b_jet prt%is_c_jet = is_c_jet prt%clustered = .true. end subroutine prt_init_pseudojet @ %def prt_init_pseudojet @ \subsubsection{Accessing contents} <>= public :: prt_get_pdg <>= elemental module function prt_get_pdg (prt) result (pdg) integer :: pdg type(prt_t), intent(in) :: prt end function prt_get_pdg <>= elemental module function prt_get_pdg (prt) result (pdg) integer :: pdg type(prt_t), intent(in) :: prt pdg = prt%pdg end function prt_get_pdg @ %def prt_get_pdg <>= public :: prt_get_momentum <>= elemental module function prt_get_momentum (prt) result (p) type(vector4_t) :: p type(prt_t), intent(in) :: prt end function prt_get_momentum <>= elemental module function prt_get_momentum (prt) result (p) type(vector4_t) :: p type(prt_t), intent(in) :: prt p = prt%p end function prt_get_momentum @ %def prt_get_momentum <>= public :: prt_get_msq <>= elemental module function prt_get_msq (prt) result (msq) real(default) :: msq type(prt_t), intent(in) :: prt end function prt_get_msq <>= elemental module function prt_get_msq (prt) result (msq) real(default) :: msq type(prt_t), intent(in) :: prt msq = prt%p2 end function prt_get_msq @ %def prt_get_msq <>= public :: prt_is_polarized <>= elemental module function prt_is_polarized (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt end function prt_is_polarized <>= elemental module function prt_is_polarized (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt%polarized end function prt_is_polarized @ %def prt_is_polarized <>= public :: prt_get_helicity <>= elemental module function prt_get_helicity (prt) result (h) integer :: h type(prt_t), intent(in) :: prt end function prt_get_helicity <>= elemental module function prt_get_helicity (prt) result (h) integer :: h type(prt_t), intent(in) :: prt h = prt%h end function prt_get_helicity @ %def prt_get_helicity <>= public :: prt_is_colorized <>= elemental module function prt_is_colorized (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt end function prt_is_colorized <>= elemental module function prt_is_colorized (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt%colorized end function prt_is_colorized @ %def prt_is_colorized <>= public :: prt_is_clustered <>= elemental module function prt_is_clustered (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt end function prt_is_clustered <>= elemental module function prt_is_clustered (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt%clustered end function prt_is_clustered @ %def prt_is_clustered <>= public :: prt_is_recombinable <>= elemental module function prt_is_recombinable (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt end function prt_is_recombinable <>= elemental module function prt_is_recombinable (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt_is_parton (prt) .or. & abs(prt%pdg) == TOP_Q .or. & prt_is_lepton (prt) .or. & prt_is_photon (prt) end function prt_is_recombinable @ %def prt_is_recombinable <>= public :: prt_is_photon <>= elemental module function prt_is_photon (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt end function prt_is_photon <>= elemental module function prt_is_photon (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt%pdg == PHOTON end function prt_is_photon @ %def prt_is_photon We do not take the top quark into account here. <>= public :: prt_is_parton <>= elemental module function prt_is_parton (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt end function prt_is_parton <>= elemental module function prt_is_parton (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = abs(prt%pdg) == DOWN_Q .or. & abs(prt%pdg) == UP_Q .or. & abs(prt%pdg) == STRANGE_Q .or. & abs(prt%pdg) == CHARM_Q .or. & abs(prt%pdg) == BOTTOM_Q .or. & prt%pdg == GLUON end function prt_is_parton @ %def prt_is_parton <>= public :: prt_is_lepton <>= elemental module function prt_is_lepton (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt end function prt_is_lepton <>= elemental module function prt_is_lepton (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = abs(prt%pdg) == ELECTRON .or. & abs(prt%pdg) == MUON .or. & abs(prt%pdg) == TAU end function prt_is_lepton @ %def prt_is_lepton <>= public :: prt_is_b_jet <>= elemental module function prt_is_b_jet (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt end function prt_is_b_jet <>= elemental module function prt_is_b_jet (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt%is_b_jet end function prt_is_b_jet @ %def prt_is_b_jet <>= public :: prt_is_c_jet <>= elemental module function prt_is_c_jet (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt end function prt_is_c_jet <>= elemental module function prt_is_c_jet (prt) result (flag) logical :: flag type(prt_t), intent(in) :: prt flag = prt%is_c_jet end function prt_is_c_jet @ %def prt_is_c_jet @ The number of open color (anticolor) lines. We inspect the list of color (anticolor) lines and count the entries that do not appear in the list of anticolors (colors). (There is no check against duplicates; we assume that color line indices are unique.) <>= public :: prt_get_n_col public :: prt_get_n_acl <>= elemental module function prt_get_n_col (prt) result (n) integer :: n type(prt_t), intent(in) :: prt end function prt_get_n_col elemental module function prt_get_n_acl (prt) result (n) integer :: n type(prt_t), intent(in) :: prt end function prt_get_n_acl <>= elemental module function prt_get_n_col (prt) result (n) integer :: n type(prt_t), intent(in) :: prt integer, dimension(:), allocatable :: col, acl integer :: i n = 0 if (prt%colorized) then do i = 1, size (prt%col) if (all (prt%col(i) /= prt%acl)) n = n + 1 end do end if end function prt_get_n_col elemental module function prt_get_n_acl (prt) result (n) integer :: n type(prt_t), intent(in) :: prt integer, dimension(:), allocatable :: col, acl integer :: i n = 0 if (prt%colorized) then do i = 1, size (prt%acl) if (all (prt%acl(i) /= prt%col)) n = n + 1 end do end if end function prt_get_n_acl @ %def prt_get_n_col @ %def prt_get_n_acl @ Return the color and anticolor-flow line indices explicitly. <>= public :: prt_get_color_indices <>= module subroutine prt_get_color_indices (prt, col, acl) type(prt_t), intent(in) :: prt integer, dimension(:), allocatable, intent(out) :: col, acl end subroutine prt_get_color_indices <>= module subroutine prt_get_color_indices (prt, col, acl) type(prt_t), intent(in) :: prt integer, dimension(:), allocatable, intent(out) :: col, acl if (prt%colorized) then col = prt%col acl = prt%acl else col = [integer::] acl = [integer::] end if end subroutine prt_get_color_indices @ %def prt_get_color_indices @ \subsubsection{Setting data} Set the PDG, momentum and momentum squared, and ancestors. If allocate-on-assignment is available, this can be simplified. <>= subroutine prt_set (prt, pdg, p, p2, src) type(prt_t), intent(inout) :: prt integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in) :: src prt%pdg = pdg prt%p = p prt%p2 = p2 if (allocated (prt%src)) then if (size (src) /= size (prt%src)) then deallocate (prt%src) allocate (prt%src (size (src))) end if else allocate (prt%src (size (src))) end if prt%src = src end subroutine prt_set @ %def prt_set @ Set the particle PDG code separately. <>= elemental subroutine prt_set_pdg (prt, pdg) type(prt_t), intent(inout) :: prt integer, intent(in) :: pdg prt%pdg = pdg end subroutine prt_set_pdg @ %def prt_set_pdg @ Set the momentum separately. <>= elemental subroutine prt_set_p (prt, p) type(prt_t), intent(inout) :: prt type(vector4_t), intent(in) :: p prt%p = p end subroutine prt_set_p @ %def prt_set_p @ Set the squared invariant mass separately. <>= elemental subroutine prt_set_p2 (prt, p2) type(prt_t), intent(inout) :: prt real(default), intent(in) :: p2 prt%p2 = p2 end subroutine prt_set_p2 @ %def prt_set_p2 @ Set helicity (optional). <>= subroutine prt_polarize (prt, h) type(prt_t), intent(inout) :: prt integer, intent(in) :: h prt%polarized = .true. prt%h = h end subroutine prt_polarize @ %def prt_polarize @ Set color-flow indices (optional). <>= subroutine prt_colorize (prt, col, acl) type(prt_t), intent(inout) :: prt integer, dimension(:), intent(in) :: col, acl prt%colorized = .true. prt%col = col prt%acl = acl end subroutine prt_colorize @ %def prt_colorize @ \subsubsection{Conversion} Transform a [[prt_t]] object into a [[c_prt_t]] object. <>= public :: c_prt <>= interface c_prt module procedure c_prt_from_prt end interface @ %def c_prt <>= elemental module function c_prt_from_prt (prt) result (c_prt) type(c_prt_t) :: c_prt type(prt_t), intent(in) :: prt end function c_prt_from_prt <>= elemental module function c_prt_from_prt (prt) result (c_prt) type(c_prt_t) :: c_prt type(prt_t), intent(in) :: prt c_prt = prt%p c_prt%type = prt%type c_prt%pdg = prt%pdg if (prt%polarized) then c_prt%polarized = 1 else c_prt%polarized = 0 end if c_prt%h = prt%h end function c_prt_from_prt @ %def c_prt_from_prt @ \subsubsection{Output} <>= public :: prt_write <>= module subroutine prt_write (prt, unit, testflag) type(prt_t), intent(in) :: prt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag end subroutine prt_write <>= module subroutine prt_write (prt, unit, testflag) type(prt_t), intent(in) :: prt integer, intent(in), optional :: unit logical, intent(in), optional :: testflag logical :: pacified type(prt_t) :: tmp character(len=7) :: fmt integer :: u, i call pac_fmt (fmt, FMT_19, FMT_14, testflag) u = given_output_unit (unit); if (u < 0) return pacified = .false. ; if (present (testflag)) pacified = testflag tmp = prt if (pacified) call pacify (tmp) write (u, "(1x,A)", advance="no") "prt(" select case (prt%type) case (PRT_UNDEFINED); write (u, "('?')", advance="no") case (PRT_BEAM); write (u, "('b:')", advance="no") case (PRT_INCOMING); write (u, "('i:')", advance="no") case (PRT_OUTGOING); write (u, "('o:')", advance="no") case (PRT_COMPOSITE); write (u, "('c:')", advance="no") end select select case (prt%type) case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING) if (prt%polarized) then write (u, "(I0,'/',I0,'|')", advance="no") prt%pdg, prt%h else write (u, "(I0,'|')", advance="no") prt%pdg end if end select select case (prt%type) case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING, PRT_COMPOSITE) if (prt%colorized) then write (u, "(*(I0,:,','))", advance="no") prt%col write (u, "('/')", advance="no") write (u, "(*(I0,:,','))", advance="no") prt%acl write (u, "('|')", advance="no") end if end select select case (prt%type) case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING, PRT_COMPOSITE) write (u, "(" // FMT_14 // ",';'," // FMT_14 // ",','," // & FMT_14 // ",','," // FMT_14 // ")", advance="no") tmp%p write (u, "('|'," // fmt // ")", advance="no") tmp%p2 end select if (allocated (prt%src)) then write (u, "('|')", advance="no") do i = 1, size (prt%src) write (u, "(1x,I0)", advance="no") prt%src(i) end do end if if (prt%is_b_jet) then write (u, "('|b jet')", advance="no") end if if (prt%is_c_jet) then write (u, "('|c jet')", advance="no") end if write (u, "(A)") ")" end subroutine prt_write @ %def prt_write @ \subsubsection{Tools} Two particles match if their [[src]] arrays are the same. <>= public :: operator(.match.) <>= interface operator(.match.) module procedure prt_match end interface @ %def .match. <>= elemental module function prt_match (prt1, prt2) result (match) logical :: match type(prt_t), intent(in) :: prt1, prt2 end function prt_match <>= elemental module function prt_match (prt1, prt2) result (match) logical :: match type(prt_t), intent(in) :: prt1, prt2 if (size (prt1%src) == size (prt2%src)) then match = all (prt1%src == prt2%src) else match = .false. end if end function prt_match @ %def prt_match @ The combine operation makes a pseudoparticle whose momentum is the result of adding (the momenta of) the pair of input particles. We trace the particles from which a particle is built by storing a [[src]] array. Each particle entry in the [[src]] list contains a list of indices which indicates its building blocks. The indices refer to an original list of particles. Index lists are sorted, and they contain no element more than once. We thus require that in a given pseudoparticle, each original particle occurs at most once. The result is intent(inout), so it will not be initialized when the subroutine is entered. If the particles carry color, we recall that the combined particle is a composite which is understood as outgoing. If one of the arguments is an incoming particle, is color entries must be reversed. <>= subroutine prt_combine (prt, prt_in1, prt_in2, ok) type(prt_t), intent(inout) :: prt type(prt_t), intent(in) :: prt_in1, prt_in2 logical :: ok integer, dimension(:), allocatable :: src integer, dimension(:), allocatable :: col1, acl1, col2, acl2 call combine_index_lists (src, prt_in1%src, prt_in2%src) ok = allocated (src) if (ok) then call prt_init_composite (prt, prt_in1%p + prt_in2%p, src) if (prt_in1%colorized .or. prt_in2%colorized) then select case (prt_in1%type) case default call prt_get_color_indices (prt_in1, col1, acl1) case (PRT_BEAM, PRT_INCOMING) call prt_get_color_indices (prt_in1, acl1, col1) end select select case (prt_in2%type) case default call prt_get_color_indices (prt_in2, col2, acl2) case (PRT_BEAM, PRT_INCOMING) call prt_get_color_indices (prt_in2, acl2, col2) end select call prt_colorize (prt, [col1, col2], [acl1, acl2]) end if end if end subroutine prt_combine @ %def prt_combine @ This variant does not produce the combined particle, it just checks whether the combination is valid (no common [[src]] entry). <>= public :: are_disjoint <>= module function are_disjoint (prt_in1, prt_in2) result (flag) logical :: flag type(prt_t), intent(in) :: prt_in1, prt_in2 end function are_disjoint <>= module function are_disjoint (prt_in1, prt_in2) result (flag) logical :: flag type(prt_t), intent(in) :: prt_in1, prt_in2 flag = index_lists_are_disjoint (prt_in1%src, prt_in2%src) end function are_disjoint @ %def are_disjoint @ [[src]] Lists with length $>1$ are built by a [[combine]] operation which merges the lists in a sorted manner. If the result would have a duplicate entry, it is discarded, and the result is unallocated. <>= subroutine combine_index_lists (res, src1, src2) integer, dimension(:), intent(in) :: src1, src2 integer, dimension(:), allocatable :: res integer :: i1, i2, i allocate (res (size (src1) + size (src2))) if (size (src1) == 0) then res = src2 return else if (size (src2) == 0) then res = src1 return end if i1 = 1 i2 = 1 LOOP: do i = 1, size (res) if (src1(i1) < src2(i2)) then res(i) = src1(i1); i1 = i1 + 1 if (i1 > size (src1)) then res(i+1:) = src2(i2:) exit LOOP end if else if (src1(i1) > src2(i2)) then res(i) = src2(i2); i2 = i2 + 1 if (i2 > size (src2)) then res(i+1:) = src1(i1:) exit LOOP end if else deallocate (res) exit LOOP end if end do LOOP end subroutine combine_index_lists @ %def combine_index_lists @ This function is similar, but it does not actually merge the list, it just checks whether they are disjoint (no common [[src]] entry). <>= function index_lists_are_disjoint (src1, src2) result (flag) logical :: flag integer, dimension(:), intent(in) :: src1, src2 integer :: i1, i2, i flag = .true. i1 = 1 i2 = 1 LOOP: do i = 1, size (src1) + size (src2) if (src1(i1) < src2(i2)) then i1 = i1 + 1 if (i1 > size (src1)) then exit LOOP end if else if (src1(i1) > src2(i2)) then i2 = i2 + 1 if (i2 > size (src2)) then exit LOOP end if else flag = .false. exit LOOP end if end do LOOP end function index_lists_are_disjoint @ %def index_lists_are_disjoint @ \subsection{subevents} Particles are collected in subevents. This type is implemented as a dynamically allocated array, which need not be completely filled. The value [[n_active]] determines the number of meaningful entries. \subsubsection{Type definition} <>= public :: subevt_t <>= type :: subevt_t private integer :: n_active = 0 type(prt_t), dimension(:), allocatable :: prt contains <> end type subevt_t @ %def subevt_t @ Initialize, allocating with size zero (default) or given size. The number of contained particles is set equal to the size. <>= public :: subevt_init <>= module subroutine subevt_init (subevt, n_active) type(subevt_t), intent(out) :: subevt integer, intent(in), optional :: n_active end subroutine subevt_init <>= module subroutine subevt_init (subevt, n_active) type(subevt_t), intent(out) :: subevt integer, intent(in), optional :: n_active if (present (n_active)) subevt%n_active = n_active allocate (subevt%prt (subevt%n_active)) end subroutine subevt_init @ %def subevt_init @ (Re-)allocate the subevent with some given size. If the size is greater than the previous one, do a real reallocation. Otherwise, just reset the recorded size. Contents are untouched, but become invalid. <>= procedure :: reset => subevt_reset <>= module subroutine subevt_reset (subevt, n_active) class(subevt_t), intent(inout) :: subevt integer, intent(in) :: n_active end subroutine subevt_reset <>= module subroutine subevt_reset (subevt, n_active) class(subevt_t), intent(inout) :: subevt integer, intent(in) :: n_active subevt%n_active = n_active if (subevt%n_active > size (subevt%prt)) then deallocate (subevt%prt) allocate (subevt%prt (subevt%n_active)) end if end subroutine subevt_reset @ %def subevt_reset @ Output. No prefix for the headline 'subevt', because this will usually be printed appending to a previous line. <>= procedure :: write => subevt_write <>= module subroutine subevt_write (object, unit, prefix, pacified) class(subevt_t), intent(in) :: object integer, intent(in), optional :: unit character(*), intent(in), optional :: prefix logical, intent(in), optional :: pacified end subroutine subevt_write <>= module subroutine subevt_write (object, unit, prefix, pacified) class(subevt_t), intent(in) :: object integer, intent(in), optional :: unit character(*), intent(in), optional :: prefix logical, intent(in), optional :: pacified integer :: u, i u = given_output_unit (unit); if (u < 0) return write (u, "(1x,A)") "subevent:" do i = 1, object%n_active if (present (prefix)) write (u, "(A)", advance="no") prefix write (u, "(1x,I0)", advance="no") i call prt_write (object%prt(i), unit = unit, testflag = pacified) end do end subroutine subevt_write @ %def subevt_write @ Defined assignment: transfer only meaningful entries. This is a deep copy (as would be default assignment). <>= interface assignment(=) module procedure subevt_assign end interface @ %def = <>= module subroutine subevt_assign (subevt, subevt_in) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: subevt_in end subroutine subevt_assign <>= module subroutine subevt_assign (subevt, subevt_in) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: subevt_in if (.not. allocated (subevt%prt)) then call subevt_init (subevt, subevt_in%n_active) else call subevt%reset (subevt_in%n_active) end if subevt%prt(:subevt%n_active) = subevt_in%prt(:subevt%n_active) end subroutine subevt_assign @ %def subevt_assign @ \subsubsection{Fill contents} Store incoming/outgoing particles which are completely defined. <>= <>= procedure :: set_beam => subevt_set_beam procedure :: set_composite => subevt_set_composite procedure :: set_incoming => subevt_set_incoming procedure :: set_outgoing => subevt_set_outgoing <>= module subroutine subevt_set_beam (subevt, i, pdg, p, p2, src) class(subevt_t), intent(inout) :: subevt integer, intent(in) :: i integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in), optional :: src end subroutine subevt_set_beam module subroutine subevt_set_incoming (subevt, i, pdg, p, p2, src) class(subevt_t), intent(inout) :: subevt integer, intent(in) :: i integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in), optional :: src end subroutine subevt_set_incoming module subroutine subevt_set_outgoing (subevt, i, pdg, p, p2, src) class(subevt_t), intent(inout) :: subevt integer, intent(in) :: i integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in), optional :: src end subroutine subevt_set_outgoing module subroutine subevt_set_composite (subevt, i, p, src) class(subevt_t), intent(inout) :: subevt integer, intent(in) :: i type(vector4_t), intent(in) :: p integer, dimension(:), intent(in) :: src end subroutine subevt_set_composite <>= module subroutine subevt_set_beam (subevt, i, pdg, p, p2, src) class(subevt_t), intent(inout) :: subevt integer, intent(in) :: i integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in), optional :: src if (present (src)) then call prt_init_beam (subevt%prt(i), pdg, p, p2, src) else call prt_init_beam (subevt%prt(i), pdg, p, p2, [i]) end if end subroutine subevt_set_beam module subroutine subevt_set_incoming (subevt, i, pdg, p, p2, src) class(subevt_t), intent(inout) :: subevt integer, intent(in) :: i integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in), optional :: src if (present (src)) then call prt_init_incoming (subevt%prt(i), pdg, p, p2, src) else call prt_init_incoming (subevt%prt(i), pdg, p, p2, [i]) end if end subroutine subevt_set_incoming module subroutine subevt_set_outgoing (subevt, i, pdg, p, p2, src) class(subevt_t), intent(inout) :: subevt integer, intent(in) :: i integer, intent(in) :: pdg type(vector4_t), intent(in) :: p real(default), intent(in) :: p2 integer, dimension(:), intent(in), optional :: src if (present (src)) then call prt_init_outgoing (subevt%prt(i), pdg, p, p2, src) else call prt_init_outgoing (subevt%prt(i), pdg, p, p2, [i]) end if end subroutine subevt_set_outgoing module subroutine subevt_set_composite (subevt, i, p, src) class(subevt_t), intent(inout) :: subevt integer, intent(in) :: i type(vector4_t), intent(in) :: p integer, dimension(:), intent(in) :: src call prt_init_composite (subevt%prt(i), p, src) end subroutine subevt_set_composite @ %def subevt_set_incoming subevt_set_outgoing subevt_set_composite @ Separately assign flavors, simultaneously for all incoming/outgoing particles. <>= procedure :: set_pdg_beam => subevt_set_pdg_beam procedure :: set_pdg_incoming => subevt_set_pdg_incoming procedure :: set_pdg_outgoing => subevt_set_pdg_outgoing <>= module subroutine subevt_set_pdg_beam (subevt, pdg) class(subevt_t), intent(inout) :: subevt integer, dimension(:), intent(in) :: pdg end subroutine subevt_set_pdg_beam module subroutine subevt_set_pdg_incoming (subevt, pdg) class(subevt_t), intent(inout) :: subevt integer, dimension(:), intent(in) :: pdg end subroutine subevt_set_pdg_incoming module subroutine subevt_set_pdg_outgoing (subevt, pdg) class(subevt_t), intent(inout) :: subevt integer, dimension(:), intent(in) :: pdg end subroutine subevt_set_pdg_outgoing <>= module subroutine subevt_set_pdg_beam (subevt, pdg) class(subevt_t), intent(inout) :: subevt integer, dimension(:), intent(in) :: pdg integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_BEAM) then call prt_set_pdg (subevt%prt(i), pdg(j)) j = j + 1 if (j > size (pdg)) exit end if end do end subroutine subevt_set_pdg_beam module subroutine subevt_set_pdg_incoming (subevt, pdg) class(subevt_t), intent(inout) :: subevt integer, dimension(:), intent(in) :: pdg integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_INCOMING) then call prt_set_pdg (subevt%prt(i), pdg(j)) j = j + 1 if (j > size (pdg)) exit end if end do end subroutine subevt_set_pdg_incoming module subroutine subevt_set_pdg_outgoing (subevt, pdg) class(subevt_t), intent(inout) :: subevt integer, dimension(:), intent(in) :: pdg integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_OUTGOING) then call prt_set_pdg (subevt%prt(i), pdg(j)) j = j + 1 if (j > size (pdg)) exit end if end do end subroutine subevt_set_pdg_outgoing @ %def subevt_set_pdg_beam @ %def subevt_set_pdg_incoming @ %def subevt_set_pdg_outgoing @ Separately assign momenta, simultaneously for all incoming/outgoing particles. <>= procedure :: set_p_beam => subevt_set_p_beam procedure :: set_p_incoming => subevt_set_p_incoming procedure :: set_p_outgoing => subevt_set_p_outgoing <>= module subroutine subevt_set_p_beam (subevt, p) class(subevt_t), intent(inout) :: subevt type(vector4_t), dimension(:), intent(in) :: p end subroutine subevt_set_p_beam module subroutine subevt_set_p_incoming (subevt, p) class(subevt_t), intent(inout) :: subevt type(vector4_t), dimension(:), intent(in) :: p end subroutine subevt_set_p_incoming module subroutine subevt_set_p_outgoing (subevt, p) class(subevt_t), intent(inout) :: subevt type(vector4_t), dimension(:), intent(in) :: p end subroutine subevt_set_p_outgoing <>= module subroutine subevt_set_p_beam (subevt, p) class(subevt_t), intent(inout) :: subevt type(vector4_t), dimension(:), intent(in) :: p integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_BEAM) then call prt_set_p (subevt%prt(i), p(j)) j = j + 1 if (j > size (p)) exit end if end do end subroutine subevt_set_p_beam module subroutine subevt_set_p_incoming (subevt, p) class(subevt_t), intent(inout) :: subevt type(vector4_t), dimension(:), intent(in) :: p integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_INCOMING) then call prt_set_p (subevt%prt(i), p(j)) j = j + 1 if (j > size (p)) exit end if end do end subroutine subevt_set_p_incoming module subroutine subevt_set_p_outgoing (subevt, p) class(subevt_t), intent(inout) :: subevt type(vector4_t), dimension(:), intent(in) :: p integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_OUTGOING) then call prt_set_p (subevt%prt(i), p(j)) j = j + 1 if (j > size (p)) exit end if end do end subroutine subevt_set_p_outgoing @ %def subevt_set_p_beam @ %def subevt_set_p_incoming @ %def subevt_set_p_outgoing @ Separately assign the squared invariant mass, simultaneously for all incoming/outgoing particles. <>= procedure :: set_p2_beam => subevt_set_p2_beam procedure :: set_p2_incoming => subevt_set_p2_incoming procedure :: set_p2_outgoing => subevt_set_p2_outgoing <>= module subroutine subevt_set_p2_beam (subevt, p2) class(subevt_t), intent(inout) :: subevt real(default), dimension(:), intent(in) :: p2 end subroutine subevt_set_p2_beam module subroutine subevt_set_p2_incoming (subevt, p2) class(subevt_t), intent(inout) :: subevt real(default), dimension(:), intent(in) :: p2 end subroutine subevt_set_p2_incoming module subroutine subevt_set_p2_outgoing (subevt, p2) class(subevt_t), intent(inout) :: subevt real(default), dimension(:), intent(in) :: p2 end subroutine subevt_set_p2_outgoing <>= module subroutine subevt_set_p2_beam (subevt, p2) class(subevt_t), intent(inout) :: subevt real(default), dimension(:), intent(in) :: p2 integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_BEAM) then call prt_set_p2 (subevt%prt(i), p2(j)) j = j + 1 if (j > size (p2)) exit end if end do end subroutine subevt_set_p2_beam module subroutine subevt_set_p2_incoming (subevt, p2) class(subevt_t), intent(inout) :: subevt real(default), dimension(:), intent(in) :: p2 integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_INCOMING) then call prt_set_p2 (subevt%prt(i), p2(j)) j = j + 1 if (j > size (p2)) exit end if end do end subroutine subevt_set_p2_incoming module subroutine subevt_set_p2_outgoing (subevt, p2) class(subevt_t), intent(inout) :: subevt real(default), dimension(:), intent(in) :: p2 integer :: i, j j = 1 do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_OUTGOING) then call prt_set_p2 (subevt%prt(i), p2(j)) j = j + 1 if (j > size (p2)) exit end if end do end subroutine subevt_set_p2_outgoing @ %def subevt_set_p2_beam @ %def subevt_set_p2_incoming @ %def subevt_set_p2_outgoing @ Set polarization for an entry <>= public :: subevt_polarize <>= module subroutine subevt_polarize (subevt, i, h) type(subevt_t), intent(inout) :: subevt integer, intent(in) :: i, h end subroutine subevt_polarize <>= module subroutine subevt_polarize (subevt, i, h) type(subevt_t), intent(inout) :: subevt integer, intent(in) :: i, h call prt_polarize (subevt%prt(i), h) end subroutine subevt_polarize @ %def subevt_polarize @ Set color-flow indices for an entry <>= public :: subevt_colorize <>= module subroutine subevt_colorize (subevt, i, col, acl) type(subevt_t), intent(inout) :: subevt integer, intent(in) :: i, col, acl end subroutine subevt_colorize <>= module subroutine subevt_colorize (subevt, i, col, acl) type(subevt_t), intent(inout) :: subevt integer, intent(in) :: i, col, acl if (col > 0 .and. acl > 0) then call prt_colorize (subevt%prt(i), [col], [acl]) else if (col > 0) then call prt_colorize (subevt%prt(i), [col], [integer ::]) else if (acl > 0) then call prt_colorize (subevt%prt(i), [integer ::], [acl]) else call prt_colorize (subevt%prt(i), [integer ::], [integer ::]) end if end subroutine subevt_colorize @ %def subevt_colorize @ \subsubsection{Accessing contents} Return true if the subevent has entries. <>= procedure :: is_nonempty => subevt_is_nonempty <>= module function subevt_is_nonempty (subevt) result (flag) logical :: flag class(subevt_t), intent(in) :: subevt end function subevt_is_nonempty <>= module function subevt_is_nonempty (subevt) result (flag) logical :: flag class(subevt_t), intent(in) :: subevt flag = subevt%n_active /= 0 end function subevt_is_nonempty @ %def subevt_is_nonempty @ Return the number of entries <>= procedure :: get_length => subevt_get_length <>= module function subevt_get_length (subevt) result (length) integer :: length class(subevt_t), intent(in) :: subevt end function subevt_get_length <>= module function subevt_get_length (subevt) result (length) integer :: length class(subevt_t), intent(in) :: subevt length = subevt%n_active end function subevt_get_length @ %def subevt_get_length @ Return a specific particle. The index is not checked for validity. <>= procedure :: get_prt => subevt_get_prt <>= module function subevt_get_prt (subevt, i) result (prt) type(prt_t) :: prt class(subevt_t), intent(in) :: subevt integer, intent(in) :: i end function subevt_get_prt <>= module function subevt_get_prt (subevt, i) result (prt) type(prt_t) :: prt class(subevt_t), intent(in) :: subevt integer, intent(in) :: i prt = subevt%prt(i) end function subevt_get_prt @ %def subevt_get_prt @ Return the partonic energy squared. We take the particles with flag [[PRT_INCOMING]] and compute their total invariant mass. <>= procedure :: get_sqrts_hat => subevt_get_sqrts_hat <>= module function subevt_get_sqrts_hat (subevt) result (sqrts_hat) class(subevt_t), intent(in) :: subevt real(default) :: sqrts_hat end function subevt_get_sqrts_hat <>= module function subevt_get_sqrts_hat (subevt) result (sqrts_hat) class(subevt_t), intent(in) :: subevt real(default) :: sqrts_hat type(vector4_t) :: p integer :: i do i = 1, subevt%n_active if (subevt%prt(i)%type == PRT_INCOMING) then p = p + prt_get_momentum (subevt%prt(i)) end if end do sqrts_hat = p ** 1 end function subevt_get_sqrts_hat @ %def subevt_get_sqrts_hat @ Return the number of incoming (outgoing) particles, respectively. Beam particles or composites are not counted. <>= procedure :: get_n_in => subevt_get_n_in procedure :: get_n_out => subevt_get_n_out <>= module function subevt_get_n_in (subevt) result (n_in) class(subevt_t), intent(in) :: subevt integer :: n_in end function subevt_get_n_in module function subevt_get_n_out (subevt) result (n_out) class(subevt_t), intent(in) :: subevt integer :: n_out end function subevt_get_n_out <>= module function subevt_get_n_in (subevt) result (n_in) class(subevt_t), intent(in) :: subevt integer :: n_in n_in = count (subevt%prt(:subevt%n_active)%type == PRT_INCOMING) end function subevt_get_n_in module function subevt_get_n_out (subevt) result (n_out) class(subevt_t), intent(in) :: subevt integer :: n_out n_out = count (subevt%prt(:subevt%n_active)%type == PRT_OUTGOING) end function subevt_get_n_out @ %def subevt_get_n_in @ %def subevt_get_n_out @ <>= interface c_prt module procedure c_prt_from_subevt module procedure c_prt_array_from_subevt end interface @ %def c_prt <>= module function c_prt_from_subevt (subevt, i) result (c_prt) type(c_prt_t) :: c_prt type(subevt_t), intent(in) :: subevt integer, intent(in) :: i end function c_prt_from_subevt module function c_prt_array_from_subevt (subevt) result (c_prt_array) type(subevt_t), intent(in) :: subevt type(c_prt_t), dimension(subevt%n_active) :: c_prt_array end function c_prt_array_from_subevt <>= module function c_prt_from_subevt (subevt, i) result (c_prt) type(c_prt_t) :: c_prt type(subevt_t), intent(in) :: subevt integer, intent(in) :: i c_prt = c_prt_from_prt (subevt%prt(i)) end function c_prt_from_subevt module function c_prt_array_from_subevt (subevt) result (c_prt_array) type(subevt_t), intent(in) :: subevt type(c_prt_t), dimension(subevt%n_active) :: c_prt_array c_prt_array = c_prt_from_prt (subevt%prt(1:subevt%n_active)) end function c_prt_array_from_subevt @ %def c_prt_from_subevt @ %def c_prt_array_from_subevt @ \subsubsection{Operations with subevents} The join operation joins two subevents. When appending the elements of the second list, we check for each particle whether it is already in the first list. If yes, it is discarded. The result list should be initialized already. If a mask is present, it refers to the second subevent. Particles where the mask is not set are discarded. <>= public :: subevt_join <>= module subroutine subevt_join (subevt, pl1, pl2, mask2) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1, pl2 logical, dimension(:), intent(in), optional :: mask2 end subroutine subevt_join <>= module subroutine subevt_join (subevt, pl1, pl2, mask2) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1, pl2 logical, dimension(:), intent(in), optional :: mask2 integer :: n1, n2, i, n n1 = pl1%n_active n2 = pl2%n_active call subevt%reset (n1 + n2) subevt%prt(:n1) = pl1%prt(:n1) n = n1 if (present (mask2)) then do i = 1, pl2%n_active if (mask2(i)) then if (disjoint (i)) then n = n + 1 subevt%prt(n) = pl2%prt(i) end if end if end do else do i = 1, pl2%n_active if (disjoint (i)) then n = n + 1 subevt%prt(n) = pl2%prt(i) end if end do end if subevt%n_active = n contains function disjoint (i) result (flag) integer, intent(in) :: i logical :: flag integer :: j do j = 1, pl1%n_active if (.not. are_disjoint (pl1%prt(j), pl2%prt(i))) then flag = .false. return end if end do flag = .true. end function disjoint end subroutine subevt_join @ %def subevt_join @ The combine operation makes a subevent whose entries are the result of adding (the momenta of) each pair of particles in the input lists. We trace the particles from which a particles is built by storing a [[src]] array. Each particle entry in the [[src]] list contains a list of indices which indicates its building blocks. The indices refer to an original list of particles. Index lists are sorted, and they contain no element more than once. We thus require that in a given pseudoparticle, each original particle occurs at most once. <>= public :: subevt_combine <>= module subroutine subevt_combine (subevt, pl1, pl2, mask12) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1, pl2 logical, dimension(:,:), intent(in), optional :: mask12 end subroutine subevt_combine <>= module subroutine subevt_combine (subevt, pl1, pl2, mask12) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1, pl2 logical, dimension(:,:), intent(in), optional :: mask12 integer :: n1, n2, i1, i2, n, j logical :: ok n1 = pl1%n_active n2 = pl2%n_active call subevt%reset (n1 * n2) n = 1 do i1 = 1, n1 do i2 = 1, n2 if (present (mask12)) then ok = mask12(i1,i2) else ok = .true. end if if (ok) call prt_combine & (subevt%prt(n), pl1%prt(i1), pl2%prt(i2), ok) if (ok) then CHECK_DOUBLES: do j = 1, n - 1 if (subevt%prt(n) .match. subevt%prt(j)) then ok = .false.; exit CHECK_DOUBLES end if end do CHECK_DOUBLES if (ok) n = n + 1 end if end do end do subevt%n_active = n - 1 end subroutine subevt_combine @ %def subevt_combine @ The collect operation makes a single-entry subevent which results from combining (the momenta of) all particles in the input list. As above, the result does not contain an original particle more than once; this is checked for each particle when it is collected. Furthermore, each entry has a mask; where the mask is false, the entry is dropped. (Thus, if the input particles are already composite, there is some chance that the result depends on the order of the input list and is not as expected. This situation should be avoided.) <>= public :: subevt_collect <>= module subroutine subevt_collect (subevt, pl1, mask1) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1 logical, dimension(:), intent(in) :: mask1 end subroutine subevt_collect <>= module subroutine subevt_collect (subevt, pl1, mask1) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1 logical, dimension(:), intent(in) :: mask1 type(prt_t) :: prt integer :: i logical :: ok call subevt%reset (1) subevt%n_active = 0 do i = 1, pl1%n_active if (mask1(i)) then if (subevt%n_active == 0) then subevt%n_active = 1 subevt%prt(1) = pl1%prt(i) else call prt_combine (prt, subevt%prt(1), pl1%prt(i), ok) if (ok) subevt%prt(1) = prt end if end if end do end subroutine subevt_collect @ %def subevt_collect @ The cluster operation is similar to [[collect]], but applies a jet algorithm. The result is a subevent consisting of jets and, possibly, unclustered extra particles. As above, the result does not contain an original particle more than once; this is checked for each particle when it is collected. Furthermore, each entry has a mask; where the mask is false, the entry is dropped. The algorithm: first determine the (pseudo)particles that participate in the clustering. They should not overlap, and the mask entry must be set. We then cluster the particles, using the given jet definition. The result particles are retrieved from the cluster sequence. We still have to determine the source indices for each jet: for each input particle, we get the jet index. Accumulating the source entries for all particles that are part of a given jet, we derive the jet source entries. Finally, we delete the C structures that have been constructed by FastJet and its interface. <>= public :: subevt_cluster <>= module subroutine subevt_cluster (subevt, pl1, dcut, mask1, jet_def, & keep_jets, exclusive) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1 real(default), intent(in) :: dcut logical, dimension(:), intent(in) :: mask1 type(jet_definition_t), intent(in) :: jet_def logical, intent(in) :: keep_jets, exclusive end subroutine subevt_cluster <>= module subroutine subevt_cluster (subevt, pl1, dcut, mask1, jet_def, & keep_jets, exclusive) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1 real(default), intent(in) :: dcut logical, dimension(:), intent(in) :: mask1 type(jet_definition_t), intent(in) :: jet_def logical, intent(in) :: keep_jets, exclusive integer, dimension(:), allocatable :: map, jet_index type(pseudojet_t), dimension(:), allocatable :: jet_in, jet_out type(pseudojet_vector_t) :: jv_in, jv_out type(cluster_sequence_t) :: cs integer :: i, n_src, n_active call map_prt_index (pl1, mask1, n_src, map) n_active = count (map /= 0) allocate (jet_in (n_active)) allocate (jet_index (n_active)) do i = 1, n_active call jet_in(i)%init (prt_get_momentum (pl1%prt(map(i)))) end do call jv_in%init (jet_in) call cs%init (jv_in, jet_def) if (exclusive) then jv_out = cs%exclusive_jets (dcut) else jv_out = cs%inclusive_jets () end if call cs%assign_jet_indices (jv_out, jet_index) allocate (jet_out (jv_out%size ())) jet_out = jv_out call fill_pseudojet (subevt, pl1, jet_out, jet_index, n_src, map) do i = 1, size (jet_out) call jet_out(i)%final () end do call jv_out%final () call cs%final () call jv_in%final () do i = 1, size (jet_in) call jet_in(i)%final () end do contains ! Uniquely combine sources and add map those new indices to the old ones subroutine map_prt_index (pl1, mask1, n_src, map) type(subevt_t), intent(in) :: pl1 logical, dimension(:), intent(in) :: mask1 integer, intent(out) :: n_src integer, dimension(:), allocatable, intent(out) :: map integer, dimension(:), allocatable :: src, src_tmp integer :: i allocate (src(0)) allocate (map (pl1%n_active), source = 0) n_active = 0 do i = 1, pl1%n_active if (.not. mask1(i)) cycle call combine_index_lists (src_tmp, src, pl1%prt(i)%src) if (.not. allocated (src_tmp)) cycle call move_alloc (from=src_tmp, to=src) n_active = n_active + 1 map(n_active) = i end do n_src = size (src) end subroutine map_prt_index ! Retrieve source(s) of a jet and fill corresponding subevent subroutine fill_pseudojet (subevt, pl1, jet_out, jet_index, n_src, map) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl1 type(pseudojet_t), dimension(:), intent(in) :: jet_out integer, dimension(:), intent(in) :: jet_index integer, dimension(:), intent(in) :: map integer, intent(in) :: n_src integer, dimension(n_src) :: src_fill integer :: i, jet, k, combined_pdg, pdg, n_quarks, n_src_fill logical :: is_b, is_c call subevt%reset (size (jet_out)) do jet = 1, size (jet_out) pdg = 0; src_fill = 0; n_src_fill = 0; combined_pdg = 0; n_quarks = 0 is_b = .false.; is_c = .false. PARTICLE: do i = 1, size (jet_index) if (jet_index(i) /= jet) cycle PARTICLE associate (prt => pl1%prt(map(i)), n_src_prt => size(pl1%prt(map(i))%src)) do k = 1, n_src_prt src_fill(n_src_fill + k) = prt%src(k) end do n_src_fill = n_src_fill + n_src_prt if (is_quark (prt%pdg)) then n_quarks = n_quarks + 1 if (.not. is_b) then if (abs (prt%pdg) == 5) then is_b = .true. is_c = .false. else if (abs (prt%pdg) == 4) then is_c = .true. end if end if if (combined_pdg == 0) combined_pdg = prt%pdg end if end associate end do PARTICLE if (keep_jets .and. n_quarks == 1) pdg = combined_pdg call prt_init_pseudojet (subevt%prt(jet), jet_out(jet), & src_fill(:n_src_fill), pdg, is_b, is_c) end do end subroutine fill_pseudojet end subroutine subevt_cluster @ %def subevt_cluster @ Do recombination. The incoming subevent [[pl]] is left unchanged if it either does not contain photons at all, or consists just of a single photon and nothing else or the photon does have a larger $R>R_0$ distance to the nearest other particle or does not fulfill the [[mask1]] condition. Otherwise, the subevent is one entry shorter and contains a single recombined particle whose original flavor is kept depending on the setting [[keep_flv]]. When this subroutine is called, it is explicitly assumed that there is only one photon. For the moment, we take here the first photon from the subevent to possibly recombine and leave this open for generalization. <>= public :: subevt_recombine <>= module subroutine subevt_recombine (subevt, pl, mask1, reco_r0, keep_flv) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl logical, dimension(:), intent(in) :: mask1 logical, intent(in) :: keep_flv real(default), intent(in) :: reco_r0 end subroutine subevt_recombine <>= module subroutine subevt_recombine (subevt, pl, mask1, reco_r0, keep_flv) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl type(prt_t), dimension(:), allocatable :: prt_rec logical, dimension(:), intent(in) :: mask1 logical, intent(in) :: keep_flv real(default), intent(in) :: reco_r0 real(default), dimension(:), allocatable :: del_rij integer, dimension(:), allocatable :: i_sortr type(prt_t) :: prt_gam, prt_comb logical :: recombine, ok integer :: i, n, i_gam, n_gam, n_rec, pdg_orig n = pl%get_length () n_gam = 0 FIND_FIRST_PHOTON: do i = 1, n if (prt_is_photon (pl%prt (i))) then n_gam = n_gam + 1 prt_gam = pl%prt (i) i_gam = i exit FIND_FIRST_PHOTON end if end do FIND_FIRST_PHOTON n_rec = n - n_gam if (n_gam == 0) then subevt = pl else if (n_rec > 0) then allocate (prt_rec (n_rec)) do i = 1, n_rec if (i == i_gam) cycle if (i < i_gam) then prt_rec(i) = pl%prt(i) else prt_rec(i) = pl%prt(i+n_gam) end if end do allocate (del_rij (n_rec), i_sortr (n_rec)) del_rij(1:n_rec) = eta_phi_distance(prt_get_momentum (prt_gam), & prt_get_momentum (prt_rec(1:n_rec))) i_sortr = order (del_rij) recombine = del_rij (i_sortr (1)) <= reco_r0 .and. mask1(i_gam) if (recombine) then call subevt%reset (pl%n_active-n_gam) do i = 1, n_rec if (i == i_sortr(1)) then pdg_orig = prt_get_pdg (prt_rec(i_sortr (1))) call prt_combine (prt_comb, prt_gam, prt_rec(i_sortr (1)), ok) if (ok) then subevt%prt(i_sortr (1)) = prt_comb if (keep_flv) call prt_set_pdg & (subevt%prt(i_sortr (1)), pdg_orig) end if else subevt%prt(i) = prt_rec(i) end if end do else subevt = pl end if else subevt = pl end if end if end subroutine subevt_recombine @ %def subevt_recombine @ Return a list of all particles for which the mask is true. <>= public :: subevt_select <>= module subroutine subevt_select (subevt, pl, mask1) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl logical, dimension(:), intent(in) :: mask1 end subroutine subevt_select <>= module subroutine subevt_select (subevt, pl, mask1) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl logical, dimension(:), intent(in) :: mask1 integer :: i, n call subevt%reset (pl%n_active) n = 0 do i = 1, pl%n_active if (mask1(i)) then n = n + 1 subevt%prt(n) = pl%prt(i) end if end do subevt%n_active = n end subroutine subevt_select @ %def subevt_select @ Return a subevent which consists of the single particle with specified [[index]]. If [[index]] is negative, count from the end. If it is out of bounds, return an empty list. <>= public :: subevt_extract <>= module subroutine subevt_extract (subevt, pl, index) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl integer, intent(in) :: index end subroutine subevt_extract <>= module subroutine subevt_extract (subevt, pl, index) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl integer, intent(in) :: index if (index > 0) then if (index <= pl%n_active) then call subevt%reset (1) subevt%prt(1) = pl%prt(index) else call subevt%reset (0) end if else if (index < 0) then if (abs (index) <= pl%n_active) then call subevt%reset (1) subevt%prt(1) = pl%prt(pl%n_active + 1 + index) else call subevt%reset (0) end if else call subevt%reset (0) end if end subroutine subevt_extract @ %def subevt_extract @ Return the list of particles sorted according to increasing values of the provided integer or real array. If no array is given, sort by PDG value. <>= public :: subevt_sort <>= interface subevt_sort module procedure subevt_sort_pdg module procedure subevt_sort_int module procedure subevt_sort_real end interface <>= module subroutine subevt_sort_pdg (subevt, pl) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl end subroutine subevt_sort_pdg module subroutine subevt_sort_int (subevt, pl, ival) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl integer, dimension(:), intent(in) :: ival end subroutine subevt_sort_int module subroutine subevt_sort_real (subevt, pl, rval) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl real(default), dimension(:), intent(in) :: rval end subroutine subevt_sort_real <>= module subroutine subevt_sort_pdg (subevt, pl) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl integer :: n n = subevt%n_active call subevt_sort_int (subevt, pl, abs (3 * subevt%prt(:n)%pdg - 1)) end subroutine subevt_sort_pdg module subroutine subevt_sort_int (subevt, pl, ival) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl integer, dimension(:), intent(in) :: ival call subevt%reset (pl%n_active) subevt%n_active = pl%n_active subevt%prt = pl%prt( order (ival) ) end subroutine subevt_sort_int module subroutine subevt_sort_real (subevt, pl, rval) type(subevt_t), intent(inout) :: subevt type(subevt_t), intent(in) :: pl real(default), dimension(:), intent(in) :: rval integer :: i integer, dimension(size(rval)) :: idx call subevt%reset (pl%n_active) subevt%n_active = pl%n_active if (allocated (subevt%prt)) deallocate (subevt%prt) allocate (subevt%prt (size(pl%prt))) idx = order (rval) do i = 1, size (idx) subevt%prt(i) = pl%prt (idx(i)) end do end subroutine subevt_sort_real @ %def subevt_sort @ Return the list of particles which have any of the specified PDG codes (and optionally particle type: beam, incoming, outgoing). <>= public :: subevt_select_pdg_code <>= module subroutine subevt_select_pdg_code (subevt, aval, subevt_in, prt_type) type(subevt_t), intent(inout) :: subevt type(pdg_array_t), intent(in) :: aval type(subevt_t), intent(in) :: subevt_in integer, intent(in), optional :: prt_type end subroutine subevt_select_pdg_code <>= module subroutine subevt_select_pdg_code (subevt, aval, subevt_in, prt_type) type(subevt_t), intent(inout) :: subevt type(pdg_array_t), intent(in) :: aval type(subevt_t), intent(in) :: subevt_in integer, intent(in), optional :: prt_type integer :: n_active, n_match logical, dimension(:), allocatable :: mask integer :: i, j n_active = subevt_in%n_active allocate (mask (n_active)) forall (i = 1:n_active) & mask(i) = aval .match. subevt_in%prt(i)%pdg if (present (prt_type)) & mask = mask .and. subevt_in%prt(:n_active)%type == prt_type n_match = count (mask) call subevt%reset (n_match) j = 0 do i = 1, n_active if (mask(i)) then j = j + 1 subevt%prt(j) = subevt_in%prt(i) end if end do end subroutine subevt_select_pdg_code @ %def subevt_select_pdg_code @ \subsection{Eliminate numerical noise} This is useful for testing purposes: set entries to zero that are smaller in absolute values than a given tolerance parameter. Note: instead of setting the tolerance in terms of EPSILON (kind-dependent), we fix it to $10^{-16}$, which is the typical value for double precision. The reason is that there are situations where intermediate representations (external libraries, files) are limited to double precision, even if the main program uses higher precision. <>= public :: pacify <>= interface pacify module procedure pacify_prt module procedure pacify_subevt end interface pacify @ %def pacify <>= module subroutine pacify_prt (prt) class(prt_t), intent(inout) :: prt end subroutine pacify_prt module subroutine pacify_subevt (subevt) class(subevt_t), intent(inout) :: subevt end subroutine pacify_subevt <>= module subroutine pacify_prt (prt) class(prt_t), intent(inout) :: prt real(default) :: e e = max (1E-10_default * energy (prt%p), 1E-13_default) call pacify (prt%p, e) call pacify (prt%p2, 1E3_default * e) end subroutine pacify_prt module subroutine pacify_subevt (subevt) class(subevt_t), intent(inout) :: subevt integer :: i do i = 1, subevt%n_active call pacify (subevt%prt(i)) end do end subroutine pacify_subevt @ %def pacify_prt @ %def pacify_subevt @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Analysis tools} This module defines structures useful for data analysis. These include observables, histograms, and plots. Observables are quantities that are calculated and summed up event by event. At the end, one can compute the average and error. Histograms have their bins in addition to the observable properties. Histograms are usually written out in tables and displayed graphically. In plots, each record creates its own entry in a table. This can be used for scatter plots if called event by event, or for plotting dependencies on parameters if called once per integration run. Graphs are container for histograms and plots, which carry their own graphics options. The type layout is still somewhat obfuscated. This would become much simpler if type extension could be used. <<[[analysis.f90]]>>= <> module analysis <> <> use os_interface <> <> <> <> <> <> interface <> end interface end module analysis @ %def analysis @ <<[[analysis_sub.f90]]>>= <> submodule (analysis) analysis_s use io_units use format_utils, only: quote_underscore, tex_format use system_defs, only: TAB use diagnostics use ifiles implicit none contains <> end submodule analysis_s @ %def analysis_s @ \subsection{Output formats} These formats share a common field width (alignment). <>= character(*), parameter, public :: HISTOGRAM_HEAD_FORMAT = "1x,A15,3x" character(*), parameter, public :: HISTOGRAM_INTG_FORMAT = "3x,I9,3x" character(*), parameter, public :: HISTOGRAM_DATA_FORMAT = "ES19.12" @ %def HISTOGRAM_HEAD_FORMAT HISTOGRAM_INTG_FORMAT HISTOGRAM_DATA_FORMAT @ \subsection{Graph options} These parameters are used for displaying data. They apply to a whole graph, which may contain more than one plot element. The GAMELAN code chunks are part of both [[graph_options]] and [[drawing_options]]. The [[drawing_options]] copy is used in histograms and plots, also as graph elements. The [[graph_options]] copy is used for [[graph]] objects as a whole. Both copies are usually identical. <>= public :: graph_options_t <>= type :: graph_options_t private type(string_t) :: id type(string_t) :: title type(string_t) :: description type(string_t) :: x_label type(string_t) :: y_label integer :: width_mm = 130 integer :: height_mm = 90 logical :: x_log = .false. logical :: y_log = .false. real(default) :: x_min = 0 real(default) :: x_max = 1 real(default) :: y_min = 0 real(default) :: y_max = 1 logical :: x_min_set = .false. logical :: x_max_set = .false. logical :: y_min_set = .false. logical :: y_max_set = .false. type(string_t) :: gmlcode_bg type(string_t) :: gmlcode_fg contains <> end type graph_options_t @ %def graph_options_t @ Initialize the record, all strings are empty. The limits are undefined. <>= procedure :: init => graph_options_init <>= module subroutine graph_options_init (graph_options) class(graph_options_t), intent(out) :: graph_options end subroutine graph_options_init <>= module subroutine graph_options_init (graph_options) class(graph_options_t), intent(out) :: graph_options graph_options%id = "" graph_options%title = "" graph_options%description = "" graph_options%x_label = "" graph_options%y_label = "" graph_options%gmlcode_bg = "" graph_options%gmlcode_fg = "" end subroutine graph_options_init @ %def graph_options_init @ Set individual options. <>= procedure :: set => graph_options_set <>= module subroutine graph_options_set (graph_options, id, & title, description, x_label, y_label, width_mm, height_mm, & x_log, y_log, x_min, x_max, y_min, y_max, & gmlcode_bg, gmlcode_fg) class(graph_options_t), intent(inout) :: graph_options type(string_t), intent(in), optional :: id type(string_t), intent(in), optional :: title type(string_t), intent(in), optional :: description type(string_t), intent(in), optional :: x_label, y_label integer, intent(in), optional :: width_mm, height_mm logical, intent(in), optional :: x_log, y_log real(default), intent(in), optional :: x_min, x_max, y_min, y_max type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg end subroutine graph_options_set <>= module subroutine graph_options_set (graph_options, id, & title, description, x_label, y_label, width_mm, height_mm, & x_log, y_log, x_min, x_max, y_min, y_max, & gmlcode_bg, gmlcode_fg) class(graph_options_t), intent(inout) :: graph_options type(string_t), intent(in), optional :: id type(string_t), intent(in), optional :: title type(string_t), intent(in), optional :: description type(string_t), intent(in), optional :: x_label, y_label integer, intent(in), optional :: width_mm, height_mm logical, intent(in), optional :: x_log, y_log real(default), intent(in), optional :: x_min, x_max, y_min, y_max type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg if (present (id)) graph_options%id = id if (present (title)) graph_options%title = title if (present (description)) graph_options%description = description if (present (x_label)) graph_options%x_label = x_label if (present (y_label)) graph_options%y_label = y_label if (present (width_mm)) graph_options%width_mm = width_mm if (present (height_mm)) graph_options%height_mm = height_mm if (present (x_log)) graph_options%x_log = x_log if (present (y_log)) graph_options%y_log = y_log if (present (x_min)) graph_options%x_min = x_min if (present (x_max)) graph_options%x_max = x_max if (present (y_min)) graph_options%y_min = y_min if (present (y_max)) graph_options%y_max = y_max if (present (x_min)) graph_options%x_min_set = .true. if (present (x_max)) graph_options%x_max_set = .true. if (present (y_min)) graph_options%y_min_set = .true. if (present (y_max)) graph_options%y_max_set = .true. if (present (gmlcode_bg)) graph_options%gmlcode_bg = gmlcode_bg if (present (gmlcode_fg)) graph_options%gmlcode_fg = gmlcode_fg end subroutine graph_options_set @ %def graph_options_set @ Write a simple account of all options. <>= procedure :: write => graph_options_write <>= module subroutine graph_options_write (gro, unit) class(graph_options_t), intent(in) :: gro integer, intent(in), optional :: unit end subroutine graph_options_write <>= module subroutine graph_options_write (gro, unit) class(graph_options_t), intent(in) :: gro integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) 1 format (A,1x,'"',A,'"') 2 format (A,1x,L1) 3 format (A,1x,ES19.12) 4 format (A,1x,I0) 5 format (A,1x,'[undefined]') write (u, 1) "title =", char (gro%title) write (u, 1) "description =", char (gro%description) write (u, 1) "x_label =", char (gro%x_label) write (u, 1) "y_label =", char (gro%y_label) write (u, 2) "x_log =", gro%x_log write (u, 2) "y_log =", gro%y_log if (gro%x_min_set) then write (u, 3) "x_min =", gro%x_min else write (u, 5) "x_min =" end if if (gro%x_max_set) then write (u, 3) "x_max =", gro%x_max else write (u, 5) "x_max =" end if if (gro%y_min_set) then write (u, 3) "y_min =", gro%y_min else write (u, 5) "y_min =" end if if (gro%y_max_set) then write (u, 3) "y_max =", gro%y_max else write (u, 5) "y_max =" end if write (u, 4) "width_mm =", gro%width_mm write (u, 4) "height_mm =", gro%height_mm write (u, 1) "gmlcode_bg =", char (gro%gmlcode_bg) write (u, 1) "gmlcode_fg =", char (gro%gmlcode_fg) end subroutine graph_options_write @ %def graph_options_write @ Write a \LaTeX\ header/footer for the analysis file. <>= subroutine graph_options_write_tex_header (gro, unit) type(graph_options_t), intent(in) :: gro integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) if (gro%title /= "") then write (u, "(A)") write (u, "(A)") "\section{" // char (gro%title) // "}" else write (u, "(A)") "\section{" // char (quote_underscore (gro%id)) // "}" end if if (gro%description /= "") then write (u, "(A)") char (gro%description) write (u, *) write (u, "(A)") "\vspace*{\baselineskip}" end if write (u, "(A)") "\vspace*{\baselineskip}" write (u, "(A)") "\unitlength 1mm" write (u, "(A,I0,',',I0,A)") & "\begin{gmlgraph*}(", & gro%width_mm, gro%height_mm, & ")[dat]" end subroutine graph_options_write_tex_header subroutine graph_options_write_tex_footer (gro, unit) type(graph_options_t), intent(in) :: gro integer, intent(in), optional :: unit integer :: u, width, height width = gro%width_mm - 10 height = gro%height_mm - 10 u = given_output_unit (unit) write (u, "(A)") " begingmleps ""Whizard-Logo.eps"";" write (u, "(A,I0,A,I0,A)") & " base := (", width, "*unitlength,", height, "*unitlength);" write (u, "(A)") " height := 9.6*unitlength;" write (u, "(A)") " width := 11.2*unitlength;" write (u, "(A)") " endgmleps;" write (u, "(A)") "\end{gmlgraph*}" end subroutine graph_options_write_tex_footer @ %def graph_options_write_tex_header @ %def graph_options_write_tex_footer @ Return the analysis object ID. <>= function graph_options_get_id (gro) result (id) type(string_t) :: id type(graph_options_t), intent(in) :: gro id = gro%id end function graph_options_get_id @ %def graph_options_get_id @ Create an appropriate [[setup]] command (linear/log). <>= function graph_options_get_gml_setup (gro) result (cmd) type(string_t) :: cmd type(graph_options_t), intent(in) :: gro type(string_t) :: x_str, y_str if (gro%x_log) then x_str = "log" else x_str = "linear" end if if (gro%y_log) then y_str = "log" else y_str = "linear" end if cmd = "setup (" // x_str // ", " // y_str // ");" end function graph_options_get_gml_setup @ %def graph_options_get_gml_setup @ Return the labels in GAMELAN form. <>= function graph_options_get_gml_x_label (gro) result (cmd) type(string_t) :: cmd type(graph_options_t), intent(in) :: gro cmd = 'label.bot (<' // '<' // gro%x_label // '>' // '>, out);' end function graph_options_get_gml_x_label function graph_options_get_gml_y_label (gro) result (cmd) type(string_t) :: cmd type(graph_options_t), intent(in) :: gro cmd = 'label.ulft (<' // '<' // gro%y_label // '>' // '>, out);' end function graph_options_get_gml_y_label @ %def graph_options_get_gml_x_label @ %def graph_options_get_gml_y_label @ Create an appropriate [[graphrange]] statement for the given graph options. Where the graph options are not set, use the supplied arguments, if any, otherwise set the undefined value. <>= function graph_options_get_gml_graphrange & (gro, x_min, x_max, y_min, y_max) result (cmd) type(string_t) :: cmd type(graph_options_t), intent(in) :: gro real(default), intent(in), optional :: x_min, x_max, y_min, y_max type(string_t) :: x_min_str, x_max_str, y_min_str, y_max_str character(*), parameter :: fmt = "(ES15.8)" if (gro%x_min_set) then x_min_str = "#" // trim (adjustl (real2string (gro%x_min, fmt))) else if (present (x_min)) then x_min_str = "#" // trim (adjustl (real2string (x_min, fmt))) else x_min_str = "??" end if if (gro%x_max_set) then x_max_str = "#" // trim (adjustl (real2string (gro%x_max, fmt))) else if (present (x_max)) then x_max_str = "#" // trim (adjustl (real2string (x_max, fmt))) else x_max_str = "??" end if if (gro%y_min_set) then y_min_str = "#" // trim (adjustl (real2string (gro%y_min, fmt))) else if (present (y_min)) then y_min_str = "#" // trim (adjustl (real2string (y_min, fmt))) else y_min_str = "??" end if if (gro%y_max_set) then y_max_str = "#" // trim (adjustl (real2string (gro%y_max, fmt))) else if (present (y_max)) then y_max_str = "#" // trim (adjustl (real2string (y_max, fmt))) else y_max_str = "??" end if cmd = "graphrange (" // x_min_str // ", " // y_min_str // "), " & // "(" // x_max_str // ", " // y_max_str // ");" end function graph_options_get_gml_graphrange @ %def graph_options_get_gml_graphrange @ Get extra GAMELAN code to be executed before and after the usual drawing commands. <>= function graph_options_get_gml_bg_command (gro) result (cmd) type(string_t) :: cmd type(graph_options_t), intent(in) :: gro cmd = gro%gmlcode_bg end function graph_options_get_gml_bg_command function graph_options_get_gml_fg_command (gro) result (cmd) type(string_t) :: cmd type(graph_options_t), intent(in) :: gro cmd = gro%gmlcode_fg end function graph_options_get_gml_fg_command @ %def graph_options_get_gml_bg_command @ %def graph_options_get_gml_fg_command @ Append the header for generic data output in ifile format. We print only labels, not graphics parameters. <>= subroutine graph_options_get_header (pl, header, comment) type(graph_options_t), intent(in) :: pl type(ifile_t), intent(inout) :: header type(string_t), intent(in), optional :: comment type(string_t) :: c if (present (comment)) then c = comment else c = "" end if call ifile_append (header, & c // "ID: " // pl%id) call ifile_append (header, & c // "title: " // pl%title) call ifile_append (header, & c // "description: " // pl%description) call ifile_append (header, & c // "x axis label: " // pl%x_label) call ifile_append (header, & c // "y axis label: " // pl%y_label) end subroutine graph_options_get_header @ %def graph_options_get_header @ \subsection{Drawing options} These options apply to an individual graph element (histogram or plot). <>= public :: drawing_options_t <>= type :: drawing_options_t type(string_t) :: dataset logical :: with_hbars = .false. logical :: with_base = .false. logical :: piecewise = .false. logical :: fill = .false. logical :: draw = .false. logical :: err = .false. logical :: symbols = .false. type(string_t) :: fill_options type(string_t) :: draw_options type(string_t) :: err_options type(string_t) :: symbol type(string_t) :: gmlcode_bg type(string_t) :: gmlcode_fg contains <> end type drawing_options_t @ %def drawing_options_t @ Write a simple account of all options. <>= procedure :: write => drawing_options_write <>= module subroutine drawing_options_write (dro, unit) class(drawing_options_t), intent(in) :: dro integer, intent(in), optional :: unit end subroutine drawing_options_write <>= module subroutine drawing_options_write (dro, unit) class(drawing_options_t), intent(in) :: dro integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) 1 format (A,1x,'"',A,'"') 2 format (A,1x,L1) write (u, 2) "with_hbars =", dro%with_hbars write (u, 2) "with_base =", dro%with_base write (u, 2) "piecewise =", dro%piecewise write (u, 2) "fill =", dro%fill write (u, 2) "draw =", dro%draw write (u, 2) "err =", dro%err write (u, 2) "symbols =", dro%symbols write (u, 1) "fill_options=", char (dro%fill_options) write (u, 1) "draw_options=", char (dro%draw_options) write (u, 1) "err_options =", char (dro%err_options) write (u, 1) "symbol =", char (dro%symbol) write (u, 1) "gmlcode_bg =", char (dro%gmlcode_bg) write (u, 1) "gmlcode_fg =", char (dro%gmlcode_fg) end subroutine drawing_options_write @ %def drawing_options_write @ Init with empty strings and default options, appropriate for either histogram or plot. <>= procedure :: init_histogram => drawing_options_init_histogram procedure :: init_plot => drawing_options_init_plot <>= module subroutine drawing_options_init_histogram (dro) class(drawing_options_t), intent(out) :: dro end subroutine drawing_options_init_histogram module subroutine drawing_options_init_plot (dro) class(drawing_options_t), intent(out) :: dro end subroutine drawing_options_init_plot <>= module subroutine drawing_options_init_histogram (dro) class(drawing_options_t), intent(out) :: dro dro%dataset = "dat" dro%with_hbars = .true. dro%with_base = .true. dro%piecewise = .true. dro%fill = .true. dro%draw = .true. dro%fill_options = "withcolor col.default" dro%draw_options = "" dro%err_options = "" dro%symbol = "fshape(circle scaled 1mm)()" dro%gmlcode_bg = "" dro%gmlcode_fg = "" end subroutine drawing_options_init_histogram module subroutine drawing_options_init_plot (dro) class(drawing_options_t), intent(out) :: dro dro%dataset = "dat" dro%draw = .true. dro%fill_options = "withcolor col.default" dro%draw_options = "" dro%err_options = "" dro%symbol = "fshape(circle scaled 1mm)()" dro%gmlcode_bg = "" dro%gmlcode_fg = "" end subroutine drawing_options_init_plot @ %def drawing_options_init_histogram @ %def drawing_options_init_plot @ Set individual options. <>= procedure :: set => drawing_options_set <>= module subroutine drawing_options_set (dro, dataset, & with_hbars, with_base, piecewise, fill, draw, err, symbols, & fill_options, draw_options, err_options, symbol, & gmlcode_bg, gmlcode_fg) class(drawing_options_t), intent(inout) :: dro type(string_t), intent(in), optional :: dataset logical, intent(in), optional :: with_hbars, with_base, piecewise logical, intent(in), optional :: fill, draw, err, symbols type(string_t), intent(in), optional :: fill_options, draw_options type(string_t), intent(in), optional :: err_options, symbol type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg end subroutine drawing_options_set <>= module subroutine drawing_options_set (dro, dataset, & with_hbars, with_base, piecewise, fill, draw, err, symbols, & fill_options, draw_options, err_options, symbol, & gmlcode_bg, gmlcode_fg) class(drawing_options_t), intent(inout) :: dro type(string_t), intent(in), optional :: dataset logical, intent(in), optional :: with_hbars, with_base, piecewise logical, intent(in), optional :: fill, draw, err, symbols type(string_t), intent(in), optional :: fill_options, draw_options type(string_t), intent(in), optional :: err_options, symbol type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg if (present (dataset)) dro%dataset = dataset if (present (with_hbars)) dro%with_hbars = with_hbars if (present (with_base)) dro%with_base = with_base if (present (piecewise)) dro%piecewise = piecewise if (present (fill)) dro%fill = fill if (present (draw)) dro%draw = draw if (present (err)) dro%err = err if (present (symbols)) dro%symbols = symbols if (present (fill_options)) dro%fill_options = fill_options if (present (draw_options)) dro%draw_options = draw_options if (present (err_options)) dro%err_options = err_options if (present (symbol)) dro%symbol = symbol if (present (gmlcode_bg)) dro%gmlcode_bg = gmlcode_bg if (present (gmlcode_fg)) dro%gmlcode_fg = gmlcode_fg end subroutine drawing_options_set @ %def drawing_options_set @ There are sepate commands for drawing the curve and for drawing errors. The symbols are applied to the latter. First of all, we may have to compute a baseline: <>= function drawing_options_get_calc_command (dro) result (cmd) type(string_t) :: cmd type(drawing_options_t), intent(in) :: dro if (dro%with_base) then cmd = "calculate " // dro%dataset // ".base (" // dro%dataset // ") " & // "(x, #0);" else cmd = "" end if end function drawing_options_get_calc_command @ %def drawing_options_get_calc_command @ Return the drawing command. <>= function drawing_options_get_draw_command (dro) result (cmd) type(string_t) :: cmd type(drawing_options_t), intent(in) :: dro if (dro%fill) then cmd = "fill" else if (dro%draw) then cmd = "draw" else cmd = "" end if if (dro%fill .or. dro%draw) then if (dro%piecewise) cmd = cmd // " piecewise" if (dro%draw .and. dro%with_base) cmd = cmd // " cyclic" cmd = cmd // " from (" // dro%dataset if (dro%with_base) then if (dro%piecewise) then cmd = cmd // ", " // dro%dataset // ".base/\" ! " else cmd = cmd // " ~ " // dro%dataset // ".base\" ! " end if end if cmd = cmd // ")" if (dro%fill) then cmd = cmd // " " // dro%fill_options if (dro%draw) cmd = cmd // " outlined" end if if (dro%draw) cmd = cmd // " " // dro%draw_options cmd = cmd // ";" end if end function drawing_options_get_draw_command @ %def drawing_options_get_draw_command @ The error command draws error bars, if any. <>= function drawing_options_get_err_command (dro) result (cmd) type(string_t) :: cmd type(drawing_options_t), intent(in) :: dro if (dro%err) then cmd = "draw piecewise " & // "from (" // dro%dataset // ".err)" & // " " // dro%err_options // ";" else cmd = "" end if end function drawing_options_get_err_command @ %def drawing_options_get_err_command @ The symbol command draws symbols, if any. <>= function drawing_options_get_symb_command (dro) result (cmd) type(string_t) :: cmd type(drawing_options_t), intent(in) :: dro if (dro%symbols) then cmd = "phantom" & // " from (" // dro%dataset // ")" & // " withsymbol (" // dro%symbol // ");" else cmd = "" end if end function drawing_options_get_symb_command @ %def drawing_options_get_symb_command @ Get extra GAMELAN code to be executed before and after the usual drawing commands. <>= function drawing_options_get_gml_bg_command (dro) result (cmd) type(string_t) :: cmd type(drawing_options_t), intent(in) :: dro cmd = dro%gmlcode_bg end function drawing_options_get_gml_bg_command function drawing_options_get_gml_fg_command (dro) result (cmd) type(string_t) :: cmd type(drawing_options_t), intent(in) :: dro cmd = dro%gmlcode_fg end function drawing_options_get_gml_fg_command @ %def drawing_options_get_gml_bg_command @ %def drawing_options_get_gml_fg_command @ \subsection{Observables} The observable type holds the accumulated observable values and weight sums which are necessary for proper averaging. <>= type :: observable_t private real(default) :: sum_values = 0 real(default) :: sum_squared_values = 0 real(default) :: sum_weights = 0 real(default) :: sum_squared_weights = 0 integer :: count = 0 type(string_t) :: obs_label type(string_t) :: obs_unit type(graph_options_t) :: graph_options end type observable_t @ %def observable_t @ Initialize with defined properties <>= subroutine observable_init (obs, obs_label, obs_unit, graph_options) type(observable_t), intent(out) :: obs type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options if (present (obs_label)) then obs%obs_label = obs_label else obs%obs_label = "" end if if (present (obs_unit)) then obs%obs_unit = obs_unit else obs%obs_unit = "" end if if (present (graph_options)) then obs%graph_options = graph_options else call obs%graph_options%init () end if end subroutine observable_init @ %def observable_init @ Reset all numeric entries. <>= subroutine observable_clear (obs) type(observable_t), intent(inout) :: obs obs%sum_values = 0 obs%sum_squared_values = 0 obs%sum_weights = 0 obs%sum_squared_weights = 0 obs%count = 0 end subroutine observable_clear @ %def observable_clear @ Record a value. Always successful for observables. <>= interface observable_record_value module procedure observable_record_value_unweighted module procedure observable_record_value_weighted end interface <>= module subroutine observable_record_value_unweighted (obs, value, success) type(observable_t), intent(inout) :: obs real(default), intent(in) :: value logical, intent(out), optional :: success end subroutine observable_record_value_unweighted module subroutine observable_record_value_weighted (obs, value, weight, success) type(observable_t), intent(inout) :: obs real(default), intent(in) :: value, weight logical, intent(out), optional :: success end subroutine observable_record_value_weighted <>= module subroutine observable_record_value_unweighted (obs, value, success) type(observable_t), intent(inout) :: obs real(default), intent(in) :: value logical, intent(out), optional :: success obs%sum_values = obs%sum_values + value obs%sum_squared_values = obs%sum_squared_values + value**2 obs%sum_weights = obs%sum_weights + 1 obs%sum_squared_weights = obs%sum_squared_weights + 1 obs%count = obs%count + 1 if (present (success)) success = .true. end subroutine observable_record_value_unweighted module subroutine observable_record_value_weighted (obs, value, weight, success) type(observable_t), intent(inout) :: obs real(default), intent(in) :: value, weight logical, intent(out), optional :: success obs%sum_values = obs%sum_values + value * weight obs%sum_squared_values = obs%sum_squared_values + value**2 * weight obs%sum_weights = obs%sum_weights + weight obs%sum_squared_weights = obs%sum_squared_weights + weight**2 obs%count = obs%count + 1 if (present (success)) success = .true. end subroutine observable_record_value_weighted @ %def observable_record_value @ Here are the statistics formulas: \begin{enumerate} \item Unweighted case: Given a sample of $n$ values $x_i$, the average is \begin{equation} \langle x \rangle = \frac{\sum x_i}{n} \end{equation} and the error estimate \begin{align} \Delta x &= \sqrt{\frac{1}{n-1}\langle{\sum(x_i - \langle x\rangle)^2}} \\ &= \sqrt{\frac{1}{n-1} \left(\frac{\sum x_i^2}{n} - \frac{(\sum x_i)^2}{n^2}\right)} \end{align} \item Weighted case: Instead of weight 1, each event comes with weight $w_i$. \begin{equation} \langle x \rangle = \frac{\sum x_i w_i}{\sum w_i} \end{equation} and \begin{equation} \Delta x = \sqrt{\frac{1}{n-1} \left(\frac{\sum x_i^2 w_i}{\sum w_i} - \frac{(\sum x_i w_i)^2}{(\sum w_i)^2}\right)} \end{equation} For $w_i=1$, this specializes to the previous formula. \end{enumerate} <>= function observable_get_n_entries (obs) result (n) integer :: n type(observable_t), intent(in) :: obs n = obs%count end function observable_get_n_entries function observable_get_average (obs) result (avg) real(default) :: avg type(observable_t), intent(in) :: obs if (obs%sum_weights /= 0) then avg = obs%sum_values / obs%sum_weights else avg = 0 end if end function observable_get_average function observable_get_error (obs) result (err) real(default) :: err type(observable_t), intent(in) :: obs real(default) :: var, n if (obs%sum_weights /= 0) then select case (obs%count) case (0:1) err = 0 case default n = obs%count var = obs%sum_squared_values / obs%sum_weights & - (obs%sum_values / obs%sum_weights) ** 2 err = sqrt (max (var, 0._default) / (n - 1)) end select else err = 0 end if end function observable_get_error @ %def observable_get_n_entries @ %def observable_get_sum @ %def observable_get_average @ %def observable_get_error @ Write label and/or physical unit to a string. <>= function observable_get_label (obs, wl, wu) result (string) type(string_t) :: string type(observable_t), intent(in) :: obs logical, intent(in) :: wl, wu type(string_t) :: obs_label, obs_unit if (wl) then if (obs%obs_label /= "") then obs_label = obs%obs_label else obs_label = "\textrm{Observable}" end if else obs_label = "" end if if (wu) then if (obs%obs_unit /= "") then if (wl) then obs_unit = "\;[" // obs%obs_unit // "]" else obs_unit = obs%obs_unit end if else obs_unit = "" end if else obs_unit = "" end if string = obs_label // obs_unit end function observable_get_label @ %def observable_get_label @ \subsection{Output} <>= subroutine observable_write (obs, unit) type(observable_t), intent(in) :: obs integer, intent(in), optional :: unit real(default) :: avg, err, relerr integer :: n integer :: u u = given_output_unit (unit); if (u < 0) return avg = observable_get_average (obs) err = observable_get_error (obs) if (avg /= 0) then relerr = err / abs (avg) else relerr = 0 end if n = observable_get_n_entries (obs) if (obs%graph_options%title /= "") then write (u, "(A,1x,3A)") & "title =", '"', char (obs%graph_options%title), '"' end if if (obs%graph_options%title /= "") then write (u, "(A,1x,3A)") & "description =", '"', char (obs%graph_options%description), '"' end if write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")", advance = "no") & "average =", avg call write_unit () write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")", advance = "no") & "error[abs] =", err call write_unit () write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")") & "error[rel] =", relerr write (u, "(A,1x,I0)") & "n_entries =", n contains subroutine write_unit () if (obs%obs_unit /= "") then write (u, "(1x,A)") char (obs%obs_unit) else write (u, *) end if end subroutine write_unit end subroutine observable_write @ %def observable_write @ \LaTeX\ output. <>= subroutine observable_write_driver (obs, unit, write_heading) type(observable_t), intent(in) :: obs integer, intent(in), optional :: unit logical, intent(in), optional :: write_heading real(default) :: avg, err integer :: n_digits logical :: heading integer :: u u = given_output_unit (unit); if (u < 0) return heading = .true.; if (present (write_heading)) heading = write_heading avg = observable_get_average (obs) err = observable_get_error (obs) if (avg /= 0 .and. err /= 0) then n_digits = max (2, 2 - int (log10 (abs (err / real (avg, default))))) else if (avg /= 0) then n_digits = 100 else n_digits = 1 end if if (heading) then write (u, "(A)") if (obs%graph_options%title /= "") then write (u, "(A)") "\section{" // char (obs%graph_options%title) & // "}" else write (u, "(A)") "\section{Observable}" end if if (obs%graph_options%description /= "") then write (u, "(A)") char (obs%graph_options%description) write (u, *) end if write (u, "(A)") "\begin{flushleft}" end if write (u, "(A)", advance="no") " $\langle{" ! $ sign write (u, "(A)", advance="no") char (observable_get_label (obs, wl=.true., wu=.false.)) write (u, "(A)", advance="no") "}\rangle = " write (u, "(A)", advance="no") char (tex_format (avg, n_digits)) write (u, "(A)", advance="no") "\pm" write (u, "(A)", advance="no") char (tex_format (err, 2)) write (u, "(A)", advance="no") "\;{" write (u, "(A)", advance="no") char (observable_get_label (obs, wl=.false., wu=.true.)) write (u, "(A)") "}" write (u, "(A)", advance="no") " \quad[n_{\text{entries}} = " write (u, "(I0)",advance="no") observable_get_n_entries (obs) write (u, "(A)") "]$" ! $ fool Emacs' noweb mode if (heading) then write (u, "(A)") "\end{flushleft}" end if end subroutine observable_write_driver @ %def observable_write_driver @ \subsection{Histograms} \subsubsection{Bins} <>= type :: bin_t private real(default) :: midpoint = 0 real(default) :: width = 0 real(default) :: sum_weights = 0 real(default) :: sum_squared_weights = 0 real(default) :: sum_excess_weights = 0 integer :: count = 0 end type bin_t @ %def bin_t <>= subroutine bin_init (bin, midpoint, width) type(bin_t), intent(out) :: bin real(default), intent(in) :: midpoint, width bin%midpoint = midpoint bin%width = width end subroutine bin_init @ %def bin_init <>= elemental subroutine bin_clear (bin) type(bin_t), intent(inout) :: bin bin%sum_weights = 0 bin%sum_squared_weights = 0 bin%sum_excess_weights = 0 bin%count = 0 end subroutine bin_clear @ %def bin_clear <>= subroutine bin_record_value (bin, normalize, weight, excess) type(bin_t), intent(inout) :: bin logical, intent(in) :: normalize real(default), intent(in) :: weight real(default), intent(in), optional :: excess real(default) :: w, e if (normalize) then if (bin%width /= 0) then w = weight / bin%width if (present (excess)) e = excess / bin%width else w = 0 if (present (excess)) e = 0 end if else w = weight if (present (excess)) e = excess end if bin%sum_weights = bin%sum_weights + w bin%sum_squared_weights = bin%sum_squared_weights + w ** 2 if (present (excess)) & bin%sum_excess_weights = bin%sum_excess_weights + abs (e) bin%count = bin%count + 1 end subroutine bin_record_value @ %def bin_record_value <>= function bin_get_midpoint (bin) result (x) real(default) :: x type(bin_t), intent(in) :: bin x = bin%midpoint end function bin_get_midpoint function bin_get_width (bin) result (w) real(default) :: w type(bin_t), intent(in) :: bin w = bin%width end function bin_get_width function bin_get_n_entries (bin) result (n) integer :: n type(bin_t), intent(in) :: bin n = bin%count end function bin_get_n_entries function bin_get_sum (bin) result (s) real(default) :: s type(bin_t), intent(in) :: bin s = bin%sum_weights end function bin_get_sum function bin_get_error (bin) result (err) real(default) :: err type(bin_t), intent(in) :: bin err = sqrt (bin%sum_squared_weights) end function bin_get_error function bin_get_excess (bin) result (excess) real(default) :: excess type(bin_t), intent(in) :: bin excess = bin%sum_excess_weights end function bin_get_excess @ %def bin_get_midpoint @ %def bin_get_width @ %def bin_get_n_entries @ %def bin_get_sum @ %def bin_get_error @ %def bin_get_excess <>= subroutine bin_write_header (unit) integer, intent(in), optional :: unit character(120) :: buffer integer :: u u = given_output_unit (unit); if (u < 0) return write (buffer, "(A,4(1x," //HISTOGRAM_HEAD_FORMAT // "),2x,A)") & "#", "bin midpoint", "value ", "error ", & "excess ", "n" write (u, "(A)") trim (buffer) end subroutine bin_write_header subroutine bin_write (bin, unit) type(bin_t), intent(in) :: bin integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,4(1x," // HISTOGRAM_DATA_FORMAT // "),2x,I0)") & bin_get_midpoint (bin), & bin_get_sum (bin), & bin_get_error (bin), & bin_get_excess (bin), & bin_get_n_entries (bin) end subroutine bin_write @ %def bin_write_header @ %def bin_write @ \subsubsection{Histograms} <>= type :: histogram_t private real(default) :: lower_bound = 0 real(default) :: upper_bound = 0 real(default) :: width = 0 integer :: n_bins = 0 logical :: normalize_bins = .false. type(observable_t) :: obs type(observable_t) :: obs_within_bounds type(bin_t) :: underflow type(bin_t), dimension(:), allocatable :: bin type(bin_t) :: overflow type(graph_options_t) :: graph_options type(drawing_options_t) :: drawing_options end type histogram_t @ %def histogram_t @ \subsubsection{Initializer/finalizer} Initialize a histogram. We may provide either the bin width or the number of bins. A finalizer is not needed, since the histogram contains no pointer (sub)components. <>= interface histogram_init module procedure histogram_init_n_bins module procedure histogram_init_bin_width end interface <>= module subroutine histogram_init_n_bins (h, id, & lower_bound, upper_bound, n_bins, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) type(histogram_t), intent(out) :: h type(string_t), intent(in) :: id real(default), intent(in) :: lower_bound, upper_bound integer, intent(in) :: n_bins logical, intent(in) :: normalize_bins type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options end subroutine histogram_init_n_bins module subroutine histogram_init_bin_width (h, id, & lower_bound, upper_bound, bin_width, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) type(histogram_t), intent(out) :: h type(string_t), intent(in) :: id real(default), intent(in) :: lower_bound, upper_bound, bin_width logical, intent(in) :: normalize_bins type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options end subroutine histogram_init_bin_width <>= module subroutine histogram_init_n_bins (h, id, & lower_bound, upper_bound, n_bins, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) type(histogram_t), intent(out) :: h type(string_t), intent(in) :: id real(default), intent(in) :: lower_bound, upper_bound integer, intent(in) :: n_bins logical, intent(in) :: normalize_bins type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options real(default) :: bin_width integer :: i call observable_init (h%obs_within_bounds, obs_label, obs_unit) call observable_init (h%obs, obs_label, obs_unit) h%lower_bound = lower_bound h%upper_bound = upper_bound h%n_bins = max (n_bins, 1) h%width = h%upper_bound - h%lower_bound h%normalize_bins = normalize_bins bin_width = h%width / h%n_bins allocate (h%bin (h%n_bins)) call bin_init (h%underflow, h%lower_bound, 0._default) do i = 1, h%n_bins call bin_init (h%bin(i), & h%lower_bound - bin_width/2 + i * bin_width, bin_width) end do call bin_init (h%overflow, h%upper_bound, 0._default) if (present (graph_options)) then h%graph_options = graph_options else call h%graph_options%init () end if call graph_options_set (h%graph_options, id = id) if (present (drawing_options)) then h%drawing_options = drawing_options else call h%drawing_options%init_histogram () end if end subroutine histogram_init_n_bins module subroutine histogram_init_bin_width (h, id, & lower_bound, upper_bound, bin_width, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) type(histogram_t), intent(out) :: h type(string_t), intent(in) :: id real(default), intent(in) :: lower_bound, upper_bound, bin_width logical, intent(in) :: normalize_bins type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options integer :: n_bins if (bin_width /= 0) then n_bins = nint ((upper_bound - lower_bound) / bin_width) else n_bins = 1 end if call histogram_init_n_bins (h, id, & lower_bound, upper_bound, n_bins, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) end subroutine histogram_init_bin_width @ %def histogram_init @ Initialize a histogram by copying another one. Since [[h]] has no pointer (sub)components, intrinsic assignment is sufficient. Optionally, we replace the drawing options. <>= subroutine histogram_init_histogram (h, h_in, drawing_options) type(histogram_t), intent(out) :: h type(histogram_t), intent(in) :: h_in type(drawing_options_t), intent(in), optional :: drawing_options h = h_in if (present (drawing_options)) then h%drawing_options = drawing_options end if end subroutine histogram_init_histogram @ %def histogram_init_histogram @ \subsubsection{Fill histograms} Clear the histogram contents, but do not modify the structure. <>= subroutine histogram_clear (h) type(histogram_t), intent(inout) :: h call observable_clear (h%obs) call observable_clear (h%obs_within_bounds) call bin_clear (h%underflow) if (allocated (h%bin)) call bin_clear (h%bin) call bin_clear (h%overflow) end subroutine histogram_clear @ %def histogram_clear @ Record a value. Successful if the value is within bounds, otherwise it is recorded as under-/overflow. Optionally, we may provide an excess weight that could be returned by the unweighting procedure. <>= subroutine histogram_record_value_unweighted (h, value, excess, success) type(histogram_t), intent(inout) :: h real(default), intent(in) :: value real(default), intent(in), optional :: excess logical, intent(out), optional :: success integer :: i_bin call observable_record_value (h%obs, value) if (h%width /= 0) then i_bin = floor (((value - h%lower_bound) / h%width) * h%n_bins) + 1 else i_bin = 0 end if if (i_bin <= 0) then call bin_record_value (h%underflow, .false., 1._default, excess) if (present (success)) success = .false. else if (i_bin <= h%n_bins) then call observable_record_value (h%obs_within_bounds, value) call bin_record_value & (h%bin(i_bin), h%normalize_bins, 1._default, excess) if (present (success)) success = .true. else call bin_record_value (h%overflow, .false., 1._default, excess) if (present (success)) success = .false. end if end subroutine histogram_record_value_unweighted @ %def histogram_record_value_unweighted @ Weighted events: analogous, but no excess weight. <>= subroutine histogram_record_value_weighted (h, value, weight, success) type(histogram_t), intent(inout) :: h real(default), intent(in) :: value, weight logical, intent(out), optional :: success integer :: i_bin call observable_record_value (h%obs, value, weight) if (h%width /= 0) then i_bin = floor (((value - h%lower_bound) / h%width) * h%n_bins) + 1 else i_bin = 0 end if if (i_bin <= 0) then call bin_record_value (h%underflow, .false., weight) if (present (success)) success = .false. else if (i_bin <= h%n_bins) then call observable_record_value (h%obs_within_bounds, value, weight) call bin_record_value (h%bin(i_bin), h%normalize_bins, weight) if (present (success)) success = .true. else call bin_record_value (h%overflow, .false., weight) if (present (success)) success = .false. end if end subroutine histogram_record_value_weighted @ %def histogram_record_value_weighted @ \subsubsection{Access contents} Inherited from the observable component (all-over average etc.) <>= function histogram_get_n_entries (h) result (n) integer :: n type(histogram_t), intent(in) :: h n = observable_get_n_entries (h%obs) end function histogram_get_n_entries function histogram_get_average (h) result (avg) real(default) :: avg type(histogram_t), intent(in) :: h avg = observable_get_average (h%obs) end function histogram_get_average function histogram_get_error (h) result (err) real(default) :: err type(histogram_t), intent(in) :: h err = observable_get_error (h%obs) end function histogram_get_error @ %def histogram_get_n_entries @ %def histogram_get_average @ %def histogram_get_error @ Analogous, but applied only to events within bounds. <>= function histogram_get_n_entries_within_bounds (h) result (n) integer :: n type(histogram_t), intent(in) :: h n = observable_get_n_entries (h%obs_within_bounds) end function histogram_get_n_entries_within_bounds function histogram_get_average_within_bounds (h) result (avg) real(default) :: avg type(histogram_t), intent(in) :: h avg = observable_get_average (h%obs_within_bounds) end function histogram_get_average_within_bounds function histogram_get_error_within_bounds (h) result (err) real(default) :: err type(histogram_t), intent(in) :: h err = observable_get_error (h%obs_within_bounds) end function histogram_get_error_within_bounds @ %def histogram_get_n_entries_within_bounds @ %def histogram_get_average_within_bounds @ %def histogram_get_error_within_bounds Get the number of bins <>= function histogram_get_n_bins (h) result (n) type(histogram_t), intent(in) :: h integer :: n n = h%n_bins end function histogram_get_n_bins @ %def histogram_get_n_bins @ Check bins. If the index is zero or above the limit, return the results for underflow or overflow, respectively. <>= function histogram_get_n_entries_for_bin (h, i) result (n) integer :: n type(histogram_t), intent(in) :: h integer, intent(in) :: i if (i <= 0) then n = bin_get_n_entries (h%underflow) else if (i <= h%n_bins) then n = bin_get_n_entries (h%bin(i)) else n = bin_get_n_entries (h%overflow) end if end function histogram_get_n_entries_for_bin function histogram_get_sum_for_bin (h, i) result (avg) real(default) :: avg type(histogram_t), intent(in) :: h integer, intent(in) :: i if (i <= 0) then avg = bin_get_sum (h%underflow) else if (i <= h%n_bins) then avg = bin_get_sum (h%bin(i)) else avg = bin_get_sum (h%overflow) end if end function histogram_get_sum_for_bin function histogram_get_error_for_bin (h, i) result (err) real(default) :: err type(histogram_t), intent(in) :: h integer, intent(in) :: i if (i <= 0) then err = bin_get_error (h%underflow) else if (i <= h%n_bins) then err = bin_get_error (h%bin(i)) else err = bin_get_error (h%overflow) end if end function histogram_get_error_for_bin function histogram_get_excess_for_bin (h, i) result (err) real(default) :: err type(histogram_t), intent(in) :: h integer, intent(in) :: i if (i <= 0) then err = bin_get_excess (h%underflow) else if (i <= h%n_bins) then err = bin_get_excess (h%bin(i)) else err = bin_get_excess (h%overflow) end if end function histogram_get_excess_for_bin @ %def histogram_get_n_entries_for_bin @ %def histogram_get_sum_for_bin @ %def histogram_get_error_for_bin @ %def histogram_get_excess_for_bin @ Return a pointer to the graph options. <>= function histogram_get_graph_options_ptr (h) result (ptr) type(graph_options_t), pointer :: ptr type(histogram_t), intent(in), target :: h ptr => h%graph_options end function histogram_get_graph_options_ptr @ %def histogram_get_graph_options_ptr @ Return a pointer to the drawing options. <>= function histogram_get_drawing_options_ptr (h) result (ptr) type(drawing_options_t), pointer :: ptr type(histogram_t), intent(in), target :: h ptr => h%drawing_options end function histogram_get_drawing_options_ptr @ %def histogram_get_drawing_options_ptr @ \subsubsection{Output} <>= subroutine histogram_write (h, unit) type(histogram_t), intent(in) :: h integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit); if (u < 0) return call bin_write_header (u) if (allocated (h%bin)) then do i = 1, h%n_bins call bin_write (h%bin(i), u) end do end if write (u, "(A)") write (u, "(A,1x,A)") "#", "Underflow:" call bin_write (h%underflow, u) write (u, "(A)") write (u, "(A,1x,A)") "#", "Overflow:" call bin_write (h%overflow, u) write (u, "(A)") write (u, "(A,1x,A)") "#", "Summary: data within bounds" call observable_write (h%obs_within_bounds, u) write (u, "(A)") write (u, "(A,1x,A)") "#", "Summary: all data" call observable_write (h%obs, u) write (u, "(A)") end subroutine histogram_write @ %def histogram_write @ Write the GAMELAN reader for histogram contents. <>= subroutine histogram_write_gml_reader (h, filename, unit) type(histogram_t), intent(in) :: h type(string_t), intent(in) :: filename integer, intent(in), optional :: unit character(*), parameter :: fmt = "(ES15.8)" integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(2x,A)") 'fromfile "' // char (filename) // '":' write (u, "(4x,A)") 'key "# Histogram:";' write (u, "(4x,A)") 'dx := #' & // real2char (h%width / h%n_bins / 2, fmt) // ';' write (u, "(4x,A)") 'for i withinblock:' write (u, "(6x,A)") 'get x, y, y.d, y.n, y.e;' if (h%drawing_options%with_hbars) then write (u, "(6x,A)") 'plot (' // char (h%drawing_options%dataset) & // ') (x,y) hbar dx;' else write (u, "(6x,A)") 'plot (' // char (h%drawing_options%dataset) & // ') (x,y);' end if if (h%drawing_options%err) then write (u, "(6x,A)") 'plot (' // char (h%drawing_options%dataset) & // '.err) ' & // '(x,y) vbar y.d;' end if !!! Future excess options for plots ! write (u, "(6x,A)") 'if show_excess: ' // & ! & 'plot(dat.e)(x, y plus y.e) hbar dx; fi' write (u, "(4x,A)") 'endfor' write (u, "(2x,A)") 'endfrom' end subroutine histogram_write_gml_reader @ %def histogram_write_gml_reader @ \LaTeX\ and GAMELAN output. <>= subroutine histogram_write_gml_driver (h, filename, unit) type(histogram_t), intent(in) :: h type(string_t), intent(in) :: filename integer, intent(in), optional :: unit type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd integer :: u u = given_output_unit (unit); if (u < 0) return call graph_options_write_tex_header (h%graph_options, unit) write (u, "(2x,A)") char (graph_options_get_gml_setup (h%graph_options)) write (u, "(2x,A)") char (graph_options_get_gml_graphrange & (h%graph_options, x_min=h%lower_bound, x_max=h%upper_bound)) call histogram_write_gml_reader (h, filename, unit) calc_cmd = drawing_options_get_calc_command (h%drawing_options) if (calc_cmd /= "") write (u, "(2x,A)") char (calc_cmd) bg_cmd = drawing_options_get_gml_bg_command (h%drawing_options) if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd) draw_cmd = drawing_options_get_draw_command (h%drawing_options) if (draw_cmd /= "") write (u, "(2x,A)") char (draw_cmd) err_cmd = drawing_options_get_err_command (h%drawing_options) if (err_cmd /= "") write (u, "(2x,A)") char (err_cmd) symb_cmd = drawing_options_get_symb_command (h%drawing_options) if (symb_cmd /= "") write (u, "(2x,A)") char (symb_cmd) fg_cmd = drawing_options_get_gml_fg_command (h%drawing_options) if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd) write (u, "(2x,A)") char (graph_options_get_gml_x_label (h%graph_options)) write (u, "(2x,A)") char (graph_options_get_gml_y_label (h%graph_options)) call graph_options_write_tex_footer (h%graph_options, unit) write (u, "(A)") "\vspace*{2\baselineskip}" write (u, "(A)") "\begin{flushleft}" write (u, "(A)") "\textbf{Data within bounds:} \\" call observable_write_driver (h%obs_within_bounds, unit, & write_heading=.false.) write (u, "(A)") "\\[0.5\baselineskip]" write (u, "(A)") "\textbf{All data:} \\" call observable_write_driver (h%obs, unit, write_heading=.false.) write (u, "(A)") "\end{flushleft}" end subroutine histogram_write_gml_driver @ %def histogram_write_gml_driver @ Return the header for generic data output as an ifile. <>= subroutine histogram_get_header (h, header, comment) type(histogram_t), intent(in) :: h type(ifile_t), intent(inout) :: header type(string_t), intent(in), optional :: comment type(string_t) :: c if (present (comment)) then c = comment else c = "" end if call ifile_append (header, c // "WHIZARD histogram data") call graph_options_get_header (h%graph_options, header, comment) call ifile_append (header, & c // "range: " // real2string (h%lower_bound) & // " - " // real2string (h%upper_bound)) call ifile_append (header, & c // "counts total: " & // int2char (histogram_get_n_entries_within_bounds (h))) call ifile_append (header, & c // "total average: " & // real2string (histogram_get_average_within_bounds (h)) // " +- " & // real2string (histogram_get_error_within_bounds (h))) end subroutine histogram_get_header @ %def histogram_get_header @ \subsection{Plots} \subsubsection{Points} <>= type :: point_t private real(default) :: x = 0 real(default) :: y = 0 real(default) :: yerr = 0 real(default) :: xerr = 0 type(point_t), pointer :: next => null () end type point_t @ %def point_t <>= interface point_init module procedure point_init_contents module procedure point_init_point end interface <>= module subroutine point_init_contents (point, x, y, yerr, xerr) type(point_t), intent(out) :: point real(default), intent(in) :: x, y real(default), intent(in), optional :: yerr, xerr end subroutine point_init_contents module subroutine point_init_point (point, point_in) type(point_t), intent(out) :: point type(point_t), intent(in) :: point_in end subroutine point_init_point <>= module subroutine point_init_contents (point, x, y, yerr, xerr) type(point_t), intent(out) :: point real(default), intent(in) :: x, y real(default), intent(in), optional :: yerr, xerr point%x = x point%y = y if (present (yerr)) point%yerr = yerr if (present (xerr)) point%xerr = xerr end subroutine point_init_contents module subroutine point_init_point (point, point_in) type(point_t), intent(out) :: point type(point_t), intent(in) :: point_in point%x = point_in%x point%y = point_in%y point%yerr = point_in%yerr point%xerr = point_in%xerr end subroutine point_init_point @ %def point_init <>= function point_get_x (point) result (x) real(default) :: x type(point_t), intent(in) :: point x = point%x end function point_get_x function point_get_y (point) result (y) real(default) :: y type(point_t), intent(in) :: point y = point%y end function point_get_y function point_get_xerr (point) result (xerr) real(default) :: xerr type(point_t), intent(in) :: point xerr = point%xerr end function point_get_xerr function point_get_yerr (point) result (yerr) real(default) :: yerr type(point_t), intent(in) :: point yerr = point%yerr end function point_get_yerr @ %def point_get_x @ %def point_get_y @ %def point_get_xerr @ %def point_get_yerr <>= subroutine point_write_header (unit) integer, intent(in) :: unit character(120) :: buffer integer :: u u = given_output_unit (unit); if (u < 0) return write (buffer, "(A,4(1x," // HISTOGRAM_HEAD_FORMAT // "))") & "#", "x ", "y ", "yerr ", "xerr " write (u, "(A)") trim (buffer) end subroutine point_write_header subroutine point_write (point, unit) type(point_t), intent(in) :: point integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(1x,4(1x," // HISTOGRAM_DATA_FORMAT // "))") & point_get_x (point), & point_get_y (point), & point_get_yerr (point), & point_get_xerr (point) end subroutine point_write @ %def point_write @ \subsubsection{Plots} <>= type :: plot_t private type(point_t), pointer :: first => null () type(point_t), pointer :: last => null () integer :: count = 0 type(graph_options_t) :: graph_options type(drawing_options_t) :: drawing_options end type plot_t @ %def plot_t @ \subsubsection{Initializer/finalizer} Initialize a plot. We provide the lower and upper bound in the $x$ direction. <>= interface plot_init module procedure plot_init_empty module procedure plot_init_plot end interface <>= module subroutine plot_init_empty (p, id, graph_options, drawing_options) type(plot_t), intent(out) :: p type(string_t), intent(in) :: id type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options end subroutine plot_init_empty <>= module subroutine plot_init_empty (p, id, graph_options, drawing_options) type(plot_t), intent(out) :: p type(string_t), intent(in) :: id type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options if (present (graph_options)) then p%graph_options = graph_options else call p%graph_options%init () end if call p%graph_options%set (id = id) if (present (drawing_options)) then p%drawing_options = drawing_options else call p%drawing_options%init_plot () end if end subroutine plot_init_empty @ %def plot_init @ Initialize a plot by copying another one, optionally merging in a new set of drawing options. Since [[p]] has pointer (sub)components, we have to explicitly deep-copy the original. <>= module subroutine plot_init_plot (p, p_in, drawing_options) type(plot_t), intent(out) :: p type(plot_t), intent(in) :: p_in type(drawing_options_t), intent(in), optional :: drawing_options end subroutine plot_init_plot <>= module subroutine plot_init_plot (p, p_in, drawing_options) type(plot_t), intent(out) :: p type(plot_t), intent(in) :: p_in type(drawing_options_t), intent(in), optional :: drawing_options type(point_t), pointer :: current, new current => p_in%first do while (associated (current)) allocate (new) call point_init (new, current) if (associated (p%last)) then p%last%next => new else p%first => new end if p%last => new current => current%next end do p%count = p_in%count p%graph_options = p_in%graph_options if (present (drawing_options)) then p%drawing_options = drawing_options else p%drawing_options = p_in%drawing_options end if end subroutine plot_init_plot @ %def plot_init_plot @ Finalize the plot by deallocating the list of points. <>= subroutine plot_final (plot) type(plot_t), intent(inout) :: plot type(point_t), pointer :: current do while (associated (plot%first)) current => plot%first plot%first => current%next deallocate (current) end do plot%last => null () end subroutine plot_final @ %def plot_final @ \subsubsection{Fill plots} Clear the plot contents, but do not modify the structure. <>= subroutine plot_clear (plot) type(plot_t), intent(inout) :: plot plot%count = 0 call plot_final (plot) end subroutine plot_clear @ %def plot_clear @ Record a value. Successful if the value is within bounds, otherwise it is recorded as under-/overflow. <>= subroutine plot_record_value (plot, x, y, yerr, xerr, success) type(plot_t), intent(inout) :: plot real(default), intent(in) :: x, y real(default), intent(in), optional :: yerr, xerr logical, intent(out), optional :: success type(point_t), pointer :: point plot%count = plot%count + 1 allocate (point) call point_init (point, x, y, yerr, xerr) if (associated (plot%first)) then plot%last%next => point else plot%first => point end if plot%last => point if (present (success)) success = .true. end subroutine plot_record_value @ %def plot_record_value @ \subsubsection{Access contents} The number of points. <>= function plot_get_n_entries (plot) result (n) integer :: n type(plot_t), intent(in) :: plot n = plot%count end function plot_get_n_entries @ %def plot_get_n_entries @ Return a pointer to the graph options. <>= function plot_get_graph_options_ptr (p) result (ptr) type(graph_options_t), pointer :: ptr type(plot_t), intent(in), target :: p ptr => p%graph_options end function plot_get_graph_options_ptr @ %def plot_get_graph_options_ptr @ Return a pointer to the drawing options. <>= function plot_get_drawing_options_ptr (p) result (ptr) type(drawing_options_t), pointer :: ptr type(plot_t), intent(in), target :: p ptr => p%drawing_options end function plot_get_drawing_options_ptr @ %def plot_get_drawing_options_ptr @ \subsubsection{Output} This output format is used by the GAMELAN driver below. <>= subroutine plot_write (plot, unit) type(plot_t), intent(in) :: plot integer, intent(in), optional :: unit type(point_t), pointer :: point integer :: u u = given_output_unit (unit); if (u < 0) return call point_write_header (u) point => plot%first do while (associated (point)) call point_write (point, unit) point => point%next end do write (u, *) write (u, "(A,1x,A)") "#", "Summary:" write (u, "(A,1x,I0)") & "n_entries =", plot_get_n_entries (plot) write (u, *) end subroutine plot_write @ %def plot_write @ Write the GAMELAN reader for plot contents. <>= subroutine plot_write_gml_reader (p, filename, unit) type(plot_t), intent(in) :: p type(string_t), intent(in) :: filename integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, "(2x,A)") 'fromfile "' // char (filename) // '":' write (u, "(4x,A)") 'key "# Plot:";' write (u, "(4x,A)") 'for i withinblock:' write (u, "(6x,A)") 'get x, y, y.err, x.err;' write (u, "(6x,A)") 'plot (' // char (p%drawing_options%dataset) & // ') (x,y);' if (p%drawing_options%err) then write (u, "(6x,A)") 'plot (' // char (p%drawing_options%dataset) & // '.err) (x,y) vbar y.err hbar x.err;' end if write (u, "(4x,A)") 'endfor' write (u, "(2x,A)") 'endfrom' end subroutine plot_write_gml_reader @ %def plot_write_gml_header @ \LaTeX\ and GAMELAN output. Analogous to histogram output. <>= subroutine plot_write_gml_driver (p, filename, unit) type(plot_t), intent(in) :: p type(string_t), intent(in) :: filename integer, intent(in), optional :: unit type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd integer :: u u = given_output_unit (unit); if (u < 0) return call graph_options_write_tex_header (p%graph_options, unit) write (u, "(2x,A)") & char (graph_options_get_gml_setup (p%graph_options)) write (u, "(2x,A)") & char (graph_options_get_gml_graphrange (p%graph_options)) call plot_write_gml_reader (p, filename, unit) calc_cmd = drawing_options_get_calc_command (p%drawing_options) if (calc_cmd /= "") write (u, "(2x,A)") char (calc_cmd) bg_cmd = drawing_options_get_gml_bg_command (p%drawing_options) if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd) draw_cmd = drawing_options_get_draw_command (p%drawing_options) if (draw_cmd /= "") write (u, "(2x,A)") char (draw_cmd) err_cmd = drawing_options_get_err_command (p%drawing_options) if (err_cmd /= "") write (u, "(2x,A)") char (err_cmd) symb_cmd = drawing_options_get_symb_command (p%drawing_options) if (symb_cmd /= "") write (u, "(2x,A)") char (symb_cmd) fg_cmd = drawing_options_get_gml_fg_command (p%drawing_options) if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd) write (u, "(2x,A)") char (graph_options_get_gml_x_label (p%graph_options)) write (u, "(2x,A)") char (graph_options_get_gml_y_label (p%graph_options)) call graph_options_write_tex_footer (p%graph_options, unit) end subroutine plot_write_gml_driver @ %def plot_write_driver @ Append header for generic data output in ifile format. <>= subroutine plot_get_header (plot, header, comment) type(plot_t), intent(in) :: plot type(ifile_t), intent(inout) :: header type(string_t), intent(in), optional :: comment type(string_t) :: c if (present (comment)) then c = comment else c = "" end if call ifile_append (header, c // "WHIZARD plot data") call graph_options_get_header (plot%graph_options, header, comment) call ifile_append (header, & c // "number of points: " & // int2char (plot_get_n_entries (plot))) end subroutine plot_get_header @ %def plot_get_header @ \subsection{Graphs} A graph is a container for several graph elements. Each graph element is either a plot or a histogram. There is an appropriate base type below (the [[analysis_object_t]]), but to avoid recursion, we define a separate base type here. Note that there is no actual recursion: a graph is an analysis object, but a graph cannot contain graphs. (If we could use type extension, the implementation would be much more transparent.) \subsubsection{Graph elements} Graph elements cannot be filled by the [[record]] command directly. The contents are always copied from elementary histograms or plots. <>= type :: graph_element_t private integer :: type = AN_UNDEFINED type(histogram_t), pointer :: h => null () type(plot_t), pointer :: p => null () end type graph_element_t @ %def graph_element_t <>= subroutine graph_element_final (el) type(graph_element_t), intent(inout) :: el select case (el%type) case (AN_HISTOGRAM) deallocate (el%h) case (AN_PLOT) call plot_final (el%p) deallocate (el%p) end select el%type = AN_UNDEFINED end subroutine graph_element_final @ %def graph_element_final @ Return the number of entries in the graph element: <>= function graph_element_get_n_entries (el) result (n) integer :: n type(graph_element_t), intent(in) :: el select case (el%type) case (AN_HISTOGRAM); n = histogram_get_n_entries (el%h) case (AN_PLOT); n = plot_get_n_entries (el%p) case default; n = 0 end select end function graph_element_get_n_entries @ %def graph_element_get_n_entries @ Return a pointer to the graph / drawing options. <>= function graph_element_get_graph_options_ptr (el) result (ptr) type(graph_options_t), pointer :: ptr type(graph_element_t), intent(in) :: el select case (el%type) case (AN_HISTOGRAM); ptr => histogram_get_graph_options_ptr (el%h) case (AN_PLOT); ptr => plot_get_graph_options_ptr (el%p) case default; ptr => null () end select end function graph_element_get_graph_options_ptr function graph_element_get_drawing_options_ptr (el) result (ptr) type(drawing_options_t), pointer :: ptr type(graph_element_t), intent(in) :: el select case (el%type) case (AN_HISTOGRAM); ptr => histogram_get_drawing_options_ptr (el%h) case (AN_PLOT); ptr => plot_get_drawing_options_ptr (el%p) case default; ptr => null () end select end function graph_element_get_drawing_options_ptr @ %def graph_element_get_graph_options_ptr @ %def graph_element_get_drawing_options_ptr @ Output, simple wrapper for the plot/histogram writer. <>= subroutine graph_element_write (el, unit) type(graph_element_t), intent(in) :: el integer, intent(in), optional :: unit type(graph_options_t), pointer :: gro type(string_t) :: id integer :: u u = given_output_unit (unit); if (u < 0) return gro => graph_element_get_graph_options_ptr (el) id = graph_options_get_id (gro) write (u, "(A,A)") '#', repeat ("-", 78) select case (el%type) case (AN_HISTOGRAM) write (u, "(A)", advance="no") "# Histogram: " write (u, "(1x,A)") char (id) call histogram_write (el%h, unit) case (AN_PLOT) write (u, "(A)", advance="no") "# Plot: " write (u, "(1x,A)") char (id) call plot_write (el%p, unit) end select end subroutine graph_element_write @ %def graph_element_write <>= subroutine graph_element_write_gml_reader (el, filename, unit) type(graph_element_t), intent(in) :: el type(string_t), intent(in) :: filename integer, intent(in), optional :: unit select case (el%type) case (AN_HISTOGRAM); call histogram_write_gml_reader (el%h, filename, unit) case (AN_PLOT); call plot_write_gml_reader (el%p, filename, unit) end select end subroutine graph_element_write_gml_reader @ %def graph_element_write_gml_reader @ \subsubsection{The graph type} The actual graph type contains its own [[graph_options]], which override the individual settings. The [[drawing_options]] are set in the graph elements. This distinction motivates the separation of the two types. <>= type :: graph_t private type(graph_element_t), dimension(:), allocatable :: el type(graph_options_t) :: graph_options end type graph_t @ %def graph_t @ \subsubsection{Initializer/finalizer} The graph is created with a definite number of elements. The elements are filled one by one, optionally with modified drawing options. <>= subroutine graph_init (g, id, n_elements, graph_options) type(graph_t), intent(out) :: g type(string_t), intent(in) :: id integer, intent(in) :: n_elements type(graph_options_t), intent(in), optional :: graph_options allocate (g%el (n_elements)) if (present (graph_options)) then g%graph_options = graph_options else call g%graph_options%init () end if call g%graph_options%set (id = id) end subroutine graph_init @ %def graph_init <>= subroutine graph_insert_histogram (g, i, h, drawing_options) type(graph_t), intent(inout), target :: g integer, intent(in) :: i type(histogram_t), intent(in) :: h type(drawing_options_t), intent(in), optional :: drawing_options type(graph_options_t), pointer :: gro type(drawing_options_t), pointer :: dro type(string_t) :: id g%el(i)%type = AN_HISTOGRAM allocate (g%el(i)%h) call histogram_init_histogram (g%el(i)%h, h, drawing_options) gro => histogram_get_graph_options_ptr (g%el(i)%h) dro => histogram_get_drawing_options_ptr (g%el(i)%h) id = graph_options_get_id (gro) call dro%set (dataset = "dat." // id) end subroutine graph_insert_histogram @ %def graph_insert_histogram <>= subroutine graph_insert_plot (g, i, p, drawing_options) type(graph_t), intent(inout) :: g integer, intent(in) :: i type(plot_t), intent(in) :: p type(drawing_options_t), intent(in), optional :: drawing_options type(graph_options_t), pointer :: gro type(drawing_options_t), pointer :: dro type(string_t) :: id g%el(i)%type = AN_PLOT allocate (g%el(i)%p) call plot_init_plot (g%el(i)%p, p, drawing_options) gro => plot_get_graph_options_ptr (g%el(i)%p) dro => plot_get_drawing_options_ptr (g%el(i)%p) id = graph_options_get_id (gro) call dro%set (dataset = "dat." // id) end subroutine graph_insert_plot @ %def graph_insert_plot @ Finalizer. <>= subroutine graph_final (g) type(graph_t), intent(inout) :: g integer :: i do i = 1, size (g%el) call graph_element_final (g%el(i)) end do deallocate (g%el) end subroutine graph_final @ %def graph_final @ \subsubsection{Access contents} The number of elements. <>= function graph_get_n_elements (graph) result (n) integer :: n type(graph_t), intent(in) :: graph n = size (graph%el) end function graph_get_n_elements @ %def graph_get_n_elements @ Retrieve a pointer to the drawing options of an element, so they can be modified. (The [[target]] attribute is not actually needed because the components are pointers.) <>= function graph_get_drawing_options_ptr (g, i) result (ptr) type(drawing_options_t), pointer :: ptr type(graph_t), intent(in), target :: g integer, intent(in) :: i ptr => graph_element_get_drawing_options_ptr (g%el(i)) end function graph_get_drawing_options_ptr @ %def graph_get_drawing_options_ptr @ \subsubsection{Output} The default output format just writes histogram and plot data. <>= subroutine graph_write (graph, unit) type(graph_t), intent(in) :: graph integer, intent(in), optional :: unit integer :: i do i = 1, size (graph%el) call graph_element_write (graph%el(i), unit) end do end subroutine graph_write @ %def graph_write @ The GAMELAN driver is not a simple wrapper, but it writes the plot/histogram contents embedded the complete graph. First, data are read in, global background commands next, then individual elements, then global foreground commands. <>= subroutine graph_write_gml_driver (g, filename, unit) type(graph_t), intent(in) :: g type(string_t), intent(in) :: filename type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd integer, intent(in), optional :: unit type(drawing_options_t), pointer :: dro integer :: u, i u = given_output_unit (unit); if (u < 0) return call graph_options_write_tex_header (g%graph_options, unit) write (u, "(2x,A)") & char (graph_options_get_gml_setup (g%graph_options)) write (u, "(2x,A)") & char (graph_options_get_gml_graphrange (g%graph_options)) do i = 1, size (g%el) call graph_element_write_gml_reader (g%el(i), filename, unit) calc_cmd = drawing_options_get_calc_command & (graph_element_get_drawing_options_ptr (g%el(i))) if (calc_cmd /= "") write (u, "(2x,A)") char (calc_cmd) end do bg_cmd = graph_options_get_gml_bg_command (g%graph_options) if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd) do i = 1, size (g%el) dro => graph_element_get_drawing_options_ptr (g%el(i)) bg_cmd = drawing_options_get_gml_bg_command (dro) if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd) draw_cmd = drawing_options_get_draw_command (dro) if (draw_cmd /= "") write (u, "(2x,A)") char (draw_cmd) err_cmd = drawing_options_get_err_command (dro) if (err_cmd /= "") write (u, "(2x,A)") char (err_cmd) symb_cmd = drawing_options_get_symb_command (dro) if (symb_cmd /= "") write (u, "(2x,A)") char (symb_cmd) fg_cmd = drawing_options_get_gml_fg_command (dro) if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd) end do fg_cmd = graph_options_get_gml_fg_command (g%graph_options) if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd) write (u, "(2x,A)") char (graph_options_get_gml_x_label (g%graph_options)) write (u, "(2x,A)") char (graph_options_get_gml_y_label (g%graph_options)) call graph_options_write_tex_footer (g%graph_options, unit) end subroutine graph_write_gml_driver @ %def graph_write_gml_driver @ Append header for generic data output in ifile format. <>= subroutine graph_get_header (graph, header, comment) type(graph_t), intent(in) :: graph type(ifile_t), intent(inout) :: header type(string_t), intent(in), optional :: comment type(string_t) :: c if (present (comment)) then c = comment else c = "" end if call ifile_append (header, c // "WHIZARD graph data") call graph_options_get_header (graph%graph_options, header, comment) call ifile_append (header, & c // "number of graph elements: " & // int2char (graph_get_n_elements (graph))) end subroutine graph_get_header @ %def graph_get_header @ \subsection{Analysis objects} This data structure holds all observables, histograms and such that are currently active. We have one global store; individual items are identified by their ID strings. (This should rather be coded by type extension.) <>= integer, parameter :: AN_UNDEFINED = 0 integer, parameter :: AN_OBSERVABLE = 1 integer, parameter :: AN_HISTOGRAM = 2 integer, parameter :: AN_PLOT = 3 integer, parameter :: AN_GRAPH = 4 <>= public :: AN_UNDEFINED, AN_HISTOGRAM, AN_OBSERVABLE, AN_PLOT, AN_GRAPH @ %def AN_UNDEFINED @ %def AN_OBSERVABLE AN_HISTOGRAM AN_PLOT AN_GRAPH <>= type :: analysis_object_t private type(string_t) :: id integer :: type = AN_UNDEFINED type(observable_t), pointer :: obs => null () type(histogram_t), pointer :: h => null () type(plot_t), pointer :: p => null () type(graph_t), pointer :: g => null () type(analysis_object_t), pointer :: next => null () end type analysis_object_t @ %def analysis_object_t @ \subsubsection{Initializer/finalizer} Allocate with the correct type but do not fill initial values. <>= subroutine analysis_object_init (obj, id, type) type(analysis_object_t), intent(out) :: obj type(string_t), intent(in) :: id integer, intent(in) :: type obj%id = id obj%type = type select case (obj%type) case (AN_OBSERVABLE); allocate (obj%obs) case (AN_HISTOGRAM); allocate (obj%h) case (AN_PLOT); allocate (obj%p) case (AN_GRAPH); allocate (obj%g) end select end subroutine analysis_object_init @ %def analysis_object_init <>= subroutine analysis_object_final (obj) type(analysis_object_t), intent(inout) :: obj select case (obj%type) case (AN_OBSERVABLE) deallocate (obj%obs) case (AN_HISTOGRAM) deallocate (obj%h) case (AN_PLOT) call plot_final (obj%p) deallocate (obj%p) case (AN_GRAPH) call graph_final (obj%g) deallocate (obj%g) end select obj%type = AN_UNDEFINED end subroutine analysis_object_final @ %def analysis_object_final @ Clear the analysis object, i.e., reset it to its initial state. Not applicable to graphs, which are always combinations of other existing objects. <>= subroutine analysis_object_clear (obj) type(analysis_object_t), intent(inout) :: obj select case (obj%type) case (AN_OBSERVABLE) call observable_clear (obj%obs) case (AN_HISTOGRAM) call histogram_clear (obj%h) case (AN_PLOT) call plot_clear (obj%p) end select end subroutine analysis_object_clear @ %def analysis_object_clear @ \subsubsection{Fill with data} Record data. The effect depends on the type of analysis object. <>= subroutine analysis_object_record_data (obj, & x, y, yerr, xerr, weight, excess, success) type(analysis_object_t), intent(inout) :: obj real(default), intent(in) :: x real(default), intent(in), optional :: y, yerr, xerr, weight, excess logical, intent(out), optional :: success select case (obj%type) case (AN_OBSERVABLE) if (present (weight)) then call observable_record_value_weighted (obj%obs, x, weight, success) else call observable_record_value_unweighted (obj%obs, x, success) end if case (AN_HISTOGRAM) if (present (weight)) then call histogram_record_value_weighted (obj%h, x, weight, success) else call histogram_record_value_unweighted (obj%h, x, excess, success) end if case (AN_PLOT) if (present (y)) then call plot_record_value (obj%p, x, y, yerr, xerr, success) else if (present (success)) success = .false. end if case default if (present (success)) success = .false. end select end subroutine analysis_object_record_data @ %def analysis_object_record_data @ Explicitly set the pointer to the next object in the list. <>= subroutine analysis_object_set_next_ptr (obj, next) type(analysis_object_t), intent(inout) :: obj type(analysis_object_t), pointer :: next obj%next => next end subroutine analysis_object_set_next_ptr @ %def analysis_object_set_next_ptr @ \subsubsection{Access contents} Return a pointer to the next object in the list. <>= function analysis_object_get_next_ptr (obj) result (next) type(analysis_object_t), pointer :: next type(analysis_object_t), intent(in) :: obj next => obj%next end function analysis_object_get_next_ptr @ %def analysis_object_get_next_ptr @ Return data as appropriate for the object type. <>= function analysis_object_get_n_elements (obj) result (n) integer :: n type(analysis_object_t), intent(in) :: obj select case (obj%type) case (AN_HISTOGRAM) n = 1 case (AN_PLOT) n = 1 case (AN_GRAPH) n = graph_get_n_elements (obj%g) case default n = 0 end select end function analysis_object_get_n_elements function analysis_object_get_n_entries (obj, within_bounds) result (n) integer :: n type(analysis_object_t), intent(in) :: obj logical, intent(in), optional :: within_bounds logical :: wb select case (obj%type) case (AN_OBSERVABLE) n = observable_get_n_entries (obj%obs) case (AN_HISTOGRAM) wb = .false.; if (present (within_bounds)) wb = within_bounds if (wb) then n = histogram_get_n_entries_within_bounds (obj%h) else n = histogram_get_n_entries (obj%h) end if case (AN_PLOT) n = plot_get_n_entries (obj%p) case default n = 0 end select end function analysis_object_get_n_entries function analysis_object_get_average (obj, within_bounds) result (avg) real(default) :: avg type(analysis_object_t), intent(in) :: obj logical, intent(in), optional :: within_bounds logical :: wb select case (obj%type) case (AN_OBSERVABLE) avg = observable_get_average (obj%obs) case (AN_HISTOGRAM) wb = .false.; if (present (within_bounds)) wb = within_bounds if (wb) then avg = histogram_get_average_within_bounds (obj%h) else avg = histogram_get_average (obj%h) end if case default avg = 0 end select end function analysis_object_get_average function analysis_object_get_error (obj, within_bounds) result (err) real(default) :: err type(analysis_object_t), intent(in) :: obj logical, intent(in), optional :: within_bounds logical :: wb select case (obj%type) case (AN_OBSERVABLE) err = observable_get_error (obj%obs) case (AN_HISTOGRAM) wb = .false.; if (present (within_bounds)) wb = within_bounds if (wb) then err = histogram_get_error_within_bounds (obj%h) else err = histogram_get_error (obj%h) end if case default err = 0 end select end function analysis_object_get_error @ %def analysis_object_get_n_elements @ %def analysis_object_get_n_entries @ %def analysis_object_get_average @ %def analysis_object_get_error @ Return pointers to the actual contents: <>= function analysis_object_get_observable_ptr (obj) result (obs) type(observable_t), pointer :: obs type(analysis_object_t), intent(in) :: obj select case (obj%type) case (AN_OBSERVABLE); obs => obj%obs case default; obs => null () end select end function analysis_object_get_observable_ptr function analysis_object_get_histogram_ptr (obj) result (h) type(histogram_t), pointer :: h type(analysis_object_t), intent(in) :: obj select case (obj%type) case (AN_HISTOGRAM); h => obj%h case default; h => null () end select end function analysis_object_get_histogram_ptr function analysis_object_get_plot_ptr (obj) result (plot) type(plot_t), pointer :: plot type(analysis_object_t), intent(in) :: obj select case (obj%type) case (AN_PLOT); plot => obj%p case default; plot => null () end select end function analysis_object_get_plot_ptr function analysis_object_get_graph_ptr (obj) result (g) type(graph_t), pointer :: g type(analysis_object_t), intent(in) :: obj select case (obj%type) case (AN_GRAPH); g => obj%g case default; g => null () end select end function analysis_object_get_graph_ptr @ %def analysis_object_get_observable_ptr @ %def analysis_object_get_histogram_ptr @ %def analysis_object_get_plot_ptr @ %def analysis_object_get_graph_ptr @ Return true if the object has a graphical representation: <>= function analysis_object_has_plot (obj) result (flag) logical :: flag type(analysis_object_t), intent(in) :: obj select case (obj%type) case (AN_HISTOGRAM); flag = .true. case (AN_PLOT); flag = .true. case (AN_GRAPH); flag = .true. case default; flag = .false. end select end function analysis_object_has_plot @ %def analysis_object_has_plot @ \subsubsection{Output} <>= subroutine analysis_object_write (obj, unit, verbose) type(analysis_object_t), intent(in) :: obj integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical :: verb integer :: u u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose write (u, "(A)") repeat ("#", 79) select case (obj%type) case (AN_OBSERVABLE) write (u, "(A)", advance="no") "# Observable:" case (AN_HISTOGRAM) write (u, "(A)", advance="no") "# Histogram: " case (AN_PLOT) write (u, "(A)", advance="no") "# Plot: " case (AN_GRAPH) write (u, "(A)", advance="no") "# Graph: " case default write (u, "(A)") "# [undefined analysis object]" return end select write (u, "(1x,A)") char (obj%id) select case (obj%type) case (AN_OBSERVABLE) call observable_write (obj%obs, unit) case (AN_HISTOGRAM) if (verb) then call obj%h%graph_options%write (unit) write (u, *) call obj%h%drawing_options%write (unit) write (u, *) end if call histogram_write (obj%h, unit) case (AN_PLOT) if (verb) then call obj%p%graph_options%write (unit) write (u, *) call obj%p%drawing_options%write (unit) write (u, *) end if call plot_write (obj%p, unit) case (AN_GRAPH) call graph_write (obj%g, unit) end select end subroutine analysis_object_write @ %def analysis_object_write @ Write the object part of the \LaTeX\ driver file. <>= subroutine analysis_object_write_driver (obj, filename, unit) type(analysis_object_t), intent(in) :: obj type(string_t), intent(in) :: filename integer, intent(in), optional :: unit select case (obj%type) case (AN_OBSERVABLE) call observable_write_driver (obj%obs, unit) case (AN_HISTOGRAM) call histogram_write_gml_driver (obj%h, filename, unit) case (AN_PLOT) call plot_write_gml_driver (obj%p, filename, unit) case (AN_GRAPH) call graph_write_gml_driver (obj%g, filename, unit) end select end subroutine analysis_object_write_driver @ %def analysis_object_write_driver @ Return a data header for external formats, in ifile form. <>= subroutine analysis_object_get_header (obj, header, comment) type(analysis_object_t), intent(in) :: obj type(ifile_t), intent(inout) :: header type(string_t), intent(in), optional :: comment select case (obj%type) case (AN_HISTOGRAM) call histogram_get_header (obj%h, header, comment) case (AN_PLOT) call plot_get_header (obj%p, header, comment) end select end subroutine analysis_object_get_header @ %def analysis_object_get_header @ \subsection{Analysis object iterator} Analysis objects are containers which have iterable data structures: histograms/bins and plots/points. If they are to be treated on a common basis, it is useful to have an iterator which hides the implementation details. The iterator is used only for elementary analysis objects that contain plot data: histograms or plots. It is invalid for meta-objects (graphs) and non-graphical objects (observables). <>= type :: analysis_iterator_t private integer :: type = AN_UNDEFINED type(analysis_object_t), pointer :: object => null () integer :: index = 1 type(point_t), pointer :: point => null () end type @ %def analysis_iterator_t @ The initializer places the iterator at the beginning of the analysis object. <>= subroutine analysis_iterator_init (iterator, object) type(analysis_iterator_t), intent(out) :: iterator type(analysis_object_t), intent(in), target :: object iterator%object => object if (associated (iterator%object)) then iterator%type = iterator%object%type select case (iterator%type) case (AN_PLOT) iterator%point => iterator%object%p%first end select end if end subroutine analysis_iterator_init @ %def analysis_iterator_init @ The iterator is valid as long as it points to an existing entry. An iterator for a data object without array data (observable) is always invalid. <>= function analysis_iterator_is_valid (iterator) result (valid) logical :: valid type(analysis_iterator_t), intent(in) :: iterator if (associated (iterator%object)) then select case (iterator%type) case (AN_HISTOGRAM) valid = iterator%index <= histogram_get_n_bins (iterator%object%h) case (AN_PLOT) valid = associated (iterator%point) case default valid = .false. end select else valid = .false. end if end function analysis_iterator_is_valid @ %def analysis_iterator_is_valid @ Advance the iterator. <>= subroutine analysis_iterator_advance (iterator) type(analysis_iterator_t), intent(inout) :: iterator if (associated (iterator%object)) then select case (iterator%type) case (AN_PLOT) iterator%point => iterator%point%next end select iterator%index = iterator%index + 1 end if end subroutine analysis_iterator_advance @ %def analysis_iterator_advance @ Retrieve the object type: <>= function analysis_iterator_get_type (iterator) result (type) integer :: type type(analysis_iterator_t), intent(in) :: iterator type = iterator%type end function analysis_iterator_get_type @ %def analysis_iterator_get_type @ Use the iterator to retrieve data. We implement a common routine which takes the data descriptors as optional arguments. Data which do not occur in the selected type trigger to an error condition. The iterator must point to a valid entry. <>= subroutine analysis_iterator_get_data (iterator, & x, y, yerr, xerr, width, excess, index, n_total) type(analysis_iterator_t), intent(in) :: iterator real(default), intent(out), optional :: x, y, yerr, xerr, width, excess integer, intent(out), optional :: index, n_total select case (iterator%type) case (AN_HISTOGRAM) if (present (x)) & x = bin_get_midpoint (iterator%object%h%bin(iterator%index)) if (present (y)) & y = bin_get_sum (iterator%object%h%bin(iterator%index)) if (present (yerr)) & yerr = bin_get_error (iterator%object%h%bin(iterator%index)) if (present (xerr)) & call invalid ("histogram", "xerr") if (present (width)) & width = bin_get_width (iterator%object%h%bin(iterator%index)) if (present (excess)) & excess = bin_get_excess (iterator%object%h%bin(iterator%index)) if (present (index)) & index = iterator%index if (present (n_total)) & n_total = histogram_get_n_bins (iterator%object%h) case (AN_PLOT) if (present (x)) & x = point_get_x (iterator%point) if (present (y)) & y = point_get_y (iterator%point) if (present (yerr)) & yerr = point_get_yerr (iterator%point) if (present (xerr)) & xerr = point_get_xerr (iterator%point) if (present (width)) & call invalid ("plot", "width") if (present (excess)) & call invalid ("plot", "excess") if (present (index)) & index = iterator%index if (present (n_total)) & n_total = plot_get_n_entries (iterator%object%p) case default call msg_bug ("analysis_iterator_get_data: called " & // "for unsupported analysis object type") end select contains subroutine invalid (typestr, objstr) character(*), intent(in) :: typestr, objstr call msg_bug ("analysis_iterator_get_data: attempt to get '" & // objstr // "' for type '" // typestr // "'") end subroutine invalid end subroutine analysis_iterator_get_data @ %def analysis_iterator_get_data @ \subsection{Analysis store} This data structure holds all observables, histograms and such that are currently active. We have one global store; individual items are identified by their ID strings and types. <>= type(analysis_store_t), save :: analysis_store @ %def analysis_store <>= type :: analysis_store_t private type(analysis_object_t), pointer :: first => null () type(analysis_object_t), pointer :: last => null () end type analysis_store_t @ %def analysis_store_t @ Delete the analysis store <>= public :: analysis_final <>= module subroutine analysis_final () end subroutine analysis_final <>= module subroutine analysis_final () type(analysis_object_t), pointer :: current do while (associated (analysis_store%first)) current => analysis_store%first analysis_store%first => current%next call analysis_object_final (current) end do analysis_store%last => null () end subroutine analysis_final @ %def analysis_final @ Append a new analysis object <>= subroutine analysis_store_append_object (id, type) type(string_t), intent(in) :: id integer, intent(in) :: type type(analysis_object_t), pointer :: obj allocate (obj) call analysis_object_init (obj, id, type) if (associated (analysis_store%last)) then analysis_store%last%next => obj else analysis_store%first => obj end if analysis_store%last => obj end subroutine analysis_store_append_object @ %def analysis_store_append_object @ Return a pointer to the analysis object with given ID. <>= function analysis_store_get_object_ptr (id) result (obj) type(string_t), intent(in) :: id type(analysis_object_t), pointer :: obj obj => analysis_store%first do while (associated (obj)) if (obj%id == id) return obj => obj%next end do end function analysis_store_get_object_ptr @ %def analysis_store_get_object_ptr @ Initialize an analysis object: either reset it if present, or append a new entry. <>= subroutine analysis_store_init_object (id, type, obj) type(string_t), intent(in) :: id integer, intent(in) :: type type(analysis_object_t), pointer :: obj, next obj => analysis_store_get_object_ptr (id) if (associated (obj)) then next => analysis_object_get_next_ptr (obj) call analysis_object_final (obj) call analysis_object_init (obj, id, type) call analysis_object_set_next_ptr (obj, next) else call analysis_store_append_object (id, type) obj => analysis_store%last end if end subroutine analysis_store_init_object @ %def analysis_store_init_object @ Get the type of a analysis object <>= public :: analysis_store_get_object_type <>= module function analysis_store_get_object_type (id) result (type) type(string_t), intent(in) :: id integer :: type end function analysis_store_get_object_type <>= module function analysis_store_get_object_type (id) result (type) type(string_t), intent(in) :: id integer :: type type(analysis_object_t), pointer :: object object => analysis_store_get_object_ptr (id) if (associated (object)) then type = object%type else type = AN_UNDEFINED end if end function analysis_store_get_object_type @ %def analysis_store_get_object_type @ Return the number of objects in the store. <>= function analysis_store_get_n_objects () result (n) integer :: n type(analysis_object_t), pointer :: current n = 0 current => analysis_store%first do while (associated (current)) n = n + 1 current => current%next end do end function analysis_store_get_n_objects @ %def analysis_store_get_n_objects @ Allocate an array and fill it with all existing IDs. <>= public :: analysis_store_get_ids <>= module subroutine analysis_store_get_ids (id) type(string_t), dimension(:), allocatable, intent(out) :: id end subroutine analysis_store_get_ids <>= module subroutine analysis_store_get_ids (id) type(string_t), dimension(:), allocatable, intent(out) :: id type(analysis_object_t), pointer :: current integer :: i allocate (id (analysis_store_get_n_objects())) i = 0 current => analysis_store%first do while (associated (current)) i = i + 1 id(i) = current%id current => current%next end do end subroutine analysis_store_get_ids @ %def analysis_store_get_ids @ \subsection{\LaTeX\ driver file} Write a driver file for all objects in the store. <>= subroutine analysis_store_write_driver_all (filename_data, unit) type(string_t), intent(in) :: filename_data integer, intent(in), optional :: unit type(analysis_object_t), pointer :: obj call analysis_store_write_driver_header (unit) obj => analysis_store%first do while (associated (obj)) call analysis_object_write_driver (obj, filename_data, unit) obj => obj%next end do call analysis_store_write_driver_footer (unit) end subroutine analysis_store_write_driver_all @ %def analysis_store_write_driver_all @ Write a driver file for an array of objects. <>= subroutine analysis_store_write_driver_obj (filename_data, id, unit) type(string_t), intent(in) :: filename_data type(string_t), dimension(:), intent(in) :: id integer, intent(in), optional :: unit type(analysis_object_t), pointer :: obj integer :: i call analysis_store_write_driver_header (unit) do i = 1, size (id) obj => analysis_store_get_object_ptr (id(i)) if (associated (obj)) & call analysis_object_write_driver (obj, filename_data, unit) end do call analysis_store_write_driver_footer (unit) end subroutine analysis_store_write_driver_obj @ %def analysis_store_write_driver_obj @ The beginning of the driver file. <>= subroutine analysis_store_write_driver_header (unit) integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write (u, '(A)') "\documentclass[12pt]{article}" write (u, *) write (u, '(A)') "\usepackage{gamelan}" write (u, '(A)') "\usepackage{amsmath}" write (u, '(A)') "\usepackage{ifpdf}" write (u, '(A)') "\ifpdf" write (u, '(A)') " \DeclareGraphicsRule{*}{mps}{*}{}" write (u, '(A)') "\else" write (u, '(A)') " \DeclareGraphicsRule{*}{eps}{*}{}" write (u, '(A)') "\fi" write (u, *) write (u, '(A)') "\begin{document}" write (u, '(A)') "\begin{gmlfile}" write (u, *) write (u, '(A)') "\begin{gmlcode}" write (u, '(A)') " color col.default, col.excess;" write (u, '(A)') " col.default = 0.9white;" write (u, '(A)') " col.excess = red;" write (u, '(A)') " boolean show_excess;" !!! Future excess options for plots ! if (mcs(1)%plot_excess .and. mcs(1)%unweighted) then ! write (u, '(A)') " show_excess = true;" ! else write (u, '(A)') " show_excess = false;" ! end if write (u, '(A)') "\end{gmlcode}" write (u, *) end subroutine analysis_store_write_driver_header @ %def analysis_store_write_driver_header @ The end of the driver file. <>= subroutine analysis_store_write_driver_footer (unit) integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit); if (u < 0) return write(u, *) write(u, '(A)') "\end{gmlfile}" write(u, '(A)') "\end{document}" end subroutine analysis_store_write_driver_footer @ %def analysis_store_write_driver_footer @ \subsection{API} \subsubsection{Creating new objects} The specific versions below: <>= public :: analysis_init_observable <>= module subroutine analysis_init_observable (id, obs_label, obs_unit, graph_options) type(string_t), intent(in) :: id type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options end subroutine analysis_init_observable <>= module subroutine analysis_init_observable (id, obs_label, obs_unit, graph_options) type(string_t), intent(in) :: id type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(analysis_object_t), pointer :: obj type(observable_t), pointer :: obs call analysis_store_init_object (id, AN_OBSERVABLE, obj) obs => analysis_object_get_observable_ptr (obj) call observable_init (obs, obs_label, obs_unit, graph_options) end subroutine analysis_init_observable @ %def analysis_init_observable <>= public :: analysis_init_histogram <>= interface analysis_init_histogram module procedure analysis_init_histogram_n_bins module procedure analysis_init_histogram_bin_width end interface <>= module subroutine analysis_init_histogram_n_bins & (id, lower_bound, upper_bound, n_bins, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) type(string_t), intent(in) :: id real(default), intent(in) :: lower_bound, upper_bound integer, intent(in) :: n_bins logical, intent(in) :: normalize_bins type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options end subroutine analysis_init_histogram_n_bins module subroutine analysis_init_histogram_bin_width & (id, lower_bound, upper_bound, bin_width, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) type(string_t), intent(in) :: id real(default), intent(in) :: lower_bound, upper_bound, bin_width logical, intent(in) :: normalize_bins type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options end subroutine analysis_init_histogram_bin_width <>= module subroutine analysis_init_histogram_n_bins & (id, lower_bound, upper_bound, n_bins, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) type(string_t), intent(in) :: id real(default), intent(in) :: lower_bound, upper_bound integer, intent(in) :: n_bins logical, intent(in) :: normalize_bins type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options type(analysis_object_t), pointer :: obj type(histogram_t), pointer :: h call analysis_store_init_object (id, AN_HISTOGRAM, obj) h => analysis_object_get_histogram_ptr (obj) call histogram_init (h, id, & lower_bound, upper_bound, n_bins, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) end subroutine analysis_init_histogram_n_bins module subroutine analysis_init_histogram_bin_width & (id, lower_bound, upper_bound, bin_width, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) type(string_t), intent(in) :: id real(default), intent(in) :: lower_bound, upper_bound, bin_width logical, intent(in) :: normalize_bins type(string_t), intent(in), optional :: obs_label, obs_unit type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options type(analysis_object_t), pointer :: obj type(histogram_t), pointer :: h call analysis_store_init_object (id, AN_HISTOGRAM, obj) h => analysis_object_get_histogram_ptr (obj) call histogram_init (h, id, & lower_bound, upper_bound, bin_width, normalize_bins, & obs_label, obs_unit, graph_options, drawing_options) end subroutine analysis_init_histogram_bin_width @ %def analysis_init_histogram_n_bins @ %def analysis_init_histogram_bin_width <>= public :: analysis_init_plot <>= module subroutine analysis_init_plot (id, graph_options, drawing_options) type(string_t), intent(in) :: id type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options end subroutine analysis_init_plot <>= module subroutine analysis_init_plot (id, graph_options, drawing_options) type(string_t), intent(in) :: id type(graph_options_t), intent(in), optional :: graph_options type(drawing_options_t), intent(in), optional :: drawing_options type(analysis_object_t), pointer :: obj type(plot_t), pointer :: plot call analysis_store_init_object (id, AN_PLOT, obj) plot => analysis_object_get_plot_ptr (obj) call plot_init (plot, id, graph_options, drawing_options) end subroutine analysis_init_plot @ %def analysis_init_plot <>= public :: analysis_init_graph <>= module subroutine analysis_init_graph (id, n_elements, graph_options) type(string_t), intent(in) :: id integer, intent(in) :: n_elements type(graph_options_t), intent(in), optional :: graph_options end subroutine analysis_init_graph <>= module subroutine analysis_init_graph (id, n_elements, graph_options) type(string_t), intent(in) :: id integer, intent(in) :: n_elements type(graph_options_t), intent(in), optional :: graph_options type(analysis_object_t), pointer :: obj type(graph_t), pointer :: graph call analysis_store_init_object (id, AN_GRAPH, obj) graph => analysis_object_get_graph_ptr (obj) call graph_init (graph, id, n_elements, graph_options) end subroutine analysis_init_graph @ %def analysis_init_graph @ \subsubsection{Recording data} This procedure resets an object or the whole store to its initial state. <>= public :: analysis_clear <>= interface analysis_clear module procedure analysis_store_clear_obj module procedure analysis_store_clear_all end interface <>= module subroutine analysis_store_clear_obj (id) type(string_t), intent(in) :: id end subroutine analysis_store_clear_obj module subroutine analysis_store_clear_all () end subroutine analysis_store_clear_all <>= module subroutine analysis_store_clear_obj (id) type(string_t), intent(in) :: id type(analysis_object_t), pointer :: obj obj => analysis_store_get_object_ptr (id) if (associated (obj)) then call analysis_object_clear (obj) end if end subroutine analysis_store_clear_obj module subroutine analysis_store_clear_all () type(analysis_object_t), pointer :: obj obj => analysis_store%first do while (associated (obj)) call analysis_object_clear (obj) obj => obj%next end do end subroutine analysis_store_clear_all @ %def analysis_clear @ There is one generic recording function whose behavior depends on the type of analysis object. <>= public :: analysis_record_data <>= module subroutine analysis_record_data (id, x, y, yerr, xerr, & weight, excess, success, exist) type(string_t), intent(in) :: id real(default), intent(in) :: x real(default), intent(in), optional :: y, yerr, xerr, weight, excess logical, intent(out), optional :: success, exist end subroutine analysis_record_data <>= module subroutine analysis_record_data (id, x, y, yerr, xerr, & weight, excess, success, exist) type(string_t), intent(in) :: id real(default), intent(in) :: x real(default), intent(in), optional :: y, yerr, xerr, weight, excess logical, intent(out), optional :: success, exist type(analysis_object_t), pointer :: obj obj => analysis_store_get_object_ptr (id) if (associated (obj)) then call analysis_object_record_data (obj, x, y, yerr, xerr, & weight, excess, success) if (present (exist)) exist = .true. else if (present (success)) success = .false. if (present (exist)) exist = .false. end if end subroutine analysis_record_data @ %def analysis_record_data @ \subsubsection{Build a graph} This routine sets up the array of graph elements by copying the graph elements given as input. The object must exist and already be initialized as a graph. <>= public :: analysis_fill_graph <>= module subroutine analysis_fill_graph (id, i, id_in, drawing_options) type(string_t), intent(in) :: id integer, intent(in) :: i type(string_t), intent(in) :: id_in type(drawing_options_t), intent(in), optional :: drawing_options end subroutine analysis_fill_graph <>= module subroutine analysis_fill_graph (id, i, id_in, drawing_options) type(string_t), intent(in) :: id integer, intent(in) :: i type(string_t), intent(in) :: id_in type(drawing_options_t), intent(in), optional :: drawing_options type(analysis_object_t), pointer :: obj type(graph_t), pointer :: g type(histogram_t), pointer :: h type(plot_t), pointer :: p obj => analysis_store_get_object_ptr (id) g => analysis_object_get_graph_ptr (obj) obj => analysis_store_get_object_ptr (id_in) if (associated (obj)) then select case (obj%type) case (AN_HISTOGRAM) h => analysis_object_get_histogram_ptr (obj) call graph_insert_histogram (g, i, h, drawing_options) case (AN_PLOT) p => analysis_object_get_plot_ptr (obj) call graph_insert_plot (g, i, p, drawing_options) case default call msg_error ("Graph '" // char (id) // "': Element '" & // char (id_in) // "' is neither histogram nor plot.") end select else call msg_error ("Graph '" // char (id) // "': Element '" & // char (id_in) // "' is undefined.") end if end subroutine analysis_fill_graph @ %def analysis_fill_graph @ \subsubsection{Retrieve generic results} Check if a named object exists. <>= public :: analysis_exists <>= module function analysis_exists (id) result (flag) type(string_t), intent(in) :: id logical :: flag end function analysis_exists <>= module function analysis_exists (id) result (flag) type(string_t), intent(in) :: id logical :: flag type(analysis_object_t), pointer :: obj flag = .true. obj => analysis_store%first do while (associated (obj)) if (obj%id == id) return obj => obj%next end do flag = .false. end function analysis_exists @ %def analysis_exists @ The following functions should work for all kinds of analysis object: <>= public :: analysis_get_n_elements public :: analysis_get_n_entries public :: analysis_get_average public :: analysis_get_error <>= module function analysis_get_n_elements (id) result (n) integer :: n type(string_t), intent(in) :: id end function analysis_get_n_elements module function analysis_get_n_entries (id, within_bounds) result (n) integer :: n type(string_t), intent(in) :: id logical, intent(in), optional :: within_bounds end function analysis_get_n_entries module function analysis_get_average (id, within_bounds) result (avg) real(default) :: avg type(string_t), intent(in) :: id logical, intent(in), optional :: within_bounds end function analysis_get_average module function analysis_get_error (id, within_bounds) result (err) real(default) :: err type(string_t), intent(in) :: id logical, intent(in), optional :: within_bounds end function analysis_get_error <>= module function analysis_get_n_elements (id) result (n) integer :: n type(string_t), intent(in) :: id type(analysis_object_t), pointer :: obj obj => analysis_store_get_object_ptr (id) if (associated (obj)) then n = analysis_object_get_n_elements (obj) else n = 0 end if end function analysis_get_n_elements module function analysis_get_n_entries (id, within_bounds) result (n) integer :: n type(string_t), intent(in) :: id logical, intent(in), optional :: within_bounds type(analysis_object_t), pointer :: obj obj => analysis_store_get_object_ptr (id) if (associated (obj)) then n = analysis_object_get_n_entries (obj, within_bounds) else n = 0 end if end function analysis_get_n_entries module function analysis_get_average (id, within_bounds) result (avg) real(default) :: avg type(string_t), intent(in) :: id type(analysis_object_t), pointer :: obj logical, intent(in), optional :: within_bounds obj => analysis_store_get_object_ptr (id) if (associated (obj)) then avg = analysis_object_get_average (obj, within_bounds) else avg = 0 end if end function analysis_get_average module function analysis_get_error (id, within_bounds) result (err) real(default) :: err type(string_t), intent(in) :: id type(analysis_object_t), pointer :: obj logical, intent(in), optional :: within_bounds obj => analysis_store_get_object_ptr (id) if (associated (obj)) then err = analysis_object_get_error (obj, within_bounds) else err = 0 end if end function analysis_get_error @ %def analysis_get_n_elements @ %def analysis_get_n_entries @ %def analysis_get_average @ %def analysis_get_error @ Return true if any analysis object is graphical <>= public :: analysis_has_plots <>= interface analysis_has_plots module procedure analysis_has_plots_any module procedure analysis_has_plots_obj end interface <>= module function analysis_has_plots_any () result (flag) logical :: flag end function analysis_has_plots_any module function analysis_has_plots_obj (id) result (flag) logical :: flag type(string_t), dimension(:), intent(in) :: id end function analysis_has_plots_obj <>= module function analysis_has_plots_any () result (flag) logical :: flag type(analysis_object_t), pointer :: obj flag = .false. obj => analysis_store%first do while (associated (obj)) flag = analysis_object_has_plot (obj) if (flag) return end do end function analysis_has_plots_any module function analysis_has_plots_obj (id) result (flag) logical :: flag type(string_t), dimension(:), intent(in) :: id type(analysis_object_t), pointer :: obj integer :: i flag = .false. do i = 1, size (id) obj => analysis_store_get_object_ptr (id(i)) if (associated (obj)) then flag = analysis_object_has_plot (obj) if (flag) return end if end do end function analysis_has_plots_obj @ %def analysis_has_plots @ \subsubsection{Iterators} Initialize an iterator for the given object. If the object does not exist or has wrong type, the iterator will be invalid. <>= subroutine analysis_init_iterator (id, iterator) type(string_t), intent(in) :: id type(analysis_iterator_t), intent(out) :: iterator type(analysis_object_t), pointer :: obj obj => analysis_store_get_object_ptr (id) if (associated (obj)) call analysis_iterator_init (iterator, obj) end subroutine analysis_init_iterator @ %def analysis_init_iterator @ \subsubsection{Output} <>= public :: analysis_write <>= interface analysis_write module procedure analysis_write_object module procedure analysis_write_all end interface @ %def interface <>= module subroutine analysis_write_object (id, unit, verbose) type(string_t), intent(in) :: id integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine analysis_write_object module subroutine analysis_write_all (unit, verbose) integer, intent(in), optional :: unit logical, intent(in), optional :: verbose end subroutine analysis_write_all <>= module subroutine analysis_write_object (id, unit, verbose) type(string_t), intent(in) :: id integer, intent(in), optional :: unit logical, intent(in), optional :: verbose type(analysis_object_t), pointer :: obj obj => analysis_store_get_object_ptr (id) if (associated (obj)) then call analysis_object_write (obj, unit, verbose) else call msg_error ("Analysis object '" // char (id) // "' not found") end if end subroutine analysis_write_object module subroutine analysis_write_all (unit, verbose) integer, intent(in), optional :: unit logical, intent(in), optional :: verbose type(analysis_object_t), pointer :: obj integer :: u u = given_output_unit (unit); if (u < 0) return obj => analysis_store%first do while (associated (obj)) call analysis_object_write (obj, unit, verbose) obj => obj%next end do end subroutine analysis_write_all @ %def analysis_write_object @ %def analysis_write_all <>= public :: analysis_write_driver <>= module subroutine analysis_write_driver (filename_data, id, unit) type(string_t), intent(in) :: filename_data type(string_t), dimension(:), intent(in), optional :: id integer, intent(in), optional :: unit end subroutine analysis_write_driver <>= module subroutine analysis_write_driver (filename_data, id, unit) type(string_t), intent(in) :: filename_data type(string_t), dimension(:), intent(in), optional :: id integer, intent(in), optional :: unit if (present (id)) then call analysis_store_write_driver_obj (filename_data, id, unit) else call analysis_store_write_driver_all (filename_data, unit) end if end subroutine analysis_write_driver @ %def analysis_write_driver <>= public :: analysis_compile_tex <>= module subroutine analysis_compile_tex (file, has_gmlcode, os_data) type(string_t), intent(in) :: file logical, intent(in) :: has_gmlcode type(os_data_t), intent(in) :: os_data end subroutine analysis_compile_tex <>= module subroutine analysis_compile_tex (file, has_gmlcode, os_data) type(string_t), intent(in) :: file logical, intent(in) :: has_gmlcode type(os_data_t), intent(in) :: os_data integer :: status if (os_data%event_analysis_ps) then call os_system_call ("make compile " // os_data%makeflags // " -f " // & char (file) // "_ana.makefile", status) if (status /= 0) then call msg_error ("Unable to compile analysis output file") end if else call msg_warning ("Skipping results display because " & // "latex/mpost/dvips is not available") end if end subroutine analysis_compile_tex @ %def analysis_compile_tex @ Write header for generic data output to an ifile. <>= subroutine analysis_get_header (id, header, comment) type(string_t), intent(in) :: id type(ifile_t), intent(inout) :: header type(string_t), intent(in), optional :: comment type(analysis_object_t), pointer :: object object => analysis_store_get_object_ptr (id) if (associated (object)) then call analysis_object_get_header (object, header, comment) end if end subroutine analysis_get_header @ %def analysis_get_header @ Write a makefile in order to do the compile steps. <>= public :: analysis_write_makefile <>= module subroutine analysis_write_makefile (filename, unit, has_gmlcode, os_data) type(string_t), intent(in) :: filename integer, intent(in) :: unit logical, intent(in) :: has_gmlcode type(os_data_t), intent(in) :: os_data end subroutine analysis_write_makefile <>= module subroutine analysis_write_makefile (filename, unit, has_gmlcode, os_data) type(string_t), intent(in) :: filename integer, intent(in) :: unit logical, intent(in) :: has_gmlcode type(os_data_t), intent(in) :: os_data write (unit, "(3A)") "# WHIZARD: Makefile for analysis '", & char (filename), "'" write (unit, "(A)") "# Automatically generated file, do not edit" write (unit, "(A)") "" write (unit, "(A)") "# LaTeX setup" write (unit, "(A)") "LATEX = " // char (os_data%latex) write (unit, "(A)") "MPOST = " // char (os_data%mpost) write (unit, "(A)") "GML = " // char (os_data%gml) write (unit, "(A)") "DVIPS = " // char (os_data%dvips) write (unit, "(A)") "PS2PDF = " // char (os_data%ps2pdf) - write (unit, "(A)") 'TEX_FLAGS = "$$TEXINPUTS:' // & - char(os_data%whizard_texpath) // '"' - write (unit, "(A)") 'MP_FLAGS = "$$MPINPUTS:' // & - char(os_data%whizard_texpath) // '"' + write (unit, "(A)") 'TEX_FLAGS = "' // char(os_data%whizard_texpath) & + // ':$$TEXINPUTS"' + write (unit, "(A)") 'MP_FLAGS = "' // char(os_data%whizard_texpath) & + // ':$$MPINPUTS"' write (unit, "(A)") "" write (unit, "(5A)") "TEX_SOURCES = ", char (filename), ".tex" if (os_data%event_analysis_pdf) then write (unit, "(5A)") "TEX_OBJECTS = ", char (filename), ".pdf" else write (unit, "(5A)") "TEX_OBJECTS = ", char (filename), ".ps" end if if (os_data%event_analysis_ps) then if (os_data%event_analysis_pdf) then write (unit, "(5A)") char (filename), ".pdf: ", & char (filename), ".tex" else write (unit, "(5A)") char (filename), ".ps: ", & char (filename), ".tex" end if write (unit, "(5A)") TAB, "-TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // & char (filename) // ".tex" if (has_gmlcode) then write (unit, "(5A)") TAB, "$(GML) " // char (filename) write (unit, "(5A)") TAB, "TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // & char (filename) // ".tex" end if write (unit, "(5A)") TAB, "$(DVIPS) -o " // char (filename) // ".ps " // & char (filename) // ".dvi" if (os_data%event_analysis_pdf) then write (unit, "(5A)") TAB, "$(PS2PDF) " // char (filename) // ".ps" end if end if write (unit, "(A)") write (unit, "(A)") "compile: $(TEX_OBJECTS)" write (unit, "(A)") ".PHONY: compile" write (unit, "(A)") write (unit, "(5A)") "CLEAN_OBJECTS = ", char (filename), ".aux" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".log" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".dvi" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".out" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".[1-9]" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".[1-9][0-9]" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".[1-9][0-9][0-9]" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".t[1-9]" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".t[1-9][0-9]" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".t[1-9][0-9][0-9]" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".ltp" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".mp" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".mpx" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".dvi" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".ps" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".pdf" write (unit, "(A)") write (unit, "(A)") "# Generic cleanup targets" write (unit, "(A)") "clean-objects:" write (unit, "(A)") TAB // "rm -f $(CLEAN_OBJECTS)" write (unit, "(A)") "" write (unit, "(A)") "clean: clean-objects" write (unit, "(A)") ".PHONY: clean" end subroutine analysis_write_makefile @ %def analysis_write_makefile @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[analysis_ut.f90]]>>= <> module analysis_ut use unit_tests use analysis_uti <> <> contains <> end module analysis_ut @ %def analysis_ut @ <<[[analysis_uti.f90]]>>= <> module analysis_uti <> <> use format_defs, only: FMT_19 use analysis <> <> contains <> end module analysis_uti @ %def analysis_ut @ API: driver for the unit tests below. <>= public :: analysis_test <>= subroutine analysis_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine analysis_test @ %def analysis_test <>= call test (analysis_1, "analysis_1", & "check elementary analysis building blocks", & u, results) <>= public :: analysis_1 <>= subroutine analysis_1 (u) integer, intent(in) :: u type(string_t) :: id1, id2, id3, id4 integer :: i id1 = "foo" id2 = "bar" id3 = "hist" id4 = "plot" write (u, "(A)") "* Test output: Analysis" write (u, "(A)") "* Purpose: test the analysis routines" write (u, "(A)") call analysis_init_observable (id1) call analysis_init_observable (id2) call analysis_init_histogram & (id3, 0.5_default, 5.5_default, 1._default, normalize_bins=.false.) call analysis_init_plot (id4) do i = 1, 3 write (u, "(A,1x," // FMT_19 // ")") "data = ", real(i,default) call analysis_record_data (id1, real(i,default)) call analysis_record_data (id2, real(i,default), & weight=real(i,default)) call analysis_record_data (id3, real(i,default)) call analysis_record_data (id4, real(i,default), real(i,default)**2) end do write (u, "(A,10(1x,I5))") "n_entries = ", & analysis_get_n_entries (id1), & analysis_get_n_entries (id2), & analysis_get_n_entries (id3), & analysis_get_n_entries (id3, within_bounds = .true.), & analysis_get_n_entries (id4), & analysis_get_n_entries (id4, within_bounds = .true.) write (u, "(A,10(1x," // FMT_19 // "))") "average = ", & analysis_get_average (id1), & analysis_get_average (id2), & analysis_get_average (id3), & analysis_get_average (id3, within_bounds = .true.) write (u, "(A,10(1x," // FMT_19 // "))") "error = ", & analysis_get_error (id1), & analysis_get_error (id2), & analysis_get_error (id3), & analysis_get_error (id3, within_bounds = .true.) write (u, "(A)") write (u, "(A)") "* Clear analysis #2" write (u, "(A)") call analysis_clear (id2) do i = 4, 6 print *, "data = ", real(i,default) call analysis_record_data (id1, real(i,default)) call analysis_record_data (id2, real(i,default), & weight=real(i,default)) call analysis_record_data (id3, real(i,default)) call analysis_record_data (id4, real(i,default), real(i,default)**2) end do write (u, "(A,10(1x,I5))") "n_entries = ", & analysis_get_n_entries (id1), & analysis_get_n_entries (id2), & analysis_get_n_entries (id3), & analysis_get_n_entries (id3, within_bounds = .true.), & analysis_get_n_entries (id4), & analysis_get_n_entries (id4, within_bounds = .true.) write (u, "(A,10(1x," // FMT_19 // "))") "average = ", & analysis_get_average (id1), & analysis_get_average (id2), & analysis_get_average (id3), & analysis_get_average (id3, within_bounds = .true.) write (u, "(A,10(1x," // FMT_19 // "))") "error = ", & analysis_get_error (id1), & analysis_get_error (id2), & analysis_get_error (id3), & analysis_get_error (id3, within_bounds = .true.) write (u, "(A)") call analysis_write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call analysis_clear () call analysis_final () write (u, "(A)") write (u, "(A)") "* Test output end: analysis_1" end subroutine analysis_1 @ %def analysis_1 Index: trunk/src/matrix_elements/matrix_elements.nw =================================================================== --- trunk/src/matrix_elements/matrix_elements.nw (revision 8883) +++ trunk/src/matrix_elements/matrix_elements.nw (revision 8884) @@ -1,11575 +1,11575 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: matrix elements and process libraries \chapter{Matrix Element Handling} \includemodulegraph{matrix_elements} In this chapter, we support internal and external matrix elements: initialization, automatic generation where necessary, and numerical evaluation. We provide the interface for code generation and linking. Matrix-element code is organized in processes and process libraries. \begin{description} \item[process\_constants] A record of static process properties, for easy transfer between various \whizard\ modules. \item[prclib\_interfaces] This module deals with matrix-element code which is accessible via external libraries (Fortran libraries or generic C-compatible libraries) and must either be generated by the program or provided by the user explicitly. The module defines and uses an abstract type [[prc_writer_t]] and two abstract extensions, one for a Fortran module and one for a C-compatible library. The implementation provides the specific methods for writing the appropriate parts in external matrix element code. \item[prc\_core\_def] This module defines the abstract types [[prc_core_def_t]] and [[prc_driver_t]]. The implementation of the former provides the configuration for processes of a certain class, while the latter accesses the corresponding matrix element, in particular those generated by the appropriate [[prc_writer_t]] object. \item[process\_libraries] This module combines the functionality of the previous module with the means for holding processes definitions (the internal counterpart of appropriate declarations in the user interface), for handling matrix elements which do not need external code, and for accessing the matrix elements by the procedures for matrix-element evaluation, integration and event generation. \item[prclib\_stacks] Collect process libraries. \item[test\_me] This module provides a test implementation for the abstract types in the [[prc_core_def]] module. The implementation is intended for self-tests of several later modules. The implementation is internal, i.e., no external code has is generated. \end{description} All data structures which are specific for a particular way of generating code or evaluating matrix element are kept abstract and thus generic. Later modules such as [[prc_omega]] provide implementations, in the form of type extensions for the various abstract types. \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process data block} We define a simple transparent type that contains universal constant process data. We will reference objects of this type for the phase-space setup, for interfacing with process libraries, for implementing matrix-element generation, and in the master process-handling module. <<[[process_constants.f90]]>>= <> module process_constants <> <> use pdg_arrays <> <> <> interface <> end interface end module process_constants @ %def process_constants @ <<[[process_constants_sub.f90]]>>= <> submodule (process_constants) process_constants_s use io_units, only: given_output_unit, free_unit use format_utils, only: write_integer_array use md5, only: md5sum implicit none contains <> end submodule process_constants_s @ %def process_constants_s @ The data type is just a block of public objects, only elementary types, no type-bound procedures. <>= public :: process_constants_t <>= type :: process_constants_t type(string_t) :: id type(string_t) :: model_name character(32) :: md5sum = "" logical :: openmp_supported = .false. integer :: n_in = 0 integer :: n_out = 0 integer :: n_flv = 0 integer :: n_hel = 0 integer :: n_col = 0 integer :: n_cin = 0 integer :: n_cf = 0 integer, dimension(:,:), allocatable :: flv_state integer, dimension(:,:), allocatable :: hel_state integer, dimension(:,:,:), allocatable :: col_state logical, dimension(:,:), allocatable :: ghost_flag complex(default), dimension(:), allocatable :: color_factors integer, dimension(:,:), allocatable :: cf_index integer, dimension(:), allocatable :: eqv_flv_index integer, dimension(:), allocatable :: eqv_hel_index contains <> end type process_constants_t @ %def process_constants_t @ <>= procedure :: get_n_tot => process_constants_get_n_tot <>= elemental module function process_constants_get_n_tot (prc_const) result (n_tot) integer :: n_tot class(process_constants_t), intent(in) :: prc_const end function process_constants_get_n_tot <>= elemental module function process_constants_get_n_tot (prc_const) result (n_tot) integer :: n_tot class(process_constants_t), intent(in) :: prc_const n_tot = prc_const%n_in + prc_const%n_out end function process_constants_get_n_tot @ %def process_constants_get_n_tot @ <>= procedure :: get_flv_state => process_constants_get_flv_state <>= module subroutine process_constants_get_flv_state (prc_const, flv_state) class(process_constants_t), intent(in) :: prc_const integer, dimension(:,:), allocatable, intent(out) :: flv_state end subroutine process_constants_get_flv_state <>= module subroutine process_constants_get_flv_state (prc_const, flv_state) class(process_constants_t), intent(in) :: prc_const integer, dimension(:,:), allocatable, intent(out) :: flv_state allocate (flv_state (size (prc_const%flv_state, 1), & size (prc_const%flv_state, 2))) flv_state = prc_const%flv_state end subroutine process_constants_get_flv_state @ %def process_constants_get_flv_state @ <>= procedure :: get_n_flv => process_constants_get_n_flv <>= module function process_constants_get_n_flv (data) result (n_flv) integer :: n_flv class(process_constants_t), intent(in) :: data end function process_constants_get_n_flv <>= module function process_constants_get_n_flv (data) result (n_flv) integer :: n_flv class(process_constants_t), intent(in) :: data n_flv = data%n_flv end function process_constants_get_n_flv @ %def process_constants_get_n_flv @ <>= procedure :: get_n_hel => process_constants_get_n_hel <>= module function process_constants_get_n_hel (data) result (n_hel) integer :: n_hel class(process_constants_t), intent(in) :: data end function process_constants_get_n_hel <>= module function process_constants_get_n_hel (data) result (n_hel) integer :: n_hel class(process_constants_t), intent(in) :: data n_hel = data%n_hel end function process_constants_get_n_hel @ %def process_constants_get_n_flv @ <>= procedure :: get_hel_state => process_constants_get_hel_state <>= module subroutine process_constants_get_hel_state (prc_const, hel_state) class(process_constants_t), intent(in) :: prc_const integer, dimension(:,:), allocatable, intent(out) :: hel_state end subroutine process_constants_get_hel_state <>= module subroutine process_constants_get_hel_state (prc_const, hel_state) class(process_constants_t), intent(in) :: prc_const integer, dimension(:,:), allocatable, intent(out) :: hel_state allocate (hel_state (size (prc_const%hel_state, 1), & size (prc_const%hel_state, 2))) hel_state = prc_const%hel_state end subroutine process_constants_get_hel_state @ %def process_constants_get_hel_state @ <>= procedure :: get_col_state => process_constants_get_col_state <>= module subroutine process_constants_get_col_state (prc_const, col_state) class(process_constants_t), intent(in) :: prc_const integer, dimension(:,:,:), allocatable, intent(out) :: col_state end subroutine process_constants_get_col_state <>= module subroutine process_constants_get_col_state (prc_const, col_state) class(process_constants_t), intent(in) :: prc_const integer, dimension(:,:,:), allocatable, intent(out) :: col_state allocate (col_state (size (prc_const%col_state, 1), & size (prc_const%col_state, 2), size (prc_const%col_state, 3))) col_state = prc_const%col_state end subroutine process_constants_get_col_state @ %def process_constants_get_col_state @ <>= procedure :: get_ghost_flag => process_constants_get_ghost_flag <>= module subroutine process_constants_get_ghost_flag (prc_const, ghost_flag) class(process_constants_t), intent(in) :: prc_const logical, dimension(:,:), allocatable, intent(out) :: ghost_flag end subroutine process_constants_get_ghost_flag <>= module subroutine process_constants_get_ghost_flag (prc_const, ghost_flag) class(process_constants_t), intent(in) :: prc_const logical, dimension(:,:), allocatable, intent(out) :: ghost_flag allocate (ghost_flag (size (prc_const%ghost_flag, 1), & size (prc_const%ghost_flag, 2))) ghost_flag = prc_const%ghost_flag end subroutine process_constants_get_ghost_flag @ %def process_constants_get_ghost_flag @ <>= procedure :: get_color_factors => process_constants_get_color_factors <>= module subroutine process_constants_get_color_factors (prc_const, col_facts) class(process_constants_t), intent(in) :: prc_const complex(default), dimension(:), allocatable, intent(out) :: col_facts end subroutine process_constants_get_color_factors <>= module subroutine process_constants_get_color_factors (prc_const, col_facts) class(process_constants_t), intent(in) :: prc_const complex(default), dimension(:), allocatable, intent(out) :: col_facts allocate (col_facts (size (prc_const%color_factors))) col_facts = prc_const%color_factors end subroutine process_constants_get_color_factors @ %def process_constants_get_color_factors @ <>= procedure :: get_cf_index => process_constants_get_cf_index <>= module subroutine process_constants_get_cf_index (prc_const, cf_index) class(process_constants_t), intent(in) :: prc_const integer, intent(out), dimension(:,:), allocatable :: cf_index end subroutine process_constants_get_cf_index <>= module subroutine process_constants_get_cf_index (prc_const, cf_index) class(process_constants_t), intent(in) :: prc_const integer, intent(out), dimension(:,:), allocatable :: cf_index allocate (cf_index (size (prc_const%cf_index, 1), & size (prc_const%cf_index, 2))) cf_index = prc_const%cf_index end subroutine process_constants_get_cf_index @ %def process_constants_get_cf_index @ <>= procedure :: set_flv_state => process_constants_set_flv_state <>= module subroutine process_constants_set_flv_state (prc_const, flv_state) class(process_constants_t), intent(inout) :: prc_const integer, intent(in), dimension(:,:), allocatable :: flv_state end subroutine process_constants_set_flv_state <>= module subroutine process_constants_set_flv_state (prc_const, flv_state) class(process_constants_t), intent(inout) :: prc_const integer, intent(in), dimension(:,:), allocatable :: flv_state if (allocated (prc_const%flv_state)) deallocate (prc_const%flv_state) allocate (prc_const%flv_state (size (flv_state, 1), & size (flv_state, 2))) prc_const%flv_state = flv_state prc_const%n_flv = size (flv_state, 2) end subroutine process_constants_set_flv_state @ %def process_constants_set_flv_state @ <>= procedure :: set_col_state => process_constants_set_col_state <>= module subroutine process_constants_set_col_state (prc_const, col_state) class(process_constants_t), intent(inout) :: prc_const integer, intent(in), dimension(:,:,:), allocatable :: col_state end subroutine process_constants_set_col_state <>= module subroutine process_constants_set_col_state (prc_const, col_state) class(process_constants_t), intent(inout) :: prc_const integer, intent(in), dimension(:,:,:), allocatable :: col_state allocate (prc_const%col_state (size (col_state, 1), & size (col_state, 2), size (col_state, 3))) prc_const%col_state = col_state end subroutine process_constants_set_col_state @ %def process_constants_set_col_state @ <>= procedure :: set_cf_index => process_constants_set_cf_index <>= module subroutine process_constants_set_cf_index (prc_const, cf_index) class(process_constants_t), intent(inout) :: prc_const integer, dimension(:,:), intent(in), allocatable :: cf_index end subroutine process_constants_set_cf_index <>= module subroutine process_constants_set_cf_index (prc_const, cf_index) class(process_constants_t), intent(inout) :: prc_const integer, dimension(:,:), intent(in), allocatable :: cf_index allocate (prc_const%cf_index (size (cf_index, 1), & size (cf_index, 2))) prc_const%cf_index = cf_index end subroutine process_constants_set_cf_index @ %def process_constants_set_cf_index @ <>= procedure :: set_color_factors => process_constants_set_color_factors <>= module subroutine process_constants_set_color_factors (prc_const, color_factors) class(process_constants_t), intent(inout) :: prc_const complex(default), dimension(:), intent(in), allocatable :: color_factors end subroutine process_constants_set_color_factors <>= module subroutine process_constants_set_color_factors (prc_const, color_factors) class(process_constants_t), intent(inout) :: prc_const complex(default), dimension(:), intent(in), allocatable :: color_factors allocate (prc_const%color_factors (size (color_factors))) prc_const%color_factors = color_factors end subroutine process_constants_set_color_factors @ %def process_constants_set_color_factors @ <>= procedure :: set_ghost_flag => process_constants_set_ghost_flag <>= module subroutine process_constants_set_ghost_flag (prc_const, ghost_flag) class(process_constants_t), intent(inout) :: prc_const logical, dimension(:,:), allocatable, intent(in) :: ghost_flag end subroutine process_constants_set_ghost_flag <>= module subroutine process_constants_set_ghost_flag (prc_const, ghost_flag) class(process_constants_t), intent(inout) :: prc_const logical, dimension(:,:), allocatable, intent(in) :: ghost_flag allocate (prc_const%ghost_flag (size (ghost_flag, 1), & size (ghost_flag, 2))) prc_const%ghost_flag = ghost_flag end subroutine process_constants_set_ghost_flag @ %def process_constants_set_ghost_flag @ <>= procedure :: get_pdg_in => process_constants_get_pdg_in <>= module function process_constants_get_pdg_in (prc_const) result (pdg_in) type(pdg_array_t), dimension(:), allocatable :: pdg_in class(process_constants_t), intent(in) :: prc_const end function process_constants_get_pdg_in <>= module function process_constants_get_pdg_in (prc_const) result (pdg_in) type(pdg_array_t), dimension(:), allocatable :: pdg_in class(process_constants_t), intent(in) :: prc_const type(pdg_array_t) :: pdg_tmp integer :: i allocate (pdg_in (prc_const%n_in)) do i = 1, prc_const%n_in pdg_tmp = prc_const%flv_state(i,:) pdg_in(i) = sort_abs (pdg_tmp, unique = .true.) end do end function process_constants_get_pdg_in @ %def process_constants_get_pdg_in @ <>= procedure :: compute_md5sum => process_constants_compute_md5sum <>= module subroutine process_constants_compute_md5sum (prc_const, include_id) class(process_constants_t), intent(inout) :: prc_const logical, intent(in) :: include_id end subroutine process_constants_compute_md5sum <>= module subroutine process_constants_compute_md5sum (prc_const, include_id) class(process_constants_t), intent(inout) :: prc_const logical, intent(in) :: include_id integer :: unit unit = prc_const%fill_unit_for_md5sum (include_id) rewind (unit) prc_const%md5sum = md5sum (unit) close (unit) end subroutine process_constants_compute_md5sum @ %process_constants_compute_md5sum @ <>= procedure :: fill_unit_for_md5sum => process_constants_fill_unit_for_md5sum <>= module function process_constants_fill_unit_for_md5sum & (prc_const, include_id) result (unit) integer :: unit class(process_constants_t), intent(in) :: prc_const logical, intent(in) :: include_id end function process_constants_fill_unit_for_md5sum <>= module function process_constants_fill_unit_for_md5sum & (prc_const, include_id) result (unit) integer :: unit class(process_constants_t), intent(in) :: prc_const logical, intent(in) :: include_id integer :: i, j, k unit = free_unit () open (unit, status="scratch", action="readwrite") if (include_id) write (unit, '(A)') char (prc_const%id) write (unit, '(A)') char (prc_const%model_name) write (unit, '(L1)') prc_const%openmp_supported write (unit, '(I0)') prc_const%n_in write (unit, '(I0)') prc_const%n_out write (unit, '(I0)') prc_const%n_flv write (unit, '(I0)') prc_const%n_hel write (unit, '(I0)') prc_const%n_col write (unit, '(I0)') prc_const%n_cin write (unit, '(I0)') prc_const%n_cf do i = 1, size (prc_const%flv_state, dim=1) do j = 1, size (prc_const%flv_state, dim=2) write (unit, '(I0)') prc_const%flv_state (i, j) end do end do do i = 1, size (prc_const%hel_state, dim=1) do j = 1, size (prc_const%hel_state, dim=2) write (unit, '(I0)') prc_const%hel_state (i, j) end do end do do i = 1, size (prc_const%col_state, dim=1) do j = 1, size (prc_const%col_state, dim=2) do k = 1, size (prc_const%col_state, dim=3) write (unit, '(I0)') prc_const%col_state (i, j, k) end do end do end do do i = 1, size (prc_const%ghost_flag, dim=1) do j = 1, size (prc_const%ghost_flag, dim=2) write (unit, '(L1)') prc_const%ghost_flag (i, j) end do end do do i = 1, size (prc_const%color_factors) write (unit, '(F0.0,F0.0)') real (prc_const%color_factors(i)), & aimag (prc_const%color_factors(i)) end do do i = 1, size (prc_const%cf_index, dim=1) do j = 1, size (prc_const%cf_index, dim=2) write (unit, '(I0)') prc_const%cf_index(i, j) end do end do end function process_constants_fill_unit_for_md5sum @ %def process_constants_fill_unit_for_md5sum @ <>= procedure :: write => process_constants_write <>= module subroutine process_constants_write (prc_const, unit) class(process_constants_t), intent(in) :: prc_const integer, intent(in), optional :: unit end subroutine process_constants_write <>= module subroutine process_constants_write (prc_const, unit) class(process_constants_t), intent(in) :: prc_const integer, intent(in), optional :: unit integer :: u, i u = given_output_unit (unit) write (u, "(1x,A,A)") "Process data of id: ", char (prc_const%id) write (u, "(1x,A,A)") "Associated model: ", char (prc_const%model_name) write (u, "(1x,A,I0)") "n_in: ", prc_const%n_in write (u, "(1x,A,I0)") "n_out: ", prc_const%n_out write (u, "(1x,A,I0)") "n_flv: ", prc_const%n_flv write (u, "(1x,A,I0)") "n_hel: ", prc_const%n_hel write (u, "(1x,A,I0)") "n_col: ", prc_const%n_col write (u, "(1x,A,I0)") "n_cin: ", prc_const%n_cin write (u, "(1x,A,I0)") "n_cf: ", prc_const%n_cf write (u, "(1x,A)") "Flavors: " do i = 1, prc_const%n_flv write (u, "(1x,A,I0)") "i_flv: ", i call write_integer_array (prc_const%flv_state (:,i)) end do end subroutine process_constants_write @ %def process_constants_write @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process library interface} The module [[prclib_interfaces]] handles external matrix-element code. \subsection{Overview} The top-level data structure is the [[prclib_driver_t]] data type. The associated type-bound procedures deal with the generation of external code, compilation and linking, and accessing the active external library. An object of type [[prclib_driver_t]] consists of the following parts: \begin{enumerate} \item\ Metadata that identify name and status of the library driver, etc. \item\ An array of process records ([[prclib_driver_record_t]]), one for each external matrix element. \item\ A record of type [[dlaccess_t]] which handles the operating-system part of linking a dynamically loadable library. \item\ A collection of procedure pointers which have a counterpart in the external library interface. Given the unique identifier of a matrix element, the procedures retrieve generic matrix-element information such as the particle content and helicity combination tables. There is also a procedure which returns pointers to the more specific procedures that a matrix element provides, called \emph{features}. \end{enumerate} The process records of type [[prclib_driver_record_t]] handle the individual matrix elements. Each record identifies a process by name ([[id]]), names the physics model to be loaded for this process, lists the features that the associated matrix-element code provides, and holds a [[writer]] object which handles all operations that depend on the process type. The numbering of process records is identical to the numbering of matrix-element codes in the external library. The writer object is of abstract type [[prc_writer_t]]. The module defines two basic, also abstract, extensions: [[prc_writer_f_module_t]] and [[prc_writer_c_lib_t]]. The first version is for matrix-element code that is available in form of Fortran modules. The writer contains type-bound procedures which create appropriate [[use]] directives and [[C]]-compatible wrapper functions for the given set of Fortran modules and their features. The second version is for matrix-element code that is available in form of a C-compatible library (this includes Fortran libraries with proper C bindings). The writer needs not write wrapper function, but explicit interface blocks for the matrix-element features. Each matrix-element variant is encoded in an appropriate extension of [[prc_writer_t]]. For instance, \oMega\ matrix elements provide an implementation [[omega_writer_t]] which extends [[prc_writer_f_module_t]]. \subsection{Workflow} We expect that the functionality provided by this module is called in the following order: \begin{enumerate} \item The caller initializes the [[prclib_driver_t]] object and fills the array of [[prclib_record_t]] entries with the appropriate process data and process-specific writer objects. \item It calls the [[generate_makefile]] method to set up an appropriate makefile in the current directory. The makefile will handle source generation, compilation and linking both for the individual matrix elements (unless this has to be done manually) and for the common external driver code which interfaces those matrix element. \item The [[generate_driver_code]] writes the common driver as source code to file. \item The methods [[make_source]], [[make_compile]], and [[make_link]] individually perform the corresponding steps in building the library. Wherever possible, they simply use the generated makefile. By calling [[make]], we make sure that we can avoid unnecessary recompilation. For the compilation and linking steps, the makefile will employ [[libtool]]. \item The [[load]] method loads the library procedures into the corresponding procedure pointers, using the [[dlopen]] mechanism via the [[dlaccess]] subobject. \end{enumerate} \subsection{The module} <<[[prclib_interfaces.f90]]>>= <> module prclib_interfaces use, intrinsic :: iso_c_binding !NODEP! use kinds <> use os_interface <> <> <> <> interface <> end interface contains <> end module prclib_interfaces @ %def prclib_interfaces @ <<[[prclib_interfaces_sub.f90]]>>= <> submodule (prclib_interfaces) prclib_interfaces_s use io_units use system_defs, only: TAB use string_utils, only: lower_case use diagnostics implicit none contains <> end submodule prclib_interfaces_s @ %def prclib_interfaces_s @ \subsection{Writers} External matrix element code provides externally visible procedures, which we denote as \emph{features}. The features consist of informational subroutines and functions which are mandatory (universal features) and matrix-element specific subroutines and functions (specific features). The driver interfaces the generic features directly, while it returns the specific features in form of bind(C) procedure pointers to the caller. For instance, function [[n_in]] is generic, while the matrix matrix-element value itself is specific. To implement these tasks, the driver needs [[use]] directives for Fortran module procedures, interface blocks for other external stuff, wrapper code, and Makefile snippets. \subsubsection{Generic writer} In the [[prc_writer_t]] data type, we collect the procedures which implement the writing tasks. The type is abstract. The concrete implementations are defined by an extension which is specific for the process type. The MD5 sum stored here should be the MD5 checksum of the current process component, which can be calculated once the process is configured completely. It can be used by implementations which work with external files, such as \oMega. <>= public :: prc_writer_t <>= type, abstract :: prc_writer_t character(32) :: md5sum = "" contains <> end type prc_writer_t @ %def prc_writer_t @ In any case, it is useful to have a string representation of the writer type. This must be implemented by all extensions. <>= procedure(get_const_string), nopass, deferred :: type_name <>= abstract interface function get_const_string () result (string) import type(string_t) :: string end function get_const_string end interface @ %def get_const_string @ Return the name of a procedure that implements a given feature, as it is provided by the external matrix-element code. For a reasonable default, we take the feature name unchanged. Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= procedure, nopass :: get_procname => prc_writer_get_procname <>= function prc_writer_get_procname (feature) result (name) type(string_t) :: name type(string_t), intent(in) :: feature name = feature end function prc_writer_get_procname @ %def prc_writer_get_procname @ Return the name of a procedure that implements a given feature with the bind(C) property, so it can be accessed via a C procedure pointer and handled by dlopen. We need this for all special features of a matrix element, since the interface has to return a C function pointer for it. For a default implementation, we prefix the external procedure name by the process ID. Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= procedure :: get_c_procname => prc_writer_get_c_procname <>= function prc_writer_get_c_procname (writer, id, feature) result (name) class(prc_writer_t), intent(in) :: writer type(string_t), intent(in) :: id, feature type(string_t) :: name name = id // "_" // feature end function prc_writer_get_c_procname @ %def get_c_procname @ Common signature of code-writing procedures. The procedure may use the process ID, and the feature name. (Not necessarily all of them.) <>= abstract interface subroutine write_code_file (writer, id) import class(prc_writer_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine write_code_file end interface abstract interface subroutine write_code (writer, unit, id) import class(prc_writer_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine write_code end interface abstract interface subroutine write_code_os & (writer, unit, id, os_data, verbose, testflag) import class(prc_writer_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag end subroutine write_code_os end interface abstract interface subroutine write_feature_code (writer, unit, id, feature) import class(prc_writer_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature end subroutine write_feature_code end interface @ %def write_code write_feature_code @ There must be a procedure which writes an interface block for a given feature. If the external matrix element is implemented as a Fortran module, this is required only for the specific features which are returned as procedure pointers. <>= procedure(write_feature_code), deferred :: write_interface @ %def write_interface @ There must also be a procedure which writes Makefile code which is specific for the current process, but not the feature. <>= procedure(write_code_os), deferred :: write_makefile_code @ %def write_makefile_code @ This procedure writes code process-specific source-code file (which need not be Fortran). It is called before [[make]] [[source]] is called. It may be a no-op, if the source code is generated by Make instead. <>= procedure(write_code_file), deferred :: write_source_code @ %def write_source_code @ This procedure is executed, once for each process, before (after) [[make]] [[compile]] is called, respectively. <>= procedure(write_code_file), deferred :: before_compile procedure(write_code_file), deferred :: after_compile @ %def before_compile @ %def after_compile @ \subsubsection{Writer for Fortran-module matrix elements} If the matrix element is available as a Fortran module, we have specific requirements: (i) the features are imported via [[use]] directives, (ii) the specific features require bind(C) wrappers. The type is still abstract, all methods must be implemented explicitly for a specific matrix-element variant. <>= public :: prc_writer_f_module_t <>= type, extends (prc_writer_t), abstract :: prc_writer_f_module_t contains <> end type prc_writer_f_module_t @ %def prc_writer_f_module_t @ Return the name of the Fortran module. As a default implementation, we take the process ID unchanged. Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= procedure, nopass :: get_module_name => prc_writer_get_module_name <>= function prc_writer_get_module_name (id) result (name) type(string_t) :: name type(string_t), intent(in) :: id name = id end function prc_writer_get_module_name @ %def prc_writer_get_module_name @ Write a [[use]] directive that associates the driver reference with the procedure in the matrix element code. By default, we use the C name for this. <>= procedure :: write_use_line => prc_writer_write_use_line <>= module subroutine prc_writer_write_use_line (writer, unit, id, feature) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t) :: id, feature end subroutine prc_writer_write_use_line <>= module subroutine prc_writer_write_use_line (writer, unit, id, feature) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t) :: id, feature write (unit, "(2x,9A)") "use ", char (writer%get_module_name (id)), & ", only: ", char (writer%get_c_procname (id, feature)), & " => ", char (writer%get_procname (feature)) end subroutine prc_writer_write_use_line @ %def prc_writer_write_use_line @ Write a wrapper routine for a feature. This also associates a C name the module procedure. The details depend on the writer variant. <>= procedure(prc_write_wrapper), deferred :: write_wrapper <>= abstract interface subroutine prc_write_wrapper (writer, unit, id, feature) import class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature end subroutine prc_write_wrapper end interface @ %def prc_write_wrapper @ This is used for testing only: initialize the writer with a specific MD5 sum string. <>= procedure :: init_test => prc_writer_init_test <>= module subroutine prc_writer_init_test (writer) class(prc_writer_t), intent(out) :: writer end subroutine prc_writer_init_test <>= module subroutine prc_writer_init_test (writer) class(prc_writer_t), intent(out) :: writer writer%md5sum = "1234567890abcdef1234567890abcdef" end subroutine prc_writer_init_test @ %def prc_writer_init_test @ \subsubsection{Writer for C-library matrix elements} This applies if the matrix element is available as a C library or a Fortran library with bind(C) compatible interface. We can use the basic version. The type is still abstract, all methods must be implemented explicitly for a specific matrix-element variant. <>= public :: prc_writer_c_lib_t <>= type, extends (prc_writer_t), abstract :: prc_writer_c_lib_t contains <> end type prc_writer_c_lib_t @ %def prc_writer_c_lib_t @ \subsection{Process records in the library driver} A process record holds the process (component) [[ID]], the physics [[model_name]], and the array of [[feature]]s that are implemented by the corresponding matrix element code. The [[writer]] component holds procedures. The procedures write source code for the current record, either for the driver or for the Makefile. <>= type :: prclib_driver_record_t type(string_t) :: id type(string_t) :: model_name type(string_t), dimension(:), allocatable :: feature class(prc_writer_t), pointer :: writer => null () contains <> end type prclib_driver_record_t @ %def prclib_driver_record @ Output routine. We indent the output, so it smoothly integrates into the output routine for the whole driver. Note: the pointer [[writer]] is introduced as a workaround for a NAG compiler bug. <>= procedure :: write => prclib_driver_record_write <>= module subroutine prclib_driver_record_write (object, unit) class(prclib_driver_record_t), intent(in) :: object integer, intent(in) :: unit end subroutine prclib_driver_record_write <>= module subroutine prclib_driver_record_write (object, unit) class(prclib_driver_record_t), intent(in) :: object integer, intent(in) :: unit integer :: j class(prc_writer_t), pointer :: writer write (unit, "(3x,A,2x,'[',A,']')") & char (object%id), char (object%model_name) if (allocated (object%feature)) then writer => object%writer write (unit, "(5x,A,A)", advance="no") & char (writer%type_name ()), ":" do j = 1, size (object%feature) write (unit, "(1x,A)", advance="no") & char (object%feature(j)) end do write (unit, *) end if end subroutine prclib_driver_record_write @ %def prclib_driver_record_write @ Get the C procedure name for a feature. Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= procedure :: get_c_procname => prclib_driver_record_get_c_procname <>= function prclib_driver_record_get_c_procname (record, feature) result (name) type(string_t) :: name class(prclib_driver_record_t), intent(in) :: record type(string_t), intent(in) :: feature name = record%writer%get_c_procname (record%id, feature) end function prclib_driver_record_get_c_procname @ %def prclib_driver_record_get_c_procname @ Write a USE directive for a given feature. Applies only if the record corresponds to a Fortran module. <>= procedure :: write_use_line => prclib_driver_record_write_use_line <>= module subroutine prclib_driver_record_write_use_line (record, unit, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(string_t), intent(in) :: feature end subroutine prclib_driver_record_write_use_line <>= module subroutine prclib_driver_record_write_use_line (record, unit, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(string_t), intent(in) :: feature select type (writer => record%writer) class is (prc_writer_f_module_t) call writer%write_use_line (unit, record%id, feature) end select end subroutine prclib_driver_record_write_use_line @ %def prclib_driver_record_write_use_line @ The alternative: write an interface block for a given feature, unless the record corresponds to a Fortran module. <>= procedure :: write_interface => prclib_driver_record_write_interface <>= module subroutine prclib_driver_record_write_interface (record, unit, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(string_t), intent(in) :: feature end subroutine prclib_driver_record_write_interface <>= module subroutine prclib_driver_record_write_interface (record, unit, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(string_t), intent(in) :: feature select type (writer => record%writer) class is (prc_writer_f_module_t) class default call writer%write_interface (unit, record%id, feature) end select end subroutine prclib_driver_record_write_interface @ %def prclib_driver_record_write_use_line @ Write all special feature interfaces for the current record. Do this for all process variants. <>= procedure :: write_interfaces => prclib_driver_record_write_interfaces <>= module subroutine prclib_driver_record_write_interfaces (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit end subroutine prclib_driver_record_write_interfaces <>= module subroutine prclib_driver_record_write_interfaces (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit integer :: i do i = 1, size (record%feature) call record%writer%write_interface (unit, record%id, record%feature(i)) end do end subroutine prclib_driver_record_write_interfaces @ %def prclib_driver_record_write_interfaces @ Write the wrapper routines for this record, if it corresponds to a Fortran module. <>= procedure :: write_wrappers => prclib_driver_record_write_wrappers <>= module subroutine prclib_driver_record_write_wrappers (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit end subroutine prclib_driver_record_write_wrappers <>= module subroutine prclib_driver_record_write_wrappers (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit integer :: i select type (writer => record%writer) class is (prc_writer_f_module_t) do i = 1, size (record%feature) call writer%write_wrapper (unit, record%id, record%feature(i)) end do end select end subroutine prclib_driver_record_write_wrappers @ %def prclib_driver_record_write_wrappers @ Write the Makefile code for this record. <>= procedure :: write_makefile_code => prclib_driver_record_write_makefile_code <>= module subroutine prclib_driver_record_write_makefile_code & (record, unit, os_data, verbose, testflag) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag end subroutine prclib_driver_record_write_makefile_code <>= module subroutine prclib_driver_record_write_makefile_code & (record, unit, os_data, verbose, testflag) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag call record%writer%write_makefile_code & (unit, record%id, os_data, verbose, testflag) end subroutine prclib_driver_record_write_makefile_code @ %def prclib_driver_record_write_makefile_code @ Write source-code files for this record. This can be used as an alternative to handling source code via Makefile. In fact, this procedure is executed before [[make]] [[source]] is called. Usually, does nothing. <>= procedure :: write_source_code => prclib_driver_record_write_source_code <>= module subroutine prclib_driver_record_write_source_code (record) class(prclib_driver_record_t), intent(in) :: record end subroutine prclib_driver_record_write_source_code <>= module subroutine prclib_driver_record_write_source_code (record) class(prclib_driver_record_t), intent(in) :: record call record%writer%write_source_code (record%id) end subroutine prclib_driver_record_write_source_code @ %def prclib_driver_record_write_source_code @ Execute commands for this record that depend on the sources, so they cannot be included in the previous procedure. This procedure is executed before (after) [[make]] [[compile]] is called, respectively. Usually, does nothing. <>= procedure :: before_compile => prclib_driver_record_before_compile procedure :: after_compile => prclib_driver_record_after_compile <>= module subroutine prclib_driver_record_before_compile (record) class(prclib_driver_record_t), intent(in) :: record end subroutine prclib_driver_record_before_compile module subroutine prclib_driver_record_after_compile (record) class(prclib_driver_record_t), intent(in) :: record end subroutine prclib_driver_record_after_compile <>= module subroutine prclib_driver_record_before_compile (record) class(prclib_driver_record_t), intent(in) :: record call record%writer%before_compile (record%id) end subroutine prclib_driver_record_before_compile module subroutine prclib_driver_record_after_compile (record) class(prclib_driver_record_t), intent(in) :: record call record%writer%after_compile (record%id) end subroutine prclib_driver_record_after_compile @ %def prclib_driver_record_before_compile @ %def prclib_driver_record_after_compile @ \subsection{The process library driver object} A [[prclib_driver_t]] object provides the interface to external matrix element code. The code is provided by an external library which is either statically or dynamically linked. The dynamic and static versions of the library are two different implementations of the abstract base type. The [[basename]] identifies the library, both by file names and by Fortran variable names. The [[loaded]] flag becomes true once all procedure pointers to the matrix element have been assigned. For a dynamical external library, the communication proceeds via a [[dlaccess]] object. [[n_processes]] is the number of external process code components that are referenced by this library. The code is addressed by index ([[i_lib]] in the process library entry above). This number should be equal to the number returned by [[get_n_prc]]. For each external process, there is a separate [[record]] which holds the data that are needed for the driver parts which are specific for a given process component. The actual pointers for the loaded library will be assigned elsewhere. The remainder is a collection of procedure pointers, which can be assigned once all external code has been compiled and linked. The procedure pointers all take a process component code index as an argument. Most return information about the process component that should match the process definition. The [[get_fptr]] procedures return a function pointer, which is the actual means to compute matrix elements or retrieve associated data. Finally, the [[unload_hook]] and [[reload_hook]] pointers allow for the insertion of additional code when a library is loaded. <>= public :: prclib_driver_t <>= type, abstract :: prclib_driver_t type(string_t) :: basename character(32) :: md5sum = "" logical :: loaded = .false. type(string_t) :: libname type(string_t) :: modellibs_ldflags integer :: n_processes = 0 type(prclib_driver_record_t), dimension(:), allocatable :: record procedure(prc_get_n_processes), nopass, pointer :: & get_n_processes => null () procedure(prc_get_stringptr), nopass, pointer :: & get_process_id_ptr => null () procedure(prc_get_stringptr), nopass, pointer :: & get_model_name_ptr => null () procedure(prc_get_stringptr), nopass, pointer :: & get_md5sum_ptr => null () procedure(prc_get_log), nopass, pointer :: & get_openmp_status => null () procedure(prc_get_int), nopass, pointer :: get_n_in => null () procedure(prc_get_int), nopass, pointer :: get_n_out => null () procedure(prc_get_int), nopass, pointer :: get_n_flv => null () procedure(prc_get_int), nopass, pointer :: get_n_hel => null () procedure(prc_get_int), nopass, pointer :: get_n_col => null () procedure(prc_get_int), nopass, pointer :: get_n_cin => null () procedure(prc_get_int), nopass, pointer :: get_n_cf => null () procedure(prc_set_int_tab1), nopass, pointer :: & set_flv_state_ptr => null () procedure(prc_set_int_tab1), nopass, pointer :: & set_hel_state_ptr => null () procedure(prc_set_col_state), nopass, pointer :: & set_col_state_ptr => null () procedure(prc_set_color_factors), nopass, pointer :: & set_color_factors_ptr => null () procedure(prc_get_fptr), nopass, pointer :: get_fptr => null () contains <> end type prclib_driver_t @ %def prclib_driver_t @ This is the dynamic version. It contains a [[dlaccess]] object for communicating with the OS. <>= public :: prclib_driver_dynamic_t <>= type, extends (prclib_driver_t) :: prclib_driver_dynamic_t type(dlaccess_t) :: dlaccess contains <> end type prclib_driver_dynamic_t @ %def prclib_driver_dynamic_t @ Print just the metadata. Procedure pointers cannot be printed. <>= procedure :: write => prclib_driver_write <>= module subroutine prclib_driver_write (object, unit, libpath) class(prclib_driver_t), intent(in) :: object integer, intent(in) :: unit logical, intent(in), optional :: libpath end subroutine prclib_driver_write <>= module subroutine prclib_driver_write (object, unit, libpath) class(prclib_driver_t), intent(in) :: object integer, intent(in) :: unit logical, intent(in), optional :: libpath logical :: write_lib integer :: i write_lib = .true. if (present (libpath)) write_lib = libpath write (unit, "(1x,A,A)") & "External matrix-element code library: ", char (object%basename) select type (object) type is (prclib_driver_dynamic_t) write (unit, "(3x,A,L1)") "static = F" class default write (unit, "(3x,A,L1)") "static = T" end select write (unit, "(3x,A,L1)") "loaded = ", object%loaded write (unit, "(3x,A,A,A)") "MD5 sum = '", object%md5sum, "'" if (write_lib) then write (unit, "(3x,A,A,A)") "Mdl flags = '", & char (object%modellibs_ldflags), "'" end if select type (object) type is (prclib_driver_dynamic_t) write (unit, *) call object%dlaccess%write (unit) end select write (unit, *) if (allocated (object%record)) then write (unit, "(1x,A)") "Matrix-element code entries:" do i = 1, object%n_processes call object%record(i)%write (unit) end do else write (unit, "(1x,A)") "Matrix-element code entries: [undefined]" end if end subroutine prclib_driver_write @ %def prclib_driver_write @ Allocate a library as either static or dynamic. For static libraries, the procedure defers control to an external procedure which knows about the available static libraries. By default, this procedure is empty, but when we build a stand-alone executable, we replace the dummy by an actual dispatcher for the available static libraries. If the static dispatcher was not successful, we allocate a dynamic library. The default version of [[dispatch_prclib_static]] resides in the [[prebuilt]] section of the \whizard\ tree, in a separate library. It does nothing, but can be replaced by a different procedure that allocates a static library driver if requested by name. Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= public :: dispatch_prclib_driver <>= subroutine dispatch_prclib_driver & (driver, basename, modellibs_ldflags) class(prclib_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename type(string_t), intent(in), optional :: modellibs_ldflags procedure(dispatch_prclib_driver) :: dispatch_prclib_static if (allocated (driver)) deallocate (driver) call dispatch_prclib_static (driver, basename) if (.not. allocated (driver)) then allocate (prclib_driver_dynamic_t :: driver) end if driver%basename = basename driver%modellibs_ldflags = modellibs_ldflags end subroutine dispatch_prclib_driver @ %def dispatch_prclib_driver @ Initialize the ID array and set [[n_processes]] accordingly. <>= procedure :: init => prclib_driver_init <>= module subroutine prclib_driver_init (driver, n_processes) class(prclib_driver_t), intent(inout) :: driver integer, intent(in) :: n_processes end subroutine prclib_driver_init <>= module subroutine prclib_driver_init (driver, n_processes) class(prclib_driver_t), intent(inout) :: driver integer, intent(in) :: n_processes driver%n_processes = n_processes allocate (driver%record (n_processes)) end subroutine prclib_driver_init @ %def prclib_driver_init @ Set the MD5 sum. This is separate because the MD5 sum may be known only after initialization. <>= procedure :: set_md5sum => prclib_driver_set_md5sum <>= module subroutine prclib_driver_set_md5sum (driver, md5sum) class(prclib_driver_t), intent(inout) :: driver character(32), intent(in) :: md5sum end subroutine prclib_driver_set_md5sum <>= module subroutine prclib_driver_set_md5sum (driver, md5sum) class(prclib_driver_t), intent(inout) :: driver character(32), intent(in) :: md5sum driver%md5sum = md5sum end subroutine prclib_driver_set_md5sum @ %def prclib_driver_set_md5sum @ Set the process record for a specific library entry. If the index is zero, we do nothing. <>= procedure :: set_record => prclib_driver_set_record <>= module subroutine prclib_driver_set_record (driver, i, & id, model_name, features, writer) class(prclib_driver_t), intent(inout) :: driver integer, intent(in) :: i type(string_t), intent(in) :: id type(string_t), intent(in) :: model_name type(string_t), dimension(:), intent(in) :: features class(prc_writer_t), intent(in), pointer :: writer end subroutine prclib_driver_set_record <>= module subroutine prclib_driver_set_record (driver, i, & id, model_name, features, writer) class(prclib_driver_t), intent(inout) :: driver integer, intent(in) :: i type(string_t), intent(in) :: id type(string_t), intent(in) :: model_name type(string_t), dimension(:), intent(in) :: features class(prc_writer_t), intent(in), pointer :: writer if (i > 0) then associate (record => driver%record(i)) record%id = id record%model_name = model_name allocate (record%feature (size (features))) record%feature = features record%writer => writer end associate end if end subroutine prclib_driver_set_record @ %def prclib_driver_set_record @ Write all USE directives for a given feature, scanning the array of processes. Only Fortran-module processes count. Then, write interface blocks for the remaining processes. The [[implicit none]] statement must go in-between. <>= procedure :: write_interfaces => prclib_driver_write_interfaces <>= module subroutine prclib_driver_write_interfaces (driver, unit, feature) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: feature end subroutine prclib_driver_write_interfaces <>= module subroutine prclib_driver_write_interfaces (driver, unit, feature) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: feature integer :: i do i = 1, driver%n_processes call driver%record(i)%write_use_line (unit, feature) end do write (unit, "(2x,9A)") "implicit none" do i = 1, driver%n_processes call driver%record(i)%write_interface (unit, feature) end do end subroutine prclib_driver_write_interfaces @ %def prclib_driver_write_interfaces @ \subsection{Write makefile} The makefile contains constant parts, parts that depend on the library name, and parts that depend on the specific processes and their types. <>= procedure :: generate_makefile => prclib_driver_generate_makefile <>= module subroutine prclib_driver_generate_makefile (driver, unit, os_data, verbose, testflag) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag end subroutine prclib_driver_generate_makefile <>= module subroutine prclib_driver_generate_makefile (driver, unit, os_data, verbose, testflag) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag integer :: i write (unit, "(A)") "# WHIZARD: Makefile for process library '" & // char (driver%basename) // "'" write (unit, "(A)") "# Automatically generated file, do not edit" write (unit, "(A)") "" write (unit, "(A)") "# Integrity check (don't modify the following line!)" write (unit, "(A)") "MD5SUM = '" // driver%md5sum // "'" write (unit, "(A)") "" write (unit, "(A)") "# Library name" write (unit, "(A)") "BASE = " // char (driver%basename) write (unit, "(A)") "" write (unit, "(A)") "# Compiler" write (unit, "(A)") "FC = " // char (os_data%fc) write (unit, "(A)") "CC = " // char (os_data%cc) write (unit, "(A)") "" write (unit, "(A)") "# Included libraries" write (unit, "(A)") "FCINCL = " // char (os_data%whizard_includes) write (unit, "(A)") "" write (unit, "(A)") "# Compiler flags" write (unit, "(A)") "FCFLAGS = " // char (os_data%fcflags) write (unit, "(A)") "FCFLAGS_PIC = " // char (os_data%fcflags_pic) write (unit, "(A)") "CFLAGS = " // char (os_data%cflags) write (unit, "(A)") "CFLAGS_PIC = " // char (os_data%cflags_pic) write (unit, "(A)") "LDFLAGS = " // char (os_data%whizard_ldflags) & // " " // char (os_data%ldflags) // " " // & char (driver%modellibs_ldflags) write (unit, "(A)") "" write (unit, "(A)") "# LaTeX setup" write (unit, "(A)") "LATEX = " // char (os_data%latex) write (unit, "(A)") "MPOST = " // char (os_data%mpost) write (unit, "(A)") "DVIPS = " // char (os_data%dvips) write (unit, "(A)") "PS2PDF = " // char (os_data%ps2pdf) - write (unit, "(A)") 'TEX_FLAGS = "$$TEXINPUTS:' // & - char(os_data%whizard_texpath) // '"' - write (unit, "(A)") 'MP_FLAGS = "$$MPINPUTS:' // & - char(os_data%whizard_texpath) // '"' + write (unit, "(A)") 'TEX_FLAGS = "' // char(os_data%whizard_texpath) & + // ':$$TEXINPUTS"' + write (unit, "(A)") 'MP_FLAGS = "' // char(os_data%whizard_texpath) & + // ':$$MPINPUTS"' write (unit, "(A)") "" write (unit, "(A)") "# Libtool" write (unit, "(A)") "LIBTOOL = " // char (os_data%whizard_libtool) if (verbose) then write (unit, "(A)") "FCOMPILE = $(LIBTOOL) --tag=FC --mode=compile" write (unit, "(A)") "CCOMPILE = $(LIBTOOL) --tag=CC --mode=compile" write (unit, "(A)") "LINK = $(LIBTOOL) --tag=FC --mode=link" else write (unit, "(A)") "FCOMPILE = @$(LIBTOOL) --silent --tag=FC --mode=compile" write (unit, "(A)") "CCOMPILE = @$(LIBTOOL) --silent --tag=CC --mode=compile" write (unit, "(A)") "LINK = @$(LIBTOOL) --silent --tag=FC --mode=link" end if write (unit, "(A)") "" write (unit, "(A)") "# Compile commands (default)" write (unit, "(A)") "LTFCOMPILE = $(FCOMPILE) $(FC) -c & &$(FCINCL) $(FCFLAGS) $(FCFLAGS_PIC)" write (unit, "(A)") "LTCCOMPILE = $(CCOMPILE) $(CC) -c & &$(CFLAGS) $(CFLAGS_PIC)" write (unit, "(A)") "" write (unit, "(A)") "# Default target" write (unit, "(A)") "all: link diags" write (unit, "(A)") "" write (unit, "(A)") "# Matrix-element code files" do i = 1, size (driver%record) call driver%record(i)%write_makefile_code (unit, os_data, verbose, testflag) end do write (unit, "(A)") "" write (unit, "(A)") "# Library driver" write (unit, "(A)") "$(BASE).lo: $(BASE).f90 $(OBJECTS)" write (unit, "(A)") TAB // "$(LTFCOMPILE) $<" if (.not. verbose) then write (unit, "(A)") TAB // '@echo " FC " $@' end if write (unit, "(A)") "" write (unit, "(A)") "# Library" write (unit, "(A)") "$(BASE).la: $(BASE).lo $(OBJECTS)" if (.not. verbose) then write (unit, "(A)") TAB // '@echo " FCLD " $@' end if write (unit, "(A)") TAB // "$(LINK) $(FC) -module -rpath /dev/null & &$(FCFLAGS) $(LDFLAGS) -o $(BASE).la $^" write (unit, "(A)") "" write (unit, "(A)") "# Main targets" write (unit, "(A)") "link: compile $(BASE).la" write (unit, "(A)") "compile: source $(OBJECTS) $(TEX_OBJECTS) $(BASE).lo" write (unit, "(A)") "compile_tex: $(TEX_OBJECTS)" write (unit, "(A)") "source: $(SOURCES) $(BASE).f90 $(TEX_SOURCES)" write (unit, "(A)") ".PHONY: link diags compile compile_tex source" write (unit, "(A)") "" write (unit, "(A)") "# Specific cleanup targets" do i = 1, size (driver%record) write (unit, "(A)") "clean-" // char (driver%record(i)%id) // ":" write (unit, "(A)") ".PHONY: clean-" // char (driver%record(i)%id) end do write (unit, "(A)") "" write (unit, "(A)") "# Generic cleanup targets" write (unit, "(A)") "clean-library:" if (verbose) then write (unit, "(A)") TAB // "rm -f $(BASE).la" else write (unit, "(A)") TAB // '@echo " RM $(BASE).la"' write (unit, "(A)") TAB // "@rm -f $(BASE).la" end if write (unit, "(A)") "clean-objects:" if (verbose) then write (unit, "(A)") TAB // "rm -f $(BASE).lo $(BASE)_driver.mod & &$(CLEAN_OBJECTS)" else write (unit, "(A)") TAB // '@echo " RM $(BASE).lo & &$(BASE)_driver.mod $(CLEAN_OBJECTS)"' write (unit, "(A)") TAB // "@rm -f $(BASE).lo $(BASE)_driver.mod & &$(CLEAN_OBJECTS)" end if write (unit, "(A)") "clean-source:" if (verbose) then write (unit, "(A)") TAB // "rm -f $(CLEAN_SOURCES)" else write (unit, "(A)") TAB // '@echo " RM $(CLEAN_SOURCES)"' write (unit, "(A)") TAB // "@rm -f $(CLEAN_SOURCES)" end if write (unit, "(A)") "clean-driver:" if (verbose) then write (unit, "(A)") TAB // "rm -f $(BASE).f90" else write (unit, "(A)") TAB // '@echo " RM $(BASE).f90"' write (unit, "(A)") TAB // "@rm -f $(BASE).f90" end if write (unit, "(A)") "clean-makefile:" if (verbose) then write (unit, "(A)") TAB // "rm -f $(BASE).makefile" else write (unit, "(A)") TAB // '@echo " RM $(BASE).makefile"' write (unit, "(A)") TAB // "@rm -f $(BASE).makefile" end if write (unit, "(A)") ".PHONY: clean-library clean-objects & &clean-source clean-driver clean-makefile" write (unit, "(A)") "" write (unit, "(A)") "clean: clean-library clean-objects clean-source" write (unit, "(A)") "distclean: clean clean-driver clean-makefile" write (unit, "(A)") ".PHONY: clean distclean" end subroutine prclib_driver_generate_makefile @ %def prclib_driver_generate_makefile @ \subsection{Write driver file} This procedure writes the process library driver source code to the specified output unit. The individual routines for writing source-code procedures are given below. <>= procedure :: generate_driver_code => prclib_driver_generate_code <>= module subroutine prclib_driver_generate_code (driver, unit) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit end subroutine prclib_driver_generate_code <>= module subroutine prclib_driver_generate_code (driver, unit) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t) :: prefix integer :: i prefix = driver%basename // "_" write (unit, "(A)") "! WHIZARD matrix-element code interface" write (unit, "(A)") "!" write (unit, "(A)") "! Automatically generated file, do not edit" call driver%write_module (unit, prefix) call driver%write_lib_md5sum_fun (unit, prefix) call driver%write_get_n_processes_fun (unit, prefix) call driver%write_get_process_id_fun (unit, prefix) call driver%write_get_model_name_fun (unit, prefix) call driver%write_get_md5sum_fun (unit, prefix) call driver%write_string_to_array_fun (unit, prefix) call driver%write_get_openmp_status_fun (unit, prefix) call driver%write_get_int_fun (unit, prefix, var_str ("n_in")) call driver%write_get_int_fun (unit, prefix, var_str ("n_out")) call driver%write_get_int_fun (unit, prefix, var_str ("n_flv")) call driver%write_get_int_fun (unit, prefix, var_str ("n_hel")) call driver%write_get_int_fun (unit, prefix, var_str ("n_col")) call driver%write_get_int_fun (unit, prefix, var_str ("n_cin")) call driver%write_get_int_fun (unit, prefix, var_str ("n_cf")) call driver%write_set_int_sub (unit, prefix, var_str ("flv_state")) call driver%write_set_int_sub (unit, prefix, var_str ("hel_state")) call driver%write_set_col_state_sub (unit, prefix) call driver%write_set_color_factors_sub (unit, prefix) call driver%write_get_fptr_sub (unit, prefix) do i = 1, driver%n_processes call driver%record(i)%write_wrappers (unit) end do end subroutine prclib_driver_generate_code @ %def prclib_driver_generate_code @ The driver module is used and required \emph{only} if we intend to link the library statically. Then, it provides the (static) driver type as a concrete implementation of the abstract library driver. This type contains the internal dispatcher for assigning the library procedures to their appropriate procedure pointers. In the dynamical case, the assignment is done via the base-type dispatcher which invokes the DL mechanism. However, compiling this together with the rest in any case should not do any harm. <>= procedure, nopass :: write_module => prclib_driver_write_module <>= module subroutine prclib_driver_write_module (unit, prefix) integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine prclib_driver_write_module <>= module subroutine prclib_driver_write_module (unit, prefix) integer, intent(in) :: unit type(string_t), intent(in) :: prefix write (unit, "(A)") "" write (unit, "(A)") "! Module: define library driver as an extension & &of the abstract driver type." write (unit, "(A)") "! This is used _only_ by the library dispatcher & &of a static executable." write (unit, "(A)") "! For a dynamical library, the stand-alone proce& &dures are linked via libdl." write (unit, "(A)") "" write (unit, "(A)") "module " & // char (prefix) // "driver" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " use iso_varying_string, string_t => varying_string" write (unit, "(A)") " use diagnostics" write (unit, "(A)") " use prclib_interfaces" write (unit, "(A)") "" write (unit, "(A)") " implicit none" write (unit, "(A)") "" write (unit, "(A)") " type, extends (prclib_driver_t) :: " & // char (prefix) // "driver_t" write (unit, "(A)") " contains" write (unit, "(A)") " procedure :: get_c_funptr => " & // char (prefix) // "driver_get_c_funptr" write (unit, "(A)") " end type " & // char (prefix) // "driver_t" write (unit, "(A)") "" write (unit, "(A)") "contains" write (unit, "(A)") "" write (unit, "(A)") " function " & // char (prefix) // "driver_get_c_funptr (driver, feature) result & &(c_fptr)" write (unit, "(A)") " class(" & // char (prefix) // "driver_t), intent(inout) :: driver" write (unit, "(A)") " type(string_t), intent(in) :: feature" write (unit, "(A)") " type(c_funptr) :: c_fptr" call write_decl ("get_n_processes", "get_n_processes") call write_decl ("get_stringptr", "get_process_id_ptr") call write_decl ("get_stringptr", "get_model_name_ptr") call write_decl ("get_stringptr", "get_md5sum_ptr") call write_decl ("get_log", "get_openmp_status") call write_decl ("get_int", "get_n_in") call write_decl ("get_int", "get_n_out") call write_decl ("get_int", "get_n_flv") call write_decl ("get_int", "get_n_hel") call write_decl ("get_int", "get_n_col") call write_decl ("get_int", "get_n_cin") call write_decl ("get_int", "get_n_cf") call write_decl ("set_int_tab1", "set_flv_state_ptr") call write_decl ("set_int_tab1", "set_hel_state_ptr") call write_decl ("set_col_state", "set_col_state_ptr") call write_decl ("set_color_factors", "set_color_factors_ptr") call write_decl ("get_fptr", "get_fptr") write (unit, "(A)") " select case (char (feature))" call write_case ("get_n_processes") call write_case ("get_process_id_ptr") call write_case ("get_model_name_ptr") call write_case ("get_md5sum_ptr") call write_case ("get_openmp_status") call write_case ("get_n_in") call write_case ("get_n_out") call write_case ("get_n_flv") call write_case ("get_n_hel") call write_case ("get_n_col") call write_case ("get_n_cin") call write_case ("get_n_cf") call write_case ("set_flv_state_ptr") call write_case ("set_hel_state_ptr") call write_case ("set_col_state_ptr") call write_case ("set_color_factors_ptr") call write_case ("get_fptr") write (unit, "(A)") " case default" write (unit, "(A)") " call msg_bug ('prclib2 driver setup: unknown & &function name')" write (unit, "(A)") " end select" write (unit, "(A)") " end function " & // char (prefix) // "driver_get_c_funptr" write (unit, "(A)") "" write (unit, "(A)") "end module " & // char (prefix) // "driver" write (unit, "(A)") "" write (unit, "(A)") "! Stand-alone external procedures: used for both & &static and dynamic linkage" contains subroutine write_decl (template, feature) character(*), intent(in) :: template, feature write (unit, "(A)") " procedure(prc_" // template // ") &" write (unit, "(A)") " :: " & // char (prefix) // feature end subroutine write_decl subroutine write_case (feature) character(*), intent(in) :: feature write (unit, "(A)") " case ('" // feature // "')" write (unit, "(A)") " c_fptr = c_funloc (" & // char (prefix) // feature // ")" end subroutine write_case end subroutine prclib_driver_write_module @ %def prclib_driver_write_module @ This function provides the overall library MD5sum. The function is for internal use (therefore not bind(C)), the external interface is via the [[get_md5sum_ptr]] procedure with index 0. <>= procedure :: write_lib_md5sum_fun => prclib_driver_write_lib_md5sum_fun <>= module subroutine prclib_driver_write_lib_md5sum_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine prclib_driver_write_lib_md5sum_fun <>= module subroutine prclib_driver_write_lib_md5sum_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix write (unit, "(A)") "" write (unit, "(A)") "! The MD5 sum of the library" write (unit, "(A)") "function " // char (prefix) & // "md5sum () result (md5sum)" write (unit, "(A)") " implicit none" write (unit, "(A)") " character(32) :: md5sum" write (unit, "(A)") " md5sum = '" // driver%md5sum // "'" write (unit, "(A)") "end function " // char (prefix) // "md5sum" end subroutine prclib_driver_write_lib_md5sum_fun @ %def prclib_driver_write_lib_md5sum_fun @ \subsection{Interface bodies for informational functions} These interfaces implement the communication between WHIZARD (the main program) and the process-library driver. The procedures are all BIND(C), so they can safely be exposed by the library and handled by the [[dlopen]] mechanism, which apparently understands only C calling conventions. In the sections below, for each procedure, we provide both the interface itself and a procedure that writes the correponding procedure as source code to the process library driver. \subsubsection{Process count} Return the number of processes contained in the library. <>= public :: prc_get_n_processes <>= abstract interface function prc_get_n_processes () result (n) bind(C) import integer(c_int) :: n end function prc_get_n_processes end interface @ %def prc_get_n_processes @ Here is the code. <>= procedure :: write_get_n_processes_fun <>= module subroutine write_get_n_processes_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_get_n_processes_fun <>= module subroutine write_get_n_processes_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix write (unit, "(A)") "" write (unit, "(A)") "! Return the number of processes in this library" write (unit, "(A)") "function " // char (prefix) & // "get_n_processes () result (n) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " implicit none" write (unit, "(A)") " integer(c_int) :: n" write (unit, "(A,I0)") " n = ", driver%n_processes write (unit, "(A)") "end function " // char (prefix) & // "get_n_processes" end subroutine write_get_n_processes_fun @ %def write_get_n_processes_fun @ \subsubsection{Informational string functions} These functions return constant information about the matrix-element code. The following procedures have to return strings. With the BIND(C) constraint, we choose to return the C pointer to a string, and its length, so the procedures implement this interface. They are actually subroutines. <>= public :: prc_get_stringptr <>= abstract interface subroutine prc_get_stringptr (i, cptr, len) bind(C) import integer(c_int), intent(in) :: i type(c_ptr), intent(out) :: cptr integer(c_int), intent(out) :: len end subroutine prc_get_stringptr end interface @ %def prc_get_stringptr @ To hide this complication, we introduce a subroutine that converts the returned C pointer to a [[string_t]] object. As a side effect, we deallocate the original after conversion -- otherwise, we might have a memory leak. For the conversion, we first pointer-convert the C pointer to a Fortran character array pointer, length 1 and size [[len]]. Using argument association and an internal subroutine, we convert this to a character array with length [[len]] and size 1. Using ordinary assignment, we finally convert this to [[string_t]]. The function takes the pointer-returning function as an argument. The index [[i]] identifies the process in the library. <>= subroutine get_string_via_cptr (string, i, get_stringptr) type(string_t), intent(out) :: string integer, intent(in) :: i procedure(prc_get_stringptr) :: get_stringptr type(c_ptr) :: cptr integer(c_int) :: pid, len character(kind=c_char), dimension(:), pointer :: c_array pid = i call get_stringptr (pid, cptr, len) if (c_associated (cptr)) then call c_f_pointer (cptr, c_array, shape = [len]) call set_string (c_array) call get_stringptr (0_c_int, cptr, len) else string = "" end if contains subroutine set_string (buffer) character(len, kind=c_char), dimension(1), intent(in) :: buffer string = buffer(1) end subroutine set_string end subroutine get_string_via_cptr @ %def get_string_via_cptr @ Since the module procedures return Fortran strings, we have to convert them. This is the necessary auxiliary routine. The routine is not BIND(C), it is not accessed from outside. <>= procedure, nopass :: write_string_to_array_fun <>= module subroutine write_string_to_array_fun (unit, prefix) integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_string_to_array_fun <>= module subroutine write_string_to_array_fun (unit, prefix) integer, intent(in) :: unit type(string_t), intent(in) :: prefix write (unit, "(A)") "" write (unit, "(A)") "! Auxiliary: convert character string & &to array pointer" write (unit, "(A)") "subroutine " // char (prefix) & // "string_to_array (string, a)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " implicit none" write (unit, "(A)") " character(*), intent(in) :: string" write (unit, "(A)") " character(kind=c_char), dimension(:), & &allocatable, intent(out) :: a" write (unit, "(A)") " integer :: i" write (unit, "(A)") " allocate (a (len (string)))" write (unit, "(A)") " do i = 1, size (a)" write (unit, "(A)") " a(i) = string(i:i)" write (unit, "(A)") " end do" write (unit, "(A)") "end subroutine " // char (prefix) & // "string_to_array" end subroutine write_string_to_array_fun @ %def write_string_to_array_fun @ The above routine is called by other functions. It is not in a module, so they need its interface explicitly. <>= subroutine write_string_to_array_interface (unit, prefix) integer, intent(in) :: unit type(string_t), intent(in) :: prefix write (unit, "(2x,A)") "interface" write (unit, "(2x,A)") " subroutine " // char (prefix) & // "string_to_array (string, a)" write (unit, "(2x,A)") " use iso_c_binding" write (unit, "(2x,A)") " implicit none" write (unit, "(2x,A)") " character(*), intent(in) :: string" write (unit, "(2x,A)") " character(kind=c_char), dimension(:), & &allocatable, intent(out) :: a" write (unit, "(2x,A)") " end subroutine " // char (prefix) & // "string_to_array" write (unit, "(2x,A)") "end interface" end subroutine write_string_to_array_interface @ %def write_string_to_array_interface @ Here are the info functions which return strings, implementing the interface [[prc_get_stringptr]]. Return the process ID for each process. <>= procedure :: write_get_process_id_fun <>= module subroutine write_get_process_id_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_get_process_id_fun <>= module subroutine write_get_process_id_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i write (unit, "(A)") "" write (unit, "(A)") "! Return the process ID of process #i & &(as a C pointer to a character array)" write (unit, "(A)") "subroutine " // char (prefix) & // "get_process_id_ptr (i, cptr, len) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " implicit none" write (unit, "(A)") " integer(c_int), intent(in) :: i" write (unit, "(A)") " type(c_ptr), intent(out) :: cptr" write (unit, "(A)") " integer(c_int), intent(out) :: len" write (unit, "(A)") " character(kind=c_char), dimension(:), & &allocatable, target, save :: a" call write_string_to_array_interface (unit, prefix) write (unit, "(A)") " select case (i)" write (unit, "(A)") " case (0); if (allocated (a)) deallocate (a)" do i = 1, driver%n_processes write (unit, "(A,I0,9A)") " case (", i, "); ", & "call ", char (prefix), "string_to_array ('", & char (driver%record(i)%id), "', a)" end do write (unit, "(A)") " end select" write (unit, "(A)") " if (allocated (a)) then" write (unit, "(A)") " cptr = c_loc (a)" write (unit, "(A)") " len = size (a)" write (unit, "(A)") " else" write (unit, "(A)") " cptr = c_null_ptr" write (unit, "(A)") " len = 0" write (unit, "(A)") " end if" write (unit, "(A)") "end subroutine " // char (prefix) & // "get_process_id_ptr" end subroutine write_get_process_id_fun @ %def write_get_process_id_fun @ Return the model name, given explicitly. <>= procedure :: write_get_model_name_fun <>= module subroutine write_get_model_name_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_get_model_name_fun <>= module subroutine write_get_model_name_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i write (unit, "(A)") "" write (unit, "(A)") "! Return the model name for process #i & &(as a C pointer to a character array)" write (unit, "(A)") "subroutine " // char (prefix) & // "get_model_name_ptr (i, cptr, len) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " implicit none" write (unit, "(A)") " integer(c_int), intent(in) :: i" write (unit, "(A)") " type(c_ptr), intent(out) :: cptr" write (unit, "(A)") " integer(c_int), intent(out) :: len" write (unit, "(A)") " character(kind=c_char), dimension(:), & &allocatable, target, save :: a" call write_string_to_array_interface (unit, prefix) write (unit, "(A)") " select case (i)" write (unit, "(A)") " case (0); if (allocated (a)) deallocate (a)" do i = 1, driver%n_processes write (unit, "(A,I0,9A)") " case (", i, "); ", & "call ", char (prefix), "string_to_array ('" , & char (driver%record(i)%model_name), & "', a)" end do write (unit, "(A)") " end select" write (unit, "(A)") " if (allocated (a)) then" write (unit, "(A)") " cptr = c_loc (a)" write (unit, "(A)") " len = size (a)" write (unit, "(A)") " else" write (unit, "(A)") " cptr = c_null_ptr" write (unit, "(A)") " len = 0" write (unit, "(A)") " end if" write (unit, "(A)") "end subroutine " // char (prefix) & // "get_model_name_ptr" end subroutine write_get_model_name_fun @ %def write_get_model_name_fun @ Call the MD5 sum function for the process. The function calls the corresponding function of the matrix-element code, and it returns the C address of a character array with length 32. <>= procedure :: write_get_md5sum_fun <>= module subroutine write_get_md5sum_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_get_md5sum_fun <>= module subroutine write_get_md5sum_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i write (unit, "(A)") "" write (unit, "(A)") "! Return the MD5 sum for the process configuration & &(as a C pointer to a character array)" write (unit, "(A)") "subroutine " // char (prefix) & // "get_md5sum_ptr (i, cptr, len) bind(C)" write (unit, "(A)") " use iso_c_binding" call driver%write_interfaces (unit, var_str ("md5sum")) write (unit, "(A)") " interface" write (unit, "(A)") " function " // char (prefix) & // "md5sum () result (md5sum)" write (unit, "(A)") " character(32) :: md5sum" write (unit, "(A)") " end function " // char (prefix) // "md5sum" write (unit, "(A)") " end interface" write (unit, "(A)") " integer(c_int), intent(in) :: i" write (unit, "(A)") " type(c_ptr), intent(out) :: cptr" write (unit, "(A)") " integer(c_int), intent(out) :: len" write (unit, "(A)") " character(kind=c_char), dimension(32), & &target, save :: md5sum" write (unit, "(A)") " select case (i)" write (unit, "(A)") " case (0)" !!! Workaround for Intel oneAPI 2022/23 regression ! write (unit, "(A)") " call copy (" // char (prefix) // "md5sum ())" write (unit, "(A)") " call copy ((" // char (prefix) // "md5sum ()))" write (unit, "(A)") " cptr = c_loc (md5sum)" do i = 1, driver%n_processes write (unit, "(A,I0,A)") " case (", i, ")" call driver%record(i)%write_md5sum_call (unit) end do write (unit, "(A)") " case default" write (unit, "(A)") " cptr = c_null_ptr" write (unit, "(A)") " end select" write (unit, "(A)") " len = 32" write (unit, "(A)") "contains" write (unit, "(A)") " subroutine copy (md5sum_tmp)" write (unit, "(A)") " character, dimension(32), intent(in) :: & &md5sum_tmp" write (unit, "(A)") " md5sum = md5sum_tmp" write (unit, "(A)") " end subroutine copy" write (unit, "(A)") "end subroutine " // char (prefix) & // "get_md5sum_ptr" end subroutine write_get_md5sum_fun @ %def write_get_md5sum_fun @ The actual call depends on the type of matrix element. <>= procedure :: write_md5sum_call => prclib_driver_record_write_md5sum_call <>= module subroutine prclib_driver_record_write_md5sum_call (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit end subroutine prclib_driver_record_write_md5sum_call <>= module subroutine prclib_driver_record_write_md5sum_call (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit call record%writer%write_md5sum_call (unit, record%id) end subroutine prclib_driver_record_write_md5sum_call @ %def prclib_driver_record_write_md5sum_call @ The interface goes into the writer base type: <>= procedure(write_code), deferred :: write_md5sum_call @ %def write_md5sum_call @ In the Fortran module case, we take a detour. The string returned by the Fortran function is copied into a fixed-size array. The copy routine is an internal subroutine of [[get_md5sum_ptr]]. We return the C address of the target array. <>= procedure :: write_md5sum_call => prc_writer_f_module_write_md5sum_call <>= module subroutine prc_writer_f_module_write_md5sum_call (writer, unit, id) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine prc_writer_f_module_write_md5sum_call <>= module subroutine prc_writer_f_module_write_md5sum_call (writer, unit, id) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id !!! Workaround for Intel oneAPI 2022/23 regression ! write (unit, "(5x,9A)") "call copy (", & ! char (writer%get_c_procname (id, var_str ("md5sum"))), " ())" write (unit, "(5x,9A)") "call copy ((", & char (writer%get_c_procname (id, var_str ("md5sum"))), " ()))" write (unit, "(5x,9A)") "cptr = c_loc (md5sum)" end subroutine prc_writer_f_module_write_md5sum_call @ %def prc_writer_f_module_write_md5sum_call @ In the C library case, the library function returns a C pointer, which we can just copy. <>= procedure :: write_md5sum_call => prc_writer_c_lib_write_md5sum_call <>= module subroutine prc_writer_c_lib_write_md5sum_call (writer, unit, id) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine prc_writer_c_lib_write_md5sum_call <>= module subroutine prc_writer_c_lib_write_md5sum_call (writer, unit, id) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") & "cptr = ", & char (writer%get_c_procname (id, var_str ("get_md5sum"))), " ()" end subroutine prc_writer_c_lib_write_md5sum_call @ %def prc_writer_c_lib_write_md5sum_call @ \subsubsection{Actual references to the info functions} The string-valued info functions return C character arrays. For the API of the library driver, we provide convenience functions which (re)convert those arrays into [[string_t]] objects. <>= procedure :: get_process_id => prclib_driver_get_process_id procedure :: get_model_name => prclib_driver_get_model_name procedure :: get_md5sum => prclib_driver_get_md5sum <>= module function prclib_driver_get_process_id (driver, i) result (string) type(string_t) :: string class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i end function prclib_driver_get_process_id module function prclib_driver_get_model_name (driver, i) result (string) type(string_t) :: string class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i end function prclib_driver_get_model_name module function prclib_driver_get_md5sum (driver, i) result (string) type(string_t) :: string class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i end function prclib_driver_get_md5sum <>= module function prclib_driver_get_process_id (driver, i) result (string) type(string_t) :: string class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i call get_string_via_cptr (string, i, driver%get_process_id_ptr) end function prclib_driver_get_process_id module function prclib_driver_get_model_name (driver, i) result (string) type(string_t) :: string class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i call get_string_via_cptr (string, i, driver%get_model_name_ptr) end function prclib_driver_get_model_name module function prclib_driver_get_md5sum (driver, i) result (string) type(string_t) :: string class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i call get_string_via_cptr (string, i, driver%get_md5sum_ptr) end function prclib_driver_get_md5sum @ %def prclib_driver_get_process_id @ %def prclib_driver_get_model_name @ %def prclib_driver_get_md5sum @ \subsubsection{Informational logical functions} When returning a logical value, we use the C boolean type, which may differ from Fortran. <>= public :: prc_get_log <>= abstract interface function prc_get_log (pid) result (l) bind(C) import integer(c_int), intent(in) :: pid logical(c_bool) :: l end function prc_get_log end interface @ %def prc_get_log @ Return a logical flag which tells whether OpenMP is supported for a specific process code. <>= procedure :: write_get_openmp_status_fun <>= module subroutine write_get_openmp_status_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_get_openmp_status_fun <>= module subroutine write_get_openmp_status_fun (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i write (unit, "(A)") "" write (unit, "(A)") "! Return the OpenMP support status" write (unit, "(A)") "function " // char (prefix) & // "get_openmp_status (i) result (openmp_status) bind(C)" write (unit, "(A)") " use iso_c_binding" call driver%write_interfaces (unit, var_str ("openmp_supported")) write (unit, "(A)") " integer(c_int), intent(in) :: i" write (unit, "(A)") " logical(c_bool) :: openmp_status" write (unit, "(A)") " select case (i)" do i = 1, driver%n_processes write (unit, "(A,I0,9A)") " case (", i, "); ", & "openmp_status = ", & char (driver%record(i)%get_c_procname & (var_str ("openmp_supported"))), " ()" end do write (unit, "(A)") " end select" write (unit, "(A)") "end function " // char (prefix) & // "get_openmp_status" end subroutine write_get_openmp_status_fun @ %def write_get_openmp_status_fun @ \subsubsection{Informational integer functions} Various process metadata are integer values. We can use a single interface for all of them. <>= public :: prc_get_int <>= abstract interface function prc_get_int (pid) result (n) bind(C) import integer(c_int), intent(in) :: pid integer(c_int) :: n end function prc_get_int end interface @ %def prc_get_int @ This function returns any data of type integer, for each process. <>= procedure :: write_get_int_fun <>= module subroutine write_get_int_fun (driver, unit, prefix, feature) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix type(string_t), intent(in) :: feature end subroutine write_get_int_fun <>= module subroutine write_get_int_fun (driver, unit, prefix, feature) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix type(string_t), intent(in) :: feature integer :: i write (unit, "(A)") "" write (unit, "(9A)") "! Return the value of ", char (feature) write (unit, "(9A)") "function ", char (prefix), & "get_", char (feature), " (pid)", & " result (", char (feature), ") bind(C)" write (unit, "(9A)") " use iso_c_binding" call driver%write_interfaces (unit, feature) write (unit, "(9A)") " integer(c_int), intent(in) :: pid" write (unit, "(9A)") " integer(c_int) :: ", char (feature) write (unit, "(9A)") " select case (pid)" do i = 1, driver%n_processes write (unit, "(2x,A,I0,9A)") "case (", i, "); ", & char (feature), " = ", & char (driver%record(i)%get_c_procname (feature)), & " ()" end do write (unit, "(9A)") " end select" write (unit, "(9A)") "end function ", char (prefix), & "get_", char (feature) end subroutine write_get_int_fun @ %def write_get_int_fun @ Write a [[case]] line that assigns the value of the external function to the current return value. <>= subroutine write_case_int_fun (record, unit, i, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit integer, intent(in) :: i type(string_t), intent(in) :: feature write (unit, "(5x,A,I0,9A)") "case (", i, "); ", & char (feature), " = ", char (record%get_c_procname (feature)) end subroutine write_case_int_fun @ %def write_case_int_fun @ \subsubsection{Flavor and helicity tables} Transferring tables is more complicated. First, a two-dimensional array. <>= public :: prc_set_int_tab1 <>= abstract interface subroutine prc_set_int_tab1 (pid, tab, shape) bind(C) import integer(c_int), intent(in) :: pid integer(c_int), dimension(*), intent(out) :: tab integer(c_int), dimension(2), intent(in) :: shape end subroutine prc_set_int_tab1 end interface @ %def prc_set_int_tab1 @ This subroutine returns a table of integers. <>= procedure :: write_set_int_sub <>= module subroutine write_set_int_sub (driver, unit, prefix, feature) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix type(string_t), intent(in) :: feature end subroutine write_set_int_sub <>= module subroutine write_set_int_sub (driver, unit, prefix, feature) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix type(string_t), intent(in) :: feature integer :: i write (unit, "(A)") "" write (unit, "(9A)") "! Set table: ", char (feature) write (unit, "(9A)") "subroutine ", char (prefix), & "set_", char (feature), "_ptr (pid, ", char (feature), & ", shape) bind(C)" write (unit, "(9A)") " use iso_c_binding" call driver%write_interfaces (unit, feature) write (unit, "(9A)") " integer(c_int), intent(in) :: pid" write (unit, "(9A)") " integer(c_int), dimension(*), intent(out) :: ", & char (feature) write (unit, "(9A)") " integer(c_int), dimension(2), intent(in) :: shape" write (unit, "(9A)") " integer, dimension(:,:), allocatable :: ", & char (feature), "_tmp" write (unit, "(9A)") " integer :: i, j" write (unit, "(9A)") " select case (pid)" do i = 1, driver%n_processes write (unit, "(2x,A,I0,A)") "case (", i, ")" call driver%record(i)%write_int_sub_call (unit, feature) end do write (unit, "(9A)") " end select" write (unit, "(9A)") "end subroutine ", char (prefix), & "set_", char (feature), "_ptr" end subroutine write_set_int_sub @ %def write_set_int_sub @ The actual call depends on the type of matrix element. <>= procedure :: write_int_sub_call => prclib_driver_record_write_int_sub_call <>= module subroutine prclib_driver_record_write_int_sub_call (record, unit, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(string_t), intent(in) :: feature end subroutine prclib_driver_record_write_int_sub_call <>= module subroutine prclib_driver_record_write_int_sub_call (record, unit, feature) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit type(string_t), intent(in) :: feature call record%writer%write_int_sub_call (unit, record%id, feature) end subroutine prclib_driver_record_write_int_sub_call @ %def prclib_driver_record_write_int_sub_call @ The interface goes into the writer base type: <>= procedure(write_feature_code), deferred :: write_int_sub_call @ %def write_int_sub_call @ In the Fortran module case, we need an extra copy in the (academical) situation where default integer and [[c_int]] differ. Otherwise, we just associate a Fortran array with the C pointer and let the matrix-element subroutine fill the array. <>= procedure :: write_int_sub_call => prc_writer_f_module_write_int_sub_call <>= module subroutine prc_writer_f_module_write_int_sub_call (writer, unit, id, feature) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature end subroutine prc_writer_f_module_write_int_sub_call <>= module subroutine prc_writer_f_module_write_int_sub_call (writer, unit, id, feature) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, "(5x,9A)") "allocate (", char (feature), "_tmp ", & "(shape(1), shape(2)))" write (unit, "(5x,9A)") "call ", & char (writer%get_c_procname (id, feature)), & " (", char (feature), "_tmp)" write (unit, "(5x,9A)") "forall (i=1:shape(1), j=1:shape(2)) " write (unit, "(8x,9A)") char (feature), "(i + shape(1)*(j-1)) = ", & char (feature), "_tmp", "(i,j)" write (unit, "(5x,9A)") "end forall" end subroutine prc_writer_f_module_write_int_sub_call @ %def prc_writer_f_module_write_int_sub_call @ In the C library case, we just transfer the C pointer to the library function. <>= procedure :: write_int_sub_call => prc_writer_c_lib_write_int_sub_call <>= module subroutine prc_writer_c_lib_write_int_sub_call (writer, unit, id, feature) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature end subroutine prc_writer_c_lib_write_int_sub_call <>= module subroutine prc_writer_c_lib_write_int_sub_call (writer, unit, id, feature) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, "(5x,9A)") "call ", & char (writer%get_c_procname (id, feature)), " (", char (feature), ")" end subroutine prc_writer_c_lib_write_int_sub_call @ %def prc_writer_c_lib_write_int_sub_call @ \subsubsection{Color state table} The color-state specification needs a table of integers (one array per color flow) and a corresponding array of color-ghost flags. <>= public :: prc_set_col_state <>= abstract interface subroutine prc_set_col_state (pid, col_state, ghost_flag, shape) bind(C) import integer(c_int), intent(in) :: pid integer(c_int), dimension(*), intent(out) :: col_state logical(c_bool), dimension(*), intent(out) :: ghost_flag integer(c_int), dimension(3), intent(in) :: shape end subroutine prc_set_col_state end interface @ %def prc_set_int_tab2 @ <>= procedure :: write_set_col_state_sub <>= module subroutine write_set_col_state_sub (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_set_col_state_sub <>= module subroutine write_set_col_state_sub (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i type(string_t) :: feature feature = "col_state" write (unit, "(A)") "" write (unit, "(9A)") "! Set tables: col_state, ghost_flag" write (unit, "(9A)") "subroutine ", char (prefix), & "set_col_state_ptr (pid, col_state, ghost_flag, shape) bind(C)" write (unit, "(9A)") " use iso_c_binding" call driver%write_interfaces (unit, feature) write (unit, "(9A)") " integer(c_int), intent(in) :: pid" write (unit, "(9A)") & " integer(c_int), dimension(*), intent(out) :: col_state" write (unit, "(9A)") & " logical(c_bool), dimension(*), intent(out) :: ghost_flag" write (unit, "(9A)") & " integer(c_int), dimension(3), intent(in) :: shape" write (unit, "(9A)") & " integer, dimension(:,:,:), allocatable :: col_state_tmp" write (unit, "(9A)") & " logical, dimension(:,:), allocatable :: ghost_flag_tmp" write (unit, "(9A)") " integer :: i, j, k" write (unit, "(A)") " select case (pid)" do i = 1, driver%n_processes write (unit, "(A,I0,A)") " case (", i, ")" call driver%record(i)%write_col_state_call (unit) end do write (unit, "(A)") " end select" write (unit, "(9A)") "end subroutine ", char (prefix), & "set_col_state_ptr" end subroutine write_set_col_state_sub @ %def write_set_col_state_sub @ The actual call depends on the type of matrix element. <>= procedure :: write_col_state_call => prclib_driver_record_write_col_state_call <>= module subroutine prclib_driver_record_write_col_state_call (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit end subroutine prclib_driver_record_write_col_state_call <>= module subroutine prclib_driver_record_write_col_state_call (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit call record%writer%write_col_state_call (unit, record%id) end subroutine prclib_driver_record_write_col_state_call @ %def prclib_driver_record_write_col_state_call @ The interface goes into the writer base type: <>= procedure(write_code), deferred :: write_col_state_call @ %def write_col_state_call @ In the Fortran module case, we need an extra copy in the (academical) situation where default integer and [[c_int]] differ. Otherwise, we just associate a Fortran array with the C pointer and let the matrix-element subroutine fill the array. <>= procedure :: write_col_state_call => prc_writer_f_module_write_col_state_call <>= module subroutine prc_writer_f_module_write_col_state_call (writer, unit, id) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine prc_writer_f_module_write_col_state_call <>= module subroutine prc_writer_f_module_write_col_state_call (writer, unit, id) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(9A)") " allocate (col_state_tmp ", & "(shape(1), shape(2), shape(3)))" write (unit, "(5x,9A)") "allocate (ghost_flag_tmp ", & "(shape(2), shape(3)))" write (unit, "(5x,9A)") "call ", & char (writer%get_c_procname (id, var_str ("col_state"))), & " (col_state_tmp, ghost_flag_tmp)" write (unit, "(5x,9A)") "forall (i = 1:shape(2), j = 1:shape(3))" write (unit, "(8x,9A)") "forall (k = 1:shape(1))" write (unit, "(11x,9A)") & "col_state(k + shape(1) * (i + shape(2)*(j-1) - 1)) ", & "= col_state_tmp(k,i,j)" write (unit, "(8x,9A)") "end forall" write (unit, "(8x,9A)") & "ghost_flag(i + shape(2)*(j-1)) = ghost_flag_tmp(i,j)" write (unit, "(5x,9A)") "end forall" end subroutine prc_writer_f_module_write_col_state_call @ %def prc_writer_f_module_write_col_state_call @ In the C library case, we just transfer the C pointer to the library function. <>= procedure :: write_col_state_call => prc_writer_c_lib_write_col_state_call <>= module subroutine prc_writer_c_lib_write_col_state_call (writer, unit, id) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine prc_writer_c_lib_write_col_state_call <>= module subroutine prc_writer_c_lib_write_col_state_call (writer, unit, id) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") "call ", & char (writer%get_c_procname (id, var_str ("col_state"))), & " (col_state, ghost_flag)" end subroutine prc_writer_c_lib_write_col_state_call @ %def prc_writer_c_lib_write_col_state_call @ \subsubsection{Color factors} For the color-factor information, we return two integer arrays and a complex array. <>= public :: prc_set_color_factors <>= abstract interface subroutine prc_set_color_factors & (pid, cf_index1, cf_index2, color_factors, shape) bind(C) import integer(c_int), intent(in) :: pid integer(c_int), dimension(*), intent(out) :: cf_index1, cf_index2 complex(c_default_complex), dimension(*), intent(out) :: color_factors integer(c_int), dimension(1), intent(in) :: shape end subroutine prc_set_color_factors end interface @ %def prc_set_color_factors @ This subroutine returns the color-flavor factor table. <>= procedure :: write_set_color_factors_sub <>= module subroutine write_set_color_factors_sub (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_set_color_factors_sub <>= module subroutine write_set_color_factors_sub (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i type(string_t) :: feature feature = "color_factors" write (unit, "(A)") "" write (unit, "(A)") "! Set tables: color factors" write (unit, "(9A)") "subroutine ", char (prefix), & "set_color_factors_ptr (pid, cf_index1, cf_index2, color_factors, ", & "shape) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " use kinds" write (unit, "(A)") " use omega_color" call driver%write_interfaces (unit, feature) write (unit, "(A)") " integer(c_int), intent(in) :: pid" write (unit, "(A)") " integer(c_int), dimension(1), intent(in) :: shape" write (unit, "(A)") " integer(c_int), dimension(*), intent(out) :: & &cf_index1, cf_index2" write (unit, "(A)") " complex(c_default_complex), dimension(*), & &intent(out) :: color_factors" write (unit, "(A)") " type(omega_color_factor), dimension(:), & &allocatable :: cf" write (unit, "(A)") " select case (pid)" do i = 1, driver%n_processes write (unit, "(2x,A,I0,A)") "case (", i, ")" call driver%record(i)%write_color_factors_call (unit) end do write (unit, "(A)") " end select" write (unit, "(A)") "end subroutine " // char (prefix) & // "set_color_factors_ptr" end subroutine write_set_color_factors_sub @ %def write_set_color_factors_sub @ The actual call depends on the type of matrix element. <>= procedure :: write_color_factors_call => prclib_driver_record_write_color_factors_call <>= module subroutine prclib_driver_record_write_color_factors_call (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit end subroutine prclib_driver_record_write_color_factors_call <>= module subroutine prclib_driver_record_write_color_factors_call (record, unit) class(prclib_driver_record_t), intent(in) :: record integer, intent(in) :: unit call record%writer%write_color_factors_call (unit, record%id) end subroutine prclib_driver_record_write_color_factors_call @ %def prclib_driver_record_write_color_factors_call @ The interface goes into the writer base type: <>= procedure(write_code), deferred :: write_color_factors_call @ %def write_color_factors_call @ In the Fortran module case, the matrix-element procedure fills an array of [[omega_color_factor]] elements. We distribute this array among two integer arrays and one complex-valued array, for which we have the C pointers. <>= procedure :: write_color_factors_call => prc_writer_f_module_write_color_factors_call <>= module subroutine prc_writer_f_module_write_color_factors_call (writer, unit, id) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine prc_writer_f_module_write_color_factors_call <>= module subroutine prc_writer_f_module_write_color_factors_call (writer, unit, id) class(prc_writer_f_module_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,A)") "allocate (cf (shape(1)))" write (unit, "(5x,9A)") "call ", & char (writer%get_c_procname (id, var_str ("color_factors"))), " (cf)" write (unit, "(5x,9A)") "cf_index1(1:shape(1)) = cf%i1" write (unit, "(5x,9A)") "cf_index2(1:shape(1)) = cf%i2" write (unit, "(5x,9A)") "color_factors(1:shape(1)) = cf%factor" end subroutine prc_writer_f_module_write_color_factors_call @ %def prc_writer_f_module_write_color_factors_call @ In the C library case, we just transfer the C pointers to the library function. There are three arrays. <>= procedure :: write_color_factors_call => & prc_writer_c_lib_write_color_factors_call <>= module subroutine prc_writer_c_lib_write_color_factors_call (writer, unit, id) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id end subroutine prc_writer_c_lib_write_color_factors_call <>= module subroutine prc_writer_c_lib_write_color_factors_call (writer, unit, id) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") "call ", & char (writer%get_c_procname (id, var_str ("color_factors"))), & " (cf_index1, cf_index2, color_factors)" end subroutine prc_writer_c_lib_write_color_factors_call @ %def prc_writer_c_lib_write_color_factors_call @ \subsection{Interfaces for C-library matrix element} If the matrix element code is not provided as a Fortran module but as a C or bind(C) Fortran library, we need explicit interfaces for the library functions. They are not identical to the Fortran module versions. They transfer pointers directly. The implementation is part of the [[prc_writer_c_lib]] type, which serves as base type for all C-library writers. It writes specific interfaces depending on the feature. We bind this as the method [[write_standard_interface]] instead of [[write_interface]], because we have to override the latter. Otherwise we could not call the method because the writer type is abstract. <>= procedure :: write_standard_interface => prc_writer_c_lib_write_interface <>= module subroutine prc_writer_c_lib_write_interface (writer, unit, id, feature) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature end subroutine prc_writer_c_lib_write_interface <>= module subroutine prc_writer_c_lib_write_interface (writer, unit, id, feature) class(prc_writer_c_lib_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature select case (char (feature)) case ("md5sum") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "function ", & char (writer%get_c_procname (id, var_str ("get_md5sum"))), & " () result (cptr) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "type(c_ptr) :: cptr" write (unit, "(5x,9A)") "end function ", & char (writer%get_c_procname (id, var_str ("get_md5sum"))) write (unit, "(2x,9A)") "end interface" case ("openmp_supported") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "function ", & char (writer%get_c_procname (id, feature)), & " () result (status) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "logical(c_bool) :: status" write (unit, "(5x,9A)") "end function ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" case ("n_in", "n_out", "n_flv", "n_hel", "n_col", "n_cin", "n_cf") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "function ", & char (writer%get_c_procname (id, feature)), & " () result (n) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "integer(c_int) :: n" write (unit, "(5x,9A)") "end function ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" case ("flv_state", "hel_state") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "subroutine ", & char (writer%get_c_procname (id, feature)), & " (", char (feature), ") bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "integer(c_int), dimension(*), intent(out) ", & ":: ", char (feature) write (unit, "(5x,9A)") "end subroutine ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" case ("col_state") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "subroutine ", & char (writer%get_c_procname (id, feature)), & " (col_state, ghost_flag) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "integer(c_int), dimension(*), intent(out) ", & ":: col_state" write (unit, "(7x,9A)") "logical(c_bool), dimension(*), intent(out) ", & ":: ghost_flag" write (unit, "(5x,9A)") "end subroutine ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" case ("color_factors") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "subroutine ", & char (writer%get_c_procname (id, feature)), & " (cf_index1, cf_index2, color_factors) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "integer(c_int), dimension(*), & &intent(out) :: cf_index1" write (unit, "(7x,9A)") "integer(c_int), dimension(*), & &intent(out) :: cf_index2" write (unit, "(7x,9A)") "complex(c_default_complex), dimension(*), & &intent(out) :: color_factors" write (unit, "(5x,9A)") "end subroutine ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" end select end subroutine prc_writer_c_lib_write_interface @ %def prc_writer_c_lib_write_interface @ \subsection{Retrieving the tables} In the previous section we had the writer routines for procedures that return tables, actually C pointers to tables. Here, we write convenience routines that unpack them and move the contents to suitable Fortran arrays. The flavor and helicity tables are two-dimensional integer arrays. We use intermediate storage for correctly transforming C to Fortran data types. <>= procedure :: set_flv_state => prclib_driver_set_flv_state procedure :: set_hel_state => prclib_driver_set_hel_state <>= module subroutine prclib_driver_set_flv_state (driver, i, flv_state) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i integer, dimension(:,:), allocatable, intent(out) :: flv_state end subroutine prclib_driver_set_flv_state module subroutine prclib_driver_set_hel_state (driver, i, hel_state) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i integer, dimension(:,:), allocatable, intent(out) :: hel_state end subroutine prclib_driver_set_hel_state <>= module subroutine prclib_driver_set_flv_state (driver, i, flv_state) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i integer, dimension(:,:), allocatable, intent(out) :: flv_state integer :: n_tot, n_flv integer(c_int) :: pid integer(c_int), dimension(:,:), allocatable :: c_flv_state pid = i n_tot = driver%get_n_in (pid) + driver%get_n_out (pid) n_flv = driver%get_n_flv (pid) allocate (flv_state (n_tot, n_flv)) allocate (c_flv_state (n_tot, n_flv)) call driver%set_flv_state_ptr & (pid, c_flv_state, int ([n_tot, n_flv], kind=c_int)) flv_state = c_flv_state end subroutine prclib_driver_set_flv_state module subroutine prclib_driver_set_hel_state (driver, i, hel_state) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i integer, dimension(:,:), allocatable, intent(out) :: hel_state integer :: n_tot, n_hel integer(c_int) :: pid integer(c_int), dimension(:,:), allocatable, target :: c_hel_state pid = i n_tot = driver%get_n_in (pid) + driver%get_n_out (pid) n_hel = driver%get_n_hel (pid) allocate (hel_state (n_tot, n_hel)) allocate (c_hel_state (n_tot, n_hel)) call driver%set_hel_state_ptr & (pid, c_hel_state, int ([n_tot, n_hel], kind=c_int)) hel_state = c_hel_state end subroutine prclib_driver_set_hel_state @ %def prclib_driver_set_flv_state @ %def prclib_driver_set_hel_state @ The color-flow table is three-dimensional, otherwise similar. We simultaneously set the ghost-flag table, which consists of logical entries. <>= procedure :: set_col_state => prclib_driver_set_col_state <>= module subroutine prclib_driver_set_col_state (driver, i, col_state, ghost_flag) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i integer, dimension(:,:,:), allocatable, intent(out) :: col_state logical, dimension(:,:), allocatable, intent(out) :: ghost_flag end subroutine prclib_driver_set_col_state <>= module subroutine prclib_driver_set_col_state (driver, i, col_state, ghost_flag) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i integer, dimension(:,:,:), allocatable, intent(out) :: col_state logical, dimension(:,:), allocatable, intent(out) :: ghost_flag integer :: n_cin, n_tot, n_col integer(c_int) :: pid integer(c_int), dimension(:,:,:), allocatable :: c_col_state logical(c_bool), dimension(:,:), allocatable :: c_ghost_flag pid = i n_cin = driver%get_n_cin (pid) n_tot = driver%get_n_in (pid) + driver%get_n_out (pid) n_col = driver%get_n_col (pid) allocate (col_state (n_cin, n_tot, n_col)) allocate (c_col_state (n_cin, n_tot, n_col)) allocate (ghost_flag (n_tot, n_col)) allocate (c_ghost_flag (n_tot, n_col)) call driver%set_col_state_ptr (pid, & c_col_state, c_ghost_flag, int ([n_cin, n_tot, n_col], kind=c_int)) col_state = c_col_state ghost_flag = c_ghost_flag end subroutine prclib_driver_set_col_state @ %def prclib_driver_set_col_state @ The color-factor table is a sparse matrix: a two-column array of indices and one array which contains the corresponding factors. <>= procedure :: set_color_factors => prclib_driver_set_color_factors <>= module subroutine prclib_driver_set_color_factors (driver, i, color_factors, cf_index) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i complex(default), dimension(:), allocatable, intent(out) :: color_factors integer, dimension(:,:), allocatable, intent(out) :: cf_index end subroutine prclib_driver_set_color_factors <>= module subroutine prclib_driver_set_color_factors (driver, i, color_factors, cf_index) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i complex(default), dimension(:), allocatable, intent(out) :: color_factors integer, dimension(:,:), allocatable, intent(out) :: cf_index integer :: n_cf integer(c_int) :: pid complex(c_default_complex), dimension(:), allocatable, target :: c_color_factors integer(c_int), dimension(:), allocatable, target :: c_cf_index1 integer(c_int), dimension(:), allocatable, target :: c_cf_index2 pid = i n_cf = driver%get_n_cf (pid) allocate (color_factors (n_cf)) allocate (c_color_factors (n_cf)) allocate (c_cf_index1 (n_cf)) allocate (c_cf_index2 (n_cf)) call driver%set_color_factors_ptr (pid, & c_cf_index1, c_cf_index2, & c_color_factors, int ([n_cf], kind=c_int)) color_factors = c_color_factors allocate (cf_index (2, n_cf)) cf_index(1,:) = c_cf_index1 cf_index(2,:) = c_cf_index2 end subroutine prclib_driver_set_color_factors @ %def prclib_driver_set_color_factors @ \subsection{Returning a procedure pointer} The functions that directly access the matrix element, event by event, are assigned to a process-specific driver object as procedure pointers. For the [[dlopen]] interface, we use C function pointers. This subroutine returns such a pointer: <>= public :: prc_get_fptr <>= abstract interface subroutine prc_get_fptr (pid, fid, fptr) bind(C) import integer(c_int), intent(in) :: pid integer(c_int), intent(in) :: fid type(c_funptr), intent(out) :: fptr end subroutine prc_get_fptr end interface @ %def prc_get_fptr @ This procedure writes the source code for the procedure pointer returning subroutine. All C functions that are provided by the matrix element code of a specific process are handled here. The selection consists of a double layered [[select]] [[case]] construct. <>= procedure :: write_get_fptr_sub <>= module subroutine write_get_fptr_sub (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix end subroutine write_get_fptr_sub <>= module subroutine write_get_fptr_sub (driver, unit, prefix) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: unit type(string_t), intent(in) :: prefix integer :: i, j write (unit, "(A)") "" write (unit, "(A)") "! Return C pointer to a procedure:" write (unit, "(A)") "! pid = process index; fid = function index" write (unit, "(4A)") "subroutine ", char (prefix), "get_fptr ", & "(pid, fid, fptr) bind(C)" write (unit, "(A)") " use iso_c_binding" write (unit, "(A)") " use kinds" write (unit, "(A)") " implicit none" write (unit, "(A)") " integer(c_int), intent(in) :: pid" write (unit, "(A)") " integer(c_int), intent(in) :: fid" write (unit, "(A)") " type(c_funptr), intent(out) :: fptr" do i = 1, driver%n_processes call driver%record(i)%write_interfaces (unit) end do write (unit, "(A)") " select case (pid)" do i = 1, driver%n_processes write (unit, "(2x,A,I0,A)") "case (", i, ")" write (unit, "(5x,A)") "select case (fid)" associate (record => driver%record(i)) do j = 1, size (record%feature) write (unit, "(5x,A,I0,9A)") "case (", j, "); ", & "fptr = c_funloc (", & char (record%get_c_procname (record%feature(j))), & ")" end do end associate write (unit, "(5x,A)") "end select" end do write (unit, "(A)") " end select" write (unit, "(3A)") "end subroutine ", char (prefix), "get_fptr" end subroutine write_get_fptr_sub @ %def write_get_fptr_sub @ The procedures for which we want to return a pointer (the 'features' of the matrix element code) are actually Fortran module procedures. If we want to have a C signature, we must write wrapper functions for all of them. The procedures, their signatures, and the appropriate writer routines are specific for the process type. To keep this generic, we do not provide the writer routines here, but just the interface for a writer routine. The actual routines are stored in the process record. The [[prefix]] indicates the library, the [[id]] indicates the process, and [[procname]] is the bare name of the procedure to be written. <>= public :: write_driver_code <>= abstract interface subroutine write_driver_code (unit, prefix, id, procname) import integer, intent(in) :: unit type(string_t), intent(in) :: prefix type(string_t), intent(in) :: id type(string_t), intent(in) :: procname end subroutine write_driver_code end interface @ %def write_driver_code @ \subsection{Hooks} Interface for additional library unload / reload hooks (currently unused!) <>= public :: prclib_unload_hook public :: prclib_reload_hook <>= abstract interface subroutine prclib_unload_hook (libname) import type(string_t), intent(in) :: libname end subroutine prclib_unload_hook subroutine prclib_reload_hook (libname) import type(string_t), intent(in) :: libname end subroutine prclib_reload_hook end interface @ %def prclib_unload_hook @ %def prclib_reload_hook @ \subsection{Make source, compile, link} Since we should have written a Makefile, these tasks amount to simple [[make]] calls. Note that the Makefile targets depend on each other, so calling [[link]] executes also the [[source]] and [[compile]] steps, when necessary. Optionally, we can use a subdirectory. We construct a prefix for the subdirectory, and generate a shell [[cd]] call that moves us into the workspace. The [[prefix]] version is intended to be prepended to a filename, and can be empty. The [[path]] version is intended to be prepended with a following slash, so the default is [[.]]. <>= public :: workspace_prefix public :: workspace_path <>= module function workspace_prefix (workspace) result (prefix) type(string_t), intent(in), optional :: workspace type(string_t) :: prefix end function workspace_prefix module function workspace_path (workspace) result (path) type(string_t), intent(in), optional :: workspace type(string_t) :: path end function workspace_path module function workspace_cmd (workspace) result (cmd) type(string_t), intent(in), optional :: workspace type(string_t) :: cmd end function workspace_cmd <>= module function workspace_prefix (workspace) result (prefix) type(string_t), intent(in), optional :: workspace type(string_t) :: prefix if (present (workspace)) then if (workspace /= "") then prefix = workspace // "/" else prefix = "" end if else prefix = "" end if end function workspace_prefix module function workspace_path (workspace) result (path) type(string_t), intent(in), optional :: workspace type(string_t) :: path if (present (workspace)) then if (workspace /= "") then path = workspace else path = "." end if else path = "." end if end function workspace_path module function workspace_cmd (workspace) result (cmd) type(string_t), intent(in), optional :: workspace type(string_t) :: cmd if (present (workspace)) then if (workspace /= "") then cmd = "cd " // workspace // " && " else cmd = "" end if else cmd = "" end if end function workspace_cmd @ %def workspace_prefix @ %def workspace_path @ %def workspace_cmd @ The first routine writes source-code files for the individual processes. First it calls the writer routines directly for each process, then it calls [[make source]]. The make command may either post-process the files, or it may do the complete work, e.g., calling an external program the generates the files. <>= procedure :: make_source => prclib_driver_make_source <>= module subroutine prclib_driver_make_source (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_make_source <>= module subroutine prclib_driver_make_source (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace integer :: i do i = 1, driver%n_processes call driver%record(i)%write_source_code () end do call os_system_call ( & workspace_cmd (workspace) & // "make source " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end subroutine prclib_driver_make_source @ %def prclib_driver_make_source @ Compile matrix element source code and the driver source code. As above, we first iterate through all processes and call [[before_compile]]. This is usually empty, but can execute code that depends on [[make_source]] already completed. Similarly, [[after_compile]] scans all processes again. <>= procedure :: make_compile => prclib_driver_make_compile <>= module subroutine prclib_driver_make_compile (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_make_compile <>= module subroutine prclib_driver_make_compile (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace integer :: i do i = 1, driver%n_processes call driver%record(i)%before_compile () end do call os_system_call ( & workspace_cmd (workspace) & // "make compile " // os_data%makeflags & // " -f " // driver%basename // ".makefile") do i = 1, driver%n_processes call driver%record(i)%after_compile () end do end subroutine prclib_driver_make_compile @ %def prclib_driver_make_compile @ Combine all matrix-element code together with the driver in a process library on disk. <>= procedure :: make_link => prclib_driver_make_link <>= module subroutine prclib_driver_make_link (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_make_link <>= module subroutine prclib_driver_make_link (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace integer :: i call os_system_call ( & workspace_cmd (workspace) & // "make link " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end subroutine prclib_driver_make_link @ %def prclib_driver_make_link @ \subsection{Clean up generated files} The task of cleaning any generated files should also be deferred to Makefile targets. Apart from removing everything, removing specific files may be useful for partial rebuilds. (Note that removing the makefile itself can only be done once, for obvious reasons.) If there is no makefile, do nothing. <>= procedure :: clean_library => prclib_driver_clean_library procedure :: clean_objects => prclib_driver_clean_objects procedure :: clean_source => prclib_driver_clean_source procedure :: clean_driver => prclib_driver_clean_driver procedure :: clean_makefile => prclib_driver_clean_makefile procedure :: clean => prclib_driver_clean procedure :: distclean => prclib_driver_distclean <>= module subroutine prclib_driver_clean_library (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean_library module subroutine prclib_driver_clean_objects (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean_objects module subroutine prclib_driver_clean_source (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean_source module subroutine prclib_driver_clean_driver (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean_driver module subroutine prclib_driver_clean_makefile (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean_makefile module subroutine prclib_driver_clean (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean module subroutine prclib_driver_distclean (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_distclean <>= module subroutine prclib_driver_clean_library (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make clean-library " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean_library module subroutine prclib_driver_clean_objects (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make clean-objects " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean_objects module subroutine prclib_driver_clean_source (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make clean-source " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean_source module subroutine prclib_driver_clean_driver (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make clean-driver " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean_driver module subroutine prclib_driver_clean_makefile (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make clean-makefile " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean_makefile module subroutine prclib_driver_clean (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make clean " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean module subroutine prclib_driver_distclean (driver, os_data, workspace) class(prclib_driver_t), intent(in) :: driver type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace if (driver%makefile_exists ()) then call os_system_call ( & workspace_cmd (workspace) & // "make distclean " // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_distclean @ %def prclib_driver_clean_library @ %def prclib_driver_clean_objects @ %def prclib_driver_clean_source @ %def prclib_driver_clean_driver @ %def prclib_driver_clean_makefile @ %def prclib_driver_clean @ %def prclib_driver_distclean @ This Make target should remove all files that apply to a specific process. We execute this when we want to force remaking source code. Note that source targets need not have prerequisites, so just calling [[make_source]] would not do anything if the files exist. <>= procedure :: clean_proc => prclib_driver_clean_proc <>= module subroutine prclib_driver_clean_proc (driver, i, os_data, workspace) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_clean_proc <>= module subroutine prclib_driver_clean_proc (driver, i, os_data, workspace) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace type(string_t) :: id if (driver%makefile_exists ()) then id = driver%record(i)%id call os_system_call ( & workspace_cmd (workspace) & // "make clean-" // driver%record(i)%id // " " & // os_data%makeflags & // " -f " // driver%basename // ".makefile") end if end subroutine prclib_driver_clean_proc @ %def prclib_driver_clean_proc @ \subsection{Further Tools} Check for the appropriate makefile. <>= procedure :: makefile_exists => prclib_driver_makefile_exists <>= module function prclib_driver_makefile_exists (driver, workspace) result (flag) class(prclib_driver_t), intent(in) :: driver type(string_t), intent(in), optional :: workspace logical :: flag end function prclib_driver_makefile_exists <>= module function prclib_driver_makefile_exists (driver, workspace) result (flag) class(prclib_driver_t), intent(in) :: driver type(string_t), intent(in), optional :: workspace logical :: flag inquire (file = char (workspace_prefix (workspace) & & // driver%basename) // ".makefile", & exist = flag) end function prclib_driver_makefile_exists @ %def prclib_driver_makefile_exists @ \subsection{Load the library} Once the library has been linked, we can dlopen it and assign all procedure pointers to their proper places in the library driver object. The [[loaded]] flag is set only if all required pointers have become assigned. <>= procedure :: load => prclib_driver_load <>= module subroutine prclib_driver_load (driver, os_data, noerror, workspace) class(prclib_driver_t), intent(inout) :: driver type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: noerror type(string_t), intent(in), optional :: workspace end subroutine prclib_driver_load <>= module subroutine prclib_driver_load (driver, os_data, noerror, workspace) class(prclib_driver_t), intent(inout) :: driver type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: noerror type(string_t), intent(in), optional :: workspace type(c_funptr) :: c_fptr logical :: ignore ignore = .false.; if (present (noerror)) ignore = noerror driver%libname = os_get_dlname ( & workspace_prefix (workspace) // driver%basename, & os_data, noerror, noerror) if (driver%libname == "") return select type (driver) type is (prclib_driver_dynamic_t) if (.not. dlaccess_is_open (driver%dlaccess)) then call dlaccess_init & (driver%dlaccess, workspace_path (workspace), & driver%libname, os_data) if (.not. ignore) call driver%check_dlerror () end if driver%loaded = dlaccess_is_open (driver%dlaccess) class default driver%loaded = .true. end select if (.not. driver%loaded) return c_fptr = driver%get_c_funptr (var_str ("get_n_processes")) call c_f_procpointer (c_fptr, driver%get_n_processes) driver%loaded = driver%loaded .and. associated (driver%get_n_processes) c_fptr = driver%get_c_funptr (var_str ("get_process_id_ptr")) call c_f_procpointer (c_fptr, driver%get_process_id_ptr) driver%loaded = driver%loaded .and. associated (driver%get_process_id_ptr) c_fptr = driver%get_c_funptr (var_str ("get_model_name_ptr")) call c_f_procpointer (c_fptr, driver%get_model_name_ptr) driver%loaded = driver%loaded .and. associated (driver%get_model_name_ptr) c_fptr = driver%get_c_funptr (var_str ("get_md5sum_ptr")) call c_f_procpointer (c_fptr, driver%get_md5sum_ptr) driver%loaded = driver%loaded .and. associated (driver%get_md5sum_ptr) c_fptr = driver%get_c_funptr (var_str ("get_openmp_status")) call c_f_procpointer (c_fptr, driver%get_openmp_status) driver%loaded = driver%loaded .and. associated (driver%get_openmp_status) c_fptr = driver%get_c_funptr (var_str ("get_n_in")) call c_f_procpointer (c_fptr, driver%get_n_in) driver%loaded = driver%loaded .and. associated (driver%get_n_in) c_fptr = driver%get_c_funptr (var_str ("get_n_out")) call c_f_procpointer (c_fptr, driver%get_n_out) driver%loaded = driver%loaded .and. associated (driver%get_n_out) c_fptr = driver%get_c_funptr (var_str ("get_n_flv")) call c_f_procpointer (c_fptr, driver%get_n_flv) driver%loaded = driver%loaded .and. associated (driver%get_n_flv) c_fptr = driver%get_c_funptr (var_str ("get_n_hel")) call c_f_procpointer (c_fptr, driver%get_n_hel) driver%loaded = driver%loaded .and. associated (driver%get_n_hel) c_fptr = driver%get_c_funptr (var_str ("get_n_col")) call c_f_procpointer (c_fptr, driver%get_n_col) driver%loaded = driver%loaded .and. associated (driver%get_n_col) c_fptr = driver%get_c_funptr (var_str ("get_n_cin")) call c_f_procpointer (c_fptr, driver%get_n_cin) driver%loaded = driver%loaded .and. associated (driver%get_n_cin) c_fptr = driver%get_c_funptr (var_str ("get_n_cf")) call c_f_procpointer (c_fptr, driver%get_n_cf) driver%loaded = driver%loaded .and. associated (driver%get_n_cf) c_fptr = driver%get_c_funptr (var_str ("set_flv_state_ptr")) call c_f_procpointer (c_fptr, driver%set_flv_state_ptr) driver%loaded = driver%loaded .and. associated (driver%set_flv_state_ptr) c_fptr = driver%get_c_funptr (var_str ("set_hel_state_ptr")) call c_f_procpointer (c_fptr, driver%set_hel_state_ptr) driver%loaded = driver%loaded .and. associated (driver%set_hel_state_ptr) c_fptr = driver%get_c_funptr (var_str ("set_col_state_ptr")) call c_f_procpointer (c_fptr, driver%set_col_state_ptr) driver%loaded = driver%loaded .and. associated (driver%set_col_state_ptr) c_fptr = driver%get_c_funptr (var_str ("set_color_factors_ptr")) call c_f_procpointer (c_fptr, driver%set_color_factors_ptr) driver%loaded = driver%loaded .and. associated (driver%set_color_factors_ptr) c_fptr = driver%get_c_funptr (var_str ("get_fptr")) call c_f_procpointer (c_fptr, driver%get_fptr) driver%loaded = driver%loaded .and. associated (driver%get_fptr) end subroutine prclib_driver_load @ %def prclib_driver_load @ Unload. To be sure, nullify the procedure pointers. <>= procedure :: unload => prclib_driver_unload <>= module subroutine prclib_driver_unload (driver) class(prclib_driver_t), intent(inout) :: driver end subroutine prclib_driver_unload <>= module subroutine prclib_driver_unload (driver) class(prclib_driver_t), intent(inout) :: driver select type (driver) type is (prclib_driver_dynamic_t) if (dlaccess_is_open (driver%dlaccess)) then call dlaccess_final (driver%dlaccess) call driver%check_dlerror () end if end select driver%loaded = .false. nullify (driver%get_n_processes) nullify (driver%get_process_id_ptr) nullify (driver%get_model_name_ptr) nullify (driver%get_md5sum_ptr) nullify (driver%get_openmp_status) nullify (driver%get_n_in) nullify (driver%get_n_out) nullify (driver%get_n_flv) nullify (driver%get_n_hel) nullify (driver%get_n_col) nullify (driver%get_n_cin) nullify (driver%get_n_cf) nullify (driver%set_flv_state_ptr) nullify (driver%set_hel_state_ptr) nullify (driver%set_col_state_ptr) nullify (driver%set_color_factors_ptr) nullify (driver%get_fptr) end subroutine prclib_driver_unload @ %def prclib_driver_unload @ This subroutine checks the [[dlerror]] content and issues a fatal error if it finds an error there. <>= procedure :: check_dlerror => prclib_driver_check_dlerror <>= module subroutine prclib_driver_check_dlerror (driver) class(prclib_driver_dynamic_t), intent(in) :: driver end subroutine prclib_driver_check_dlerror <>= module subroutine prclib_driver_check_dlerror (driver) class(prclib_driver_dynamic_t), intent(in) :: driver if (dlaccess_has_error (driver%dlaccess)) then call msg_fatal (char (dlaccess_get_error (driver%dlaccess))) end if end subroutine prclib_driver_check_dlerror @ %def prclib_driver_check_dlerror @ Get the handle (C function pointer) for a given ``feature'' of the matrix element code, so it can be assigned to the appropriate procedure pointer slot. In the static case, this is a trivial pointer assignment, hard-coded into the driver type implementation. <>= procedure (prclib_driver_get_c_funptr), deferred :: get_c_funptr <>= abstract interface function prclib_driver_get_c_funptr (driver, feature) result (c_fptr) import class(prclib_driver_t), intent(inout) :: driver type(string_t), intent(in) :: feature type(c_funptr) :: c_fptr end function prclib_driver_get_c_funptr end interface @ %def prclib_driver_get_c_funptr @ In the dynamic-library case, we call the DL interface to retrieve the C pointer to a named procedure. <>= procedure :: get_c_funptr => prclib_driver_dynamic_get_c_funptr <>= module function prclib_driver_dynamic_get_c_funptr & (driver, feature) result (c_fptr) class(prclib_driver_dynamic_t), intent(inout) :: driver type(string_t), intent(in) :: feature type(c_funptr) :: c_fptr end function prclib_driver_dynamic_get_c_funptr <>= module function prclib_driver_dynamic_get_c_funptr & (driver, feature) result (c_fptr) class(prclib_driver_dynamic_t), intent(inout) :: driver type(string_t), intent(in) :: feature type(c_funptr) :: c_fptr type(string_t) :: prefix, full_name prefix = lower_case (driver%basename) // "_" full_name = prefix // feature c_fptr = dlaccess_get_c_funptr (driver%dlaccess, full_name) call driver%check_dlerror () end function prclib_driver_dynamic_get_c_funptr @ %def prclib_driver_get_c_funptr @ \subsection{MD5 sums} Recall the MD5 sum written in the Makefile <>= procedure :: get_md5sum_makefile => prclib_driver_get_md5sum_makefile <>= module function prclib_driver_get_md5sum_makefile & (driver, workspace) result (md5sum) class(prclib_driver_t), intent(in) :: driver type(string_t), intent(in), optional :: workspace character(32) :: md5sum end function prclib_driver_get_md5sum_makefile <>= module function prclib_driver_get_md5sum_makefile & (driver, workspace) result (md5sum) class(prclib_driver_t), intent(in) :: driver type(string_t), intent(in), optional :: workspace character(32) :: md5sum type(string_t) :: filename character(80) :: buffer logical :: exist integer :: u, iostat md5sum = "" filename = workspace_prefix (workspace) // driver%basename // ".makefile" inquire (file = char (filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (filename), action = "read", status = "old") iostat = 0 do read (u, "(A)", iostat = iostat) buffer if (iostat /= 0) exit buffer = adjustl (buffer) select case (buffer(1:9)) case ("MD5SUM = ") read (buffer(11:), "(A32)") md5sum exit end select end do close (u) end if end function prclib_driver_get_md5sum_makefile @ %def prclib_driver_get_md5sum_makefile @ Recall the MD5 sum written in the driver source code. <>= procedure :: get_md5sum_driver => prclib_driver_get_md5sum_driver <>= module function prclib_driver_get_md5sum_driver (driver, workspace) result (md5sum) class(prclib_driver_t), intent(in) :: driver type(string_t), intent(in), optional :: workspace character(32) :: md5sum end function prclib_driver_get_md5sum_driver <>= module function prclib_driver_get_md5sum_driver (driver, workspace) result (md5sum) class(prclib_driver_t), intent(in) :: driver type(string_t), intent(in), optional :: workspace character(32) :: md5sum type(string_t) :: filename character(80) :: buffer logical :: exist integer :: u, iostat md5sum = "" filename = workspace_prefix (workspace) // driver%basename // ".f90" inquire (file = char (filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (filename), action = "read", status = "old") iostat = 0 do read (u, "(A)", iostat = iostat) buffer if (iostat /= 0) exit buffer = adjustl (buffer) select case (buffer(1:9)) case ("md5sum = ") read (buffer(11:), "(A32)") md5sum exit end select end do close (u) end if end function prclib_driver_get_md5sum_driver @ %def prclib_driver_get_md5sum_driver @ Recall the MD5 sum written in the matrix element source code. <>= procedure :: get_md5sum_source => prclib_driver_get_md5sum_source <>= module function prclib_driver_get_md5sum_source & (driver, i, workspace) result (md5sum) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i type(string_t), intent(in), optional :: workspace character(32) :: md5sum end function prclib_driver_get_md5sum_source <>= module function prclib_driver_get_md5sum_source & (driver, i, workspace) result (md5sum) class(prclib_driver_t), intent(in) :: driver integer, intent(in) :: i type(string_t), intent(in), optional :: workspace character(32) :: md5sum type(string_t) :: filename character(80) :: buffer logical :: exist integer :: u, iostat md5sum = "" filename = workspace_prefix (workspace) // driver%record(i)%id // ".f90" inquire (file = char (filename), exist = exist) if (exist) then u = free_unit () open (u, file = char (filename), action = "read", status = "old") iostat = 0 do read (u, "(A)", iostat = iostat) buffer if (iostat /= 0) exit buffer = adjustl (buffer) select case (buffer(1:9)) case ("md5sum = ") read (buffer(11:), "(A32)") md5sum exit end select end do close (u) end if end function prclib_driver_get_md5sum_source @ %def prclib_driver_get_md5sum_source @ \subsection{Unit Test} Test module, followed by the corresponding implementation module. <<[[prclib_interfaces_ut.f90]]>>= <> module prclib_interfaces_ut use kinds use system_dependencies, only: CC_IS_GNU, CC_HAS_QUADMATH use unit_tests use prclib_interfaces_uti <> <> <> contains <> end module prclib_interfaces_ut @ %def prclib_interfaces_ut @ <<[[prclib_interfaces_uti.f90]]>>= <> module prclib_interfaces_uti use, intrinsic :: iso_c_binding !NODEP! use kinds use system_dependencies, only: CC_HAS_QUADMATH, DEFAULT_FC_PRECISION <> use io_units use system_defs, only: TAB use os_interface use prclib_interfaces <> <> <> <> contains <> <> end module prclib_interfaces_uti @ %def prclib_interfaces_ut @ API: driver for the unit tests below. <>= public :: prclib_interfaces_test <>= subroutine prclib_interfaces_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine prclib_interfaces_test @ %def prclib_interfaces_test @ \subsubsection{Empty process list} Test 1: Create a driver object and display its contents. One of the feature lists references a writer procedure; this is just a dummy that does nothing useful. <>= call test (prclib_interfaces_1, "prclib_interfaces_1", & "create driver object", & u, results) <>= public :: prclib_interfaces_1 <>= subroutine prclib_interfaces_1 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver character(32), parameter :: md5sum = "prclib_interfaces_1_md5sum " class(prc_writer_t), pointer :: test_writer_1 write (u, "(A)") "* Test output: prclib_interfaces_1" write (u, "(A)") "* Purpose: display the driver object contents" write (u, *) write (u, "(A)") "* Create a prclib driver object" write (u, "(A)") call dispatch_prclib_driver (driver, var_str ("prclib"), var_str ("")) call driver%init (3) call driver%set_md5sum (md5sum) allocate (test_writer_1_t :: test_writer_1) call driver%set_record (1, var_str ("test1"), var_str ("test_model"), & [var_str ("init")], test_writer_1) call driver%set_record (2, var_str ("test2"), var_str ("foo_model"), & [var_str ("another_proc")], test_writer_1) call driver%set_record (3, var_str ("test3"), var_str ("test_model"), & [var_str ("init"), var_str ("some_proc")], test_writer_1) call driver%write (u) deallocate (test_writer_1) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_interfaces_1" end subroutine prclib_interfaces_1 @ %def prclib_interfaces_1 @ The writer: the procedures write just comment lines. We can fix an instance of this as a parameter (since it has no mutable content) and just reference the fixed parameter. NOTE: temporarily made public. <>= type, extends (prc_writer_t) :: test_writer_1_t contains procedure, nopass :: type_name => test_writer_1_type_name procedure :: write_makefile_code => test_writer_1_mk procedure :: write_source_code => test_writer_1_src procedure :: write_interface => test_writer_1_if procedure :: write_md5sum_call => test_writer_1_md5sum procedure :: write_int_sub_call => test_writer_1_int_sub procedure :: write_col_state_call => test_writer_1_col_state procedure :: write_color_factors_call => test_writer_1_col_factors procedure :: before_compile => test_writer_1_before_compile procedure :: after_compile => test_writer_1_after_compile end type test_writer_1_t @ %def test_writer_1 @ <>= function test_writer_1_type_name () result (string) type(string_t) :: string string = "test_1" end function test_writer_1_type_name subroutine test_writer_1_mk & (writer, unit, id, os_data, verbose, testflag) class(test_writer_1_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag write (unit, "(5A)") "# Makefile code for process ", char (id), & " goes here." end subroutine test_writer_1_mk subroutine test_writer_1_src (writer, id) class(test_writer_1_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_1_src subroutine test_writer_1_if (writer, unit, id, feature) class(test_writer_1_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, "(2x,9A)") "! Interface code for ", & char (id), "_", char (writer%get_procname (feature)), & " goes here." end subroutine test_writer_1_if subroutine test_writer_1_md5sum (writer, unit, id) class(test_writer_1_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") "! MD5sum call for ", char (id), " goes here." end subroutine test_writer_1_md5sum subroutine test_writer_1_int_sub (writer, unit, id, feature) class(test_writer_1_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, "(5x,9A)") "! ", char (feature), " call for ", & char (id), " goes here." end subroutine test_writer_1_int_sub subroutine test_writer_1_col_state (writer, unit, id) class(test_writer_1_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") "! col_state call for ", & char (id), " goes here." end subroutine test_writer_1_col_state subroutine test_writer_1_col_factors (writer, unit, id) class(test_writer_1_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id write (unit, "(5x,9A)") "! color_factors call for ", & char (id), " goes here." end subroutine test_writer_1_col_factors subroutine test_writer_1_before_compile (writer, id) class(test_writer_1_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_1_before_compile subroutine test_writer_1_after_compile (writer, id) class(test_writer_1_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_1_after_compile @ %def test_writer_1_type_name @ %def test_writer_1_mk test_writer_1_if @ %def test_writer_1_md5sum test_writer_1_int_sub @ %def test_writer_1_col_state test_writer_1_col_factors @ %def test_writer_1_before_compile test_writer_1_after_compile @ \subsubsection{Process library driver file} Test 2: Write the driver file for a test case with two processes. The first process needs no wrapper (C library), the second one needs wrappers (Fortran module library). <>= call test (prclib_interfaces_2, "prclib_interfaces_2", & "write driver file", & u, results) <>= public :: prclib_interfaces_2 <>= subroutine prclib_interfaces_2 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver character(32), parameter :: md5sum = "prclib_interfaces_2_md5sum " class(prc_writer_t), pointer :: test_writer_1, test_writer_2 write (u, "(A)") "* Test output: prclib_interfaces_2" write (u, "(A)") "* Purpose: check the generated driver source code" write (u, "(A)") write (u, "(A)") "* Create a prclib driver object (2 processes)" write (u, "(A)") call dispatch_prclib_driver (driver, var_str ("prclib2"), var_str ("")) call driver%init (2) call driver%set_md5sum (md5sum) allocate (test_writer_1_t :: test_writer_1) allocate (test_writer_2_t :: test_writer_2) call driver%set_record (1, var_str ("test1"), var_str ("Test_model"), & [var_str ("proc1")], test_writer_1) call driver%set_record (2, var_str ("test2"), var_str ("Test_model"), & [var_str ("proc1"), var_str ("proc2")], test_writer_2) call driver%write (u) write (u, "(A)") write (u, "(A)") "* Write the driver file" write (u, "(A)") "* File contents:" write (u, "(A)") call driver%generate_driver_code (u) deallocate (test_writer_1) deallocate (test_writer_2) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_interfaces_2" end subroutine prclib_interfaces_2 @ %def prclib_interfaces_2 @ A writer with wrapper code: the procedures again write just comment lines. Since all procedures are NOPASS, we can reuse two of the TBP. <>= type, extends (prc_writer_f_module_t) :: test_writer_2_t contains procedure, nopass :: type_name => test_writer_2_type_name procedure :: write_makefile_code => test_writer_2_mk procedure :: write_source_code => test_writer_2_src procedure :: write_interface => test_writer_2_if procedure :: write_wrapper => test_writer_2_wr procedure :: before_compile => test_writer_2_before_compile procedure :: after_compile => test_writer_2_after_compile end type test_writer_2_t @ %def test_writer_2 @ <>= function test_writer_2_type_name () result (string) type(string_t) :: string string = "test_2" end function test_writer_2_type_name subroutine test_writer_2_mk & (writer, unit, id, os_data, verbose, testflag) class(test_writer_2_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag write (unit, "(5A)") "# Makefile code for process ", char (id), & " goes here." end subroutine test_writer_2_mk subroutine test_writer_2_src (writer, id) class(test_writer_2_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_2_src subroutine test_writer_2_if (writer, unit, id, feature) class(test_writer_2_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, "(2x,9A)") "! Interface code for ", & char (writer%get_module_name (id)), "_", & char (writer%get_procname (feature)), " goes here." end subroutine test_writer_2_if subroutine test_writer_2_wr (writer, unit, id, feature) class(test_writer_2_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, *) write (unit, "(9A)") "! Wrapper code for ", & char (writer%get_c_procname (id, feature)), " goes here." end subroutine test_writer_2_wr subroutine test_writer_2_before_compile (writer, id) class(test_writer_2_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_2_before_compile subroutine test_writer_2_after_compile (writer, id) class(test_writer_2_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_2_after_compile @ %def test_writer_2_type_name test_writer_2_wr @ %def test_writer_2_before_compile test_writer_2_after_compile @ \subsubsection{Process library makefile} Test 3: Write the makefile for compiling and linking the process library (processes and driver code). There are two processes, one with one method, one with two methods. To have predictable output, we reset the system-dependent initial components of [[os_data]] to known values. <>= call test (prclib_interfaces_3, "prclib_interfaces_3", & "write makefile", & u, results) <>= public :: prclib_interfaces_3 <>= subroutine prclib_interfaces_3 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver type(os_data_t) :: os_data character(32), parameter :: md5sum = "prclib_interfaces_3_md5sum " class(prc_writer_t), pointer :: test_writer_1, test_writer_2 call os_data%init () os_data%fc = "fortran-compiler" os_data%whizard_includes = "-I module-dir" os_data%fcflags = "-C=all" os_data%fcflags_pic = "-PIC" os_data%cc = "c-compiler" os_data%cflags = "-I include-dir" os_data%cflags_pic = "-PIC" os_data%whizard_ldflags = "" os_data%ldflags = "" os_data%whizard_libtool = "my-libtool" os_data%latex = "latex -halt-on-error" os_data%mpost = "mpost --math=scaled -halt-on-error" os_data%dvips = "dvips" os_data%ps2pdf = "ps2pdf14" os_data%whizard_texpath = "" write (u, "(A)") "* Test output: prclib_interfaces_3" write (u, "(A)") "* Purpose: check the generated Makefile" write (u, *) write (u, "(A)") "* Create a prclib driver object (2 processes)" write (u, "(A)") call dispatch_prclib_driver (driver, var_str ("prclib3"), var_str ("")) call driver%init (2) call driver%set_md5sum (md5sum) allocate (test_writer_1_t :: test_writer_1) allocate (test_writer_2_t :: test_writer_2) call driver%set_record (1, var_str ("test1"), var_str ("Test_model"), & [var_str ("proc1")], test_writer_1) call driver%set_record (2, var_str ("test2"), var_str ("Test_model"), & [var_str ("proc1"), var_str ("proc2")], test_writer_2) call driver%write (u) write (u, "(A)") write (u, "(A)") "* Write Makefile" write (u, "(A)") "* File contents:" write (u, "(A)") call driver%generate_makefile (u, os_data, verbose = .true.) deallocate (test_writer_1) deallocate (test_writer_2) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_interfaces_3" end subroutine prclib_interfaces_3 @ %def prclib_interfaces_3 @ \subsubsection{Compile test with Fortran module} Test 4: Write driver and makefile and try to compile and link the library driver. There is a single test process with a single feature. The process code is provided as a Fortran module, therefore we need a wrapper for the featured procedure. <>= call test (prclib_interfaces_4, "prclib_interfaces_4", & "compile and link (Fortran module)", & u, results) <>= public :: prclib_interfaces_4 <>= subroutine prclib_interfaces_4 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver class(prc_writer_t), pointer :: test_writer_4 type(os_data_t) :: os_data integer :: u_file integer, dimension(:,:), allocatable :: flv_state integer, dimension(:,:), allocatable :: hel_state integer, dimension(:,:,:), allocatable :: col_state logical, dimension(:,:), allocatable :: ghost_flag integer, dimension(:,:), allocatable :: cf_index complex(default), dimension(:), allocatable :: color_factors character(32), parameter :: md5sum = "prclib_interfaces_4_md5sum " character(32) :: md5sum_file type(c_funptr) :: proc1_ptr interface subroutine proc1_t (n) bind(C) import integer(c_int), intent(out) :: n end subroutine proc1_t end interface procedure(proc1_t), pointer :: proc1 integer(c_int) :: n write (u, "(A)") "* Test output: prclib_interfaces_4" write (u, "(A)") "* Purpose: compile, link, and load process library" write (u, "(A)") "* with (fake) matrix-element code & &as a Fortran module" write (u, *) write (u, "(A)") "* Create a prclib driver object (1 process)" write (u, "(A)") call os_data%init () allocate (test_writer_4_t :: test_writer_4) call test_writer_4%init_test () call dispatch_prclib_driver (driver, var_str ("prclib4"), var_str ("")) call driver%init (1) call driver%set_md5sum (md5sum) call driver%set_record (1, var_str ("test4"), var_str ("Test_model"), & [var_str ("proc1")], test_writer_4) call driver%write (u) write (u, *) write (u, "(A)") "* Write Makefile" u_file = free_unit () open (u_file, file="prclib4.makefile", status="replace", action="write") call driver%generate_makefile (u_file, os_data, verbose = .false.) close (u_file) write (u, "(A)") write (u, "(A)") "* Recall MD5 sum from Makefile" write (u, "(A)") md5sum_file = driver%get_md5sum_makefile () write (u, "(1x,A,A,A)") "MD5 sum = '", md5sum_file, "'" write (u, "(A)") write (u, "(A)") "* Write driver source code" u_file = free_unit () open (u_file, file="prclib4.f90", status="replace", action="write") call driver%generate_driver_code (u_file) close (u_file) write (u, "(A)") write (u, "(A)") "* Recall MD5 sum from driver source" write (u, "(A)") md5sum_file = driver%get_md5sum_driver () write (u, "(1x,A,A,A)") "MD5 sum = '", md5sum_file, "'" write (u, "(A)") write (u, "(A)") "* Write matrix-element source code" call driver%make_source (os_data) write (u, "(A)") write (u, "(A)") "* Recall MD5 sum from matrix-element source" write (u, "(A)") md5sum_file = driver%get_md5sum_source (1) write (u, "(1x,A,A,A)") "MD5 sum = '", md5sum_file, "'" write (u, "(A)") write (u, "(A)") "* Compile source code" call driver%make_compile (os_data) write (u, "(A)") "* Link library" call driver%make_link (os_data) write (u, "(A)") "* Load library" call driver%load (os_data) write (u, *) call driver%write (u) write (u, *) if (driver%loaded) then write (u, "(A)") "* Call library functions:" write (u, *) write (u, "(1x,A,I0)") "n_processes = ", driver%get_n_processes () write (u, "(1x,A,A,A)") "process_id = '", & char (driver%get_process_id (1)), "'" write (u, "(1x,A,A,A)") "model_name = '", & char (driver%get_model_name (1)), "'" write (u, "(1x,A,A,A)") "md5sum (lib) = '", & char (driver%get_md5sum (0)), "'" write (u, "(1x,A,A,A)") "md5sum (proc) = '", & char (driver%get_md5sum (1)), "'" write (u, "(1x,A,L1)") "openmp_status = ", driver%get_openmp_status (1) write (u, "(1x,A,I0)") "n_in = ", driver%get_n_in (1) write (u, "(1x,A,I0)") "n_out = ", driver%get_n_out (1) write (u, "(1x,A,I0)") "n_flv = ", driver%get_n_flv (1) write (u, "(1x,A,I0)") "n_hel = ", driver%get_n_hel (1) write (u, "(1x,A,I0)") "n_col = ", driver%get_n_col (1) write (u, "(1x,A,I0)") "n_cin = ", driver%get_n_cin (1) write (u, "(1x,A,I0)") "n_cf = ", driver%get_n_cf (1) call driver%set_flv_state (1, flv_state) write (u, "(1x,A,10(1x,I0))") "flv_state =", flv_state call driver%set_hel_state (1, hel_state) write (u, "(1x,A,10(1x,I0))") "hel_state =", hel_state call driver%set_col_state (1, col_state, ghost_flag) write (u, "(1x,A,10(1x,I0))") "col_state =", col_state write (u, "(1x,A,10(1x,L1))") "ghost_flag =", ghost_flag call driver%set_color_factors (1, color_factors, cf_index) write (u, "(1x,A,10(1x,F5.3))") "color_factors =", color_factors write (u, "(1x,A,10(1x,I0))") "cf_index =", cf_index call driver%get_fptr (1, 1, proc1_ptr) call c_f_procpointer (proc1_ptr, proc1) if (associated (proc1)) then write (u, *) call proc1 (n) write (u, "(1x,A,I0)") "proc1(1) = ", n end if end if deallocate (test_writer_4) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_interfaces_4" end subroutine prclib_interfaces_4 @ %def prclib_interfaces_4 @ This version of test-code writer actually writes an interface and wrapper code. The wrapped function is a no-parameter function with integer result. The stored MD5 sum may be modified. We will reuse this later, therefore public. <>= public :: test_writer_4_t <>= type, extends (prc_writer_f_module_t) :: test_writer_4_t contains procedure, nopass :: type_name => test_writer_4_type_name procedure, nopass :: get_module_name => & test_writer_4_get_module_name procedure :: write_makefile_code => test_writer_4_mk procedure :: write_source_code => test_writer_4_src procedure :: write_interface => test_writer_4_if procedure :: write_wrapper => test_writer_4_wr procedure :: before_compile => test_writer_4_before_compile procedure :: after_compile => test_writer_4_after_compile end type test_writer_4_t @ %def test_writer_4 @ <>= function test_writer_4_type_name () result (string) type(string_t) :: string string = "test_4" end function test_writer_4_type_name function test_writer_4_get_module_name (id) result (name) type(string_t), intent(in) :: id type(string_t) :: name name = "tpr_" // id end function test_writer_4_get_module_name subroutine test_writer_4_mk & (writer, unit, id, os_data, verbose, testflag) class(test_writer_4_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag write (unit, "(5A)") "SOURCES += ", char (id), ".f90" write (unit, "(5A)") "OBJECTS += ", char (id), ".lo" write (unit, "(5A)") "CLEAN_SOURCES += ", char (id), ".f90" write (unit, "(5A)") "CLEAN_OBJECTS += tpr_", char (id), ".mod" write (unit, "(5A)") "CLEAN_OBJECTS += ", char (id), ".lo" write (unit, "(5A)") char (id), ".lo: ", char (id), ".f90" if (.not. verbose) then write (unit, "(5A)") TAB // '@echo " FC " $@' end if write (unit, "(5A)") TAB, "$(LTFCOMPILE) $<" end subroutine test_writer_4_mk subroutine test_writer_4_src (writer, id) class(test_writer_4_t), intent(in) :: writer type(string_t), intent(in) :: id call write_test_module_file (id, var_str ("proc1"), writer%md5sum) end subroutine test_writer_4_src subroutine test_writer_4_if (writer, unit, id, feature) class(test_writer_4_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "subroutine ", & char (writer%get_c_procname (id, feature)), & " (n) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "integer(c_int), intent(out) :: n" write (unit, "(5x,9A)") "end subroutine ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" end subroutine test_writer_4_if subroutine test_writer_4_wr (writer, unit, id, feature) class(test_writer_4_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature write (unit, *) write (unit, "(9A)") "subroutine ", & char (writer%get_c_procname (id, feature)), & " (n) bind(C)" write (unit, "(2x,9A)") "use iso_c_binding" write (unit, "(2x,9A)") "use tpr_", char (id), ", only: ", & char (writer%get_procname (feature)) write (unit, "(2x,9A)") "implicit none" write (unit, "(2x,9A)") "integer(c_int), intent(out) :: n" write (unit, "(2x,9A)") "call ", char (feature), " (n)" write (unit, "(9A)") "end subroutine ", & char (writer%get_c_procname (id, feature)) end subroutine test_writer_4_wr subroutine test_writer_4_before_compile (writer, id) class(test_writer_4_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_4_before_compile subroutine test_writer_4_after_compile (writer, id) class(test_writer_4_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_4_after_compile @ %def test_writer_2_type_name test_writer_4_wr @ %def test_writer_4_before_compile test_writer_4_after_compile @ We need a test module file (actually, one for each process in the test above) that allows us to check compilation and linking. The test module implements a colorless $1\to 2$ process, and it implements one additional function (feature), the name given as an argument. <>= subroutine write_test_module_file (basename, feature, md5sum) type(string_t), intent(in) :: basename type(string_t), intent(in) :: feature character(32), intent(in) :: md5sum integer :: u u = free_unit () open (u, file = char (basename) // ".f90", & status = "replace", action = "write") write (u, "(A)") "! (Pseudo) matrix element code file & &for WHIZARD self-test" write (u, *) write (u, "(A)") "module tpr_" // char (basename) write (u, *) write (u, "(2x,A)") "use kinds" write (u, "(2x,A)") "use omega_color, OCF => omega_color_factor" write (u, *) write (u, "(2x,A)") "implicit none" write (u, "(2x,A)") "private" write (u, *) call write_test_me_code_1 (u) write (u, *) write (u, "(2x,A)") "public :: " // char (feature) write (u, *) write (u, "(A)") "contains" write (u, *) call write_test_me_code_2 (u, md5sum) write (u, *) write (u, "(2x,A)") "subroutine " // char (feature) // " (n)" write (u, "(2x,A)") " integer, intent(out) :: n" write (u, "(2x,A)") " n = 42" write (u, "(2x,A)") "end subroutine " // char (feature) write (u, *) write (u, "(A)") "end module tpr_" // char (basename) close (u) end subroutine write_test_module_file @ %def write_test_module_file @ The following two subroutines provide building blocks for a matrix-element source code file, useful only for testing the workflow. The first routine writes the header part, the other routine the implementation of the procedures listed in the header. <>= subroutine write_test_me_code_1 (u) integer, intent(in) :: u write (u, "(2x,A)") "public :: md5sum" write (u, "(2x,A)") "public :: openmp_supported" write (u, *) write (u, "(2x,A)") "public :: n_in" write (u, "(2x,A)") "public :: n_out" write (u, "(2x,A)") "public :: n_flv" write (u, "(2x,A)") "public :: n_hel" write (u, "(2x,A)") "public :: n_cin" write (u, "(2x,A)") "public :: n_col" write (u, "(2x,A)") "public :: n_cf" write (u, *) write (u, "(2x,A)") "public :: flv_state" write (u, "(2x,A)") "public :: hel_state" write (u, "(2x,A)") "public :: col_state" write (u, "(2x,A)") "public :: color_factors" end subroutine write_test_me_code_1 subroutine write_test_me_code_2 (u, md5sum) integer, intent(in) :: u character(32), intent(in) :: md5sum write (u, "(2x,A)") "pure function md5sum ()" write (u, "(2x,A)") " character(len=32) :: md5sum" write (u, "(2x,A)") " md5sum = '" // md5sum // "'" write (u, "(2x,A)") "end function md5sum" write (u, *) write (u, "(2x,A)") "pure function openmp_supported () result (status)" write (u, "(2x,A)") " logical :: status" write (u, "(2x,A)") " status = .false." write (u, "(2x,A)") "end function openmp_supported" write (u, *) write (u, "(2x,A)") "pure function n_in () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 1" write (u, "(2x,A)") "end function n_in" write (u, *) write (u, "(2x,A)") "pure function n_out () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 2" write (u, "(2x,A)") "end function n_out" write (u, *) write (u, "(2x,A)") "pure function n_flv () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 1" write (u, "(2x,A)") "end function n_flv" write (u, *) write (u, "(2x,A)") "pure function n_hel () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 1" write (u, "(2x,A)") "end function n_hel" write (u, *) write (u, "(2x,A)") "pure function n_cin () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 2" write (u, "(2x,A)") "end function n_cin" write (u, *) write (u, "(2x,A)") "pure function n_col () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 1" write (u, "(2x,A)") "end function n_col" write (u, *) write (u, "(2x,A)") "pure function n_cf () result (n)" write (u, "(2x,A)") " integer :: n" write (u, "(2x,A)") " n = 1" write (u, "(2x,A)") "end function n_cf" write (u, *) write (u, "(2x,A)") "pure subroutine flv_state (a)" write (u, "(2x,A)") " integer, dimension(:,:), intent(out) :: a" write (u, "(2x,A)") " a = reshape ([1,2,3], [3,1])" write (u, "(2x,A)") "end subroutine flv_state" write (u, *) write (u, "(2x,A)") "pure subroutine hel_state (a)" write (u, "(2x,A)") " integer, dimension(:,:), intent(out) :: a" write (u, "(2x,A)") " a = reshape ([0,0,0], [3,1])" write (u, "(2x,A)") "end subroutine hel_state" write (u, *) write (u, "(2x,A)") "pure subroutine col_state (a, g)" write (u, "(2x,A)") " integer, dimension(:,:,:), intent(out) :: a" write (u, "(2x,A)") " logical, dimension(:,:), intent(out) :: g" write (u, "(2x,A)") " a = reshape ([0,0, 0,0, 0,0], [2,3,1])" write (u, "(2x,A)") " g = reshape ([.false., .false., .false.], [3,1])" write (u, "(2x,A)") "end subroutine col_state" write (u, *) write (u, "(2x,A)") "pure subroutine color_factors (cf)" write (u, "(2x,A)") " type(OCF), dimension(:), intent(out) :: cf" write (u, "(2x,A)") " cf = [ OCF(1,1,+1._default) ]" write (u, "(2x,A)") "end subroutine color_factors" end subroutine write_test_me_code_2 @ %def write_test_me_code_1 write_test_me_code_2 @ \subsubsection{Compile test with Fortran bind(C) library} Test 5: Write driver and makefile and try to compile and link the library driver. There is a single test process with a single feature. The process code is provided as a Fortran library of independent procedures. These procedures are bind(C). <>= call test (prclib_interfaces_5, "prclib_interfaces_5", & "compile and link (Fortran library)", & u, results) <>= public :: prclib_interfaces_5 <>= subroutine prclib_interfaces_5 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver class(prc_writer_t), pointer :: test_writer_5 type(os_data_t) :: os_data integer :: u_file integer, dimension(:,:), allocatable :: flv_state integer, dimension(:,:), allocatable :: hel_state integer, dimension(:,:,:), allocatable :: col_state logical, dimension(:,:), allocatable :: ghost_flag integer, dimension(:,:), allocatable :: cf_index complex(default), dimension(:), allocatable :: color_factors character(32), parameter :: md5sum = "prclib_interfaces_5_md5sum " type(c_funptr) :: proc1_ptr interface subroutine proc1_t (n) bind(C) import integer(c_int), intent(out) :: n end subroutine proc1_t end interface procedure(proc1_t), pointer :: proc1 integer(c_int) :: n write (u, "(A)") "* Test output: prclib_interfaces_5" write (u, "(A)") "* Purpose: compile, link, and load process library" write (u, "(A)") "* with (fake) matrix-element code & &as a Fortran bind(C) library" write (u, *) write (u, "(A)") "* Create a prclib driver object (1 process)" write (u, "(A)") call os_data%init () allocate (test_writer_5_t :: test_writer_5) call dispatch_prclib_driver (driver, var_str ("prclib5"), var_str ("")) call driver%init (1) call driver%set_md5sum (md5sum) call driver%set_record (1, var_str ("test5"), var_str ("Test_model"), & [var_str ("proc1")], test_writer_5) call driver%write (u) write (u, *) write (u, "(A)") "* Write makefile" u_file = free_unit () open (u_file, file="prclib5.makefile", status="replace", action="write") call driver%generate_makefile (u_file, os_data, verbose = .false.) close (u_file) write (u, "(A)") "* Write driver source code" u_file = free_unit () open (u_file, file="prclib5.f90", status="replace", action="write") call driver%generate_driver_code (u_file) close (u_file) write (u, "(A)") "* Write matrix-element source code" call driver%make_source (os_data) write (u, "(A)") "* Compile source code" call driver%make_compile (os_data) write (u, "(A)") "* Link library" call driver%make_link (os_data) write (u, "(A)") "* Load library" call driver%load (os_data) write (u, *) call driver%write (u) write (u, *) if (driver%loaded) then write (u, "(A)") "* Call library functions:" write (u, *) write (u, "(1x,A,I0)") "n_processes = ", driver%get_n_processes () write (u, "(1x,A,A)") "process_id = ", & char (driver%get_process_id (1)) write (u, "(1x,A,A)") "model_name = ", & char (driver%get_model_name (1)) write (u, "(1x,A,A)") "md5sum = ", & char (driver%get_md5sum (1)) write (u, "(1x,A,L1)") "openmp_status = ", driver%get_openmp_status (1) write (u, "(1x,A,I0)") "n_in = ", driver%get_n_in (1) write (u, "(1x,A,I0)") "n_out = ", driver%get_n_out (1) write (u, "(1x,A,I0)") "n_flv = ", driver%get_n_flv (1) write (u, "(1x,A,I0)") "n_hel = ", driver%get_n_hel (1) write (u, "(1x,A,I0)") "n_col = ", driver%get_n_col (1) write (u, "(1x,A,I0)") "n_cin = ", driver%get_n_cin (1) write (u, "(1x,A,I0)") "n_cf = ", driver%get_n_cf (1) call driver%set_flv_state (1, flv_state) write (u, "(1x,A,10(1x,I0))") "flv_state =", flv_state call driver%set_hel_state (1, hel_state) write (u, "(1x,A,10(1x,I0))") "hel_state =", hel_state call driver%set_col_state (1, col_state, ghost_flag) write (u, "(1x,A,10(1x,I0))") "col_state =", col_state write (u, "(1x,A,10(1x,L1))") "ghost_flag =", ghost_flag call driver%set_color_factors (1, color_factors, cf_index) write (u, "(1x,A,10(1x,F5.3))") "color_factors =", color_factors write (u, "(1x,A,10(1x,I0))") "cf_index =", cf_index call driver%get_fptr (1, 1, proc1_ptr) call c_f_procpointer (proc1_ptr, proc1) if (associated (proc1)) then write (u, *) call proc1 (n) write (u, "(1x,A,I0)") "proc1(1) = ", n end if end if deallocate (test_writer_5) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_interfaces_5" end subroutine prclib_interfaces_5 @ %def prclib_interfaces_5 @ This version of test-code writer writes interfaces for all standard features plus one specific feature. The interfaces are all bind(C), so no wrapper is needed. <>= type, extends (prc_writer_c_lib_t) :: test_writer_5_t contains procedure, nopass :: type_name => test_writer_5_type_name procedure :: write_makefile_code => test_writer_5_mk procedure :: write_source_code => test_writer_5_src procedure :: write_interface => test_writer_5_if procedure :: before_compile => test_writer_5_before_compile procedure :: after_compile => test_writer_5_after_compile end type test_writer_5_t @ %def test_writer_5 @ The <>= function test_writer_5_type_name () result (string) type(string_t) :: string string = "test_5" end function test_writer_5_type_name subroutine test_writer_5_mk & (writer, unit, id, os_data, verbose, testflag) class(test_writer_5_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag write (unit, "(5A)") "SOURCES += ", char (id), ".f90" write (unit, "(5A)") "OBJECTS += ", char (id), ".lo" write (unit, "(5A)") char (id), ".lo: ", char (id), ".f90" if (.not. verbose) then write (unit, "(5A)") TAB // '@echo " FC " $@' end if write (unit, "(5A)") TAB, "$(LTFCOMPILE) $<" end subroutine test_writer_5_mk subroutine test_writer_5_src (writer, id) class(test_writer_5_t), intent(in) :: writer type(string_t), intent(in) :: id call write_test_f_lib_file (id, var_str ("proc1")) end subroutine test_writer_5_src subroutine test_writer_5_if (writer, unit, id, feature) class(test_writer_5_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id, feature select case (char (feature)) case ("proc1") write (unit, "(2x,9A)") "interface" write (unit, "(5x,9A)") "subroutine ", & char (writer%get_c_procname (id, feature)), & " (n) bind(C)" write (unit, "(7x,9A)") "import" write (unit, "(7x,9A)") "implicit none" write (unit, "(7x,9A)") "integer(c_int), intent(out) :: n" write (unit, "(5x,9A)") "end subroutine ", & char (writer%get_c_procname (id, feature)) write (unit, "(2x,9A)") "end interface" case default call writer%write_standard_interface (unit, id, feature) end select end subroutine test_writer_5_if subroutine test_writer_5_before_compile (writer, id) class(test_writer_5_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_5_before_compile subroutine test_writer_5_after_compile (writer, id) class(test_writer_5_t), intent(in) :: writer type(string_t), intent(in) :: id end subroutine test_writer_5_after_compile @ %def test_writer_5_type_name test_writer_5_mk @ %def test_writer_5_if @ %def test_writer_5_before_compile test_writer_5_after_compile @ We need a test module file (actually, one for each process in the test above) that allows us to check compilation and linking. The test module implements a colorless $1\to 2$ process, and it implements one additional function (feature), the name given as an argument. <>= subroutine write_test_f_lib_file (basename, feature) type(string_t), intent(in) :: basename type(string_t), intent(in) :: feature integer :: u u = free_unit () open (u, file = char (basename) // ".f90", & status = "replace", action = "write") write (u, "(A)") "! (Pseudo) matrix element code file & &for WHIZARD self-test" call write_test_me_code_3 (u, char (basename)) write (u, *) write (u, "(A)") "subroutine " // char (basename) // "_" & // char (feature) // " (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int), intent(out) :: n" write (u, "(A)") " n = 42" write (u, "(A)") "end subroutine " // char (basename) // "_" & // char (feature) close (u) end subroutine write_test_f_lib_file @ %def write_test_module_file @ The following matrix-element source code is identical to the previous one, but modified such as to provide independent procedures without a module envelope. <>= subroutine write_test_me_code_3 (u, id) integer, intent(in) :: u character(*), intent(in) :: id write (u, "(A)") "function " // id // "_get_md5sum () & &result (cptr) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " type(c_ptr) :: cptr" write (u, "(A)") " character(c_char), dimension(32), & &target, save :: md5sum" write (u, "(A)") " md5sum = copy (c_char_& &'1234567890abcdef1234567890abcdef')" write (u, "(A)") " cptr = c_loc (md5sum)" write (u, "(A)") "contains" write (u, "(A)") " function copy (md5sum)" write (u, "(A)") " character(c_char), dimension(32) :: copy" write (u, "(A)") " character(c_char), dimension(32), intent(in) :: & &md5sum" write (u, "(A)") " copy = md5sum" write (u, "(A)") " end function copy" write (u, "(A)") "end function " // id // "_get_md5sum" write (u, *) write (u, "(A)") "function " // id // "_openmp_supported () & &result (status) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " logical(c_bool) :: status" write (u, "(A)") " status = .false." write (u, "(A)") "end function " // id // "_openmp_supported" write (u, *) write (u, "(A)") "function " // id // "_n_in () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 1" write (u, "(A)") "end function " // id // "_n_in" write (u, *) write (u, "(A)") "function " // id // "_n_out () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 2" write (u, "(A)") "end function " // id // "_n_out" write (u, *) write (u, "(A)") "function " // id // "_n_flv () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 1" write (u, "(A)") "end function " // id // "_n_flv" write (u, *) write (u, "(A)") "function " // id // "_n_hel () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 1" write (u, "(A)") "end function " // id // "_n_hel" write (u, *) write (u, "(A)") "function " // id // "_n_cin () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 2" write (u, "(A)") "end function " // id // "_n_cin" write (u, *) write (u, "(A)") "function " // id // "_n_col () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 1" write (u, "(A)") "end function " // id // "_n_col" write (u, *) write (u, "(A)") "function " // id // "_n_cf () result (n) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int) :: n" write (u, "(A)") " n = 1" write (u, "(A)") "end function " // id // "_n_cf" write (u, *) write (u, "(A)") "subroutine " // id // "_flv_state (flv_state) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int), dimension(*), intent(out) :: flv_state" write (u, "(A)") " flv_state(1:3) = [1,2,3]" write (u, "(A)") "end subroutine " // id // "_flv_state" write (u, *) write (u, "(A)") "subroutine " // id // "_hel_state (hel_state) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int), dimension(*), intent(out) :: hel_state" write (u, "(A)") " hel_state(1:3) = [0,0,0]" write (u, "(A)") "end subroutine " // id // "_hel_state" write (u, *) write (u, "(A)") "subroutine " // id // "_col_state & &(col_state, ghost_flag) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int), dimension(*), intent(out) & &:: col_state" write (u, "(A)") " logical(c_bool), dimension(*), intent(out) & &:: ghost_flag" write (u, "(A)") " col_state(1:6) = [0,0, 0,0, 0,0]" write (u, "(A)") " ghost_flag(1:3) = [.false., .false., .false.]" write (u, "(A)") "end subroutine " // id // "_col_state" write (u, *) write (u, "(A)") "subroutine " // id // "_color_factors & &(cf_index1, cf_index2, color_factors) bind(C)" write (u, "(A)") " use iso_c_binding" write (u, "(A)") " use kinds" write (u, "(A)") " implicit none" write (u, "(A)") " integer(c_int), dimension(*), intent(out) :: cf_index1" write (u, "(A)") " integer(c_int), dimension(*), intent(out) :: cf_index2" write (u, "(A)") " complex(c_default_complex), dimension(*), & &intent(out) :: color_factors" write (u, "(A)") " cf_index1(1:1) = [1]" write (u, "(A)") " cf_index2(1:1) = [1]" write (u, "(A)") " color_factors(1:1) = [1]" write (u, "(A)") "end subroutine " // id // "_color_factors" end subroutine write_test_me_code_3 @ %def write_test_me_code_3 @ \subsubsection{Compile test with genuine C library} Test 6: Write driver and makefile and try to compile and link the library driver. There is a single test process with a single feature. The process code is provided as a C library of independent procedures. These procedures should match the Fortran bind(C) interface. <>= if (default == double .or. (CC_IS_GNU .and. CC_HAS_QUADMATH)) then call test (prclib_interfaces_6, "prclib_interfaces_6", & "compile and link (C library)", & u, results) end if <>= public :: prclib_interfaces_6 <>= subroutine prclib_interfaces_6 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver class(prc_writer_t), pointer :: test_writer_6 type(os_data_t) :: os_data integer :: u_file integer, dimension(:,:), allocatable :: flv_state integer, dimension(:,:), allocatable :: hel_state integer, dimension(:,:,:), allocatable :: col_state logical, dimension(:,:), allocatable :: ghost_flag integer, dimension(:,:), allocatable :: cf_index complex(default), dimension(:), allocatable :: color_factors character(32), parameter :: md5sum = "prclib_interfaces_6_md5sum " type(c_funptr) :: proc1_ptr interface subroutine proc1_t (n) bind(C) import integer(c_int), intent(out) :: n end subroutine proc1_t end interface procedure(proc1_t), pointer :: proc1 integer(c_int) :: n write (u, "(A)") "* Test output: prclib_interfaces_6" write (u, "(A)") "* Purpose: compile, link, and load process library" write (u, "(A)") "* with (fake) matrix-element code & &as a C library" write (u, *) write (u, "(A)") "* Create a prclib driver object (1 process)" write (u, "(A)") call os_data%init () allocate (test_writer_6_t :: test_writer_6) call dispatch_prclib_driver (driver, var_str ("prclib6"), var_str ("")) call driver%init (1) call driver%set_md5sum (md5sum) call driver%set_record (1, var_str ("test6"), var_str ("Test_model"), & [var_str ("proc1")], test_writer_6) call driver%write (u) write (u, *) write (u, "(A)") "* Write makefile" u_file = free_unit () open (u_file, file="prclib6.makefile", status="replace", action="write") call driver%generate_makefile (u_file, os_data, verbose = .false.) close (u_file) write (u, "(A)") "* Write driver source code" u_file = free_unit () open (u_file, file="prclib6.f90", status="replace", action="write") call driver%generate_driver_code (u_file) close (u_file) write (u, "(A)") "* Write matrix-element source code" call driver%make_source (os_data) write (u, "(A)") "* Compile source code" call driver%make_compile (os_data) write (u, "(A)") "* Link library" call driver%make_link (os_data) write (u, "(A)") "* Load library" call driver%load (os_data) write (u, *) call driver%write (u) write (u, *) if (driver%loaded) then write (u, "(A)") "* Call library functions:" write (u, *) write (u, "(1x,A,I0)") "n_processes = ", driver%get_n_processes () write (u, "(1x,A,A)") "process_id = ", & char (driver%get_process_id (1)) write (u, "(1x,A,A)") "model_name = ", & char (driver%get_model_name (1)) write (u, "(1x,A,A)") "md5sum = ", & char (driver%get_md5sum (1)) write (u, "(1x,A,L1)") "openmp_status = ", driver%get_openmp_status (1) write (u, "(1x,A,I0)") "n_in = ", driver%get_n_in (1) write (u, "(1x,A,I0)") "n_out = ", driver%get_n_out (1) write (u, "(1x,A,I0)") "n_flv = ", driver%get_n_flv (1) write (u, "(1x,A,I0)") "n_hel = ", driver%get_n_hel (1) write (u, "(1x,A,I0)") "n_col = ", driver%get_n_col (1) write (u, "(1x,A,I0)") "n_cin = ", driver%get_n_cin (1) write (u, "(1x,A,I0)") "n_cf = ", driver%get_n_cf (1) call driver%set_flv_state (1, flv_state) write (u, "(1x,A,10(1x,I0))") "flv_state =", flv_state call driver%set_hel_state (1, hel_state) write (u, "(1x,A,10(1x,I0))") "hel_state =", hel_state call driver%set_col_state (1, col_state, ghost_flag) write (u, "(1x,A,10(1x,I0))") "col_state =", col_state write (u, "(1x,A,10(1x,L1))") "ghost_flag =", ghost_flag call driver%set_color_factors (1, color_factors, cf_index) write (u, "(1x,A,10(1x,F5.3))") "color_factors =", color_factors write (u, "(1x,A,10(1x,I0))") "cf_index =", cf_index call driver%get_fptr (1, 1, proc1_ptr) call c_f_procpointer (proc1_ptr, proc1) if (associated (proc1)) then write (u, *) call proc1 (n) write (u, "(1x,A,I0)") "proc1(1) = ", n end if end if deallocate (test_writer_6) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_interfaces_6" end subroutine prclib_interfaces_6 @ %def prclib_interfaces_6 @ This version of test-code writer writes interfaces for all standard features plus one specific feature. The interfaces are all bind(C), so no wrapper is needed. The driver part is identical to the Fortran case, so we simply extend the previous [[test_writer_5]] type. We only have to override the Makefile writer. <>= type, extends (test_writer_5_t) :: test_writer_6_t contains procedure, nopass :: type_name => test_writer_6_type_name procedure :: write_makefile_code => test_writer_6_mk procedure :: write_source_code => test_writer_6_src end type test_writer_6_t @ %def test_writer_6 @ <>= function test_writer_6_type_name () result (string) type(string_t) :: string string = "test_6" end function test_writer_6_type_name subroutine test_writer_6_mk & (writer, unit, id, os_data, verbose, testflag) class(test_writer_6_t), intent(in) :: writer integer, intent(in) :: unit type(string_t), intent(in) :: id type(os_data_t), intent(in) :: os_data logical, intent(in) :: verbose logical, intent(in), optional :: testflag write (unit, "(5A)") "SOURCES += ", char (id), ".c" write (unit, "(5A)") "OBJECTS += ", char (id), ".lo" write (unit, "(5A)") char (id), ".lo: ", char (id), ".c" if (.not. verbose) then write (unit, "(5A)") TAB // '@echo " FC " $@' end if write (unit, "(5A)") TAB, "$(LTCCOMPILE) $<" end subroutine test_writer_6_mk subroutine test_writer_6_src (writer, id) class(test_writer_6_t), intent(in) :: writer type(string_t), intent(in) :: id call write_test_c_lib_file (id, var_str ("proc1")) end subroutine test_writer_6_src @ %def test_writer_6_type_name test_writer_6_mk @ We need a test module file (actually, one for each process in the test above) that allows us to check compilation and linking. The test module implements a colorless $1\to 2$ process, and it implements one additional function (feature), the name given as an argument. <>= subroutine write_test_c_lib_file (basename, feature) type(string_t), intent(in) :: basename type(string_t), intent(in) :: feature integer :: u u = free_unit () open (u, file = char (basename) // ".c", & status = "replace", action = "write") write (u, "(A)") "/* (Pseudo) matrix element code file & &for WHIZARD self-test */" write (u, "(A)") "#include " if (CC_HAS_QUADMATH) then write (u, "(A)") "#include " end if write (u, *) call write_test_me_code_4 (u, char (basename)) write (u, *) write (u, "(A)") "void " // char (basename) // "_" & // char (feature) // "(int* n) {" write (u, "(A)") " *n = 42;" write (u, "(A)") "}" close (u) end subroutine write_test_c_lib_file @ %def write_test_module_file @ The following matrix-element source code is equivalent to the code in the previous example, but coded in C. <>= subroutine write_test_me_code_4 (u, id) integer, intent(in) :: u character(*), intent(in) :: id write (u, "(A)") "char* " // id // "_get_md5sum() {" write (u, "(A)") " return ""1234567890abcdef1234567890abcdef"";" write (u, "(A)") "}" write (u, *) write (u, "(A)") "bool " // id // "_openmp_supported() {" write (u, "(A)") " return false;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_in() {" write (u, "(A)") " return 1;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_out() {" write (u, "(A)") " return 2;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_flv() {" write (u, "(A)") " return 1;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_hel() {" write (u, "(A)") " return 1;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_cin() {" write (u, "(A)") " return 2;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_col() {" write (u, "(A)") " return 1;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "int " // id // "_n_cf() {" write (u, "(A)") " return 1;" write (u, "(A)") "}" write (u, *) write (u, "(A)") "void " // id // "_flv_state( int (*a)[] ) {" write (u, "(A)") " static int flv_state[1][3] = { { 1, 2, 3 } };" write (u, "(A)") " int j;" write (u, "(A)") " for (j = 0; j < 3; j++) { (*a)[j] & &= flv_state[0][j]; }" write (u, "(A)") "}" write (u, *) write (u, "(A)") "void " // id // "_hel_state( int (*a)[] ) {" write (u, "(A)") " static int hel_state[1][3] = { { 0, 0, 0 } };" write (u, "(A)") " int j;" write (u, "(A)") " for (j = 0; j < 3; j++) { (*a)[j] & &= hel_state[0][j]; }" write (u, "(A)") "}" write (u, *) write (u, "(A)") "void " // id // "_col_state& &( int (*a)[], bool (*g)[] ) {" write (u, "(A)") " static int col_state[1][3][2] = & &{ { {0, 0}, {0, 0}, {0, 0} } };" write (u, "(A)") " static bool ghost_flag[1][3] = & &{ { false, false, false } };" write (u, "(A)") " int j,k;" write (u, "(A)") " for (j = 0; j < 3; j++) {" write (u, "(A)") " for (k = 0; k < 2; k++) {" write (u, "(A)") " (*a)[j*2+k] = col_state[0][j][k];" write (u, "(A)") " }" write (u, "(A)") " (*g)[j] = ghost_flag[0][j];" write (u, "(A)") " }" write (u, "(A)") "}" write (u, *) select case (DEFAULT_FC_PRECISION) case ("quadruple") write (u, "(A)") "void " // id // "_color_factors& &( int (*cf_index1)[], int (*cf_index2)[], & &__complex128 (*color_factors)[] ) {" case ("extended") write (u, "(A)") "void " // id // "_color_factors& &( int (*cf_index1)[], int (*cf_index2)[], & &long double _Complex (*color_factors)[] ) {" case default write (u, "(A)") "void " // id // "_color_factors& &( int (*cf_index1)[], int (*cf_index2)[], & &double _Complex (*color_factors)[] ) {" end select write (u, "(A)") " (*color_factors)[0] = 1;" write (u, "(A)") " (*cf_index1)[0] = 1;" write (u, "(A)") " (*cf_index2)[0] = 1;" write (u, "(A)") "}" end subroutine write_test_me_code_4 @ %def write_test_me_code_4 @ \subsubsection{Test cleanup targets} Test 7: Repeat test 4 (create, compile, link Fortran module and driver) and properly clean up all generated files. <>= call test (prclib_interfaces_7, "prclib_interfaces_7", & "cleanup", & u, results) <>= public :: prclib_interfaces_7 <>= subroutine prclib_interfaces_7 (u) integer, intent(in) :: u class(prclib_driver_t), allocatable :: driver class(prc_writer_t), pointer :: test_writer_4 type(os_data_t) :: os_data integer :: u_file character(32), parameter :: md5sum = "1234567890abcdef1234567890abcdef" write (u, "(A)") "* Test output: prclib_interfaces_7" write (u, "(A)") "* Purpose: compile and link process library" write (u, "(A)") "* with (fake) matrix-element code & &as a Fortran module" write (u, "(A)") "* then clean up generated files" write (u, *) write (u, "(A)") "* Create a prclib driver object (1 process)" allocate (test_writer_4_t :: test_writer_4) call os_data%init () call dispatch_prclib_driver (driver, var_str ("prclib7"), var_str ("")) call driver%init (1) call driver%set_md5sum (md5sum) call driver%set_record (1, var_str ("test7"), var_str ("Test_model"), & [var_str ("proc1")], test_writer_4) write (u, "(A)") "* Write makefile" u_file = free_unit () open (u_file, file="prclib7.makefile", status="replace", action="write") call driver%generate_makefile (u_file, os_data, verbose = .false.) close (u_file) write (u, "(A)") "* Write driver source code" u_file = free_unit () open (u_file, file="prclib7.f90", status="replace", action="write") call driver%generate_driver_code (u_file) close (u_file) write (u, "(A)") "* Write matrix-element source code" call driver%make_source (os_data) write (u, "(A)") "* Compile source code" call driver%make_compile (os_data) write (u, "(A)") "* Link library" call driver%make_link (os_data) write (u, "(A)") "* File check" write (u, *) call check_file (u, "test7.f90") call check_file (u, "tpr_test7.mod") call check_file (u, "test7.lo") call check_file (u, "prclib7.makefile") call check_file (u, "prclib7.f90") call check_file (u, "prclib7.lo") call check_file (u, "prclib7.la") write (u, *) write (u, "(A)") "* Delete library" write (u, *) call driver%clean_library (os_data) call check_file (u, "prclib7.la") write (u, *) write (u, "(A)") "* Delete object code" write (u, *) call driver%clean_objects (os_data) call check_file (u, "test7.lo") call check_file (u, "tpr_test7.mod") call check_file (u, "prclib7.lo") write (u, *) write (u, "(A)") "* Delete source code" write (u, *) call driver%clean_source (os_data) call check_file (u, "test7.f90") write (u, *) write (u, "(A)") "* Delete driver source code" write (u, *) call driver%clean_driver (os_data) call check_file (u, "prclib7.f90") write (u, *) write (u, "(A)") "* Delete makefile" write (u, *) call driver%clean_makefile (os_data) call check_file (u, "prclib7.makefile") deallocate (test_writer_4) write (u, *) write (u, "(A)") "* Test output end: prclib_interfaces_7" end subroutine prclib_interfaces_7 @ %def prclib_interfaces_7 @ Auxiliary routine: check and report existence of a file <>= subroutine check_file (u, file) integer, intent(in) :: u character(*), intent(in) :: file logical :: exist inquire (file=file, exist=exist) write (u, "(2x,A,A,L1)") file, " = ", exist end subroutine check_file @ %def check_file @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Abstract process core configuration} In this module, we define abstract data types that handle the method-specific part of defining a process (including all of its options) and accessing an external matrix element. There are no unit tests, these are deferred to the [[process_libraries]] module below. <<[[prc_core_def.f90]]>>= <> module prc_core_def <> use process_constants use prclib_interfaces <> <> <> <> interface <> end interface end module prc_core_def @ %def prc_core_def @ <<[[prc_core_def_sub.f90]]>>= <> submodule (prc_core_def) prc_core_def_s use io_units use diagnostics implicit none contains <> end submodule prc_core_def_s @ %def prc_core_def_s @ \subsection{Process core definition type} For storing configuration data that depend on the specific process variant, we introduce a polymorphic type. At this point, we just declare an abstract base type. This allows us to defer the implementation to later modules. There should be no components that need explicit finalization, otherwise we would have to call a finalizer from the [[process_component_def_t]] wrapper. @ Translate a [[prc_core_def_t]] to above named integers <>= public :: prc_core_def_t <>= type, abstract :: prc_core_def_t class(prc_writer_t), allocatable :: writer contains <> end type prc_core_def_t @ %def prc_core_def_t @ Interfaces for the deferred methods. This returns a string. No passed argument; the string is constant and depends just on the type. <>= procedure (prc_core_def_get_string), nopass, deferred :: type_string <>= abstract interface function prc_core_def_get_string () result (string) import type(string_t) :: string end function prc_core_def_get_string end interface @ %def prc_core_def_get_string @ The [[write]] method should display the content completely. <>= procedure (prc_core_def_write), deferred :: write <>= abstract interface subroutine prc_core_def_write (object, unit) import class(prc_core_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine prc_core_def_write end interface @ %def prc_core_def_write @ The [[read]] method should fill the content completely. <>= procedure (prc_core_def_read), deferred :: read <>= abstract interface subroutine prc_core_def_read (object, unit) import class(prc_core_def_t), intent(out) :: object integer, intent(in) :: unit end subroutine prc_core_def_read end interface @ %def prc_core_def_read @ This communicates a MD5 checksum to the writer inside the [[core_def]] object, if there is any. Usually, this checksum is not yet known at the time when the writer is initialized. <>= procedure :: set_md5sum => prc_core_def_set_md5sum <>= module subroutine prc_core_def_set_md5sum (core_def, md5sum) class(prc_core_def_t), intent(inout) :: core_def character(32) :: md5sum end subroutine prc_core_def_set_md5sum <>= module subroutine prc_core_def_set_md5sum (core_def, md5sum) class(prc_core_def_t), intent(inout) :: core_def character(32) :: md5sum if (allocated (core_def%writer)) core_def%writer%md5sum = md5sum end subroutine prc_core_def_set_md5sum @ %def prc_core_def_set_md5sum @ Allocate an appropriate driver object which corresponds to the chosen process core definition. For internal matrix element (i.e., those which do not need external code), the driver should have access to all matrix element information from the beginning. In short, it is the matrix-element code. For external matrix elements, the driver will get access to the external matrix element code. <>= procedure(prc_core_def_allocate_driver), deferred :: allocate_driver <>= abstract interface subroutine prc_core_def_allocate_driver (object, driver, basename) import class(prc_core_def_t), intent(in) :: object class(prc_core_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename end subroutine prc_core_def_allocate_driver end interface @ %def prc_core_def_allocate_driver @ This flag tells whether the particular variant needs external code. We implement a default function which returns false. The flag depends only on the type, therefore we implement it as [[nopass]]. <>= procedure, nopass :: needs_code => prc_core_def_needs_code <>= module function prc_core_def_needs_code () result (flag) logical :: flag end function prc_core_def_needs_code <>= module function prc_core_def_needs_code () result (flag) logical :: flag flag = .false. end function prc_core_def_needs_code @ %def prc_core_def_needs_code @ This subroutine allocates an array which holds the name of all features that this process core implements. This feature applies to matrix element code that is not coded as a Fortran module but communicates via independent library functions, which follow the C calling conventions. The addresses of those functions are returned as C function pointers, which can be converted into Fortran procedure pointers. The conversion is done in code specific for the process variant; here we just retrieve the C function pointer. The array returned here serves the purpose of writing specific driver code. The driver interfaces only those C functions which are supported for the given process core. If the process core does not require external code, this array is meaningless. <>= procedure(prc_core_def_get_features), nopass, deferred & :: get_features <>= abstract interface subroutine prc_core_def_get_features (features) import type(string_t), dimension(:), allocatable, intent(out) :: features end subroutine prc_core_def_get_features end interface @ %def prc_core_def_get_features @ Assign pointers to the process-specific procedures to the driver, if the process is external. <>= procedure(prc_core_def_connect), deferred :: connect <>= abstract interface subroutine prc_core_def_connect (def, lib_driver, i, proc_driver) import class(prc_core_def_t), intent(in) :: def class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver end subroutine prc_core_def_connect end interface @ %def prc_core_def_connect @ \subsection{Process core template} We must be able to automatically allocate a process core definition object with the appropriate type, given only the type name. To this end, we introduce a [[prc_template_t]] type which is simply a wrapper for an empty [[prc_core_def_t]] object. Choosing one of the templates from an array, we can allocate the target object. <>= public :: prc_template_t <>= type :: prc_template_t class(prc_core_def_t), allocatable :: core_def end type prc_template_t @ %def prc_template_t @ The allocation routine. We use the [[source]] option of the [[allocate]] statement. The [[mold]] option would probably more appropriate, but is a F2008 feature. <>= public :: allocate_core_def <>= module subroutine allocate_core_def (template, name, core_def) type(prc_template_t), dimension(:), intent(in) :: template type(string_t), intent(in) :: name class(prc_core_def_t), allocatable :: core_def end subroutine allocate_core_def <>= module subroutine allocate_core_def (template, name, core_def) type(prc_template_t), dimension(:), intent(in) :: template type(string_t), intent(in) :: name class(prc_core_def_t), allocatable :: core_def integer :: i do i = 1, size (template) if (template(i)%core_def%type_string () == name) then allocate (core_def, source = template(i)%core_def) return end if end do end subroutine allocate_core_def @ %def allocate_core_def @ \subsection{Process driver} For each process component, we implement a driver object which holds the calls to the matrix element and various auxiliary routines as procedure pointers. Any actual calculation will use this object to communicate with the process. Depending on the type of process (as described by a corresponding [[prc_core_def]] object), the procedure pointers may refer to external or internal code, and there may be additional procedures for certain types. The base type defined here is abstract. <>= public :: prc_core_driver_t <>= type, abstract :: prc_core_driver_t contains <> end type prc_core_driver_t @ %def prc_core_driver_t @ This returns the process type. No reference to contents. <>= procedure(prc_core_driver_type_name), nopass, deferred :: type_name <>= abstract interface function prc_core_driver_type_name () result (type) import type(string_t) :: type end function prc_core_driver_type_name end interface @ %def prc_core_driver_type_name @ \subsection{Process driver for intrinsic process} This is an abstract extension for the driver type. It has one additional method, namely a subroutine that fills the record of constant process data. For an external process, this task is performed by the external library driver instead. <>= public :: process_driver_internal_t <>= type, extends (prc_core_driver_t), abstract :: process_driver_internal_t contains <> end type process_driver_internal_t @ %def process_driver_internal_t <>= procedure(process_driver_fill_constants), deferred :: fill_constants <>= abstract interface subroutine process_driver_fill_constants (driver, data) import class(process_driver_internal_t), intent(in) :: driver type(process_constants_t), intent(out) :: data end subroutine process_driver_fill_constants end interface @ %def process_driver_fill_constants @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process library access} \label{sec:process_libraries} Processes (the code and data that are necessary for evaluating matrix elements of a particular process or process component) are organized in process libraries. In full form, process libraries contain generated and dynamically compiled and linked code, so they are actual libraries on the OS level. Alternatively, there may be simple processes that can be generated without referring to external libraries, and external libraries that are just linked in. This module interfaces the OS to create, build, and use process libraries. We work with two related data structures. There is the list of process configurations that stores the user input and data derived from it. A given process configuration list is scanned for creating a process library, which consists of both data and code. The creation step involves calling external programs and incorporating external code. For the subsequent integration and event generation steps, we read the process library. We also support partial (re)creation of the process library. To this end, we should be able to reconstruct the configuration data records from the process library. <<[[process_libraries.f90]]>>= <> module process_libraries use, intrinsic :: iso_c_binding !NODEP! <> use physics_defs use os_interface use model_data use particle_specifiers use process_constants use prclib_interfaces use prc_core_def <> <> <> <> interface <> end interface end module process_libraries @ %def process_libraries @ <<[[process_libraries_sub.f90]]>>= <> submodule (process_libraries) process_libraries_s use io_units use diagnostics use md5 implicit none contains <> end submodule process_libraries_s @ %def process_libraries_s @ \subsection{Auxiliary stuff} Here is a small subroutine that strips the left-hand side and the equals sign off an equation. <>= public :: strip_equation_lhs <>= module subroutine strip_equation_lhs (buffer) character(*), intent(inout) :: buffer end subroutine strip_equation_lhs <>= module subroutine strip_equation_lhs (buffer) character(*), intent(inout) :: buffer type(string_t) :: string, prefix string = buffer call split (string, prefix, "=") buffer = string end subroutine strip_equation_lhs @ %def strip_equation_lhs @ \subsection{Process definition objects} We collect process configuration data in a derived type, [[process_def_t]]. A process can be a collection of several components which are treated as a single entity for the purpose of observables and event generation. Multiple process components may initially be defined by the user. The system may add additional components, e.g., subtraction terms. The common data type is [[process_component_def_t]]. Within each component, there are several universal data items, and a part which depend on the particular process variant. The latter is covered by an abstract type [[prc_core_def_t]] and its extensions. @ \subsubsection{Wrapper for components} We define a wrapper type for the configuration of individual components. The string [[basename]] is used for building file, module, and function names for the current process component. Initially, it will be built from the corresponding process basename by appending an alphanumeric suffix. The logical [[initial]] tells whether this is a user-defined (true) or system-generated (false) configuration. The numbers [[n_in]], [[n_out]], and [[n_tot]] denote the incoming, outgoing and total number of particles (partons) participating in the process component, respectively. These are the nominal particles, as input by the user (recombination may change the particle content, for the output events). The string arrays [[prt_in]] and [[prt_out]] hold the particle specifications as provided by the user. For a system-generated process component, they remain deallocated. The [[method]] string is used to determine the type of process matrix element and how it is obtained. The [[description]] string collects the information about particle content and method in a single human-readable string. The pointer object [[core_def]] is allocated according to the actual process variant, which depends on the method. The subobject holds any additional configuration data that is relevant for the process component. We assume that no finalizer is needed. <>= public :: process_component_def_t <>= type :: process_component_def_t private type(string_t) :: basename logical :: initial = .false. integer :: n_in = 0 integer :: n_out = 0 integer :: n_tot = 0 type(prt_spec_t), dimension(:), allocatable :: prt_in type(prt_spec_t), dimension(:), allocatable :: prt_out type(string_t) :: method type(string_t) :: description class(prc_core_def_t), allocatable :: core_def character(32) :: md5sum = "" integer :: nlo_type = BORN integer, dimension(N_ASSOCIATED_COMPONENTS) :: associated_components = 0 logical :: active integer :: fixed_emitter = -1 integer :: alpha_power = 0 integer :: alphas_power = 0 contains <> end type process_component_def_t @ %def process_component_def_t @ Display the complete content. <>= procedure :: write => process_component_def_write <>= module subroutine process_component_def_write (object, unit) class(process_component_def_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine process_component_def_write <>= module subroutine process_component_def_write (object, unit) class(process_component_def_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(3x,A,A)") "Component ID = ", char (object%basename) write (u, "(3x,A,L1)") "Initial component = ", object%initial write (u, "(3x,A,I0,1x,I0,1x,I0)") "N (in, out, tot) = ", & object%n_in, object%n_out, object%n_tot write (u, "(3x,A)", advance="no") "Particle content = " if (allocated (object%prt_in)) then call prt_spec_write (object%prt_in, u, advance="no") else write (u, "(A)", advance="no") "[undefined]" end if write (u, "(A)", advance="no") " => " if (allocated (object%prt_out)) then call prt_spec_write (object%prt_out, u, advance="no") else write (u, "(A)", advance="no") "[undefined]" end if write (u, "(A)") if (object%method /= "") then write (u, "(3x,A,A)") "Method = ", & char (object%method) else write (u, "(3x,A)") "Method = [undefined]" end if if (allocated (object%core_def)) then write (u, "(3x,A,A)") "Process variant = ", & char (object%core_def%type_string ()) call object%core_def%write (u) else write (u, "(3x,A)") "Process variant = [undefined]" end if write (u, "(3x,A,A,A)") "MD5 sum (def) = '", object%md5sum, "'" end subroutine process_component_def_write @ %def process_component_def_write @ Read the process component definition. Allocate the process variant definition with appropriate type, matching the type name on file with the provided templates. <>= procedure :: read => process_component_def_read <>= module subroutine process_component_def_read (component, unit, core_def_templates) class(process_component_def_t), intent(out) :: component integer, intent(in) :: unit type(prc_template_t), dimension(:), intent(in) :: core_def_templates end subroutine process_component_def_read <>= module subroutine process_component_def_read (component, unit, core_def_templates) class(process_component_def_t), intent(out) :: component integer, intent(in) :: unit type(prc_template_t), dimension(:), intent(in) :: core_def_templates character(80) :: buffer type(string_t) :: var_buffer, prefix, in_state, out_state type(string_t) :: variant_type read (unit, "(A)") buffer call strip_equation_lhs (buffer) component%basename = trim (adjustl (buffer)) read (unit, "(A)") buffer call strip_equation_lhs (buffer) read (buffer, *) component%initial read (unit, "(A)") buffer call strip_equation_lhs (buffer) read (buffer, *) component%n_in, component%n_out, component%n_tot call get (unit, var_buffer) call split (var_buffer, prefix, "=") ! keeps 'in => out' call split (var_buffer, prefix, "=") ! actually: separator is '=>' in_state = prefix if (component%n_in > 0) then call prt_spec_read (component%prt_in, in_state) end if out_state = extract (var_buffer, 2) if (component%n_out > 0) then call prt_spec_read (component%prt_out, out_state) end if read (unit, "(A)") buffer call strip_equation_lhs (buffer) component%method = trim (adjustl (buffer)) if (component%method == "[undefined]") & component%method = "" read (unit, "(A)") buffer call strip_equation_lhs (buffer) variant_type = trim (adjustl (buffer)) call allocate_core_def & (core_def_templates, variant_type, component%core_def) if (allocated (component%core_def)) then call component%core_def%read (unit) end if read (unit, "(A)") buffer call strip_equation_lhs (buffer) read (buffer(3:34), "(A32)") component%md5sum end subroutine process_component_def_read @ %def process_component_def_read @ Short account. <>= procedure :: show => process_component_def_show <>= module subroutine process_component_def_show (object, unit) class(process_component_def_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine process_component_def_show <>= module subroutine process_component_def_show (object, unit) class(process_component_def_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(6x,A)", advance="no") char (object%basename) if (.not. object%initial) & write (u, "('*')", advance="no") write (u, "(':',1x)", advance="no") if (allocated (object%prt_in)) then call prt_spec_write (object%prt_in, u, advance="no") else write (u, "(A)", advance="no") "[undefined]" end if write (u, "(A)", advance="no") " => " if (allocated (object%prt_out)) then call prt_spec_write (object%prt_out, u, advance="no") else write (u, "(A)", advance="no") "[undefined]" end if if (object%method /= "") then write (u, "(2x,'[',A,']')") char (object%method) else write (u, *) end if end subroutine process_component_def_show @ %def process_component_def_show @ Compute the MD5 sum of a process component. We reset the stored MD5 sum to the empty string (so a previous value is not included in the calculation), then write a temporary file and calculate the MD5 sum of that file. This implies that all data that are displayed by the [[write]] method become part of the MD5 sum calculation. The [[model]] is not part of the object, but must be included in the MD5 sum. Otherwise, modifying the model and nothing else would not trigger remaking the process-component source. Note that the model parameters may change later and therefore are not incorporated. After the MD5 sum of the component has been computed, we communicate it to the [[writer]] subobject of the specific [[core_def]] component. Although these types are abstract, the MD5-related features are valid for the abstract types. <>= procedure :: compute_md5sum => process_component_def_compute_md5sum <>= module subroutine process_component_def_compute_md5sum (component, model) class(process_component_def_t), intent(inout) :: component class(model_data_t), intent(in), optional, target :: model end subroutine process_component_def_compute_md5sum <>= module subroutine process_component_def_compute_md5sum (component, model) class(process_component_def_t), intent(inout) :: component class(model_data_t), intent(in), optional, target :: model integer :: u component%md5sum = "" u = free_unit () open (u, status = "scratch", action = "readwrite") if (present (model)) write (u, "(A32)") model%get_md5sum () call component%write (u) rewind (u) component%md5sum = md5sum (u) close (u) if (allocated (component%core_def)) then call component%core_def%set_md5sum (component%md5sum) end if end subroutine process_component_def_compute_md5sum @ %def process_component_def_compute_md5sum @ <>= procedure :: get_def_type_string => process_component_def_get_def_type_string <>= module function process_component_def_get_def_type_string (component) result (type_string) type(string_t) :: type_string class(process_component_def_t), intent(in) :: component end function process_component_def_get_def_type_string <>= module function process_component_def_get_def_type_string (component) result (type_string) type(string_t) :: type_string class(process_component_def_t), intent(in) :: component type_string = component%core_def%type_string () end function process_component_def_get_def_type_string @ %def process_component_def_get_def_type_string @ Allocate the process driver (with a suitable type) for a process component. For internal processes, we may set all data already at this stage. <>= procedure :: allocate_driver => process_component_def_allocate_driver <>= module subroutine process_component_def_allocate_driver (component, driver) class(process_component_def_t), intent(in) :: component class(prc_core_driver_t), intent(out), allocatable :: driver end subroutine process_component_def_allocate_driver <>= module subroutine process_component_def_allocate_driver (component, driver) class(process_component_def_t), intent(in) :: component class(prc_core_driver_t), intent(out), allocatable :: driver if (allocated (component%core_def)) then call component%core_def%allocate_driver (driver, component%basename) end if end subroutine process_component_def_allocate_driver @ %def process_component_def_allocate_driver @ Tell whether the process core needs external code. <>= procedure :: needs_code => process_component_def_needs_code <>= module function process_component_def_needs_code (component) result (flag) class(process_component_def_t), intent(in) :: component logical :: flag end function process_component_def_needs_code <>= module function process_component_def_needs_code (component) result (flag) class(process_component_def_t), intent(in) :: component logical :: flag flag = component%core_def%needs_code () end function process_component_def_needs_code @ %def process_component_def_needs_code @ If there is external code, the [[core_def]] subobject should provide a writer object. This method returns a pointer to the writer. <>= procedure :: get_writer_ptr => process_component_def_get_writer_ptr <>= module function process_component_def_get_writer_ptr (component) result (writer) class(process_component_def_t), intent(in), target :: component class(prc_writer_t), pointer :: writer end function process_component_def_get_writer_ptr <>= module function process_component_def_get_writer_ptr (component) result (writer) class(process_component_def_t), intent(in), target :: component class(prc_writer_t), pointer :: writer writer => component%core_def%writer end function process_component_def_get_writer_ptr @ %def process_component_def_get_writer_ptr @ Return an array which holds the names of all C functions that this process component implements. <>= procedure :: get_features => process_component_def_get_features <>= module function process_component_def_get_features (component) result (features) class(process_component_def_t), intent(in) :: component type(string_t), dimension(:), allocatable :: features end function process_component_def_get_features <>= module function process_component_def_get_features (component) result (features) class(process_component_def_t), intent(in) :: component type(string_t), dimension(:), allocatable :: features call component%core_def%get_features (features) end function process_component_def_get_features @ %def process_component_def_get_features @ Assign procedure pointers in the [[driver]] component (external processes). For internal processes, this is meaningless. <>= procedure :: connect => process_component_def_connect <>= module subroutine process_component_def_connect & (component, lib_driver, i, proc_driver) class(process_component_def_t), intent(in) :: component class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver end subroutine process_component_def_connect <>= module subroutine process_component_def_connect & (component, lib_driver, i, proc_driver) class(process_component_def_t), intent(in) :: component class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver select type (proc_driver) class is (process_driver_internal_t) !!! Nothing to do class default call component%core_def%connect (lib_driver, i, proc_driver) end select end subroutine process_component_def_connect @ %def process_component_def_connect @ Return a pointer to the process core definition, which is of abstract type. <>= procedure :: get_core_def_ptr => process_component_get_core_def_ptr <>= module function process_component_get_core_def_ptr (component) result (ptr) class(process_component_def_t), intent(in), target :: component class(prc_core_def_t), pointer :: ptr end function process_component_get_core_def_ptr <>= module function process_component_get_core_def_ptr (component) result (ptr) class(process_component_def_t), intent(in), target :: component class(prc_core_def_t), pointer :: ptr ptr => component%core_def end function process_component_get_core_def_ptr @ %def process_component_get_core_def_ptr @ Return nominal particle counts, as input by the user. <>= procedure :: get_n_in => process_component_def_get_n_in procedure :: get_n_out => process_component_def_get_n_out procedure :: get_n_tot => process_component_def_get_n_tot <>= module function process_component_def_get_n_in (component) result (n_in) class(process_component_def_t), intent(in) :: component integer :: n_in end function process_component_def_get_n_in module function process_component_def_get_n_out (component) result (n_out) class(process_component_def_t), intent(in) :: component integer :: n_out end function process_component_def_get_n_out module function process_component_def_get_n_tot (component) result (n_tot) class(process_component_def_t), intent(in) :: component integer :: n_tot end function process_component_def_get_n_tot <>= module function process_component_def_get_n_in (component) result (n_in) class(process_component_def_t), intent(in) :: component integer :: n_in n_in = component%n_in end function process_component_def_get_n_in module function process_component_def_get_n_out (component) result (n_out) class(process_component_def_t), intent(in) :: component integer :: n_out n_out = component%n_out end function process_component_def_get_n_out module function process_component_def_get_n_tot (component) result (n_tot) class(process_component_def_t), intent(in) :: component integer :: n_tot n_tot = component%n_tot end function process_component_def_get_n_tot @ %def process_component_def_get_n_in @ %def process_component_def_get_n_out @ %def process_component_def_get_n_tot @ Allocate and return string arrays for the incoming and outgoing particles. <>= procedure :: get_prt_in => process_component_def_get_prt_in procedure :: get_prt_out => process_component_def_get_prt_out <>= module subroutine process_component_def_get_prt_in (component, prt) class(process_component_def_t), intent(in) :: component type(string_t), dimension(:), intent(out), allocatable :: prt end subroutine process_component_def_get_prt_in module subroutine process_component_def_get_prt_out (component, prt) class(process_component_def_t), intent(in) :: component type(string_t), dimension(:), intent(out), allocatable :: prt end subroutine process_component_def_get_prt_out <>= module subroutine process_component_def_get_prt_in (component, prt) class(process_component_def_t), intent(in) :: component type(string_t), dimension(:), intent(out), allocatable :: prt integer :: i allocate (prt (component%n_in)) do i = 1, component%n_in prt(i) = component%prt_in(i)%to_string () end do end subroutine process_component_def_get_prt_in module subroutine process_component_def_get_prt_out (component, prt) class(process_component_def_t), intent(in) :: component type(string_t), dimension(:), intent(out), allocatable :: prt integer :: i allocate (prt (component%n_out)) do i = 1, component%n_out prt(i) = component%prt_out(i)%to_string () end do end subroutine process_component_def_get_prt_out @ %def process_component_def_get_prt_in @ %def process_component_def_get_prt_out @ Return the incoming and outgoing particle specifiers as-is. <>= procedure :: get_prt_spec_in => process_component_def_get_prt_spec_in procedure :: get_prt_spec_out => process_component_def_get_prt_spec_out <>= module function process_component_def_get_prt_spec_in (component) result (prt) class(process_component_def_t), intent(in) :: component type(prt_spec_t), dimension(:), allocatable :: prt end function process_component_def_get_prt_spec_in module function process_component_def_get_prt_spec_out (component) result (prt) class(process_component_def_t), intent(in) :: component type(prt_spec_t), dimension(:), allocatable :: prt end function process_component_def_get_prt_spec_out <>= module function process_component_def_get_prt_spec_in (component) result (prt) class(process_component_def_t), intent(in) :: component type(prt_spec_t), dimension(:), allocatable :: prt allocate (prt (component%n_in)) prt(:) = component%prt_in(:) end function process_component_def_get_prt_spec_in module function process_component_def_get_prt_spec_out (component) result (prt) class(process_component_def_t), intent(in) :: component type(prt_spec_t), dimension(:), allocatable :: prt allocate (prt (component%n_out)) prt(:) = component%prt_out(:) end function process_component_def_get_prt_spec_out @ %def process_component_def_get_prt_spec_in @ %def process_component_def_get_prt_spec_out @ Return the combination of incoming particles as a PDG code <>= procedure :: get_pdg_in => process_component_def_get_pdg_in <>= module subroutine process_component_def_get_pdg_in (component, model, pdg) class(process_component_def_t), intent(in) :: component class(model_data_t), intent(in), target :: model integer, intent(out), dimension(:) :: pdg end subroutine process_component_def_get_pdg_in <>= module subroutine process_component_def_get_pdg_in (component, model, pdg) class(process_component_def_t), intent(in) :: component class(model_data_t), intent(in), target :: model integer, intent(out), dimension(:) :: pdg integer :: i do i = 1, size (pdg) pdg(i) = model%get_pdg (component%prt_in(i)%to_string ()) end do end subroutine process_component_def_get_pdg_in @ %def process_component_def_get_pdg_in @ Return the MD5 sum. <>= procedure :: get_md5sum => process_component_def_get_md5sum <>= pure module function process_component_def_get_md5sum (component) result (md5sum) class(process_component_def_t), intent(in) :: component character(32) :: md5sum end function process_component_def_get_md5sum <>= pure module function process_component_def_get_md5sum (component) result (md5sum) class(process_component_def_t), intent(in) :: component character(32) :: md5sum md5sum = component%md5sum end function process_component_def_get_md5sum @ %def process_component_def_get_md5sum @ Get NLO data <>= procedure :: get_nlo_type => process_component_def_get_nlo_type procedure :: get_associated_born & => process_component_def_get_associated_born procedure :: get_associated_real_fin & => process_component_def_get_associated_real_fin procedure :: get_associated_real_sing & => process_component_def_get_associated_real_sing procedure :: get_associated_subtraction & => process_component_def_get_associated_subtraction procedure :: get_association_list & => process_component_def_get_association_list procedure :: can_be_integrated & => process_component_def_can_be_integrated procedure :: get_associated_real => process_component_def_get_associated_real <>= elemental module function process_component_def_get_nlo_type & (component) result (nlo_type) integer :: nlo_type class(process_component_def_t), intent(in) :: component end function process_component_def_get_nlo_type elemental module function process_component_def_get_associated_born & (component) result (i_born) integer :: i_born class(process_component_def_t), intent(in) :: component end function process_component_def_get_associated_born elemental module function process_component_def_get_associated_real_fin & (component) result (i_rfin) integer :: i_rfin class(process_component_def_t), intent(in) :: component end function process_component_def_get_associated_real_fin elemental module function process_component_def_get_associated_real_sing & (component) result (i_rsing) integer :: i_rsing class(process_component_def_t), intent(in) :: component end function process_component_def_get_associated_real_sing elemental module function process_component_def_get_associated_subtraction & (component) result (i_sub) integer :: i_sub class(process_component_def_t), intent(in) :: component end function process_component_def_get_associated_subtraction elemental module function process_component_def_can_be_integrated & (component) result (active) logical :: active class(process_component_def_t), intent(in) :: component end function process_component_def_can_be_integrated module function process_component_def_get_association_list & (component, i_skip_in) result (list) integer, dimension(:), allocatable :: list class(process_component_def_t), intent(in) :: component integer, intent(in), optional :: i_skip_in end function process_component_def_get_association_list module function process_component_def_get_associated_real & (component) result (i_real) integer :: i_real class(process_component_def_t), intent(in) :: component end function process_component_def_get_associated_real <>= elemental module function process_component_def_get_nlo_type & (component) result (nlo_type) integer :: nlo_type class(process_component_def_t), intent(in) :: component nlo_type = component%nlo_type end function process_component_def_get_nlo_type elemental module function process_component_def_get_associated_born & (component) result (i_born) integer :: i_born class(process_component_def_t), intent(in) :: component i_born = component%associated_components(ASSOCIATED_BORN) end function process_component_def_get_associated_born elemental module function process_component_def_get_associated_real_fin & (component) result (i_rfin) integer :: i_rfin class(process_component_def_t), intent(in) :: component i_rfin = component%associated_components(ASSOCIATED_REAL_FIN) end function process_component_def_get_associated_real_fin elemental module function process_component_def_get_associated_real_sing & (component) result (i_rsing) integer :: i_rsing class(process_component_def_t), intent(in) :: component i_rsing = component%associated_components(ASSOCIATED_REAL_SING) end function process_component_def_get_associated_real_sing elemental module function process_component_def_get_associated_subtraction & (component) result (i_sub) integer :: i_sub class(process_component_def_t), intent(in) :: component i_sub = component%associated_components(ASSOCIATED_SUB) end function process_component_def_get_associated_subtraction elemental module function process_component_def_can_be_integrated & (component) result (active) logical :: active class(process_component_def_t), intent(in) :: component active = component%active end function process_component_def_can_be_integrated module function process_component_def_get_association_list & (component, i_skip_in) result (list) integer, dimension(:), allocatable :: list class(process_component_def_t), intent(in) :: component integer, intent(in), optional :: i_skip_in integer :: i, j, n, i_skip logical :: valid i_skip = 0; if (present (i_skip_in)) i_skip = i_skip_in n = count (component%associated_components /= 0) - 1 if (i_skip > 0) then if (component%associated_components(i_skip) > 0) n = n - 1 end if allocate (list (n)) j = 1 do i = 1, size(component%associated_components) valid = component%associated_components(i) /= 0 & .and. i /= ASSOCIATED_SUB .and. i /= i_skip if (valid) then list(j) = component%associated_components(i) j = j + 1 end if end do end function process_component_def_get_association_list module function process_component_def_get_associated_real & (component) result (i_real) integer :: i_real class(process_component_def_t), intent(in) :: component i_real = component%associated_components(ASSOCIATED_REAL) end function process_component_def_get_associated_real @ %def process_component_def_get_nlo_type, process_component_def_get_associated_born @ %def process_component_def_can_be_integrated @ %def process_component_def_get_association_list @ %def process_component_def_get_associated_real @ %def process_component_def_get_associated_real_fin @ %def process_component_def_get_associated_subtraction @ <>= procedure :: get_me_method => process_component_def_get_me_method <>= elemental module function process_component_def_get_me_method (component) result (method) type(string_t) :: method class(process_component_def_t), intent(in) :: component end function process_component_def_get_me_method <>= elemental module function process_component_def_get_me_method (component) result (method) type(string_t) :: method class(process_component_def_t), intent(in) :: component method = component%method end function process_component_def_get_me_method @ %def process_component_def_get_me_method @ <>= procedure :: get_fixed_emitter => process_component_def_get_fixed_emitter <>= module function process_component_def_get_fixed_emitter (component) result (emitter) integer :: emitter class(process_component_def_t), intent(in) :: component end function process_component_def_get_fixed_emitter <>= module function process_component_def_get_fixed_emitter (component) result (emitter) integer :: emitter class(process_component_def_t), intent(in) :: component emitter = component%fixed_emitter end function process_component_def_get_fixed_emitter @ %def process_component_def_get_fixed_emitter @ <>= procedure :: get_coupling_powers => process_component_def_get_coupling_powers <>= pure module subroutine process_component_def_get_coupling_powers & (component, alpha_power, alphas_power) class(process_component_def_t), intent(in) :: component integer, intent(out) :: alpha_power, alphas_power end subroutine process_component_def_get_coupling_powers <>= pure module subroutine process_component_def_get_coupling_powers & (component, alpha_power, alphas_power) class(process_component_def_t), intent(in) :: component integer, intent(out) :: alpha_power, alphas_power alpha_power = component%alpha_power alphas_power = component%alphas_power end subroutine process_component_def_get_coupling_powers @ %def process_component_def_get_coupling_powers @ \subsubsection{Process definition} The process component definitions are collected in a common process definition object. The [[id]] is the ID string that the user has provided for identifying this process. It must be a string that is allowed as part of a Fortran variable name, since it may be used for generating code. The number [[n_in]] is 1 or 2 for a decay or scattering process, respectively. This must be identical to [[n_in]] for all components. The initial and extra component definitions (see above) are allocated as the [[initial]] and [[extra]] arrays, respectively. The latter are determined from the former. The [[md5sum]] is used to verify the integrity of the configuration. <>= public :: process_def_t <>= type :: process_def_t private type(string_t) :: id integer :: num_id = 0 class(model_data_t), pointer :: model => null () type(string_t) :: model_name integer :: n_in = 0 integer :: n_initial = 0 integer :: n_extra = 0 type(process_component_def_t), dimension(:), allocatable :: initial type(process_component_def_t), dimension(:), allocatable :: extra character(32) :: md5sum = "" logical :: nlo_process = .false. logical :: negative_sf = .false. logical :: requires_resonances = .false. contains <> end type process_def_t @ %def process_def_t @ Write the process definition including components: <>= procedure :: write => process_def_write <>= module subroutine process_def_write (object, unit) class(process_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine process_def_write <>= module subroutine process_def_write (object, unit) class(process_def_t), intent(in) :: object integer, intent(in) :: unit integer :: i write (unit, "(1x,A,A,A)") "ID = '", char (object%id), "'" if (object%num_id /= 0) & write (unit, "(1x,A,I0)") "ID(num) = ", object%num_id select case (object%n_in) case (1); write (unit, "(1x,A)") "Decay" case (2); write (unit, "(1x,A)") "Scattering" case default write (unit, "(1x,A)") "[Undefined process]" return end select if (object%model_name /= "") then write (unit, "(1x,A,A)") "Model = ", char (object%model_name) else write (unit, "(1x,A)") "Model = [undefined]" end if write (unit, "(1x,A,I0)") "Initially defined component(s) = ", & object%n_initial write (unit, "(1x,A,I0)") "Extra generated component(s) = ", & object%n_extra if (object%requires_resonances) then ! This line has to matched with the reader below! write (unit, "(1x,A,I0)") "Resonant subprocesses required" end if write (unit, "(1x,A,A,A)") "MD5 sum = '", object%md5sum, "'" if (allocated (object%initial)) then do i = 1, size (object%initial) write (unit, "(1x,A,I0)") "Component #", i call object%initial(i)%write (unit) end do end if if (allocated (object%extra)) then do i = 1, size (object%extra) write (unit, "(1x,A,I0)") "Component #", object%n_initial + i call object%extra(i)%write (unit) end do end if end subroutine process_def_write @ %def process_def_write @ Read the process definition including components. <>= procedure :: read => process_def_read <>= module subroutine process_def_read (object, unit, core_def_templates) class(process_def_t), intent(out) :: object integer, intent(in) :: unit type(prc_template_t), dimension(:), intent(in) :: core_def_templates end subroutine process_def_read <>= module subroutine process_def_read (object, unit, core_def_templates) class(process_def_t), intent(out) :: object integer, intent(in) :: unit type(prc_template_t), dimension(:), intent(in) :: core_def_templates integer :: i, i1, i2 character(80) :: buffer, ref read (unit, "(A)") buffer call strip_equation_lhs (buffer) i1 = scan (buffer, "'") i2 = scan (buffer, "'", back=.true.) if (i2 > i1) then object%id = buffer(i1+1:i2-1) else object%id = "" end if read (unit, "(A)") buffer select case (buffer(2:11)) case ("Decay "); object%n_in = 1 case ("Scattering"); object%n_in = 2 case default return end select read (unit, "(A)") buffer call strip_equation_lhs (buffer) object%model_name = trim (adjustl (buffer)) if (object%model_name == "[undefined]") object%model_name = "" read (unit, "(A)") buffer call strip_equation_lhs (buffer) read (buffer, *) object%n_initial read (unit, "(A)") buffer call strip_equation_lhs (buffer) read (buffer, *) object%n_extra read (unit, "(A)") buffer if (buffer(1:9) == " Resonant") then object%requires_resonances = .true. read (unit, "(A)") buffer else object%requires_resonances = .false. end if call strip_equation_lhs (buffer) read (buffer(3:34), "(A32)") object%md5sum if (object%n_initial > 0) then allocate (object%initial (object%n_initial)) do i = 1, object%n_initial read (unit, "(A)") buffer write (ref, "(1x,A,I0)") "Component #", i if (buffer /= ref) return ! Wrong component header call object%initial(i)%read (unit, core_def_templates) end do end if end subroutine process_def_read @ %def process_def_read @ Short account. <>= procedure :: show => process_def_show <>= module subroutine process_def_show (object, unit) class(process_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine process_def_show <>= module subroutine process_def_show (object, unit) class(process_def_t), intent(in) :: object integer, intent(in) :: unit integer :: i write (unit, "(4x,A)", advance="no") char (object%id) if (object%num_id /= 0) & write (unit, "(1x,'(',I0,')')", advance="no") object%num_id if (object%model_name /= "") & write (unit, "(1x,'[',A,']')", advance="no") char (object%model_name) if (object%requires_resonances) then write (unit, "(1x,A)", advance="no") "[+ resonant subprocesses]" end if write (unit, *) if (allocated (object%initial)) then do i = 1, size (object%initial) call object%initial(i)%show (unit) end do end if if (allocated (object%extra)) then do i = 1, size (object%extra) call object%extra(i)%show (unit) end do end if end subroutine process_def_show @ %def process_def_show @ Initialize an entry (initialize the process definition inside). We allocate the 'initial' set of components. Extra components remain unallocated. The model should be present as a pointer. This allows us to retrieve the model's MD5 sum. However, for various tests it is sufficient to have the name. We create the basenames for the process components by appending a suffix which we increment for each component. <>= procedure :: init => process_def_init <>= module subroutine process_def_init (def, id, & model, model_name, n_in, n_components, num_id, & nlo_process, negative_sf, requires_resonances) class(process_def_t), intent(out) :: def type(string_t), intent(in), optional :: id class(model_data_t), intent(in), optional, target :: model type(string_t), intent(in), optional :: model_name integer, intent(in), optional :: n_in integer, intent(in), optional :: n_components integer, intent(in), optional :: num_id logical, intent(in), optional :: nlo_process logical, intent(in), optional :: negative_sf logical, intent(in), optional :: requires_resonances end subroutine process_def_init <>= module subroutine process_def_init (def, id, & model, model_name, n_in, n_components, num_id, & nlo_process, negative_sf, requires_resonances) class(process_def_t), intent(out) :: def type(string_t), intent(in), optional :: id class(model_data_t), intent(in), optional, target :: model type(string_t), intent(in), optional :: model_name integer, intent(in), optional :: n_in integer, intent(in), optional :: n_components integer, intent(in), optional :: num_id logical, intent(in), optional :: nlo_process logical, intent(in), optional :: negative_sf logical, intent(in), optional :: requires_resonances character(16) :: suffix integer :: i if (present (id)) then def%id = id else def%id = "" end if if (present (num_id)) then def%num_id = num_id end if if (present (model)) then def%model => model def%model_name = model%get_name () else def%model => null () if (present (model_name)) then def%model_name = model_name else def%model_name = "" end if end if if (present (n_in)) def%n_in = n_in if (present (n_components)) then def%n_initial = n_components allocate (def%initial (n_components)) end if if (present (nlo_process)) then def%nlo_process = nlo_process end if if (present (negative_sf)) then def%negative_sf = negative_sf end if if (present (requires_resonances)) then def%requires_resonances = requires_resonances end if def%initial%initial = .true. def%initial%method = "" do i = 1, def%n_initial write (suffix, "(A,I0)") "_i", i def%initial(i)%basename = def%id // trim (suffix) end do def%initial%description = "" end subroutine process_def_init @ %def process_def_init @ Explicitly set the model name (for unit test). <>= procedure :: set_model_name => process_def_set_model_name <>= module subroutine process_def_set_model_name (def, model_name) class(process_def_t), intent(inout) :: def type(string_t), intent(in) :: model_name end subroutine process_def_set_model_name <>= module subroutine process_def_set_model_name (def, model_name) class(process_def_t), intent(inout) :: def type(string_t), intent(in) :: model_name def%model_name = model_name end subroutine process_def_set_model_name @ %def process_def_set_model_name @ Initialize an initial component. The particle content must be specified. The process core block is not (yet) allocated. We assume that the particle arrays match the [[n_in]] and [[n_out]] values in size. The model is referred to by name; it is identified as an existing model later. The index [[i]] must refer to an existing element of the component array. Data specific for the process core of a component are imported as the [[core_def]] argument. We should allocate an object of class [[prc_core_def_t]] with the appropriate specific type, fill it, and transfer it to the process component definition here. The allocation is moved, so the original allocated object is returned empty. <>= procedure :: import_component => process_def_import_component <>= module subroutine process_def_import_component (def, & i, n_out, prt_in, prt_out, method, variant, & nlo_type, can_be_integrated) class(process_def_t), intent(inout) :: def integer, intent(in) :: i integer, intent(in), optional :: n_out type(prt_spec_t), dimension(:), intent(in), optional :: prt_in type(prt_spec_t), dimension(:), intent(in), optional :: prt_out type(string_t), intent(in), optional :: method integer, intent(in), optional :: nlo_type logical, intent(in), optional :: can_be_integrated class(prc_core_def_t), & intent(inout), allocatable, optional :: variant end subroutine process_def_import_component <>= module subroutine process_def_import_component (def, & i, n_out, prt_in, prt_out, method, variant, & nlo_type, can_be_integrated) class(process_def_t), intent(inout) :: def integer, intent(in) :: i integer, intent(in), optional :: n_out type(prt_spec_t), dimension(:), intent(in), optional :: prt_in type(prt_spec_t), dimension(:), intent(in), optional :: prt_out type(string_t), intent(in), optional :: method integer, intent(in), optional :: nlo_type logical, intent(in), optional :: can_be_integrated type(string_t) :: nlo_type_string class(prc_core_def_t), & intent(inout), allocatable, optional :: variant integer :: p associate (comp => def%initial(i)) if (present (n_out)) then comp%n_in = def%n_in comp%n_out = n_out comp%n_tot = def%n_in + n_out end if if (present (prt_in)) then allocate (comp%prt_in (size (prt_in))) comp%prt_in = prt_in end if if (present (prt_out)) then allocate (comp%prt_out (size (prt_out))) comp%prt_out = prt_out end if if (present (method)) comp%method = method if (present (variant)) then call move_alloc (variant, comp%core_def) end if if (present (nlo_type)) then comp%nlo_type = nlo_type end if if (present (can_be_integrated)) then comp%active = can_be_integrated else comp%active = .true. end if if (allocated (comp%prt_in) .and. allocated (comp%prt_out)) then associate (d => comp%description) d = "" do p = 1, size (prt_in) if (p > 1) d = d // ", " d = d // comp%prt_in(p)%to_string () end do d = d // " => " do p = 1, size (prt_out) if (p > 1) d = d // ", " d = d // comp%prt_out(p)%to_string () end do if (comp%method /= "") then if ((def%nlo_process .and. .not. comp%active) .or. & comp%nlo_type == NLO_SUBTRACTION) then d = d // " [inactive]" else d = d // " [" // comp%method // "]" end if end if nlo_type_string = component_status (comp%nlo_type) if (nlo_type_string /= "born") then d = d // ", [" // nlo_type_string // "]" end if end associate end if end associate end subroutine process_def_import_component @ %def process_def_import_component @ <>= procedure :: get_n_components => process_def_get_n_components <>= module function process_def_get_n_components (def) result (n) class(process_def_t), intent(in) :: def integer :: n end function process_def_get_n_components <>= module function process_def_get_n_components (def) result (n) class(process_def_t), intent(in) :: def integer :: n n = size (def%initial) end function process_def_get_n_components @ %def process_def_get_n_components @ <>= procedure :: set_fixed_emitter => process_def_set_fixed_emitter <>= module subroutine process_def_set_fixed_emitter (def, i, emitter) class(process_def_t), intent(inout) :: def integer, intent(in) :: i, emitter end subroutine process_def_set_fixed_emitter <>= module subroutine process_def_set_fixed_emitter (def, i, emitter) class(process_def_t), intent(inout) :: def integer, intent(in) :: i, emitter def%initial(i)%fixed_emitter = emitter end subroutine process_def_set_fixed_emitter @ %def process_def_set_fixed_emitter @ <>= procedure :: set_coupling_powers => process_def_set_coupling_powers <>= module subroutine process_def_set_coupling_powers (def, alpha_power, alphas_power) class(process_def_t), intent(inout) :: def integer, intent(in) :: alpha_power, alphas_power end subroutine process_def_set_coupling_powers <>= module subroutine process_def_set_coupling_powers (def, alpha_power, alphas_power) class(process_def_t), intent(inout) :: def integer, intent(in) :: alpha_power, alphas_power def%initial(1)%alpha_power = alpha_power def%initial(1)%alphas_power = alphas_power end subroutine process_def_set_coupling_powers @ %def process_def_set_coupling_powers @ <>= procedure :: set_associated_components => & process_def_set_associated_components <>= module subroutine process_def_set_associated_components (def, i, & i_list, remnant, real_finite, mismatch) class(process_def_t), intent(inout) :: def logical, intent(in) :: remnant, real_finite, mismatch integer, intent(in) :: i integer, dimension(:), intent(in) :: i_list end subroutine process_def_set_associated_components <>= module subroutine process_def_set_associated_components (def, i, & i_list, remnant, real_finite, mismatch) class(process_def_t), intent(inout) :: def logical, intent(in) :: remnant, real_finite, mismatch integer, intent(in) :: i integer, dimension(:), intent(in) :: i_list integer :: add_index add_index = 0 associate (comp => def%initial(i)%associated_components) comp(ASSOCIATED_BORN) = i_list(1) comp(ASSOCIATED_REAL) = i_list(2) comp(ASSOCIATED_VIRT) = i_list(3) comp(ASSOCIATED_SUB) = i_list(4) if (remnant) then comp(ASSOCIATED_PDF) = i_list(5) add_index = add_index + 1 end if if (real_finite) then comp(ASSOCIATED_REAL_FIN) = i_list(5+add_index) add_index = add_index + 1 end if if (mismatch) then !!! incomplete end if end associate end subroutine process_def_set_associated_components @ %def process_def_set_associated_components @ Compute the MD5 sum for this process definition. We compute the MD5 sums for all components individually, than concatenate a string of those and compute the MD5 sum of this string. We also include the model name. All other data part of the component definitions. <>= procedure :: compute_md5sum => process_def_compute_md5sum <>= module subroutine process_def_compute_md5sum (def, model) class(process_def_t), intent(inout) :: def class(model_data_t), intent(in), optional, target :: model end subroutine process_def_compute_md5sum <>= module subroutine process_def_compute_md5sum (def, model) class(process_def_t), intent(inout) :: def class(model_data_t), intent(in), optional, target :: model integer :: i type(string_t) :: buffer buffer = def%model_name do i = 1, def%n_initial call def%initial(i)%compute_md5sum (model) buffer = buffer // def%initial(i)%md5sum end do do i = 1, def%n_extra call def%extra(i)%compute_md5sum (model) buffer = buffer // def%initial(i)%md5sum end do def%md5sum = md5sum (char (buffer)) end subroutine process_def_compute_md5sum @ %def process_def_compute_md5sum @ Return the MD5 sum of the process or of a process component. <>= procedure :: get_md5sum => process_def_get_md5sum <>= module function process_def_get_md5sum (def, i_component) result (md5sum) class(process_def_t), intent(in) :: def integer, intent(in), optional :: i_component character(32) :: md5sum end function process_def_get_md5sum <>= module function process_def_get_md5sum (def, i_component) result (md5sum) class(process_def_t), intent(in) :: def integer, intent(in), optional :: i_component character(32) :: md5sum if (present (i_component)) then md5sum = def%initial(i_component)%md5sum else md5sum = def%md5sum end if end function process_def_get_md5sum @ %def process_def_get_md5sum @ Return a pointer to the definition of a particular component (for test purposes). <>= procedure :: get_core_def_ptr => process_def_get_core_def_ptr <>= module function process_def_get_core_def_ptr (def, i_component) result (ptr) class(process_def_t), intent(in), target :: def integer, intent(in) :: i_component class(prc_core_def_t), pointer :: ptr end function process_def_get_core_def_ptr <>= module function process_def_get_core_def_ptr (def, i_component) result (ptr) class(process_def_t), intent(in), target :: def integer, intent(in) :: i_component class(prc_core_def_t), pointer :: ptr ptr => def%initial(i_component)%get_core_def_ptr () end function process_def_get_core_def_ptr @ %def process_def_get_core_def_ptr @ This query tells whether a specific process component relies on external code. This includes all traditional WHIZARD matrix elements which rely on \oMega\ for code generation. Other process components (trivial decays, subtraction terms) do not require external code. NOTE: Implemented only for initial component. The query is passed to the process component. <>= procedure :: needs_code => process_def_needs_code <>= module function process_def_needs_code (def, i_component) result (flag) class(process_def_t), intent(in) :: def integer, intent(in) :: i_component logical :: flag end function process_def_needs_code <>= module function process_def_needs_code (def, i_component) result (flag) class(process_def_t), intent(in) :: def integer, intent(in) :: i_component logical :: flag flag = def%initial(i_component)%needs_code () end function process_def_needs_code @ %def process_def_needs_code @ Return the first entry for the incoming particle(s), PDG code, of this process. <>= procedure :: get_pdg_in_1 => process_def_get_pdg_in_1 <>= module subroutine process_def_get_pdg_in_1 (def, pdg) class(process_def_t), intent(in), target :: def integer, dimension(:), intent(out) :: pdg end subroutine process_def_get_pdg_in_1 <>= module subroutine process_def_get_pdg_in_1 (def, pdg) class(process_def_t), intent(in), target :: def integer, dimension(:), intent(out) :: pdg call def%initial(1)%get_pdg_in (def%model, pdg) end subroutine process_def_get_pdg_in_1 @ %def process_def_get_pdg_in_1 @ <>= procedure :: is_nlo => process_def_is_nlo <>= elemental module function process_def_is_nlo (def) result (flag) logical :: flag class(process_def_t), intent(in) :: def end function process_def_is_nlo <>= elemental module function process_def_is_nlo (def) result (flag) logical :: flag class(process_def_t), intent(in) :: def flag = def%nlo_process end function process_def_is_nlo @ %def process_def_is_nlo @ <>= procedure :: get_nlo_type => process_def_get_nlo_type <>= elemental module function process_def_get_nlo_type (def, i_component) result (nlo_type) integer :: nlo_type class(process_def_t), intent(in) :: def integer, intent(in) :: i_component end function process_def_get_nlo_type <>= elemental module function process_def_get_nlo_type (def, i_component) result (nlo_type) integer :: nlo_type class(process_def_t), intent(in) :: def integer, intent(in) :: i_component nlo_type = def%initial(i_component)%nlo_type end function process_def_get_nlo_type @ %def process_def_get_nlo_type @ <>= procedure :: get_negative_sf => process_def_get_negative_sf <>= elemental module function process_def_get_negative_sf (def) result (neg_sf) logical :: neg_sf class(process_def_t), intent(in) :: def end function process_def_get_negative_sf <>= elemental module function process_def_get_negative_sf (def) result (neg_sf) logical :: neg_sf class(process_def_t), intent(in) :: def neg_sf = def%negative_sf end function process_def_get_negative_sf @ %def process_def_get_negative_sf @ Number of incoming particles, common to all components. <>= procedure :: get_n_in => process_def_get_n_in <>= module function process_def_get_n_in (def) result (n_in) class(process_def_t), intent(in) :: def integer :: n_in end function process_def_get_n_in <>= module function process_def_get_n_in (def) result (n_in) class(process_def_t), intent(in) :: def integer :: n_in n_in = def%n_in end function process_def_get_n_in @ %def process_def_get_n_in @ Pointer to a particular component definition record. <>= procedure :: get_component_def_ptr => process_def_get_component_def_ptr <>= module function process_def_get_component_def_ptr (def, i) result (component) type(process_component_def_t), pointer :: component class(process_def_t), intent(in), target :: def integer, intent(in) :: i end function process_def_get_component_def_ptr <>= module function process_def_get_component_def_ptr (def, i) result (component) type(process_component_def_t), pointer :: component class(process_def_t), intent(in), target :: def integer, intent(in) :: i if (i <= def%n_initial) then component => def%initial(i) else component => null () end if end function process_def_get_component_def_ptr @ %def process_def_get_component_def_ptr @ \subsubsection{Process definition list} A list of process definitions is the starting point for creating a process library. The list is built when reading the user input. When reading an existing process library, the list is used for cross-checking and updating the configuration. We need a type for the list entry. The simplest way is to extend the process definition type, so all methods apply to the process definition directly. <>= public :: process_def_entry_t <>= type, extends (process_def_t) :: process_def_entry_t private type(process_def_entry_t), pointer :: next => null () end type process_def_entry_t @ %def process_def_entry_t @ This is the type for the list itself. <>= public :: process_def_list_t <>= type :: process_def_list_t private type(process_def_entry_t), pointer :: first => null () type(process_def_entry_t), pointer :: last => null () contains <> end type process_def_list_t @ %def process_def_list_t @ The deallocates the list iteratively. We assume that the list entries do not need finalization themselves. <>= procedure :: final => process_def_list_final <>= module subroutine process_def_list_final (list) class(process_def_list_t), intent(inout) :: list end subroutine process_def_list_final <>= module subroutine process_def_list_final (list) class(process_def_list_t), intent(inout) :: list type(process_def_entry_t), pointer :: current nullify (list%last) do while (associated (list%first)) current => list%first list%first => current%next deallocate (current) end do end subroutine process_def_list_final @ %def process_def_list_final @ Write the complete list. <>= procedure :: write => process_def_list_write <>= module subroutine process_def_list_write (object, unit, libpath) class(process_def_list_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath end subroutine process_def_list_write <>= module subroutine process_def_list_write (object, unit, libpath) class(process_def_list_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath type(process_def_entry_t), pointer :: entry integer :: i, u u = given_output_unit (unit) if (associated (object%first)) then i = 1 entry => object%first do while (associated (entry)) write (u, "(1x,A,I0,A)") "Process #", i, ":" call entry%write (u) i = i + 1 entry => entry%next if (associated (entry)) write (u, *) end do else write (u, "(1x,A)") "Process definition list: [empty]" end if end subroutine process_def_list_write @ %def process_def_list_write @ Short account. <>= procedure :: show => process_def_list_show <>= module subroutine process_def_list_show (object, unit) class(process_def_list_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine process_def_list_show <>= module subroutine process_def_list_show (object, unit) class(process_def_list_t), intent(in) :: object integer, intent(in), optional :: unit type(process_def_entry_t), pointer :: entry integer :: u u = given_output_unit (unit) if (associated (object%first)) then write (u, "(2x,A)") "Processes:" entry => object%first do while (associated (entry)) call entry%show (u) entry => entry%next end do else write (u, "(2x,A)") "Processes: [empty]" end if end subroutine process_def_list_show @ %def process_def_list_show @ Read the complete list. We need an array of templates for the component subobjects of abstract [[prc_core_t]] type, to allocate them with the correct specific type. NOTE: Error handling is missing. Reading will just be aborted on error, or an I/O error occurs. <>= procedure :: read => process_def_list_read <>= module subroutine process_def_list_read (object, unit, core_def_templates) class(process_def_list_t), intent(out) :: object integer, intent(in) :: unit type(prc_template_t), dimension(:), intent(in) :: core_def_templates end subroutine process_def_list_read <>= module subroutine process_def_list_read (object, unit, core_def_templates) class(process_def_list_t), intent(out) :: object integer, intent(in) :: unit type(prc_template_t), dimension(:), intent(in) :: core_def_templates type(process_def_entry_t), pointer :: entry character(80) :: buffer, ref integer :: i read (unit, "(A)") buffer write (ref, "(1x,A)") "Process definition list: [empty]" if (buffer == ref) return ! OK: empty library backspace (unit) READ_ENTRIES: do i = 1, huge(0)-1 if (i > 1) read (unit, *, end=1) read (unit, "(A)") buffer write (ref, "(1x,A,I0,A)") "Process #", i, ":" if (buffer /= ref) return ! Wrong process header: done. allocate (entry) call entry%read (unit, core_def_templates) call object%append (entry) end do READ_ENTRIES 1 continue ! EOF: done end subroutine process_def_list_read @ %def process_def_list_read @ Append an entry to the list. The entry should be allocated as a pointer, and the pointer allocation is transferred. The original pointer is returned null. <>= procedure :: append => process_def_list_append <>= module subroutine process_def_list_append (list, entry) class(process_def_list_t), intent(inout) :: list type(process_def_entry_t), intent(inout), pointer :: entry end subroutine process_def_list_append <>= module subroutine process_def_list_append (list, entry) class(process_def_list_t), intent(inout) :: list type(process_def_entry_t), intent(inout), pointer :: entry if (list%contains (entry%id)) then call msg_fatal ("Recording process: '" // char (entry%id) & // "' has already been defined") end if if (associated (list%first)) then list%last%next => entry else list%first => entry end if list%last => entry entry => null () end subroutine process_def_list_append @ %def process_def_list_append @ \subsubsection{Probe the process definition list} Return the number of processes supported by the library. <>= procedure :: get_n_processes => process_def_list_get_n_processes <>= module function process_def_list_get_n_processes (list) result (n) integer :: n class(process_def_list_t), intent(in) :: list end function process_def_list_get_n_processes <>= module function process_def_list_get_n_processes (list) result (n) integer :: n class(process_def_list_t), intent(in) :: list type(process_def_entry_t), pointer :: current n = 0 current => list%first do while (associated (current)) n = n + 1 current => current%next end do end function process_def_list_get_n_processes @ %def process_def_list_get_n_processes @ Allocate an array with the process IDs supported by the library. <>= procedure :: get_process_id_list => process_def_list_get_process_id_list <>= module subroutine process_def_list_get_process_id_list (list, id) class(process_def_list_t), intent(in) :: list type(string_t), dimension(:), allocatable, intent(out) :: id end subroutine process_def_list_get_process_id_list <>= module subroutine process_def_list_get_process_id_list (list, id) class(process_def_list_t), intent(in) :: list type(string_t), dimension(:), allocatable, intent(out) :: id type(process_def_entry_t), pointer :: current integer :: i allocate (id (list%get_n_processes ())) i = 0 current => list%first do while (associated (current)) i = i + 1 id(i) = current%id current => current%next end do end subroutine process_def_list_get_process_id_list @ %def process_def_list_get_process_id_list @ Return just the processes which require resonant subprocesses. <>= procedure :: get_process_id_req_resonant => & process_def_list_get_process_id_req_resonant <>= module subroutine process_def_list_get_process_id_req_resonant (list, id) class(process_def_list_t), intent(in) :: list type(string_t), dimension(:), allocatable, intent(out) :: id end subroutine process_def_list_get_process_id_req_resonant <>= module subroutine process_def_list_get_process_id_req_resonant (list, id) class(process_def_list_t), intent(in) :: list type(string_t), dimension(:), allocatable, intent(out) :: id type(process_def_entry_t), pointer :: current integer :: i allocate (id (list%get_n_processes ())) i = 0 current => list%first do while (associated (current)) if (current%requires_resonances) then i = i + 1 id(i) = current%id end if current => current%next end do id = id(1:i) end subroutine process_def_list_get_process_id_req_resonant @ %def process_def_list_get_process_id_list @ Return a pointer to a particular process entry. <>= procedure :: get_process_def_ptr => process_def_list_get_process_def_ptr <>= module function process_def_list_get_process_def_ptr (list, id) result (entry) type(process_def_entry_t), pointer :: entry class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id end function process_def_list_get_process_def_ptr <>= module function process_def_list_get_process_def_ptr (list, id) result (entry) type(process_def_entry_t), pointer :: entry class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(process_def_entry_t), pointer :: current current => list%first do while (associated (current)) if (id == current%id) exit current => current%next end do entry => current end function process_def_list_get_process_def_ptr @ %def process_def_list_get_process_def_ptr @ Return true if a given process is in the library. <>= procedure :: contains => process_def_list_contains <>= module function process_def_list_contains (list, id) result (flag) logical :: flag class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id end function process_def_list_contains <>= module function process_def_list_contains (list, id) result (flag) logical :: flag class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(process_def_entry_t), pointer :: current current => list%get_process_def_ptr (id) flag = associated (current) end function process_def_list_contains @ %def process_def_list_contains @ Return the index of the entry that corresponds to a given process. <>= procedure :: get_entry_index => process_def_list_get_entry_index <>= module function process_def_list_get_entry_index (list, id) result (n) integer :: n class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id end function process_def_list_get_entry_index <>= module function process_def_list_get_entry_index (list, id) result (n) integer :: n class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(process_def_entry_t), pointer :: current n = 0 current => list%first do while (associated (current)) n = n + 1 if (id == current%id) then return end if current => current%next end do n = 0 end function process_def_list_get_entry_index @ %def process_def_list_get_entry_index @ Return the numerical ID for a process. <>= procedure :: get_num_id => process_def_list_get_num_id <>= module function process_def_list_get_num_id (list, id) result (num_id) integer :: num_id class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id end function process_def_list_get_num_id <>= module function process_def_list_get_num_id (list, id) result (num_id) integer :: num_id class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(process_def_entry_t), pointer :: current current => list%get_process_def_ptr (id) if (associated (current)) then num_id = current%num_id else num_id = 0 end if end function process_def_list_get_num_id @ %def process_def_list_get_num_id @ Return the model name for a given process in the library. <>= procedure :: get_model_name => process_def_list_get_model_name <>= module function process_def_list_get_model_name (list, id) result (model_name) type(string_t) :: model_name class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id end function process_def_list_get_model_name <>= module function process_def_list_get_model_name (list, id) result (model_name) type(string_t) :: model_name class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(process_def_entry_t), pointer :: current current => list%get_process_def_ptr (id) if (associated (current)) then model_name = current%model_name else model_name = "" end if end function process_def_list_get_model_name @ %def process_def_list_get_model_name @ Return the number of incoming particles of a given process in the library. This tells us whether the process is a decay or a scattering. <>= procedure :: get_n_in => process_def_list_get_n_in <>= module function process_def_list_get_n_in (list, id) result (n) integer :: n class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id end function process_def_list_get_n_in <>= module function process_def_list_get_n_in (list, id) result (n) integer :: n class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(process_def_entry_t), pointer :: current current => list%get_process_def_ptr (id) if (associated (current)) then n = current%n_in else n = 0 end if end function process_def_list_get_n_in @ %def process_def_list_get_n_in @ Return the incoming particle pdg codesnumber of incoming particles of a given process in the library. If there is a PDG array, return only the first code for each beam. This serves as a quick way for (re)constructing beam properties. <>= procedure :: get_pdg_in_1 => process_def_list_get_pdg_in_1 <>= module subroutine process_def_list_get_pdg_in_1 (list, id, pdg) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id integer, dimension(:), intent(out) :: pdg end subroutine process_def_list_get_pdg_in_1 <>= module subroutine process_def_list_get_pdg_in_1 (list, id, pdg) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id integer, dimension(:), intent(out) :: pdg type(process_def_entry_t), pointer :: current current => list%get_process_def_ptr (id) if (associated (current)) then call current%get_pdg_in_1 (pdg) else pdg = 0 end if end subroutine process_def_list_get_pdg_in_1 @ %def process_def_list_get_pdg_in_1 @ Return the list of component IDs of a given process in the library. <>= procedure :: get_component_list => process_def_list_get_component_list <>= module subroutine process_def_list_get_component_list (list, id, cid) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(string_t), dimension(:), allocatable, intent(out) :: cid end subroutine process_def_list_get_component_list <>= module subroutine process_def_list_get_component_list (list, id, cid) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(string_t), dimension(:), allocatable, intent(out) :: cid type(process_def_entry_t), pointer :: current integer :: i, n current => list%get_process_def_ptr (id) if (associated (current)) then allocate (cid (current%n_initial + current%n_extra)) do i = 1, current%n_initial cid(i) = current%initial(i)%basename end do n = current%n_initial do i = 1, current%n_extra cid(n + i) = current%extra(i)%basename end do end if end subroutine process_def_list_get_component_list @ %def process_def_list_get_component_list @ Return the list of component description strings for a given process in the library. <>= procedure :: get_component_description_list => & process_def_list_get_component_description_list <>= module subroutine process_def_list_get_component_description_list & (list, id, description) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(string_t), dimension(:), allocatable, intent(out) :: description end subroutine process_def_list_get_component_description_list <>= module subroutine process_def_list_get_component_description_list & (list, id, description) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id type(string_t), dimension(:), allocatable, intent(out) :: description type(process_def_entry_t), pointer :: current integer :: i, n current => list%get_process_def_ptr (id) if (associated (current)) then allocate (description (current%n_initial + current%n_extra)) do i = 1, current%n_initial description(i) = current%initial(i)%description end do n = current%n_initial do i = 1, current%n_extra description(n + i) = current%extra(i)%description end do end if end subroutine process_def_list_get_component_description_list @ %def process_def_list_get_component_description_list @ Return whether the entry requires construction of a resonanct subprocess set. <>= procedure :: req_resonant => process_def_list_req_resonant <>= module function process_def_list_req_resonant (list, id) result (flag) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id logical :: flag end function process_def_list_req_resonant <>= module function process_def_list_req_resonant (list, id) result (flag) class(process_def_list_t), intent(in) :: list type(string_t), intent(in) :: id logical :: flag type(process_def_entry_t), pointer :: current current => list%get_process_def_ptr (id) if (associated (current)) then flag = current%requires_resonances else flag = .false. end if end function process_def_list_req_resonant @ %def process_def_list_req_resonant @ \subsection{Process library} The process library object is the interface between the process definition data, as provided by the user, generated or linked process code on file, and the process run data that reference the process code. \subsubsection{Process library entry} For each process component that is part of the library, there is a separate library entry ([[process_library_entry_t]]. The library entry connects a process definition with the specific code (if any) in the compiled driver library. The [[status]] indicates how far the process has been processed by the system (definition, code generation, compilation, linking). A process with status [[STAT_LOADED]] is accessible for computing matrix elements. The [[def]] pointer identifies the corresponding process definition. The process component within that definition is identified by the [[i_component]] index. The [[i_external]] index refers to the compiled library driver. If it is zero, there is no associated matrix-element code. The [[driver]] component holds the pointers to the matrix-element specific functions, in particular the matrix element function itself. <>= type :: process_library_entry_t private integer :: status = STAT_UNKNOWN type(process_def_t), pointer :: def => null () integer :: i_component = 0 integer :: i_external = 0 class(prc_core_driver_t), allocatable :: driver contains <> end type process_library_entry_t @ %def process_library_entry_t @ Here are the available status codes. An entry starts with [[UNKNOWN]] status. Once the association with a valid process definition is established, the status becomes [[CONFIGURED]]. If matrix element source code is to be generated by the system or provided from elsewhere, [[CODE_GENERATED]] indicates that this is done. The [[COMPILED]] status is next, it also applies to processes which are accessed as precompiled binaries. Finally, the library is linked and process pointers are set; this is marked as [[LOADED]]. For a process library, the initial status is [[OPEN]], since process definitions may be added. After configuration, the process content is fixed and the status becomes [[CONFIGURED]]. The further states are as above, always referring to the lowest status among the process entries. <>= integer, parameter, public :: STAT_UNKNOWN = 0 integer, parameter, public :: STAT_OPEN = 1 integer, parameter, public :: STAT_CONFIGURED = 2 integer, parameter, public :: STAT_SOURCE = 3 integer, parameter, public :: STAT_COMPILED = 4 integer, parameter, public :: STAT_LINKED = 5 integer, parameter, public :: STAT_ACTIVE = 6 integer, parameter, public :: ASSOCIATED_BORN = 1 integer, parameter, public :: ASSOCIATED_REAL = 2 integer, parameter, public :: ASSOCIATED_VIRT = 3 integer, parameter, public :: ASSOCIATED_SUB = 4 integer, parameter, public :: ASSOCIATED_PDF = 5 integer, parameter, public :: ASSOCIATED_REAL_SING = 6 integer, parameter, public :: ASSOCIATED_REAL_FIN = 7 integer, parameter, public :: N_ASSOCIATED_COMPONENTS = 7 @ %def STAT_UNKNOWN STAT_OPEN STAT_CONFIGURED @ %def STAT_SOURCE STAT_COMPILED STAT_LINKED STAT_ACTIVE @ These are the associated code letters, for output: <>= character, dimension(0:6), parameter :: STATUS_LETTER = & ["?", "o", "f", "s", "c", "l", "a"] @ %def STATUS_LETTER @ This produces a condensed account of the library entry. The status is indicated by a letter in brackets, then the ID and component index of the associated process definition, finally the library index, if available. <>= procedure :: to_string => process_library_entry_to_string <>= module function process_library_entry_to_string (object) result (string) type(string_t) :: string class(process_library_entry_t), intent(in) :: object end function process_library_entry_to_string <>= module function process_library_entry_to_string (object) result (string) type(string_t) :: string class(process_library_entry_t), intent(in) :: object character(32) :: buffer string = "[" // STATUS_LETTER(object%status) // "]" select case (object%status) case (STAT_UNKNOWN) case default if (associated (object%def)) then write (buffer, "(I0)") object%i_component string = string // " " // object%def%id // "." // trim (buffer) end if if (object%i_external /= 0) then write (buffer, "(I0)") object%i_external string = string // " = ext:" // trim (buffer) else string = string // " = int" end if if (allocated (object%driver)) then string = string // " (" // object%driver%type_name () // ")" end if end select end function process_library_entry_to_string @ %def process_library_entry_to_string @ Initialize with data. Used for the unit tests. <>= procedure :: init => process_library_entry_init <>= module subroutine process_library_entry_init (object, & status, def, i_component, i_external, driver_template) class(process_library_entry_t), intent(out) :: object integer, intent(in) :: status type(process_def_t), target, intent(in) :: def integer, intent(in) :: i_component integer, intent(in) :: i_external class(prc_core_driver_t), intent(inout), allocatable, optional & :: driver_template end subroutine process_library_entry_init <>= module subroutine process_library_entry_init (object, & status, def, i_component, i_external, driver_template) class(process_library_entry_t), intent(out) :: object integer, intent(in) :: status type(process_def_t), target, intent(in) :: def integer, intent(in) :: i_component integer, intent(in) :: i_external class(prc_core_driver_t), intent(inout), allocatable, optional & :: driver_template object%status = status object%def => def object%i_component = i_component object%i_external = i_external if (present (driver_template)) then call move_alloc (driver_template, object%driver) end if end subroutine process_library_entry_init @ %def process_library_entry_init @ Assign pointers for all process-specific features. We have to combine the method from the [[core_def]] specification, the assigned pointers within the library driver, the index within that driver, and the process driver which should receive the links. <>= procedure :: connect => process_library_entry_connect <>= module subroutine process_library_entry_connect (entry, lib_driver, i) class(process_library_entry_t), intent(inout) :: entry class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i end subroutine process_library_entry_connect <>= module subroutine process_library_entry_connect (entry, lib_driver, i) class(process_library_entry_t), intent(inout) :: entry class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i call entry%def%initial(entry%i_component)%connect & (lib_driver, i, entry%driver) end subroutine process_library_entry_connect @ %def process_library_entry_connect @ \subsubsection{The process library object} The [[process_library_t]] type is an extension of the [[process_def_list_t]] type. Thus, it automatically contains the process definition list. The [[basename]] identifies the library generically. The [[external]] flag is true if any process within the library needs external code, so the library must correspond to an actual code library (statically or dynamically linked). The [[entry]] array contains all process components that can be handled by this library. Each entry refers to the process (component) definition and to the associated external matrix element code, if there is any. The [[driver]] object is needed only if [[external]] is true. This object handles all interactions with external matrix-element code. The [[md5sum]] summarizes the complete [[process_def_list_t]] base object. It can be used to check if the library configuration has changed. <>= public :: process_library_t <>= type, extends (process_def_list_t) :: process_library_t private type(string_t) :: basename integer :: n_entries = 0 logical :: external = .false. integer :: status = STAT_UNKNOWN logical :: static = .false. logical :: driver_exists = .false. logical :: makefile_exists = .false. integer :: update_counter = 0 type(process_library_entry_t), dimension(:), allocatable :: entry class(prclib_driver_t), allocatable :: driver character(32) :: md5sum = "" contains <> end type process_library_t @ %def process_library_t @ For the output, we write first the metadata and the DL access record, then the library entries in short form, and finally the process definition list which is the base object. Don't write the MD5 sum since this is used to generate it. <>= procedure :: write => process_library_write <>= module subroutine process_library_write (object, unit, libpath) class(process_library_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath end subroutine process_library_write <>= module subroutine process_library_write (object, unit, libpath) class(process_library_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath integer :: i, u u = given_output_unit (unit) write (u, "(1x,A,A)") "Process library: ", char (object%basename) write (u, "(3x,A,L1)") "external = ", object%external write (u, "(3x,A,L1)") "makefile exists = ", object%makefile_exists write (u, "(3x,A,L1)") "driver exists = ", object%driver_exists write (u, "(3x,A,A1)") "code status = ", & STATUS_LETTER (object%status) write (u, *) if (allocated (object%entry)) then write (u, "(1x,A)", advance="no") "Process library entries:" write (u, "(1x,I0)") object%n_entries do i = 1, size (object%entry) write (u, "(1x,A,I0,A,A)") "Entry #", i, ": ", & char (object%entry(i)%to_string ()) end do write (u, *) end if if (object%external) then call object%driver%write (u, libpath) write (u, *) end if call object%process_def_list_t%write (u) end subroutine process_library_write @ %def process_library_write @ Condensed version for screen output. <>= procedure :: show => process_library_show <>= module subroutine process_library_show (object, unit) class(process_library_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine process_library_show <>= module subroutine process_library_show (object, unit) class(process_library_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(A,A)") "Process library: ", char (object%basename) write (u, "(2x,A,L1)") "external = ", object%external if (object%static) then write (u, "(2x,A,L1)") "static = ", .true. else write (u, "(2x,A,L1)") "makefile exists = ", object%makefile_exists write (u, "(2x,A,L1)") "driver exists = ", object%driver_exists end if write (u, "(2x,A,A1)", advance="no") "code status = " select case (object%status) case (STAT_UNKNOWN); write (u, "(A)") "[unknown]" case (STAT_OPEN); write (u, "(A)") "open" case (STAT_CONFIGURED); write (u, "(A)") "configured" case (STAT_SOURCE); write (u, "(A)") "source code exists" case (STAT_COMPILED); write (u, "(A)") "compiled" case (STAT_LINKED); write (u, "(A)") "linked" case (STAT_ACTIVE); write (u, "(A)") "active" end select call object%process_def_list_t%show (u) end subroutine process_library_show @ %def process_library_show @ The initializer defines just the basename. We may now add process definitions to the library. <>= procedure :: init => process_library_init <>= module subroutine process_library_init (lib, basename) class(process_library_t), intent(out) :: lib type(string_t), intent(in) :: basename end subroutine process_library_init <>= module subroutine process_library_init (lib, basename) class(process_library_t), intent(out) :: lib type(string_t), intent(in) :: basename lib%basename = basename lib%status = STAT_OPEN call msg_message ("Process library '" // char (basename) & // "': initialized") end subroutine process_library_init @ %def process_library_init @ This alternative initializer declares the library as static. We should now add process definitions to the library, but all external process code exists already. We need the driver object, and we should check the defined processes against the stored ones. <>= procedure :: init_static => process_library_init_static <>= module subroutine process_library_init_static (lib, basename) class(process_library_t), intent(out) :: lib type(string_t), intent(in) :: basename end subroutine process_library_init_static <>= module subroutine process_library_init_static (lib, basename) class(process_library_t), intent(out) :: lib type(string_t), intent(in) :: basename lib%basename = basename lib%status = STAT_OPEN lib%static = .true. call msg_message ("Static process library '" // char (basename) & // "': initialized") end subroutine process_library_init_static @ %def process_library_init_static @ The [[configure]] procedure scans the allocated entries in the process definition list. The configuration proceeds in three passes. In the first pass, we scan the process definition list and count the number of process components and the number of components which need external code. This is used to allocate the [[entry]] array. In the second pass, we initialize the [[entry]] elements which connect process definitions, process driver objects, and external code. In the third pass, we initialize the library driver object, allocating an entry for each external matrix element. NOTE: Currently we handle only [[initial]] process components; [[extra]] components are ignored. <>= procedure :: configure => process_library_configure <>= module subroutine process_library_configure (lib, os_data) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data end subroutine process_library_configure <>= module subroutine process_library_configure (lib, os_data) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data type(process_def_entry_t), pointer :: def_entry integer :: n_entries, n_external, i_entry, i_external type(string_t) :: model_name integer :: i_component n_entries = 0 n_external = 0 if (allocated (lib%entry)) deallocate (lib%entry) def_entry => lib%first do while (associated (def_entry)) do i_component = 1, def_entry%n_initial n_entries = n_entries + 1 if (def_entry%initial(i_component)%needs_code ()) then n_external = n_external + 1 lib%external = .true. end if end do def_entry => def_entry%next end do call lib%allocate_entries (n_entries) i_entry = 0 i_external = 0 def_entry => lib%first do while (associated (def_entry)) do i_component = 1, def_entry%n_initial i_entry = i_entry + 1 associate (lib_entry => lib%entry(i_entry)) lib_entry%status = STAT_CONFIGURED lib_entry%def => def_entry%process_def_t lib_entry%i_component = i_component if (def_entry%initial(i_component)%needs_code ()) then i_external = i_external + 1 lib_entry%i_external = i_external end if call def_entry%initial(i_component)%allocate_driver & (lib_entry%driver) end associate end do def_entry => def_entry%next end do call dispatch_prclib_driver (lib%driver, & lib%basename, lib%get_modellibs_ldflags (os_data)) call lib%driver%init (n_external) do i_entry = 1, n_entries associate (lib_entry => lib%entry(i_entry)) i_component = lib_entry%i_component model_name = lib_entry%def%model_name associate (def => lib_entry%def%initial(i_component)) if (def%needs_code ()) then call lib%driver%set_record (lib_entry%i_external, & def%basename, & model_name, & def%get_features (), def%get_writer_ptr ()) end if end associate end associate end do if (lib%static) then if (lib%n_entries /= 0) lib%entry%status = STAT_LINKED lib%status = STAT_LINKED else if (lib%external) then where (lib%entry%i_external == 0) lib%entry%status = STAT_LINKED lib%status = STAT_CONFIGURED lib%makefile_exists = .false. lib%driver_exists = .false. else if (lib%n_entries /= 0) lib%entry%status = STAT_LINKED lib%status = STAT_LINKED end if end subroutine process_library_configure @ %def process_library_configure @ Basic setup: allocate the [[entry]] array. <>= procedure :: allocate_entries => process_library_allocate_entries <>= module subroutine process_library_allocate_entries (lib, n_entries) class(process_library_t), intent(inout) :: lib integer, intent(in) :: n_entries end subroutine process_library_allocate_entries <>= module subroutine process_library_allocate_entries (lib, n_entries) class(process_library_t), intent(inout) :: lib integer, intent(in) :: n_entries lib%n_entries = n_entries allocate (lib%entry (n_entries)) end subroutine process_library_allocate_entries @ %def process_library_allocate_entries @ Initialize an entry with data (used by unit tests). <>= procedure :: init_entry => process_library_init_entry <>= module subroutine process_library_init_entry (lib, i, & status, def, i_component, i_external, driver_template) class(process_library_t), intent(inout) :: lib integer, intent(in) :: i integer, intent(in) :: status type(process_def_t), target, intent(in) :: def integer, intent(in) :: i_component integer, intent(in) :: i_external class(prc_core_driver_t), intent(inout), allocatable, optional & :: driver_template end subroutine process_library_init_entry <>= module subroutine process_library_init_entry (lib, i, & status, def, i_component, i_external, driver_template) class(process_library_t), intent(inout) :: lib integer, intent(in) :: i integer, intent(in) :: status type(process_def_t), target, intent(in) :: def integer, intent(in) :: i_component integer, intent(in) :: i_external class(prc_core_driver_t), intent(inout), allocatable, optional & :: driver_template call lib%entry(i)%init (status, def, i_component, i_external, & driver_template) end subroutine process_library_init_entry @ %def process_library_init_entry @ Compute the MD5 sum. We concatenate the individual MD5 sums of all processes (which, in turn, are derived from the MD5 sums of their components) and compute the MD5 sum of that. This should be executed \emph{after} configuration, where the driver was initialized, since otherwise the MD5 sum stored in the driver would be overwritten. <>= procedure :: compute_md5sum => process_library_compute_md5sum <>= module subroutine process_library_compute_md5sum (lib, model) class(process_library_t), intent(inout) :: lib class(model_data_t), intent(in), optional, target :: model end subroutine process_library_compute_md5sum <>= module subroutine process_library_compute_md5sum (lib, model) class(process_library_t), intent(inout) :: lib class(model_data_t), intent(in), optional, target :: model type(process_def_entry_t), pointer :: def_entry type(string_t) :: buffer buffer = lib%basename def_entry => lib%first do while (associated (def_entry)) call def_entry%compute_md5sum (model) buffer = buffer // def_entry%md5sum def_entry => def_entry%next end do lib%md5sum = md5sum (char (buffer)) call lib%driver%set_md5sum (lib%md5sum) end subroutine process_library_compute_md5sum @ %def process_library_compute_md5sum @ Write an appropriate makefile, if there are external processes. Unless [[force]] is in effect, first check if there is already a makefile with the correct MD5 sum. If yes, do nothing. The [[workspace]] optional argument puts any library code in a subdirectory. <>= procedure :: write_makefile => process_library_write_makefile <>= module subroutine process_library_write_makefile & (lib, os_data, force, verbose, testflag, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in) :: force, verbose logical, intent(in), optional :: testflag type(string_t), intent(in), optional :: workspace end subroutine process_library_write_makefile <>= module subroutine process_library_write_makefile & (lib, os_data, force, verbose, testflag, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in) :: force, verbose logical, intent(in), optional :: testflag type(string_t), intent(in), optional :: workspace character(32) :: md5sum_file logical :: generate integer :: unit if (lib%external .and. .not. lib%static) then generate = .true. if (.not. force) then md5sum_file = lib%driver%get_md5sum_makefile (workspace) if (lib%md5sum == md5sum_file) then call msg_message ("Process library '" // char (lib%basename) & // "': keeping makefile") generate = .false. end if end if if (generate) then call msg_message ("Process library '" // char (lib%basename) & // "': writing makefile") unit = free_unit () open (unit, & file = char (workspace_prefix (workspace) & & // lib%driver%basename // ".makefile"), & status="replace", action="write") call lib%driver%generate_makefile (unit, os_data, verbose, testflag) close (unit) end if lib%makefile_exists = .true. end if end subroutine process_library_write_makefile @ %def process_library_write_makefile @ @ Write the driver source code for the library to file, if there are external processes. <>= procedure :: write_driver => process_library_write_driver <>= module subroutine process_library_write_driver (lib, force, workspace) class(process_library_t), intent(inout) :: lib logical, intent(in) :: force type(string_t), intent(in), optional :: workspace end subroutine process_library_write_driver <>= module subroutine process_library_write_driver (lib, force, workspace) class(process_library_t), intent(inout) :: lib logical, intent(in) :: force type(string_t), intent(in), optional :: workspace character(32) :: md5sum_file logical :: generate integer :: unit if (lib%external .and. .not. lib%static) then generate = .true. if (.not. force) then md5sum_file = lib%driver%get_md5sum_driver (workspace) if (lib%md5sum == md5sum_file) then call msg_message ("Process library '" // char (lib%basename) & // "': keeping driver") generate = .false. end if end if if (generate) then call msg_message ("Process library '" // char (lib%basename) & // "': writing driver") unit = free_unit () open (unit, & file = char (workspace_prefix (workspace) & & // lib%driver%basename // ".f90"), & status="replace", action="write") call lib%driver%generate_driver_code (unit) close (unit) end if lib%driver_exists = .true. end if end subroutine process_library_write_driver @ %def process_library_write_driver @ Update the compilation status of an external library. Strictly speaking, this is not necessary for a one-time run, since the individual library methods will update the status themselves. However, it allows us to identify compilation steps that we can skip because the file exists or is already loaded, for the whole library or for particular entries. Independently, the building process is controlled by a makefile. Thus, previous files are reused if they are not modified by the current compilation. \begin{enumerate} \item If it is not already loaded, attempt to load the library. If successful, check the overall MD5 sum. If it matches, just keep it loaded and mark as ACTIVE. If not, check the MD5 sum for all linked process components. Where it matches, mark the entry as COMPILED. Then, unload the library and mark as CONFIGURED. Thus, we can identify compiled files for all matrix elements which are accessible via the previous compiled library, even if it is no longer up to date. \item If the library is now in CONFIGURED state, look for valid source files. Each entry that is just in CONFIGURED state will advance to SOURCE if the MD5 sum matches. Finally, advance the whole library to SOURCE if all entries are at least in this condition. \end{enumerate} <>= procedure :: update_status => process_library_update_status <>= module subroutine process_library_update_status (lib, os_data, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace end subroutine process_library_update_status <>= module subroutine process_library_update_status (lib, os_data, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data type(string_t), intent(in), optional :: workspace character(32) :: md5sum_file integer :: i, i_external, i_component if (lib%external) then select case (lib%status) case (STAT_CONFIGURED:STAT_LINKED) call lib%driver%load (os_data, noerror=.true., workspace=workspace) end select if (lib%driver%loaded) then md5sum_file = lib%driver%get_md5sum (0) if (lib%md5sum == md5sum_file) then call lib%load_entries () lib%entry%status = STAT_ACTIVE lib%status = STAT_ACTIVE call msg_message ("Process library '" // char (lib%basename) & // "': active") else do i = 1, lib%n_entries associate (entry => lib%entry(i)) i_external = entry%i_external i_component = entry%i_component if (i_external /= 0) then md5sum_file = lib%driver%get_md5sum (i_external) if (entry%def%get_md5sum (i_component) == md5sum_file) then entry%status = STAT_COMPILED else entry%status = STAT_CONFIGURED end if end if end associate end do call lib%driver%unload () lib%status = STAT_CONFIGURED end if end if select case (lib%status) case (STAT_CONFIGURED) do i = 1, lib%n_entries associate (entry => lib%entry(i)) i_external = entry%i_external i_component = entry%i_component if (i_external /= 0) then select case (entry%status) case (STAT_CONFIGURED) md5sum_file = lib%driver%get_md5sum_source & (i_external, workspace) if (entry%def%get_md5sum (i_component) == md5sum_file) then entry%status = STAT_SOURCE end if end select end if end associate end do if (all (lib%entry%status >= STAT_SOURCE)) then md5sum_file = lib%driver%get_md5sum_driver (workspace) if (lib%md5sum == md5sum_file) then lib%status = STAT_SOURCE end if end if end select end if end subroutine process_library_update_status @ %def process_library_update_status @ This procedure triggers code generation for all processes where this is possible. We generate code only for external processes of status [[STAT_CONFIGURED]], which then advance to [[STAT_SOURCE]]. If, for a particular process, the status is already advanced, we do not remove previous files, so [[make]] will consider them as up to date if they exist. Otherwise, we remove those files to force a fresh [[make]]. Finally, if any source code has been generated, we need a driver file. <>= procedure :: make_source => process_library_make_source <>= module subroutine process_library_make_source & (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace end subroutine process_library_make_source <>= module subroutine process_library_make_source & (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace logical :: keep_old integer :: i, i_external keep_old = .false. if (present (keep_old_source)) keep_old = keep_old_source if (lib%external .and. .not. lib%static) then select case (lib%status) case (STAT_CONFIGURED) if (keep_old) then call msg_message ("Process library '" // char (lib%basename) & // "': keeping source code") else call msg_message ("Process library '" // char (lib%basename) & // "': creating source code") do i = 1, size (lib%entry) associate (entry => lib%entry(i)) i_external = entry%i_external if (i_external /= 0 & .and. lib%entry(i)%status == STAT_CONFIGURED) then call lib%driver%clean_proc & (i_external, os_data, workspace) end if end associate if (signal_is_pending ()) return end do call lib%driver%make_source (os_data, workspace) end if lib%status = STAT_SOURCE where (lib%entry%i_external /= 0 & .and. lib%entry%status == STAT_CONFIGURED) lib%entry%status = STAT_SOURCE end where lib%status = STAT_SOURCE end select end if end subroutine process_library_make_source @ %def process_library_make_source @ Compile the generated code and update the status codes. Try to make the sources first, just in case. This includes compiling possible \LaTeX Feynman diagram files. <>= procedure :: make_compile => process_library_make_compile <>= module subroutine process_library_make_compile & (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace end subroutine process_library_make_compile <>= module subroutine process_library_make_compile & (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace if (lib%external .and. .not. lib%static) then select case (lib%status) case (STAT_CONFIGURED) call lib%make_source (os_data, keep_old_source, workspace) end select if (signal_is_pending ()) return select case (lib%status) case (STAT_SOURCE) call msg_message ("Process library '" // char (lib%basename) & // "': compiling sources") call lib%driver%make_compile (os_data, workspace) where (lib%entry%i_external /= 0 & .and. lib%entry%status == STAT_SOURCE) lib%entry%status = STAT_COMPILED end where lib%status = STAT_COMPILED end select end if end subroutine process_library_make_compile @ %def process_library_make_compile @ Link the process library. Try to compile first, just in case. <>= procedure :: make_link => process_library_make_link <>= module subroutine process_library_make_link & (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace end subroutine process_library_make_link <>= module subroutine process_library_make_link & (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace if (lib%external .and. .not. lib%static) then select case (lib%status) case (STAT_CONFIGURED:STAT_SOURCE) call lib%make_compile (os_data, keep_old_source, workspace) end select if (signal_is_pending ()) return select case (lib%status) case (STAT_COMPILED) call msg_message ("Process library '" // char (lib%basename) & // "': linking") call lib%driver%make_link (os_data, workspace) lib%entry%status = STAT_LINKED lib%status = STAT_LINKED end select end if end subroutine process_library_make_link @ %def process_library_make_link @ Load the process library, i.e., assign pointers to the library functions. <>= procedure :: load => process_library_load <>= module subroutine process_library_load (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace end subroutine process_library_load <>= module subroutine process_library_load (lib, os_data, keep_old_source, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in), optional :: keep_old_source type(string_t), intent(in), optional :: workspace select case (lib%status) case (STAT_CONFIGURED:STAT_COMPILED) call lib%make_link (os_data, keep_old_source, workspace) end select if (signal_is_pending ()) return select case (lib%status) case (STAT_LINKED) if (lib%external) then call msg_message ("Process library '" // char (lib%basename) & // "': loading") call lib%driver%load (os_data, workspace=workspace) call lib%load_entries () end if lib%entry%status = STAT_ACTIVE lib%status = STAT_ACTIVE end select end subroutine process_library_load @ %def process_library_load @ This is the actual loading part for the process methods. <>= procedure :: load_entries => process_library_load_entries <>= module subroutine process_library_load_entries (lib) class(process_library_t), intent(inout) :: lib end subroutine process_library_load_entries <>= module subroutine process_library_load_entries (lib) class(process_library_t), intent(inout) :: lib integer :: i do i = 1, size (lib%entry) associate (entry => lib%entry(i)) if (entry%i_external /= 0) then call entry%connect (lib%driver, entry%i_external) end if end associate end do end subroutine process_library_load_entries @ %def process_library_load_entries @ Unload the library, if possible. This reverts the status to ``linked''. <>= procedure :: unload => process_library_unload <>= module subroutine process_library_unload (lib) class(process_library_t), intent(inout) :: lib end subroutine process_library_unload <>= module subroutine process_library_unload (lib) class(process_library_t), intent(inout) :: lib select case (lib%status) case (STAT_ACTIVE) if (lib%external) then call msg_message ("Process library '" // char (lib%basename) & // "': unloading") call lib%driver%unload () end if lib%entry%status = STAT_LINKED lib%status = STAT_LINKED end select end subroutine process_library_unload @ %def process_library_unload @ Unload, clean all generated files and revert the library status. If [[distclean]] is set, also remove the makefile and the driver source. <>= procedure :: clean => process_library_clean <>= module subroutine process_library_clean (lib, os_data, distclean, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in) :: distclean type(string_t), intent(in), optional :: workspace end subroutine process_library_clean <>= module subroutine process_library_clean (lib, os_data, distclean, workspace) class(process_library_t), intent(inout) :: lib type(os_data_t), intent(in) :: os_data logical, intent(in) :: distclean type(string_t), intent(in), optional :: workspace call lib%unload () if (lib%external .and. .not. lib%static) then call msg_message ("Process library '" // char (lib%basename) & // "': removing old files") if (distclean) then call lib%driver%distclean (os_data, workspace) else call lib%driver%clean (os_data, workspace) end if end if where (lib%entry%i_external /= 0) lib%entry%status = STAT_CONFIGURED elsewhere lib%entry%status = STAT_LINKED end where if (lib%external) then lib%status = STAT_CONFIGURED else lib%status = STAT_LINKED end if end subroutine process_library_clean @ %def process_library_clean @ Unload and revert the library status to INITIAL. This allows for appending new processes. No files are deleted. <>= procedure :: open => process_library_open <>= module subroutine process_library_open (lib) class(process_library_t), intent(inout) :: lib end subroutine process_library_open <>= module subroutine process_library_open (lib) class(process_library_t), intent(inout) :: lib select case (lib%status) case (STAT_OPEN) case default call lib%unload () if (.not. lib%static) then lib%entry%status = STAT_OPEN lib%status = STAT_OPEN if (lib%external) lib%update_counter = lib%update_counter + 1 call msg_message ("Process library '" // char (lib%basename) & // "': open") else call msg_error ("Static process library '" // char (lib%basename) & // "': processes can't be appended") end if end select end subroutine process_library_open @ %def process_library_open @ \subsection{Use the library} Return the base name of the library <>= procedure :: get_name => process_library_get_name <>= module function process_library_get_name (lib) result (name) class(process_library_t), intent(in) :: lib type(string_t) :: name end function process_library_get_name <>= module function process_library_get_name (lib) result (name) class(process_library_t), intent(in) :: lib type(string_t) :: name name = lib%basename end function process_library_get_name @ %def process_library_get_name @ Once activated, we view the process library object as an interface for accessing the matrix elements. <>= procedure :: is_active => process_library_is_active <>= module function process_library_is_active (lib) result (flag) logical :: flag class(process_library_t), intent(in) :: lib end function process_library_is_active <>= module function process_library_is_active (lib) result (flag) logical :: flag class(process_library_t), intent(in) :: lib flag = lib%status == STAT_ACTIVE end function process_library_is_active @ %def process_library_is_active @ Return the current status code of the library. If an index is provided, return the status of that entry. <>= procedure :: get_status => process_library_get_status <>= module function process_library_get_status (lib, i) result (status) class(process_library_t), intent(in) :: lib integer, intent(in), optional :: i integer :: status end function process_library_get_status <>= module function process_library_get_status (lib, i) result (status) class(process_library_t), intent(in) :: lib integer, intent(in), optional :: i integer :: status if (present (i)) then status = lib%entry(i)%status else status = lib%status end if end function process_library_get_status @ %def process_library_get_status @ Return the update counter. Since this is incremented each time the library is re-opened, we can use this to check if existing pointers to matrix element code are still valid. <>= procedure :: get_update_counter => process_library_get_update_counter <>= module function process_library_get_update_counter (lib) result (counter) class(process_library_t), intent(in) :: lib integer :: counter end function process_library_get_update_counter <>= module function process_library_get_update_counter (lib) result (counter) class(process_library_t), intent(in) :: lib integer :: counter counter = lib%update_counter end function process_library_get_update_counter @ %def process_library_get_update_counter @ Manually set the current status code of the library. If the optional flag is set, set also the entry status codes. This is used for unit tests. <>= procedure :: set_status => process_library_set_status <>= module subroutine process_library_set_status (lib, status, entries) class(process_library_t), intent(inout) :: lib integer, intent(in) :: status logical, intent(in), optional :: entries end subroutine process_library_set_status <>= module subroutine process_library_set_status (lib, status, entries) class(process_library_t), intent(inout) :: lib integer, intent(in) :: status logical, intent(in), optional :: entries lib%status = status if (present (entries)) then if (entries) lib%entry%status = status end if end subroutine process_library_set_status @ %def process_library_set_status @ Return the load status of the associated driver. <>= procedure :: is_loaded => process_library_is_loaded <>= module function process_library_is_loaded (lib) result (flag) class(process_library_t), intent(in) :: lib logical :: flag end function process_library_is_loaded <>= module function process_library_is_loaded (lib) result (flag) class(process_library_t), intent(in) :: lib logical :: flag flag = lib%driver%loaded end function process_library_is_loaded @ %def process_library_is_loaded @ Retrieve constants using the process library driver. We assume that the process code has been loaded, if external. <>= procedure :: fill_constants => process_library_entry_fill_constants <>= module subroutine process_library_entry_fill_constants (entry, driver, data) class(process_library_entry_t), intent(in) :: entry class(prclib_driver_t), intent(in) :: driver type(process_constants_t), intent(out) :: data end subroutine process_library_entry_fill_constants <>= module subroutine process_library_entry_fill_constants (entry, driver, data) class(process_library_entry_t), intent(in) :: entry class(prclib_driver_t), intent(in) :: driver type(process_constants_t), intent(out) :: data integer :: i if (entry%i_external /= 0) then i = entry%i_external data%id = driver%get_process_id (i) data%model_name = driver%get_model_name (i) data%md5sum = driver%get_md5sum (i) data%openmp_supported = driver%get_openmp_status (i) data%n_in = driver%get_n_in (i) data%n_out = driver%get_n_out (i) data%n_flv = driver%get_n_flv (i) data%n_hel = driver%get_n_hel (i) data%n_col = driver%get_n_col (i) data%n_cin = driver%get_n_cin (i) data%n_cf = driver%get_n_cf (i) call driver%set_flv_state (i, data%flv_state) call driver%set_hel_state (i, data%hel_state) call driver%set_col_state (i, data%col_state, data%ghost_flag) call driver%set_color_factors (i, data%color_factors, data%cf_index) else select type (proc_driver => entry%driver) class is (process_driver_internal_t) call proc_driver%fill_constants (data) end select end if end subroutine process_library_entry_fill_constants @ %def process_library_entry_fill_constants @ Retrieve the constants for a process <>= procedure :: fill_constants => process_library_fill_constants <>= module subroutine process_library_fill_constants (lib, id, i_component, data) class(process_library_t), intent(in) :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component type(process_constants_t), intent(out) :: data end subroutine process_library_fill_constants <>= module subroutine process_library_fill_constants (lib, id, i_component, data) class(process_library_t), intent(in) :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component type(process_constants_t), intent(out) :: data integer :: i do i = 1, size (lib%entry) associate (entry => lib%entry(i)) if (entry%def%id == id .and. entry%i_component == i_component) then call entry%fill_constants (lib%driver, data) return end if end associate end do end subroutine process_library_fill_constants @ %def process_library_fill_constants @ Retrieve the constants and a connected driver for a process, identified by a process ID and a subprocess index. We scan the process entries until we have found a match. <>= procedure :: connect_process => process_library_connect_process <>= module subroutine process_library_connect_process & (lib, id, i_component, data, proc_driver) class(process_library_t), intent(in) :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component type(process_constants_t), intent(out) :: data class(prc_core_driver_t), allocatable, intent(out) :: proc_driver end subroutine process_library_connect_process <>= module subroutine process_library_connect_process & (lib, id, i_component, data, proc_driver) class(process_library_t), intent(in) :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component type(process_constants_t), intent(out) :: data class(prc_core_driver_t), allocatable, intent(out) :: proc_driver integer :: i do i = 1, size (lib%entry) associate (entry => lib%entry(i)) if (entry%def%id == id .and. entry%i_component == i_component) then call entry%fill_constants (lib%driver, data) allocate (proc_driver, source = entry%driver) return end if end associate end do call msg_fatal ("Process library '" // char (lib%basename) & // "': process '" // char (id) // "' not found") end subroutine process_library_connect_process @ %def process_library_connect_process @ Shortcut for use in unit tests: fetch the MD5sum from a specific library entry and inject it into the writer of a specific record. <>= procedure :: test_transfer_md5sum => process_library_test_transfer_md5sum <>= module subroutine process_library_test_transfer_md5sum (lib, r, e, c) class(process_library_t), intent(inout) :: lib integer, intent(in) :: r, e, c end subroutine process_library_test_transfer_md5sum <>= module subroutine process_library_test_transfer_md5sum (lib, r, e, c) class(process_library_t), intent(inout) :: lib integer, intent(in) :: r, e, c associate (writer => lib%driver%record(r)%writer) writer%md5sum = lib%entry(e)%def%get_md5sum (c) end associate end subroutine process_library_test_transfer_md5sum @ %def process_library_test_transfer_md5sum @ <>= procedure :: get_nlo_type => process_library_get_nlo_type <>= module function process_library_get_nlo_type (lib, id, i_component) result (nlo_type) integer :: nlo_type class(process_library_t), intent(in) :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component end function process_library_get_nlo_type <>= module function process_library_get_nlo_type (lib, id, i_component) result (nlo_type) integer :: nlo_type class(process_library_t), intent(in) :: lib type(string_t), intent(in) :: id integer, intent(in) :: i_component integer :: i do i = 1, size (lib%entry) if (lib%entry(i)%def%id == id .and. lib%entry(i)%i_component == i_component) then nlo_type = lib%entry(i)%def%get_nlo_type (i_component) exit end if end do end function process_library_get_nlo_type @ %def process_library_get_nlo_type @ \subsection{Collect model-specific libraries} This returns appropriate linker flags for the model parameter libraries that are used by the generated matrix element. At the end, the main libwhizard is appended (again), because functions from that may be reqired. Extra models in the local user space need to be treated individually. <>= procedure :: get_modellibs_ldflags => process_library_get_modellibs_ldflags <>= module function process_library_get_modellibs_ldflags (prc_lib, os_data) result (flags) class(process_library_t), intent(in) :: prc_lib type(os_data_t), intent(in) :: os_data type(string_t) :: flags end function process_library_get_modellibs_ldflags <>= module function process_library_get_modellibs_ldflags (prc_lib, os_data) result (flags) class(process_library_t), intent(in) :: prc_lib type(os_data_t), intent(in) :: os_data type(string_t) :: flags type(string_t), dimension(:), allocatable :: models type(string_t) :: modelname, modellib, modellib_full logical :: exist integer :: i, j, mi flags = " -lomega" if ((.not. os_data%use_testfiles) .and. & os_dir_exist (os_data%whizard_models_libpath_local)) & flags = flags // " -L" // os_data%whizard_models_libpath_local flags = flags // " -L" // os_data%whizard_models_libpath allocate (models(prc_lib%n_entries + 1)) models = "" mi = 1 if (allocated (prc_lib%entry)) then SCAN: do i = 1, prc_lib%n_entries if (associated (prc_lib%entry(i)%def)) then if (prc_lib%entry(i)%def%model_name /= "") then modelname = prc_lib%entry(i)%def%model_name else cycle SCAN end if else cycle SCAN end if do j = 1, mi if (models(mi) == modelname) cycle SCAN end do models(mi) = modelname mi = mi + 1 if (os_data%use_libtool) then modellib = "libparameters_" // modelname // ".la" else modellib = "libparameters_" // modelname // ".a" end if exist = .false. if (.not. os_data%use_testfiles) then modellib_full = os_data%whizard_models_libpath_local & // "/" // modellib inquire (file=char (modellib_full), exist=exist) end if if (.not. exist) then modellib_full = os_data%whizard_models_libpath & // "/" // modellib inquire (file=char (modellib_full), exist=exist) end if if (exist) flags = flags // " -lparameters_" // modelname end do SCAN end if deallocate (models) flags = flags // " -lwhizard" end function process_library_get_modellibs_ldflags @ %def process_library_get_modellibs_ldflags @ <>= procedure :: get_static_modelname => process_library_get_static_modelname <>= module function process_library_get_static_modelname (prc_lib, os_data) result (name) class(process_library_t), intent(in) :: prc_lib type(os_data_t), intent(in) :: os_data type(string_t) :: name end function process_library_get_static_modelname <>= module function process_library_get_static_modelname (prc_lib, os_data) result (name) class(process_library_t), intent(in) :: prc_lib type(os_data_t), intent(in) :: os_data type(string_t) :: name type(string_t), dimension(:), allocatable :: models type(string_t) :: modelname, modellib, modellib_full logical :: exist integer :: i, j, mi name = "" allocate (models(prc_lib%n_entries + 1)) models = "" mi = 1 if (allocated (prc_lib%entry)) then SCAN: do i = 1, prc_lib%n_entries if (associated (prc_lib%entry(i)%def)) then if (prc_lib%entry(i)%def%model_name /= "") then modelname = prc_lib%entry(i)%def%model_name else cycle SCAN end if else cycle SCAN end if do j = 1, mi if (models(mi) == modelname) cycle SCAN end do models(mi) = modelname mi = mi + 1 modellib = "libparameters_" // modelname // ".a" exist = .false. if (.not. os_data%use_testfiles) then modellib_full = os_data%whizard_models_libpath_local & // "/" // modellib inquire (file=char (modellib_full), exist=exist) end if if (.not. exist) then modellib_full = os_data%whizard_models_libpath & // "/" // modellib inquire (file=char (modellib_full), exist=exist) end if if (exist) name = name // " " // modellib_full end do SCAN end if deallocate (models) end function process_library_get_static_modelname @ %def process_library_get_static_modelname @ \subsection{Unit Test} Test module, followed by the corresponding implementation module. <<[[process_libraries_ut.f90]]>>= <> module process_libraries_ut use unit_tests use process_libraries_uti <> <> contains <> end module process_libraries_ut @ %def process_libraries_ut @ <<[[process_libraries_uti.f90]]>>= <> module process_libraries_uti use, intrinsic :: iso_c_binding !NODEP! <> use io_units use os_interface use particle_specifiers, only: new_prt_spec use process_constants use prclib_interfaces use prc_core_def use process_libraries use prclib_interfaces_ut, only: test_writer_4_t <> <> <> contains <> <> end module process_libraries_uti @ %def process_libraries_ut @ API: driver for the unit tests below. <>= public :: process_libraries_test <>= subroutine process_libraries_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine process_libraries_test @ %def process_libraries_test @ \subsubsection{Empty process list} Test 1: Write an empty process list. <>= call test (process_libraries_1, "process_libraries_1", & "empty process list", & u, results) <>= public :: process_libraries_1 <>= subroutine process_libraries_1 (u) integer, intent(in) :: u type(process_def_list_t) :: process_def_list write (u, "(A)") "* Test output: process_libraries_1" write (u, "(A)") "* Purpose: Display an empty process definition list" write (u, "(A)") call process_def_list%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_1" end subroutine process_libraries_1 @ %def process_libraries_1 @ \subsubsection{Process definition list} Test 2: Process definition list with processes and components. Construct the list, write to file, read it in again, and display. Finalize and delete the list after use. We define a trivial 'test' type for the process variant. The test type contains just one (meaningless) data item, which is an integer. <>= type, extends (prc_core_def_t) :: prcdef_2_t integer :: data = 0 logical :: file = .false. contains <> end type prcdef_2_t @ %def prcdef_2_t @ The process variant is named 'test'. <>= procedure, nopass :: type_string => prcdef_2_type_string <>= function prcdef_2_type_string () result (string) type(string_t) :: string string = "test" end function prcdef_2_type_string @ %def prcdef_2_type_string @ Write the contents (the integer value). <>= procedure :: write => prcdef_2_write <>= subroutine prcdef_2_write (object, unit) class(prcdef_2_t), intent(in) :: object integer, intent(in) :: unit write (unit, "(3x,A,I0)") "Test data = ", object%data end subroutine prcdef_2_write @ %def prcdef_2_write @ Recover the integer value. <>= procedure :: read => prcdef_2_read <>= subroutine prcdef_2_read (object, unit) class(prcdef_2_t), intent(out) :: object integer, intent(in) :: unit character(80) :: buffer read (unit, "(A)") buffer call strip_equation_lhs (buffer) read (buffer, *) object%data end subroutine prcdef_2_read @ %def prcdef_2_read @ No external procedures. <>= procedure, nopass :: get_features => prcdef_2_get_features <>= subroutine prcdef_2_get_features (features) type(string_t), dimension(:), allocatable, intent(out) :: features allocate (features (0)) end subroutine prcdef_2_get_features @ %def prcdef_2_get_features @ No code generated. <>= procedure :: generate_code => prcdef_2_generate_code <>= subroutine prcdef_2_generate_code (object, & basename, model_name, prt_in, prt_out) class(prcdef_2_t), intent(in) :: object type(string_t), intent(in) :: basename type(string_t), intent(in) :: model_name type(string_t), dimension(:), intent(in) :: prt_in type(string_t), dimension(:), intent(in) :: prt_out end subroutine prcdef_2_generate_code @ %def prcdef_2_generate_code @ Allocate the driver with the appropriate type. <>= procedure :: allocate_driver => prcdef_2_allocate_driver <>= subroutine prcdef_2_allocate_driver (object, driver, basename) class(prcdef_2_t), intent(in) :: object class(prc_core_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename allocate (prctest_2_t :: driver) end subroutine prcdef_2_allocate_driver @ %def prcdef_2_allocate_driver @ Nothing to connect. <>= procedure :: connect => prcdef_2_connect <>= subroutine prcdef_2_connect (def, lib_driver, i, proc_driver) class(prcdef_2_t), intent(in) :: def class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver end subroutine prcdef_2_connect @ %def prcdef_2_connect @ The associated driver type. <>= type, extends (process_driver_internal_t) :: prctest_2_t contains <> end type prctest_2_t @ %def prctest_2_t @ Return the type name. <>= procedure, nopass :: type_name => prctest_2_type_name <>= function prctest_2_type_name () result (type) type(string_t) :: type type = "test" end function prctest_2_type_name @ %def prctest_2_type_name @ This should fill constant process data. We do not check those here, however, therefore nothing done. <>= procedure :: fill_constants => prctest_2_fill_constants <>= subroutine prctest_2_fill_constants (driver, data) class(prctest_2_t), intent(in) :: driver type(process_constants_t), intent(out) :: data end subroutine prctest_2_fill_constants @ %def prctest_2_fill_constants @ Here is the actual test. For reading, we need a list of templates, i.e., an array containing allocated objects for all available process variants. This is the purpose of [[process_core_templates]]. Here, we have only a single template for the 'test' variant. <>= call test (process_libraries_2, "process_libraries_2", & "process definition list", & u, results) <>= public :: process_libraries_2 <>= subroutine process_libraries_2 (u) integer, intent(in) :: u type(prc_template_t), dimension(:), allocatable :: process_core_templates type(process_def_list_t) :: process_def_list type(process_def_entry_t), pointer :: entry => null () class(prc_core_def_t), allocatable :: test_def integer :: scratch_unit write (u, "(A)") "* Test output: process_libraries_2" write (u, "(A)") "* Purpose: Construct a process definition list," write (u, "(A)") "* write it to file and reread it" write (u, "(A)") "" write (u, "(A)") "* Construct a process definition list" write (u, "(A)") "* First process definition: empty" write (u, "(A)") "* Second process definition: two components" write (u, "(A)") "* First component: empty" write (u, "(A)") "* Second component: test data" write (u, "(A)") "* Third process definition:" write (u, "(A)") "* Embedded decays and polarization" write (u, "(A)") allocate (process_core_templates (1)) allocate (prcdef_2_t :: process_core_templates(1)%core_def) allocate (entry) call entry%init (var_str ("first"), n_in = 0, n_components = 0) call entry%compute_md5sum () call process_def_list%append (entry) allocate (entry) call entry%init (var_str ("second"), model_name = var_str ("Test"), & n_in = 1, n_components = 2) allocate (prcdef_2_t :: test_def) select type (test_def) type is (prcdef_2_t); test_def%data = 42 end select call entry%import_component (2, n_out = 2, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), & method = var_str ("test"), & variant = test_def) call entry%compute_md5sum () call process_def_list%append (entry) allocate (entry) call entry%init (var_str ("third"), model_name = var_str ("Test"), & n_in = 2, n_components = 1) allocate (prcdef_2_t :: test_def) call entry%import_component (1, n_out = 3, & prt_in = & new_prt_spec ([var_str ("a"), var_str ("b")]), & prt_out = & [new_prt_spec (var_str ("c")), & new_prt_spec (var_str ("d"), .true.), & new_prt_spec (var_str ("e"), [var_str ("e_decay")])], & method = var_str ("test"), & variant = test_def) call entry%compute_md5sum () call process_def_list%append (entry) call process_def_list%write (u) write (u, "(A)") "" write (u, "(A)") "* Write the process definition list to (scratch) file" scratch_unit = free_unit () open (unit = scratch_unit, status="scratch", action = "readwrite") call process_def_list%write (scratch_unit) call process_def_list%final () write (u, "(A)") "* Reread it" write (u, "(A)") "" rewind (scratch_unit) call process_def_list%read (scratch_unit, process_core_templates) close (scratch_unit) call process_def_list%write (u) call process_def_list%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_2" end subroutine process_libraries_2 @ %def process_libraries_2 @ \subsubsection{Process library object} Test 3: Process library object with several process definitions and library entries. Just construct the object, modify some initial content, and write the result. The modifications are mostly applied directly, so we do not test anything but the contents and the output routine. <>= call test (process_libraries_3, "process_libraries_3", & "recover process definition list from file", & u, results) <>= public :: process_libraries_3 <>= subroutine process_libraries_3 (u) integer, intent(in) :: u type(process_library_t) :: lib type(process_def_entry_t), pointer :: entry class(prc_core_driver_t), allocatable :: driver_template write (u, "(A)") "* Test output: process_libraries_3" write (u, "(A)") "* Purpose: Construct a process library object & &with entries" write (u, "(A)") "" write (u, "(A)") "* Construct and display a process library object" write (u, "(A)") "* with 5 entries" write (u, "(A)") "* associated with 3 matrix element codes" write (u, "(A)") "* corresponding to 3 process definitions" write (u, "(A)") "* with 2, 1, 1 components, respectively" write (u, "(A)") call lib%init (var_str ("testlib")) call lib%set_status (STAT_ACTIVE) call lib%allocate_entries (5) allocate (entry) call entry%init (var_str ("test_a"), n_in = 2, n_components = 2) allocate (prctest_2_t :: driver_template) call lib%init_entry (3, STAT_SOURCE, entry%process_def_t, 2, 2, & driver_template) call lib%init_entry (4, STAT_COMPILED, entry%process_def_t, 1, 0) call lib%append (entry) allocate (entry) call entry%init (var_str ("test_b"), n_in = 2, n_components = 1) call lib%init_entry (2, STAT_CONFIGURED, entry%process_def_t, 1, 1) call lib%append (entry) allocate (entry) call entry%init (var_str ("test_c"), n_in = 2, n_components = 1) allocate (prctest_2_t :: driver_template) call lib%init_entry (5, STAT_LINKED, entry%process_def_t, 1, 3, & driver_template) call lib%append (entry) call lib%write (u) call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_3" end subroutine process_libraries_3 @ %def process_libraries_3 @ \subsubsection{Process library for test matrix element (no file)} Test 4: We proceed through the library generation and loading phases with a test matrix element type that needs no code written on file. <>= call test (process_libraries_4, "process_libraries_4", & "build and load internal process library", & u, results) <>= public :: process_libraries_4 <>= subroutine process_libraries_4 (u) integer, intent(in) :: u type(process_library_t) :: lib type(process_def_entry_t), pointer :: entry class(prc_core_def_t), allocatable :: core_def type(os_data_t) :: os_data write (u, "(A)") "* Test output: process_libraries_4" write (u, "(A)") "* Purpose: build a process library with an & &internal (pseudo) matrix element" write (u, "(A)") "* No Makefile or code should be generated" write (u, "(A)") write (u, "(A)") "* Initialize a process library with one entry & &(no external code)" write (u, "(A)") call os_data%init () call lib%init (var_str ("proclibs4")) allocate (prcdef_2_t :: core_def) allocate (entry) call entry%init (var_str ("proclibs4_a"), n_in = 1, n_components = 1) call entry%import_component (1, n_out = 2, variant = core_def) call lib%append (entry) write (u, "(A)") "* Configure library" write (u, "(A)") call lib%configure (os_data) write (u, "(A)") "* Compute MD5 sum" write (u, "(A)") call lib%compute_md5sum () write (u, "(A)") "* Write makefile (no-op)" write (u, "(A)") call lib%write_makefile (os_data, force = .true., verbose = .true.) write (u, "(A)") "* Write driver source code (no-op)" write (u, "(A)") call lib%write_driver (force = .true.) write (u, "(A)") "* Write process source code (no-op)" write (u, "(A)") call lib%make_source (os_data) write (u, "(A)") "* Compile (no-op)" write (u, "(A)") call lib%make_compile (os_data) write (u, "(A)") "* Link (no-op)" write (u, "(A)") call lib%make_link (os_data) write (u, "(A)") "* Load (no-op)" write (u, "(A)") call lib%load (os_data) call lib%write (u) call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_4" end subroutine process_libraries_4 @ %def process_libraries_4 @ \subsubsection{Build workflow for test matrix element} Test 5: We write source code for a dummy process. We define another trivial type for the process variant. The test type contains just no variable data, but produces code on file. <>= type, extends (prc_core_def_t) :: prcdef_5_t contains <> end type prcdef_5_t @ %def prcdef_5_t @ The process variant is named [[test_file]]. <>= procedure, nopass :: type_string => prcdef_5_type_string <>= function prcdef_5_type_string () result (string) type(string_t) :: string string = "test_file" end function prcdef_5_type_string @ %def prcdef_5_type_string @ We reuse the writer [[test_writer_4]] from the previous module. <>= procedure :: init => prcdef_5_init <>= subroutine prcdef_5_init (object) class(prcdef_5_t), intent(out) :: object allocate (test_writer_4_t :: object%writer) end subroutine prcdef_5_init @ %def prcdef_5_init @ Nothing to write. <>= procedure :: write => prcdef_5_write <>= subroutine prcdef_5_write (object, unit) class(prcdef_5_t), intent(in) :: object integer, intent(in) :: unit end subroutine prcdef_5_write @ %def prcdef_5_write @ Nothing to read. <>= procedure :: read => prcdef_5_read <>= subroutine prcdef_5_read (object, unit) class(prcdef_5_t), intent(out) :: object integer, intent(in) :: unit end subroutine prcdef_5_read @ %def prcdef_5_read @ Allocate the driver with the appropriate type. <>= procedure :: allocate_driver => prcdef_5_allocate_driver <>= subroutine prcdef_5_allocate_driver (object, driver, basename) class(prcdef_5_t), intent(in) :: object class(prc_core_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename allocate (prctest_5_t :: driver) end subroutine prcdef_5_allocate_driver @ %def prcdef_5_allocate_driver @ This time we need code: <>= procedure, nopass :: needs_code => prcdef_5_needs_code <>= function prcdef_5_needs_code () result (flag) logical :: flag flag = .true. end function prcdef_5_needs_code @ %def prcdef_5_needs_code @ For the test case, we implement a single feature [[proc1]]. <>= procedure, nopass :: get_features => prcdef_5_get_features <>= subroutine prcdef_5_get_features (features) type(string_t), dimension(:), allocatable, intent(out) :: features allocate (features (1)) features = [ var_str ("proc1") ] end subroutine prcdef_5_get_features @ %def prcdef_5_get_features @ Nothing to connect. <>= procedure :: connect => prcdef_5_connect <>= subroutine prcdef_5_connect (def, lib_driver, i, proc_driver) class(prcdef_5_t), intent(in) :: def class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver end subroutine prcdef_5_connect @ %def prcdef_5_connect @ The driver type. <>= type, extends (prc_core_driver_t) :: prctest_5_t contains <> end type prctest_5_t @ %def prctest_5_t @ Return the type name. <>= procedure, nopass :: type_name => prctest_5_type_name <>= function prctest_5_type_name () result (type) type(string_t) :: type type = "test_file" end function prctest_5_type_name @ %def prctest_5_type_name @ Here is the actual test: <>= call test (process_libraries_5, "process_libraries_5", & "build external process library", & u, results) <>= public :: process_libraries_5 <>= subroutine process_libraries_5 (u) integer, intent(in) :: u type(process_library_t) :: lib type(process_def_entry_t), pointer :: entry class(prc_core_def_t), allocatable :: core_def type(os_data_t) :: os_data write (u, "(A)") "* Test output: process_libraries_5" write (u, "(A)") "* Purpose: build a process library with an & &external (pseudo) matrix element" write (u, "(A)") write (u, "(A)") "* Initialize a process library with one entry" write (u, "(A)") call lib%init (var_str ("proclibs5")) call os_data%init () allocate (prcdef_5_t :: core_def) select type (core_def) type is (prcdef_5_t) call core_def%init () end select allocate (entry) call entry%init (var_str ("proclibs5_a"), & model_name = var_str ("Test_Model"), & n_in = 1, n_components = 1) call entry%import_component (1, n_out = 2, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), & method = var_str ("test"), & variant = core_def) call lib%append (entry) write (u, "(A)") "* Configure library" write (u, "(A)") call lib%configure (os_data) write (u, "(A)") "* Compute MD5 sum" write (u, "(A)") call lib%compute_md5sum () write (u, "(A)") "* Write makefile" write (u, "(A)") call lib%write_makefile (os_data, force = .true., verbose = .false.) write (u, "(A)") "* Write driver source code" write (u, "(A)") call lib%write_driver (force = .true.) write (u, "(A)") "* Write process source code" write (u, "(A)") call lib%make_source (os_data) write (u, "(A)") "* Compile" write (u, "(A)") call lib%make_compile (os_data) write (u, "(A)") "* Link" write (u, "(A)") call lib%make_link (os_data) call lib%write (u, libpath = .false.) call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_5" end subroutine process_libraries_5 @ %def process_libraries_5 @ \subsubsection{Build and load library with test matrix element} Test 6: We write source code for a dummy process. This process variant is identical to the previous case, but it supports a driver for the test procedure 'proc1'. <>= type, extends (prc_core_def_t) :: prcdef_6_t contains <> end type prcdef_6_t @ %def prcdef_6_t @ The process variant is named [[test_file]]. <>= procedure, nopass :: type_string => prcdef_6_type_string <>= function prcdef_6_type_string () result (string) type(string_t) :: string string = "test_file" end function prcdef_6_type_string @ %def prcdef_6_type_string @ We reuse the writer [[test_writer_4]] from the previous module. <>= procedure :: init => prcdef_6_init <>= subroutine prcdef_6_init (object) class(prcdef_6_t), intent(out) :: object allocate (test_writer_4_t :: object%writer) call object%writer%init_test () end subroutine prcdef_6_init @ %def prcdef_6_init @ Nothing to write. <>= procedure :: write => prcdef_6_write <>= subroutine prcdef_6_write (object, unit) class(prcdef_6_t), intent(in) :: object integer, intent(in) :: unit end subroutine prcdef_6_write @ %def prcdef_6_write @ Nothing to read. <>= procedure :: read => prcdef_6_read <>= subroutine prcdef_6_read (object, unit) class(prcdef_6_t), intent(out) :: object integer, intent(in) :: unit end subroutine prcdef_6_read @ %def prcdef_6_read @ Allocate the driver with the appropriate type. <>= procedure :: allocate_driver => prcdef_6_allocate_driver <>= subroutine prcdef_6_allocate_driver (object, driver, basename) class(prcdef_6_t), intent(in) :: object class(prc_core_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename allocate (prctest_6_t :: driver) end subroutine prcdef_6_allocate_driver @ %def prcdef_6_allocate_driver @ This time we need code: <>= procedure, nopass :: needs_code => prcdef_6_needs_code <>= function prcdef_6_needs_code () result (flag) logical :: flag flag = .true. end function prcdef_6_needs_code @ %def prcdef_6_needs_code @ For the test case, we implement a single feature [[proc1]]. <>= procedure, nopass :: get_features => prcdef_6_get_features <>= subroutine prcdef_6_get_features (features) type(string_t), dimension(:), allocatable, intent(out) :: features allocate (features (1)) features = [ var_str ("proc1") ] end subroutine prcdef_6_get_features @ %def prcdef_6_get_features @ The interface of the only specific feature. <>= abstract interface subroutine proc1_t (n) bind(C) import integer(c_int), intent(out) :: n end subroutine proc1_t end interface @ %def proc1_t @ Connect the feature [[proc1]] with the process driver. <>= procedure :: connect => prcdef_6_connect <>= subroutine prcdef_6_connect (def, lib_driver, i, proc_driver) class(prcdef_6_t), intent(in) :: def class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver integer(c_int) :: pid, fid type(c_funptr) :: fptr select type (proc_driver) type is (prctest_6_t) pid = i fid = 1 call lib_driver%get_fptr (pid, fid, fptr) call c_f_procpointer (fptr, proc_driver%proc1) end select end subroutine prcdef_6_connect @ %def prcdef_6_connect @ The driver type. <>= type, extends (prc_core_driver_t) :: prctest_6_t procedure(proc1_t), nopass, pointer :: proc1 => null () contains <> end type prctest_6_t @ %def prctest_6_t @ Return the type name. <>= procedure, nopass :: type_name => prctest_6_type_name <>= function prctest_6_type_name () result (type) type(string_t) :: type type = "test_file" end function prctest_6_type_name @ %def prctest_6_type_name @ Here is the actual test: <>= call test (process_libraries_6, "process_libraries_6", & "build and load external process library", & u, results) <>= public :: process_libraries_6 <>= subroutine process_libraries_6 (u) integer, intent(in) :: u type(process_library_t) :: lib type(process_def_entry_t), pointer :: entry class(prc_core_def_t), allocatable :: core_def type(os_data_t) :: os_data type(string_t), dimension(:), allocatable :: name_list type(process_constants_t) :: data class(prc_core_driver_t), allocatable :: proc_driver integer :: i integer(c_int) :: n write (u, "(A)") "* Test output: process_libraries_6" write (u, "(A)") "* Purpose: build and load a process library" write (u, "(A)") "* with an external (pseudo) matrix element" write (u, "(A)") "* Check single-call linking" write (u, "(A)") write (u, "(A)") "* Initialize a process library with one entry" write (u, "(A)") call lib%init (var_str ("proclibs6")) call os_data%init () allocate (prcdef_6_t :: core_def) select type (core_def) type is (prcdef_6_t) call core_def%init () end select allocate (entry) call entry%init (var_str ("proclibs6_a"), & model_name = var_str ("Test_model"), & n_in = 1, n_components = 1) call entry%import_component (1, n_out = 2, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), & method = var_str ("test"), & variant = core_def) call lib%append (entry) write (u, "(A)") "* Configure library" write (u, "(A)") call lib%configure (os_data) write (u, "(A)") "* Write makefile" write (u, "(A)") call lib%write_makefile (os_data, force = .true., verbose = .false.) write (u, "(A)") "* Write driver source code" write (u, "(A)") call lib%write_driver (force = .true.) write (u, "(A)") "* Write process source code, compile, link, load" write (u, "(A)") call lib%load (os_data) call lib%write (u, libpath = .false.) write (u, "(A)") write (u, "(A)") "* Probe library API:" write (u, "(A)") write (u, "(1x,A,A,A)") "name = '", & char (lib%get_name ()), "'" write (u, "(1x,A,L1)") "is active = ", & lib%is_active () write (u, "(1x,A,I0)") "n_processes = ", & lib%get_n_processes () write (u, "(1x,A)", advance="no") "processes =" call lib%get_process_id_list (name_list) do i = 1, size (name_list) write (u, "(1x,A)", advance="no") char (name_list(i)) end do write (u, *) write (u, "(1x,A,L1)") "proclibs6_a is process = ", & lib%contains (var_str ("proclibs6_a")) write (u, "(1x,A,I0)") "proclibs6_a has index = ", & lib%get_entry_index (var_str ("proclibs6_a")) write (u, "(1x,A,L1)") "foobar is process = ", & lib%contains (var_str ("foobar")) write (u, "(1x,A,I0)") "foobar has index = ", & lib%get_entry_index (var_str ("foobar")) write (u, "(1x,A,I0)") "n_in(proclibs6_a) = ", & lib%get_n_in (var_str ("proclibs6_a")) write (u, "(1x,A,A)") "model_name(proclibs6_a) = ", & char (lib%get_model_name (var_str ("proclibs6_a"))) write (u, "(1x,A)", advance="no") "components(proclibs6_a) =" call lib%get_component_list (var_str ("proclibs6_a"), name_list) do i = 1, size (name_list) write (u, "(1x,A)", advance="no") char (name_list(i)) end do write (u, *) write (u, "(A)") write (u, "(A)") "* Constants of proclibs6_a_i1:" write (u, "(A)") call lib%connect_process (var_str ("proclibs6_a"), 1, data, proc_driver) write (u, "(1x,A,A)") "component ID = ", char (data%id) write (u, "(1x,A,A)") "model name = ", char (data%model_name) write (u, "(1x,A,A,A)") "md5sum = '", data%md5sum, "'" write (u, "(1x,A,L1)") "openmp supported = ", data%openmp_supported write (u, "(1x,A,I0)") "n_in = ", data%n_in write (u, "(1x,A,I0)") "n_out = ", data%n_out write (u, "(1x,A,I0)") "n_flv = ", data%n_flv write (u, "(1x,A,I0)") "n_hel = ", data%n_hel write (u, "(1x,A,I0)") "n_col = ", data%n_col write (u, "(1x,A,I0)") "n_cin = ", data%n_cin write (u, "(1x,A,I0)") "n_cf = ", data%n_cf write (u, "(1x,A,10(1x,I0))") "flv state =", data%flv_state write (u, "(1x,A,10(1x,I0))") "hel state =", data%hel_state write (u, "(1x,A,10(1x,I0))") "col state =", data%col_state write (u, "(1x,A,10(1x,L1))") "ghost flag =", data%ghost_flag write (u, "(1x,A,10(1x,F5.3))") "color factors =", data%color_factors write (u, "(1x,A,10(1x,I0))") "cf index =", data%cf_index write (u, "(A)") write (u, "(A)") "* Call feature of proclibs6_a:" write (u, "(A)") select type (proc_driver) type is (prctest_6_t) call proc_driver%proc1 (n) write (u, "(1x,A,I0)") "proc1 = ", n end select call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_6" end subroutine process_libraries_6 @ %def process_libraries_6 @ \subsubsection{MD5 sums} Check MD5 sum calculation. <>= call test (process_libraries_7, "process_libraries_7", & "process definition list", & u, results) <>= public :: process_libraries_7 <>= subroutine process_libraries_7 (u) integer, intent(in) :: u type(prc_template_t), dimension(:), allocatable :: process_core_templates type(process_def_entry_t), target :: entry class(prc_core_def_t), allocatable :: test_def class(prc_core_def_t), pointer :: def write (u, "(A)") "* Test output: process_libraries_7" write (u, "(A)") "* Purpose: Construct a process definition list & &and check MD5 sums" write (u, "(A)") write (u, "(A)") "* Construct a process definition list" write (u, "(A)") "* Process: two components" write (u, "(A)") allocate (process_core_templates (1)) allocate (prcdef_2_t :: process_core_templates(1)%core_def) call entry%init (var_str ("first"), model_name = var_str ("Test"), & n_in = 1, n_components = 2) allocate (prcdef_2_t :: test_def) select type (test_def) type is (prcdef_2_t); test_def%data = 31 end select call entry%import_component (1, n_out = 3, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("c"), & var_str ("e")]), & method = var_str ("test"), & variant = test_def) allocate (prcdef_2_t :: test_def) select type (test_def) type is (prcdef_2_t); test_def%data = 42 end select call entry%import_component (2, n_out = 2, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), & method = var_str ("test"), & variant = test_def) call entry%write (u) write (u, "(A)") write (u, "(A)") "* Compute MD5 sums" write (u, "(A)") call entry%compute_md5sum () call entry%write (u) write (u, "(A)") write (u, "(A)") "* Recalculate MD5 sums (should be identical)" write (u, "(A)") call entry%compute_md5sum () call entry%write (u) write (u, "(A)") write (u, "(A)") "* Modify a component and recalculate MD5 sums" write (u, "(A)") def => entry%get_core_def_ptr (2) select type (def) type is (prcdef_2_t) def%data = 54 end select call entry%compute_md5sum () call entry%write (u) write (u, "(A)") write (u, "(A)") "* Modify the model and recalculate MD5 sums" write (u, "(A)") call entry%set_model_name (var_str ("foo")) call entry%compute_md5sum () call entry%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_7" end subroutine process_libraries_7 @ %def process_libraries_7 @ Here is the actual test: <>= call test (process_libraries_8, "process_libraries_8", & "library status checks", & u, results) <>= public :: process_libraries_8 <>= subroutine process_libraries_8 (u) integer, intent(in) :: u type(process_library_t) :: lib type(process_def_entry_t), pointer :: entry class(prc_core_def_t), allocatable :: core_def type(os_data_t) :: os_data write (u, "(A)") "* Test output: process_libraries_8" write (u, "(A)") "* Purpose: build and load a process library" write (u, "(A)") "* with an external (pseudo) matrix element" write (u, "(A)") "* Check status updates" write (u, "(A)") write (u, "(A)") "* Initialize a process library with one entry" write (u, "(A)") call lib%init (var_str ("proclibs8")) call os_data%init () allocate (prcdef_6_t :: core_def) select type (core_def) type is (prcdef_6_t) call core_def%init () end select allocate (entry) call entry%init (var_str ("proclibs8_a"), & model_name = var_str ("Test_model"), & n_in = 1, n_components = 1) call entry%import_component (1, n_out = 2, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("c")]), & method = var_str ("test"), & variant = core_def) call lib%append (entry) write (u, "(A)") "* Configure library" write (u, "(A)") call lib%configure (os_data) call lib%compute_md5sum () call lib%test_transfer_md5sum (1, 1, 1) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(A)") write (u, "(A)") "* Write makefile" write (u, "(A)") call lib%write_makefile (os_data, force = .true., verbose = .false.) write (u, "(A)") "* Update status" write (u, "(A)") call lib%update_status (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(A)") write (u, "(A)") "* Write driver source code" write (u, "(A)") call lib%write_driver (force = .false.) write (u, "(A)") "* Write process source code" write (u, "(A)") call lib%make_source (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(A)") write (u, "(A)") "* Compile and load" write (u, "(A)") call lib%load (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(A)") write (u, "(A)") "* Append process and reconfigure" write (u, "(A)") allocate (prcdef_6_t :: core_def) select type (core_def) type is (prcdef_6_t) call core_def%init () end select allocate (entry) call entry%init (var_str ("proclibs8_b"), & model_name = var_str ("Test_model"), & n_in = 1, n_components = 1) call entry%import_component (1, n_out = 2, & prt_in = new_prt_spec ([var_str ("a")]), & prt_out = new_prt_spec ([var_str ("b"), var_str ("d")]), & method = var_str ("test"), & variant = core_def) call lib%append (entry) call lib%configure (os_data) call lib%compute_md5sum () call lib%test_transfer_md5sum (2, 2, 1) call lib%write_makefile (os_data, force = .false., verbose = .false.) call lib%write_driver (force = .false.) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Update status" write (u, "(A)") call lib%update_status (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Write source code" write (u, "(A)") call lib%make_source (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Reset status" write (u, "(A)") call lib%set_status (STAT_CONFIGURED, entries=.true.) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Update status" write (u, "(A)") call lib%update_status (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Partial cleanup" write (u, "(A)") call lib%clean (os_data, distclean = .false.) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Update status" write (u, "(A)") call lib%update_status (os_data) write (u, "(1x,A,L1)") "library loaded = ", lib%is_loaded () write (u, "(1x,A,I0)") "lib status = ", lib%get_status () write (u, "(1x,A,I0)") "proc1 status = ", lib%get_status (1) write (u, "(1x,A,I0)") "proc2 status = ", lib%get_status (2) write (u, "(A)") write (u, "(A)") "* Complete cleanup" call lib%clean (os_data, distclean = .true.) call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: process_libraries_8" end subroutine process_libraries_8 @ %def process_libraries_8 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Process Library Stacks} For storing and handling multiple libraries, we define process library stacks. These are ordinary stacks where new entries are pushed onto the top. <<[[prclib_stacks.f90]]>>= <> module prclib_stacks <> use process_libraries <> <> <> interface <> end interface end module prclib_stacks @ %def prclib_stacks @ <<[[prclib_stacks_sub.f90]]>>= <> submodule (prclib_stacks) prclib_stacks_s use io_units use format_utils, only: write_separator implicit none contains <> end submodule prclib_stacks_s @ %def prclib_stacks_s @ \subsection{The stack entry type} A stack entry is a process library object, augmented by a pointer to the next entry. We do not need specific methods, all relevant methods are inherited. On higher level, process libraries should be prepared as process entry objects. <>= public :: prclib_entry_t <>= type, extends (process_library_t) :: prclib_entry_t type(prclib_entry_t), pointer :: next => null () end type prclib_entry_t @ %def prclib_entry_t @ \subsection{The prclib stack type} For easy conversion and lookup it is useful to store the filling number in the object. The content is stored as a linked list. <>= public :: prclib_stack_t <>= type :: prclib_stack_t integer :: n = 0 type(prclib_entry_t), pointer :: first => null () contains <> end type prclib_stack_t @ %def prclib_stack_t @ Finalizer. Iteratively deallocate the stack entries. The resulting empty stack can be immediately recycled, if necessary. <>= procedure :: final => prclib_stack_final <>= module subroutine prclib_stack_final (object) class(prclib_stack_t), intent(inout) :: object end subroutine prclib_stack_final <>= module subroutine prclib_stack_final (object) class(prclib_stack_t), intent(inout) :: object type(prclib_entry_t), pointer :: lib do while (associated (object%first)) lib => object%first object%first => lib%next call lib%final () deallocate (lib) end do object%n = 0 end subroutine prclib_stack_final @ %def prclib_stack_final @ Output. The entries on the stack will be ordered LIFO, i.e., backwards. <>= procedure :: write => prclib_stack_write <>= module subroutine prclib_stack_write (object, unit, libpath) class(prclib_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath end subroutine prclib_stack_write <>= module subroutine prclib_stack_write (object, unit, libpath) class(prclib_stack_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: libpath type(prclib_entry_t), pointer :: lib integer :: u u = given_output_unit (unit) call write_separator (u, 2) select case (object%n) case (0) write (u, "(1x,A)") "Process library stack: [empty]" case default write (u, "(1x,A)") "Process library stack:" lib => object%first do while (associated (lib)) call write_separator (u) call lib%write (u, libpath) lib => lib%next end do end select call write_separator (u, 2) end subroutine prclib_stack_write @ %def prclib_stack_write @ \subsection{Operating on Stacks} We take a library entry pointer and push it onto the stack. The previous pointer is nullified. Subsequently, the library entry is `owned' by the stack and will be finalized when the stack is deleted. <>= procedure :: push => prclib_stack_push <>= module subroutine prclib_stack_push (stack, lib) class(prclib_stack_t), intent(inout) :: stack type(prclib_entry_t), intent(inout), pointer :: lib end subroutine prclib_stack_push <>= module subroutine prclib_stack_push (stack, lib) class(prclib_stack_t), intent(inout) :: stack type(prclib_entry_t), intent(inout), pointer :: lib lib%next => stack%first stack%first => lib lib => null () stack%n = stack%n + 1 end subroutine prclib_stack_push @ %def prclib_stack_push @ \subsection{Accessing Contents} Return a pointer to the topmost stack element. The result type is just the bare [[process_library_t]]. There is no [[target]] attribute required since the stack elements are allocated via pointers. <>= procedure :: get_first_ptr => prclib_stack_get_first_ptr <>= module function prclib_stack_get_first_ptr (stack) result (ptr) class(prclib_stack_t), intent(in) :: stack type(process_library_t), pointer :: ptr end function prclib_stack_get_first_ptr <>= module function prclib_stack_get_first_ptr (stack) result (ptr) class(prclib_stack_t), intent(in) :: stack type(process_library_t), pointer :: ptr if (associated (stack%first)) then ptr => stack%first%process_library_t else ptr => null () end if end function prclib_stack_get_first_ptr @ %def prclib_stack_get_first_ptr @ Return a complete list of the libraries (names) in the stack. The list is in the order in which the elements got pushed onto the stack, so the 'first' entry is listed last. <>= procedure :: get_names => prclib_stack_get_names <>= module subroutine prclib_stack_get_names (stack, libname) class(prclib_stack_t), intent(in) :: stack type(string_t), dimension(:), allocatable, intent(out) :: libname end subroutine prclib_stack_get_names <>= module subroutine prclib_stack_get_names (stack, libname) class(prclib_stack_t), intent(in) :: stack type(string_t), dimension(:), allocatable, intent(out) :: libname type(prclib_entry_t), pointer :: lib integer :: i allocate (libname (stack%n)) i = stack%n lib => stack%first do while (associated (lib)) libname(i) = lib%get_name () i = i - 1 lib => lib%next end do end subroutine prclib_stack_get_names @ %def prclib_stack_get_names @ Return a pointer to the library with given name. <>= procedure :: get_library_ptr => prclib_stack_get_library_ptr <>= module function prclib_stack_get_library_ptr (stack, libname) result (ptr) class(prclib_stack_t), intent(in) :: stack type(string_t), intent(in) :: libname type(process_library_t), pointer :: ptr end function prclib_stack_get_library_ptr <>= module function prclib_stack_get_library_ptr (stack, libname) result (ptr) class(prclib_stack_t), intent(in) :: stack type(string_t), intent(in) :: libname type(process_library_t), pointer :: ptr type(prclib_entry_t), pointer :: current current => stack%first do while (associated (current)) if (current%get_name () == libname) then ptr => current%process_library_t return end if current => current%next end do ptr => null () end function prclib_stack_get_library_ptr @ %def prclib_stack_get_library_ptr @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[prclib_stacks_ut.f90]]>>= <> module prclib_stacks_ut use unit_tests use prclib_stacks_uti <> <> contains <> end module prclib_stacks_ut @ %def prclib_stacks_ut @ <<[[prclib_stacks_uti.f90]]>>= <> module prclib_stacks_uti <> use prclib_stacks <> <> contains <> end module prclib_stacks_uti @ %def prclib_stacks_ut @ API: driver for the unit tests below. <>= public :: prclib_stacks_test <>= subroutine prclib_stacks_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine prclib_stacks_test @ %def prclib_stacks_test @ \subsubsection{Write an empty process library stack} The most trivial test is to write an uninitialized process library stack. <>= call test (prclib_stacks_1, "prclib_stacks_1", & "write an empty process library stack", & u, results) <>= public :: prclib_stacks_1 <>= subroutine prclib_stacks_1 (u) integer, intent(in) :: u type(prclib_stack_t) :: stack write (u, "(A)") "* Test output: prclib_stacks_1" write (u, "(A)") "* Purpose: display an empty process library stack" write (u, "(A)") call stack%write (u) write (u, "(A)") write (u, "(A)") "* Test output end: prclib_stacks_1" end subroutine prclib_stacks_1 @ %def prclib_stacks_1 @ \subsubsection{Fill a process library stack} Fill a process library stack with two (identical) processes. <>= call test (prclib_stacks_2, "prclib_stacks_2", & "fill a process library stack", & u, results) <>= public :: prclib_stacks_2 <>= subroutine prclib_stacks_2 (u) integer, intent(in) :: u type(prclib_stack_t) :: stack type(prclib_entry_t), pointer :: lib write (u, "(A)") "* Test output: prclib_stacks_2" write (u, "(A)") "* Purpose: fill a process library stack" write (u, "(A)") write (u, "(A)") "* Initialize two (empty) libraries & &and push them on the stack" write (u, "(A)") allocate (lib) call lib%init (var_str ("lib1")) call stack%push (lib) allocate (lib) call lib%init (var_str ("lib2")) call stack%push (lib) call stack%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" call stack%final () write (u, "(A)") write (u, "(A)") "* Test output end: prclib_stacks_2" end subroutine prclib_stacks_2 @ %def prclib_stacks_2 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Trivial matrix element for tests} For the purpose of testing the workflow, we implement here two matrix elements with the simplest possible structure. This matrix element generator can only generate a single scattering process and a single decay process. The scattering process is a quartic interaction of a massless, neutral and colorless scalar [[s]] with unit coupling results in a trivial $2\to 2$ scattering process. The matrix element is implemented internally, so we do not need the machinery of external process libraries. The decay process is a decay of [[s]] into a pair of colored fermions [[f]]. <<[[prc_test.f90]]>>= <> module prc_test use, intrinsic :: iso_c_binding !NODEP! <> <> use os_interface use particle_specifiers, only: new_prt_spec use process_constants use prclib_interfaces use prc_core_def use process_libraries <> <> <> interface <> end interface contains <> end module prc_test @ %def prc_test @ <<[[prc_test_sub.f90]]>>= <> submodule (prc_test) prc_test_s implicit none contains <> end submodule prc_test_s @ %def prc_test_s @ \subsection{Process definition} For the process definition we implement an extension of the [[prc_core_def_t]] abstract type. <>= public :: prc_test_def_t <>= type, extends (prc_core_def_t) :: prc_test_def_t type(string_t) :: model_name type(string_t), dimension(:), allocatable :: prt_in type(string_t), dimension(:), allocatable :: prt_out contains <> end type prc_test_def_t @ %def prc_test_def_t <>= procedure, nopass :: type_string => prc_test_def_type_string <>= module function prc_test_def_type_string () result (string) type(string_t) :: string end function prc_test_def_type_string <>= module function prc_test_def_type_string () result (string) type(string_t) :: string string = "test_me" end function prc_test_def_type_string @ %def prc_test_def_type_string @ There is no 'feature' here since there is no external code. <>= procedure, nopass :: get_features => prc_test_def_get_features <>= module subroutine prc_test_def_get_features (features) type(string_t), dimension(:), allocatable, intent(out) :: features end subroutine prc_test_def_get_features <>= module subroutine prc_test_def_get_features (features) type(string_t), dimension(:), allocatable, intent(out) :: features allocate (features (0)) end subroutine prc_test_def_get_features @ %def prc_test_def_get_features @ Initialization: set some data (not really useful). <>= procedure :: init => prc_test_def_init <>= module subroutine prc_test_def_init (object, model_name, prt_in, prt_out) class(prc_test_def_t), intent(out) :: object type(string_t), intent(in) :: model_name type(string_t), dimension(:), intent(in) :: prt_in type(string_t), dimension(:), intent(in) :: prt_out end subroutine prc_test_def_init <>= module subroutine prc_test_def_init (object, model_name, prt_in, prt_out) class(prc_test_def_t), intent(out) :: object type(string_t), intent(in) :: model_name type(string_t), dimension(:), intent(in) :: prt_in type(string_t), dimension(:), intent(in) :: prt_out object%model_name = model_name allocate (object%prt_in (size (prt_in))) object%prt_in = prt_in allocate (object%prt_out (size (prt_out))) object%prt_out = prt_out end subroutine prc_test_def_init @ %def prc_test_def_init @ Write/read process- and method-specific data. (No-op) <>= procedure :: write => prc_test_def_write <>= module subroutine prc_test_def_write (object, unit) class(prc_test_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine prc_test_def_write <>= module subroutine prc_test_def_write (object, unit) class(prc_test_def_t), intent(in) :: object integer, intent(in) :: unit end subroutine prc_test_def_write @ %def prc_test_def_write @ <>= procedure :: read => prc_test_def_read <>= module subroutine prc_test_def_read (object, unit) class(prc_test_def_t), intent(out) :: object integer, intent(in) :: unit end subroutine prc_test_def_read <>= module subroutine prc_test_def_read (object, unit) class(prc_test_def_t), intent(out) :: object integer, intent(in) :: unit end subroutine prc_test_def_read @ %def prc_test_def_read @ Allocate the driver for test ME matrix elements. We get the actual component ID (basename), and we can transfer all process-specific data from the process definition.Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= procedure :: allocate_driver => prc_test_def_allocate_driver <>= subroutine prc_test_def_allocate_driver (object, driver, basename) class(prc_test_def_t), intent(in) :: object class(prc_core_driver_t), intent(out), allocatable :: driver type(string_t), intent(in) :: basename allocate (prc_test_t :: driver) select type (driver) type is (prc_test_t) driver%id = basename driver%model_name = object%model_name select case (size (object%prt_in)) case (1); driver%scattering = .false. case (2); driver%scattering = .true. end select end select end subroutine prc_test_def_allocate_driver @ %def prc_test_def_allocate_driver @ Nothing to connect. This subroutine will not be called. <>= procedure :: connect => prc_test_def_connect <>= module subroutine prc_test_def_connect (def, lib_driver, i, proc_driver) class(prc_test_def_t), intent(in) :: def class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver end subroutine prc_test_def_connect <>= module subroutine prc_test_def_connect (def, lib_driver, i, proc_driver) class(prc_test_def_t), intent(in) :: def class(prclib_driver_t), intent(in) :: lib_driver integer, intent(in) :: i class(prc_core_driver_t), intent(inout) :: proc_driver end subroutine prc_test_def_connect @ %def prc_test_def_connect @ \subsection{Driver} <>= public :: prc_test_t <>= type, extends (process_driver_internal_t) :: prc_test_t type(string_t) :: id type(string_t) :: model_name logical :: scattering = .true. contains <> end type prc_test_t @ %def prc_test_t @ In contrast to generic matrix-element implementations, we can hard-wire the amplitude method as a type-bound procedure. <>= procedure, nopass :: get_amplitude => prc_test_get_amplitude <>= module function prc_test_get_amplitude (p) result (amp) complex(default) :: amp real(default), dimension(:,:), intent(in) :: p end function prc_test_get_amplitude <>= module function prc_test_get_amplitude (p) result (amp) complex(default) :: amp real(default), dimension(:,:), intent(in) :: p amp = 1 end function prc_test_get_amplitude @ %def prc_test_get_amplitude @ The reported type is the same as for the [[prc_test_def_t]] type. <>= procedure, nopass :: type_name => prc_test_type_name <>= module function prc_test_type_name () result (string) type(string_t) :: string end function prc_test_type_name <>= module function prc_test_type_name () result (string) type(string_t) :: string string = "test_me" end function prc_test_type_name @ %def prc_test_type_name @ Fill process constants. <>= procedure :: fill_constants => prc_test_fill_constants <>= module subroutine prc_test_fill_constants (driver, data) class(prc_test_t), intent(in) :: driver type(process_constants_t), intent(out) :: data end subroutine prc_test_fill_constants <>= module subroutine prc_test_fill_constants (driver, data) class(prc_test_t), intent(in) :: driver type(process_constants_t), intent(out) :: data data%id = driver%id data%model_name = driver%model_name if (driver%scattering) then data%n_in = 2 data%n_out = 2 data%n_flv = 1 data%n_hel = 1 data%n_col = 1 data%n_cin = 2 data%n_cf = 1 allocate (data%flv_state (4, 1)) data%flv_state = 25 allocate (data%hel_state (4, 1)) data%hel_state = 0 allocate (data%col_state (2, 4, 1)) data%col_state = 0 allocate (data%ghost_flag (4, 1)) data%ghost_flag = .false. allocate (data%color_factors (1)) data%color_factors = 1 allocate (data%cf_index (2, 1)) data%cf_index = 1 else data%n_in = 1 data%n_out = 2 data%n_flv = 1 data%n_hel = 2 data%n_col = 1 data%n_cin = 2 data%n_cf = 1 allocate (data%flv_state (3, 1)) data%flv_state(:,1) = [25, 6, -6] allocate (data%hel_state (3, 2)) data%hel_state(:,1) = [0, 1,-1] data%hel_state(:,2) = [0,-1, 1] allocate (data%col_state (2, 3, 1)) data%col_state = reshape ([0,0, 1,0, 0,-1], [2,3,1]) allocate (data%ghost_flag (3, 1)) data%ghost_flag = .false. allocate (data%color_factors (1)) data%color_factors = 3 allocate (data%cf_index (2, 1)) data%cf_index = 1 end if end subroutine prc_test_fill_constants @ %def prc_test_fill_constants @ \subsection{Shortcut} Since this module is there for testing purposes, we set up a subroutine that does all the work at once: create a library with the two processes (scattering and decay), configure and load, and set up the driver. Due to a bug of bind(C) features with submodules in gfortran 7/8/9 (and maybe together with MPI) this needs to be in the module, not the submodule. <>= public :: prc_test_create_library <>= subroutine prc_test_create_library & (libname, lib, scattering, decay, procname1, procname2) type(string_t), intent(in) :: libname type(process_library_t), intent(out) :: lib logical, intent(in), optional :: scattering, decay type(string_t), intent(in), optional :: procname1, procname2 type(string_t) :: model_name, procname type(string_t), dimension(:), allocatable :: prt_in, prt_out class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry type(os_data_t) :: os_data logical :: sca, dec sca = .true.; if (present (scattering)) sca = scattering dec = .false.; if (present (decay)) dec = decay call os_data%init () call lib%init (libname) model_name = "Test" if (sca) then if (present (procname1)) then procname = procname1 else procname = libname end if allocate (prt_in (2), prt_out (2)) prt_in = [var_str ("s"), var_str ("s")] prt_out = [var_str ("s"), var_str ("s")] allocate (prc_test_def_t :: def) select type (def) type is (prc_test_def_t) call def%init (model_name, prt_in, prt_out) end select allocate (entry) call entry%init (procname, model_name = model_name, & n_in = 2, n_components = 1) call entry%import_component (1, n_out = size (prt_out), & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("test_me"), & variant = def) call lib%append (entry) end if if (dec) then if (present (procname2)) then procname = procname2 else procname = libname end if if (allocated (prt_in)) deallocate (prt_in, prt_out) allocate (prt_in (1), prt_out (2)) prt_in = [var_str ("s")] prt_out = [var_str ("f"), var_str ("fbar")] allocate (prc_test_def_t :: def) select type (def) type is (prc_test_def_t) call def%init (model_name, prt_in, prt_out) end select allocate (entry) call entry%init (procname, model_name = model_name, & n_in = 1, n_components = 1) call entry%import_component (1, n_out = size (prt_out), & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("test_decay"), & variant = def) call lib%append (entry) end if call lib%configure (os_data) call lib%load (os_data) end subroutine prc_test_create_library @ %def prc_test_create_library @ \subsection{Unit Test} Test module, followed by the corresponding implementation module. <<[[prc_test_ut.f90]]>>= <> module prc_test_ut use unit_tests use prc_test_uti <> <> contains <> end module prc_test_ut @ %def prc_test_ut @ <<[[prc_test_uti.f90]]>>= <> module prc_test_uti <> <> use os_interface use particle_specifiers, only: new_prt_spec use process_constants use prc_core_def use process_libraries use prc_test <> <> contains <> end module prc_test_uti @ %def prc_test_ut @ API: driver for the unit tests below. <>= public :: prc_test_test <>= subroutine prc_test_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine prc_test_test @ %def prc_test_test @ \subsubsection{Generate and load the scattering process} The process is $s s \to s s$, where $s$ is a trivial scalar particle, for vanishing mass and unit coupling. We initialize the process, build the library, and compute the particular matrix element for momenta of unit energy and right-angle scattering. (The scattering is independent of angle.) The matrix element is equal to unity. <>= call test (prc_test_1, "prc_test_1", & "build and load trivial process", & u, results) <>= public :: prc_test_1 <>= subroutine prc_test_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(process_library_t) :: lib class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry type(string_t) :: model_name type(string_t), dimension(:), allocatable :: prt_in, prt_out type(process_constants_t) :: data class(prc_core_driver_t), allocatable :: driver real(default), dimension(0:3,4) :: p integer :: i write (u, "(A)") "* Test output: prc_test_1" write (u, "(A)") "* Purpose: create a trivial process" write (u, "(A)") "* build a library and & &access the matrix element" write (u, "(A)") write (u, "(A)") "* Initialize a process library with one entry" write (u, "(A)") call os_data%init () call lib%init (var_str ("prc_test1")) model_name = "Test" allocate (prt_in (2), prt_out (2)) prt_in = [var_str ("s"), var_str ("s")] prt_out = [var_str ("s"), var_str ("s")] allocate (prc_test_def_t :: def) select type (def) type is (prc_test_def_t) call def%init (model_name, prt_in, prt_out) end select allocate (entry) call entry%init (var_str ("prc_test1_a"), model_name = model_name, & n_in = 2, n_components = 1) call entry%import_component (1, n_out = size (prt_out), & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("test_me"), & variant = def) call lib%append (entry) write (u, "(A)") "* Configure library" write (u, "(A)") call lib%configure (os_data) write (u, "(A)") "* Load library" write (u, "(A)") call lib%load (os_data) call lib%write (u) write (u, "(A)") write (u, "(A)") "* Probe library API:" write (u, "(A)") write (u, "(1x,A,L1)") "is active = ", & lib%is_active () write (u, "(1x,A,I0)") "n_processes = ", & lib%get_n_processes () write (u, "(A)") write (u, "(A)") "* Constants of prc_test1_a_i1:" write (u, "(A)") call lib%connect_process (var_str ("prc_test1_a"), 1, data, driver) write (u, "(1x,A,A)") "component ID = ", char (data%id) write (u, "(1x,A,A)") "model name = ", char (data%model_name) write (u, "(1x,A,A,A)") "md5sum = '", data%md5sum, "'" write (u, "(1x,A,L1)") "openmp supported = ", data%openmp_supported write (u, "(1x,A,I0)") "n_in = ", data%n_in write (u, "(1x,A,I0)") "n_out = ", data%n_out write (u, "(1x,A,I0)") "n_flv = ", data%n_flv write (u, "(1x,A,I0)") "n_hel = ", data%n_hel write (u, "(1x,A,I0)") "n_col = ", data%n_col write (u, "(1x,A,I0)") "n_cin = ", data%n_cin write (u, "(1x,A,I0)") "n_cf = ", data%n_cf write (u, "(1x,A,10(1x,I0))") "flv state =", data%flv_state write (u, "(1x,A,10(1x,I2))") "hel state =", data%hel_state(:,1) write (u, "(1x,A,10(1x,I0))") "col state =", data%col_state write (u, "(1x,A,10(1x,L1))") "ghost flag =", data%ghost_flag write (u, "(1x,A,10(1x,F5.3))") "color factors =", data%color_factors write (u, "(1x,A,10(1x,I0))") "cf index =", data%cf_index write (u, "(A)") write (u, "(A)") "* Set kinematics:" write (u, "(A)") p = reshape ([ & 1.0_default, 0.0_default, 0.0_default, 1.0_default, & 1.0_default, 0.0_default, 0.0_default,-1.0_default, & 1.0_default, 1.0_default, 0.0_default, 0.0_default, & 1.0_default,-1.0_default, 0.0_default, 0.0_default & ], [4,4]) do i = 1, 4 write (u, "(2x,A,I0,A,4(1x,F7.4))") "p", i, " =", p(:,i) end do write (u, "(A)") write (u, "(A)") "* Compute matrix element:" write (u, "(A)") select type (driver) type is (prc_test_t) write (u, "(1x,A,1x,E11.4)") "|amp| =", abs (driver%get_amplitude (p)) end select call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: prc_test_1" end subroutine prc_test_1 @ %def prc_test_1 @ \subsubsection{Shortcut} This is identical to the previous test, but we create the library be a single command. This is handy for other modules which use the test process. <>= call test (prc_test_2, "prc_test_2", & "build and load trivial process using shortcut", & u, results) <>= public :: prc_test_2 <>= subroutine prc_test_2 (u) integer, intent(in) :: u type(process_library_t) :: lib class(prc_core_driver_t), allocatable :: driver type(process_constants_t) :: data real(default), dimension(0:3,4) :: p write (u, "(A)") "* Test output: prc_test_2" write (u, "(A)") "* Purpose: create a trivial process" write (u, "(A)") "* build a library and & &access the matrix element" write (u, "(A)") write (u, "(A)") "* Build and load a process library with one entry" call prc_test_create_library (var_str ("prc_test2"), lib) call lib%connect_process (var_str ("prc_test2"), 1, data, driver) p = reshape ([ & 1.0_default, 0.0_default, 0.0_default, 1.0_default, & 1.0_default, 0.0_default, 0.0_default,-1.0_default, & 1.0_default, 1.0_default, 0.0_default, 0.0_default, & 1.0_default,-1.0_default, 0.0_default, 0.0_default & ], [4,4]) write (u, "(A)") write (u, "(A)") "* Compute matrix element:" write (u, "(A)") select type (driver) type is (prc_test_t) write (u, "(1x,A,1x,E11.4)") "|amp| =", abs (driver%get_amplitude (p)) end select call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: prc_test_2" end subroutine prc_test_2 @ %def prc_test_2 @ \subsubsection{Generate and load the decay process} The process is $s \to f\bar f$, where $s$ is a trivial scalar particle and $f$ is a colored fermion. We initialize the process, build the library, and compute the particular matrix element for a fixed momentum configuration. (The decay is independent of angle.) The matrix element is equal to unity. <>= call test (prc_test_3, "prc_test_3", & "build and load trivial decay", & u, results) <>= public :: prc_test_3 <>= subroutine prc_test_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(process_library_t) :: lib class(prc_core_def_t), allocatable :: def type(process_def_entry_t), pointer :: entry type(string_t) :: model_name type(string_t), dimension(:), allocatable :: prt_in, prt_out type(process_constants_t) :: data class(prc_core_driver_t), allocatable :: driver real(default), dimension(0:3,3) :: p integer :: i write (u, "(A)") "* Test output: prc_test_3" write (u, "(A)") "* Purpose: create a trivial decay process" write (u, "(A)") "* build a library and & &access the matrix element" write (u, "(A)") write (u, "(A)") "* Initialize a process library with one entry" write (u, "(A)") call os_data%init () call lib%init (var_str ("prc_test3")) model_name = "Test" allocate (prt_in (1), prt_out (2)) prt_in = [var_str ("s")] prt_out = [var_str ("f"), var_str ("F")] allocate (prc_test_def_t :: def) select type (def) type is (prc_test_def_t) call def%init (model_name, prt_in, prt_out) end select allocate (entry) call entry%init (var_str ("prc_test3_a"), model_name = model_name, & n_in = 1, n_components = 1) call entry%import_component (1, n_out = size (prt_out), & prt_in = new_prt_spec (prt_in), & prt_out = new_prt_spec (prt_out), & method = var_str ("test_me"), & variant = def) call lib%append (entry) write (u, "(A)") "* Configure library" write (u, "(A)") call lib%configure (os_data) write (u, "(A)") "* Load library" write (u, "(A)") call lib%load (os_data) call lib%write (u) write (u, "(A)") write (u, "(A)") "* Probe library API:" write (u, "(A)") write (u, "(1x,A,L1)") "is active = ", & lib%is_active () write (u, "(1x,A,I0)") "n_processes = ", & lib%get_n_processes () write (u, "(A)") write (u, "(A)") "* Constants of prc_test3_a_i1:" write (u, "(A)") call lib%connect_process (var_str ("prc_test3_a"), 1, data, driver) write (u, "(1x,A,A)") "component ID = ", char (data%id) write (u, "(1x,A,A)") "model name = ", char (data%model_name) write (u, "(1x,A,A,A)") "md5sum = '", data%md5sum, "'" write (u, "(1x,A,L1)") "openmp supported = ", data%openmp_supported write (u, "(1x,A,I0)") "n_in = ", data%n_in write (u, "(1x,A,I0)") "n_out = ", data%n_out write (u, "(1x,A,I0)") "n_flv = ", data%n_flv write (u, "(1x,A,I0)") "n_hel = ", data%n_hel write (u, "(1x,A,I0)") "n_col = ", data%n_col write (u, "(1x,A,I0)") "n_cin = ", data%n_cin write (u, "(1x,A,I0)") "n_cf = ", data%n_cf write (u, "(1x,A,10(1x,I0))") "flv state =", data%flv_state write (u, "(1x,A,10(1x,I2))") "hel state =", data%hel_state(:,1) write (u, "(1x,A,10(1x,I2))") "hel state =", data%hel_state(:,2) write (u, "(1x,A,10(1x,I0))") "col state =", data%col_state write (u, "(1x,A,10(1x,L1))") "ghost flag =", data%ghost_flag write (u, "(1x,A,10(1x,F5.3))") "color factors =", data%color_factors write (u, "(1x,A,10(1x,I0))") "cf index =", data%cf_index write (u, "(A)") write (u, "(A)") "* Set kinematics:" write (u, "(A)") p = reshape ([ & 125._default, 0.0_default, 0.0_default, 0.0_default, & 62.5_default, 0.0_default, 0.0_default, 62.5_default, & 62.5_default, 0.0_default, 0.0_default,-62.5_default & ], [4,3]) do i = 1, 3 write (u, "(2x,A,I0,A,4(1x,F8.4))") "p", i, " =", p(:,i) end do write (u, "(A)") write (u, "(A)") "* Compute matrix element:" write (u, "(A)") select type (driver) type is (prc_test_t) write (u, "(1x,A,1x,E11.4)") "|amp| =", abs (driver%get_amplitude (p)) end select call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: prc_test_3" end subroutine prc_test_3 @ %def prc_test_3 @ \subsubsection{Shortcut} This is identical to the previous test, but we create the library be a single command. This is handy for other modules which use the test process. <>= call test (prc_test_4, "prc_test_4", & "build and load trivial decay using shortcut", & u, results) <>= public :: prc_test_4 <>= subroutine prc_test_4 (u) integer, intent(in) :: u type(process_library_t) :: lib class(prc_core_driver_t), allocatable :: driver type(process_constants_t) :: data real(default), dimension(0:3,3) :: p write (u, "(A)") "* Test output: prc_test_4" write (u, "(A)") "* Purpose: create a trivial decay process" write (u, "(A)") "* build a library and & &access the matrix element" write (u, "(A)") write (u, "(A)") "* Build and load a process library with one entry" call prc_test_create_library (var_str ("prc_test4"), lib, & scattering=.false., decay=.true.) call lib%connect_process (var_str ("prc_test4"), 1, data, driver) p = reshape ([ & 125._default, 0.0_default, 0.0_default, 0.0_default, & 62.5_default, 0.0_default, 0.0_default, 62.5_default, & 62.5_default, 0.0_default, 0.0_default,-62.5_default & ], [4,3]) write (u, "(A)") write (u, "(A)") "* Compute matrix element:" write (u, "(A)") select type (driver) type is (prc_test_t) write (u, "(1x,A,1x,E11.4)") "|amp| =", abs (driver%get_amplitude (p)) end select call lib%final () write (u, "(A)") write (u, "(A)") "* Test output end: prc_test_4" end subroutine prc_test_4 @ %def prc_test_4 Index: trunk/omega/share/doc/Makefile.am =================================================================== --- trunk/omega/share/doc/Makefile.am (revision 8883) +++ trunk/omega/share/doc/Makefile.am (revision 8884) @@ -1,270 +1,270 @@ # Makefile.am -- Makefile for O'Mega within and without WHIZARD ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2023 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD 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. # # WHIZARD 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. # ######################################################################## ######################################################################## ### TODO: fix weaving of lexers and parsers ######################################################################## include $(top_srcdir)/omega/src/Makefile.sources VPATH = $(srcdir):$(top_builddir)/omega/src:$(srcdir):$(top_srcdir)/omega/src PICTURES_PDF = \ modules.pdf \ omega-paper-1-pics-1.pdf \ omega-paper-1-pics-2.pdf \ omega-paper-1-pics-3.pdf \ omega-paper-1-pics-4.pdf \ omega-paper-1-pics-5.pdf \ omega-paper-1-pics-6.pdf \ omega-paper-1-pics-7.pdf \ omega-paper-1-pics-8.pdf \ omega-paper-1-pics-9.pdf \ omega-paper-1-pics-10.pdf \ bhabha.pdf bhabha0.pdf \ epemudbardubar.pdf epemudbardubar0.pdf \ epemudbarmunumubar.pdf epemudbarmunumubar0.pdf \ sign_ex.pdf fusion_rules.pdf mom_choice.pdf \ mom_flow.pdf LATEX_STYLES = \ flex.cls thophys.sty thohacks.sty \ noweb.sty ocamlweb.sty ytableau.sty \ feynmp.sty feynmp.mp emp.sty -TEX_FLAGS = "$$TEXINPUTS:$(top_srcdir)/omega/share/doc" -MP_FLAGS = "$$MPINPUTS:$(top_srcdir)/omega/share/doc" +TEX_FLAGS = "$(top_srcdir)/omega/share/doc:$$TEXINPUTS" +MP_FLAGS = "$(top_srcdir)/omega/share/doc:$$MPINPUTS" if DISTRIBUTION PDFS = omega.pdf omega-paper-1.pdf omega-paper-2.pdf else PDFS = endif ### Files needed to be installed with the O'Mega distribution modelsdir = $(pkgdatadir)/doc if CONTEXT_AVAILABLE dist_doc_DATA = $(PDFS) else dist_doc_DATA = endif EXTRA_DIST = $(PICTURES_PDF) $(LATEX_STYLES) if NOWEB_AVAILABLE pdf-local: $(PDFS) else pdf-local: endif SUFFIXES = .mly .mll .ml .implementation .mli .interface .nw .tex .pdf MPOST_LATEX = TEX=$(LATEX) TEXINPUTS=$(TEX_FLAGS) MPINPUTS=$(MP_FLAGS) $(MPOST) if DISTRIBUTION if CONTEXT_AVAILABLE if PDFLATEX_AVAILABLE .tex.pdf: @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; else \ echo " PDFLATEX " $<; TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; fi if MPOST_AVAILABLE @if test -r $*pics.mp; then \ if $(AM_V_P); then MPINPUTS=$(MP_FLAGS) $(MPOST) $*pics; else \ echo " METAPOST " $*pics.mp; MPINPUTS=$(MP_FLAGS) $(MPOST) $*pics > /dev/null; fi; \ fi @if test -r $*.mp; then \ if $(AM_V_P); then $(MPOST_LATEX) $*; else \ echo " METAPOST " $*.mp; $(MPOST_LATEX) $* >/dev/null; fi; \ fi endif MPOST_AVAILABLE $(AM_V_at)echo " PDFLATEX skipping -bibtex $*" @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; else \ echo " PDFLATEX " $<; TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; fi @if $(AM_V_P); then \ if grep -s 'Rerun to get cross-references right.' $*.log; then \ TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; \ fi; else \ if grep -s 'Rerun to get cross-references right.' $*.log >/dev/null; then \ echo " PDFLATEX " $< "(for cross-references)"; \ TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; \ fi; \ fi endif PDFLATEX_AVAILABLE endif CONTEXT_AVAILABLE endif DISTRIBUTION if DISTRIBUTION if CONTEXT_AVAILABLE if PDFLATEX_AVAILABLE omega-paper-1.pdf: modules.pdf \ omega-paper-1-pics-1.pdf \ omega-paper-1-pics-2.pdf \ omega-paper-1-pics-3.pdf \ omega-paper-1-pics-4.pdf \ omega-paper-1-pics-5.pdf \ omega-paper-1-pics-6.pdf \ omega-paper-1-pics-7.pdf \ omega-paper-1-pics-8.pdf \ omega-paper-1-pics-9.pdf \ omega-paper-1-pics-10.pdf # Dependencies and avoid mpost race condition omega-paper-2.pdf: \ omega-paper-1.pdf sign_ex.pdf fusion_rules.pdf \ mom_choice.pdf mom_flow.pdf endif PDFLATEX_AVAILABLE endif CONTEXT_AVAILABLE endif DISTRIBUTION OMEGA_CORE_INTERFACES = $(OMEGA_CORE_MLI:.mli=.interface) OMEGA_CORE_IMPLEMENTATIONS = $(OMEGA_CORE_ML:.ml=.implementation) OMEGA_MODELLIB_INTERFACES = $(OMEGA_MODELLIB_MLI:.mli=.interface) OMEGA_MODELLIB_IMPLEMENTATIONS = $(OMEGA_MODELLIB_ML:.ml=.implementation) OMEGA_TARGETLIB_INTERFACES = $(OMEGA_TARGETLIB_MLI:.mli=.interface) OMEGA_TARGETLIB_IMPLEMENTATIONS = $(OMEGA_TARGETLIB_ML:.ml=.implementation) OMEGA_APPLICATIONS_IMPLEMENTATIONS = $(OMEGA_APPLICATIONS_ML:.ml=.implementation) OMEGA_INTERFACES = \ $(OMEGA_CORE_INTERFACES) \ $(OMEGA_MODELLIB_INTERFACES) \ $(OMEGA_TARGETLIB_INTERFACES) OMEGA_IMPLEMENTATIONS = \ $(OMEGA_CORE_IMPLEMENTATIONS) \ $(OMEGA_MODELLIB_IMPLEMENTATIONS) \ $(OMEGA_TARGETLIB_IMPLEMENTATIONS) \ $(OMEGA_APPLICATIONS_IMPLEMENTATIONS) if !NOWEB_AVAILABLE omega.pdf: else NOWEB_AVAILABLE omega.pdf: \ $(OMEGA_INTERFACES) $(OMEGA_IMPLEMENTATIONS) omegalib.tex index.tex \ $(PICTURES_PDF) .nw.tex: @if $(AM_V_P); then :; else echo " NOWEAVE " $@; fi $(AM_V_at)$(NOWEAVE) -delay $< > $@ if DISTRIBUTION if OCAMLWEB_AVAILABLE .mll.implementation: @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb --no-index $< >$@ .mly.implementation: @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb --no-index $< >$@ .ml.implementation: @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb --no-index $< >$@ .mli.interface: @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb --no-index $< >$@ index.tex: $(OMEGA_CAML) @if $(AM_V_P); then :; else echo " OCAMLWEB " $@; fi $(AM_V_at)$(OCAMLWEB) --no-preamble --noweb $^ | \ sed -n '/\\ocwbeginindex{}/,/\\ocwendindex{}/p' >$@ endif OCAMLWEB_AVAILABLE endif DISTRIBUTION endif NOWEB_AVAILABLE ######################################################################## ## Cleanup tasks mostlyclean-latex: -rm -f *.log *.aux *.toc *.mpx *.idx *.out omega*.mp \ omega*pics.t[0-9]* omega*pics.[0-9]* $(PICTURES_PDF) \ omegalib.tex clean-latex: maintainer-clean-latex: -rm $(PDFS) if NOWEB_AVAILABLE mostlyclean-omega: -test "$(srcdir)" != "." && rm -f $(PDFS) maintainer-clean-omega: else mostlyclean-omega: maintainer-clean-omega: endif .PHONY: mostlyclean-latex clean-latex maintainer-clean-latex .PHONY: mostlyclean-omega maintainer-clean-omega if OCAMLWEB_AVAILABLE mostlyclean-caml: -rm -f $(OMEGA_INTERFACES) $(OMEGA_IMPLEMENTATIONS) index.tex else mostlyclean-caml: endif clean-caml: if OCAMLWEB_AVAILABLE maintainer-clean-caml: -rm -f $(OMEGA_INTERFACES) $(OMEGA_IMPLEMENTATIONS) index.tex else maintainer-clean-caml: endif .PHONY: mostlyclean-caml clean-caml maintainer-clean-caml ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets mostlyclean-local: mostlyclean-latex mostlyclean-caml mostlyclean-omega clean-local: clean-latex clean-caml maintainer-clean-local: maintainer-clean-latex maintainer-clean-caml \ maintainer-clean-omega maintainer-clean-backup if !DISTRIBUTION install-data-hook: -$(INSTALL) -m 644 omega.pdf $(DESTDIR)$(datarootdir)/doc/omega -$(INSTALL) -m 644 omega-paper-1.pdf $(DESTDIR)$(datarootdir)/doc/omega -$(INSTALL) -m 644 omega-paper-2.pdf $(DESTDIR)$(datarootdir)/doc/omega uninstall-hook: -rm -f $(DESTDIR)/$(datarootdir)/doc/omega/omega.pdf -rm -f $(DESTDIR)/$(datarootdir)/doc/omega/omega-paper-1.pdf -rm -f $(DESTDIR)/$(datarootdir)/doc/omega/omega-paper-2.pdf endif ######################################################################## ## The End. ######################################################################## Index: trunk/share/tests/unit_tests/ref-output/prclib_interfaces_3.ref =================================================================== --- trunk/share/tests/unit_tests/ref-output/prclib_interfaces_3.ref (revision 8883) +++ trunk/share/tests/unit_tests/ref-output/prclib_interfaces_3.ref (revision 8884) @@ -1,111 +1,111 @@ * Test output: prclib_interfaces_3 * Purpose: check the generated Makefile * Create a prclib driver object (2 processes) External matrix-element code library: prclib3 static = F loaded = F MD5 sum = 'prclib_interfaces_3_md5sum ' Mdl flags = '' DL access info: is open = F error = [none] Matrix-element code entries: test1 [Test_model] test_1: proc1 test2 [Test_model] test_2: proc1 proc2 * Write Makefile * File contents: # WHIZARD: Makefile for process library 'prclib3' # Automatically generated file, do not edit # Integrity check (don't modify the following line!) MD5SUM = 'prclib_interfaces_3_md5sum ' # Library name BASE = prclib3 # Compiler FC = fortran-compiler CC = c-compiler # Included libraries FCINCL = -I module-dir # Compiler flags FCFLAGS = -C=all FCFLAGS_PIC = -PIC CFLAGS = -I include-dir CFLAGS_PIC = -PIC LDFLAGS = # LaTeX setup LATEX = latex -halt-on-error MPOST = mpost --math=scaled -halt-on-error DVIPS = dvips PS2PDF = ps2pdf14 -TEX_FLAGS = "$$TEXINPUTS:" -MP_FLAGS = "$$MPINPUTS:" +TEX_FLAGS = ":$$TEXINPUTS" +MP_FLAGS = ":$$MPINPUTS" # Libtool LIBTOOL = my-libtool FCOMPILE = $(LIBTOOL) --tag=FC --mode=compile CCOMPILE = $(LIBTOOL) --tag=CC --mode=compile LINK = $(LIBTOOL) --tag=FC --mode=link # Compile commands (default) LTFCOMPILE = $(FCOMPILE) $(FC) -c $(FCINCL) $(FCFLAGS) $(FCFLAGS_PIC) LTCCOMPILE = $(CCOMPILE) $(CC) -c $(CFLAGS) $(CFLAGS_PIC) # Default target all: link diags # Matrix-element code files # Makefile code for process test1 goes here. # Makefile code for process test2 goes here. # Library driver $(BASE).lo: $(BASE).f90 $(OBJECTS) $(LTFCOMPILE) $< # Library $(BASE).la: $(BASE).lo $(OBJECTS) $(LINK) $(FC) -module -rpath /dev/null $(FCFLAGS) $(LDFLAGS) -o $(BASE).la $^ # Main targets link: compile $(BASE).la compile: source $(OBJECTS) $(TEX_OBJECTS) $(BASE).lo compile_tex: $(TEX_OBJECTS) source: $(SOURCES) $(BASE).f90 $(TEX_SOURCES) .PHONY: link diags compile compile_tex source # Specific cleanup targets clean-test1: .PHONY: clean-test1 clean-test2: .PHONY: clean-test2 # Generic cleanup targets clean-library: rm -f $(BASE).la clean-objects: rm -f $(BASE).lo $(BASE)_driver.mod $(CLEAN_OBJECTS) clean-source: rm -f $(CLEAN_SOURCES) clean-driver: rm -f $(BASE).f90 clean-makefile: rm -f $(BASE).makefile .PHONY: clean-library clean-objects clean-source clean-driver clean-makefile clean: clean-library clean-objects clean-source distclean: clean clean-driver clean-makefile .PHONY: clean distclean * Test output end: prclib_interfaces_3 Index: trunk/share/doc/Makefile.am =================================================================== --- trunk/share/doc/Makefile.am (revision 8883) +++ trunk/share/doc/Makefile.am (revision 8884) @@ -1,305 +1,305 @@ ## Makefile.am -- Makefile for WHIZARD ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2023 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD 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. # # WHIZARD 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. # ######################################################################## ## The WHIZARD documented source is assembled from various directories ## defined outside the DISTRIBUTION environment as modern autotools ## versions complain otherwise w_srcdir = $(top_srcdir)/src VPATH = $(srcdir):$(w_srcdir)/noweb-frame:$(w_srcdir)/utilities:$(w_srcdir)/testing:$(w_srcdir)/system:$(w_srcdir)/combinatorics:$(w_srcdir)/parsing:$(w_srcdir)/rng:$(w_srcdir)/expr_base:$(w_srcdir)/physics:$(w_srcdir)/qed_pdf:$(w_srcdir)/qft:$(w_srcdir)/types:$(w_srcdir)/matrix_elements:$(w_srcdir)/particles:$(w_srcdir)/beams:$(w_srcdir)/me_methods:$(w_srcdir)/events:$(w_srcdir)/phase_space:$(w_srcdir)/vegas:$(w_srcdir)/mci:$(w_srcdir)/fks:$(w_srcdir)/gosam:$(w_srcdir)/openloops:$(w_srcdir)/blha:$(w_srcdir)/shower:$(w_srcdir)/muli:$(w_srcdir)/variables:$(w_srcdir)/model_features:$(w_srcdir)/threshold:$(w_srcdir)/process_integration:$(w_srcdir)/matching:$(w_srcdir)/transforms:$(w_srcdir)/whizard-core:$(w_srcdir)/main:$(w_srcdir)/api ## The primary targets if DISTRIBUTION ## The manual source has to be distributed dist_noinst_DATA = manual.tex $(PACKAGE).tex \ book.hva custom.hva fancysection.hva Whizard-Logo.jpg \ $(MANUAL_PICS) dep2dot.py MANUAL_PICS = \ proc_4f-history.pdf whizstruct.pdf cc10_1.pdf \ cc10_2.pdf Z-lineshape_1.pdf Z-lineshape_2.pdf \ flow4.pdf lep_higgs_1.pdf \ lep_higgs_2.pdf lep_higgs_3.pdf circe2-smoothing.pdf \ resonance_e_gam.pdf resonance_n_charged.pdf \ resonance_n_hadron.pdf resonance_n_particles.pdf \ resonance_n_photons.pdf resonance_n_visible.pdf if NOWEB_AVAILABLE dist_pdf_DATA = manual.pdf $(PACKAGE).pdf gamelan_manual.pdf else dist_pdf_DATA = manual.pdf gamelan_manual.pdf endif else dist_pdf_DATA = endif pdf-local: manual.pdf $(PACKAGE).pdf gamelan_manual.pdf if DISTRIBUTION if HEVEA_AVAILABLE html_DATA = manual.html index.html endif HEVEA_AVAILABLE endif DISTRIBUTION GML=../../src/gamelan/whizard-gml --math=scaled -halt-on-error --gmldir ../../src/gamelan LATEX_STYLES = \ noweb.sty thophys.sty gamelan.sty hevea.sty -TEX_FLAGS = "$$TEXINPUTS:$(top_srcdir)/share/doc" +TEX_FLAGS = "$(top_srcdir)/share/doc:$$TEXINPUTS" EXTRA_DIST = $(LATEX_STYLES) ## don't try to run the files in parallel (TeXLive 2009 doesn't like it) manual.pdf: $(PACKAGE).pdf $(PACKAGE).pdf: gamelan_manual.pdf $(WHIZARD_DEPENDENCY_GRAPHS_PDF) overview.pdf manual.pdf: variables.tex variables.tex: ../../src/whizard ../../src/whizard --generate-variables-tex > variables.tex gamelan_manual.pdf: gamelan.sty SUFFIXES: .dot .tex .pdf .dot.pdf: @if $(AM_V_P); then :; else echo " DOT " $@; fi $(AM_V_at)$(DOT) -Tpdf $< > $@ if DISTRIBUTION WHIZARD_DEPENDENCY_GRAPHS_DOT = \ blha.dot \ beams.dot \ combinatorics.dot \ events.dot \ expr_base.dot \ fks.dot \ gosam.dot \ matching.dot \ matrix_elements.dot \ vegas.dot \ mci.dot \ me_methods.dot \ model_features.dot \ muli.dot \ openloops.dot \ parsing.dot \ particles.dot \ phase_space.dot \ physics.dot \ qed_pdf.dot \ process_integration.dot \ qft.dot \ rng.dot \ shower.dot \ system.dot \ testing.dot \ threshold.dot \ transforms.dot \ types.dot \ utilities.dot \ variables.dot \ whizard-core.dot \ main.dot \ api.dot WHIZARD_DEPENDENCY_GRAPHS_PDF = $(WHIZARD_DEPENDENCY_GRAPHS_DOT:.dot=.pdf) all-dots: $(WHIZARD_DEPENDENCY_GRAPHS_DOT) overview.dot $(WHIZARD_DEPENDENCY_GRAPHS_DOT): @rm -f $@ @if $(AM_V_P); then \ $(top_srcdir)/share/doc/dep2dot.py \ ../../src/`echo $@ | sed 's/.dot//'`/Makefile.depend > $@; else \ echo " DEP2DOT " $@; \ $(top_srcdir)/share/doc/dep2dot.py \ ../../src/`echo $@ | sed 's/.dot//'`/Makefile.depend > $@; fi overview.dot: @rm -f $@ @if $(AM_V_P); then \ list=''; \ for dep in $(WHIZARD_DEPENDENCY_GRAPHS_DOT); do \ list="$$list ../../src/`echo $$dep | sed 's/.dot//'`/Makefile.depend"; \ done ; \ $(top_srcdir)/share/doc/dep2dot.py $$list > $@; else \ echo " DEP2DOT " $@; \ list=''; \ for dep in $(WHIZARD_DEPENDENCY_GRAPHS_DOT); do \ list="$$list ../../src/`echo $$dep | sed 's/.dot//'`/Makefile.depend"; \ done ; \ $(top_srcdir)/share/doc/dep2dot.py $$list > $@; fi dist_noinst_DATA += $(WHIZARD_DEPENDENCY_GRAPHS_DOT) overview.dot endif ## Rules for creating PDF if DISTRIBUTION if PDFLATEX_AVAILABLE .tex.pdf: @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; else \ echo " PDFLATEX " $<; TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; fi @if $(AM_V_P); then \ while grep 'Rerun to get cross-references right\.' $*.log; \ do TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; \ done; else \ echo " PDFLATEX " $< "(for cross-references)"; \ while grep 'Rerun to get cross-references right\.' $*.log >/dev/null; \ do TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; \ done; \ fi @if test -r $*.mp; then \ if $(AM_V_P); then $(GML) $*; else echo " GML " $*; $(GML) $* >/dev/null; fi; \ fi @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; else \ echo " PDFLATEX " $<; TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; fi endif PDFLATEX_AVAILABLE endif DISTRIBUTION ## Rules for creating HTML if HEVEA_AVAILABLE HEVEAOPTS = -exec xxdate.exe -I $(top_srcdir)/share/doc \ book.hva fancysection.hva custom.hva HACHAOPTS = -tocbis if DISTRIBUTION index.html: manual.html @if $(AM_V_P); then $(HACHA) $(HACHAOPTS) -o index.html manual.html; else \ echo " HACHA " $@; $(HACHA) $(HACHAOPTS) -o index.html manual.html >/dev/null 2>&1; fi manual.html: variables.tex manual.tex $(MANUAL_PICS) @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(HEVEA) -fix $(HEVEAOPTS) manual.tex; else \ echo " HEVEA " $@; \ TEXINPUTS=$(TEX_FLAGS) $(HEVEA) -s -fix $(HEVEAOPTS) manual.tex >/dev/null 2>&1; fi @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(IMAGEN) -pdf manual; else \ echo " IMAGEN manual"; TEXINPUTS=$(TEX_FLAGS) $(IMAGEN) -pdf manual >/dev/null 2>&1; fi ### There are no Feynman diagrams at the moment inside the manual. # $(MPOST) manualpics.mp @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(HEVEA) -fix $(HEVEAOPTS) manual.tex; else \ echo " HEVEA " $@; TEXINPUTS=$(TEX_FLAGS) $(HEVEA) -s -fix $(HEVEAOPTS) manual.tex; fi else @echo "HEVEA not available. The HTML manual cannot be made" endif !DISTRIBUTION endif HEVEA_AVAILABLE if NOWEB_AVAILABLE WHIZARD_NOWEB_SRC = \ whizard-prelude.nw \ utilities.nw \ testing.nw \ system.nw \ combinatorics.nw \ parsing.nw rng.nw physics.nw qed_pdf.nw qft.nw \ types.nw \ matrix_elements.nw \ particles.nw \ beams.nw \ me_methods.nw \ events.nw \ phase_space.nw \ vegas.nw \ mci.nw \ shower.nw muli.nw \ blha.nw gosam.nw \ openloops.nw fks.nw \ model_features.nw \ threshold.nw \ process_integration.nw \ matching.nw \ transforms.nw \ whizard.nw \ whizard-postlude.nw $(PACKAGE).tex: $(WHIZARD_NOWEB_SRC) -rm -f $@ @if $(AM_V_P); then :; else echo " NOWEAVE " $@; fi $(AM_V_at)$(NOWEAVE) -delay $^ | $(CPIF) $@ gamelan.sty: $(top_srcdir)/src/gamelan/gamelan.nw @if $(AM_V_P); then :; else echo " NOTANGLE " $@; fi $(AM_V_at)$(NOTANGLE) -R$@ $< | $(CPIF) $@ endif NOWEB_AVAILABLE ## Cleanup tasks mostlyclean-latex: -rm -f *.aux *.log *.dvi *.toc *.idx *.out *.ltp *.mp *.mpx *.glo \ gamelan_manual.[1-9] gamelan_manual.[1-9][0-9] \ manual.pdf gamelan_manual.pdf \ $(WHIZARD_DEPENDENCY_GRAPHS_DOT) $(WHIZARD_DEPENDENCY_GRAPHS_PDF) \ overview.dot overview.pdf variables.tex -test "$(srcdir)" != "." && rm -f $(PACKAGE).pdf clean-latex: maintainer-clean-latex: -rm manual.pdf gamelan_manual.pdf if NOWEB_AVAILABLE mostlyclean-whizard: -rm -f $(PACKAGE).tex $(PACKAGE).pdf gamelan.sty maintainer-clean-whizard: else mostlyclean-whizard: maintainer-clean-whizard: endif .PHONY: mostlyclean-latex clean-latex maintainer-clean-latex .PHONY: mostlyclean-whizard maintainer-clean-whizard mostlyclean-html: -rm -f *.haux *.htoc *.css index.html contents_motif.gif \ next_motif.gif previous_motif.gif contents_motif.svg \ next_motif.svg previous_motif.svg manual*.html manual*.png \ manual.image.tex clean-html: maintainer-clean-html: -rm -f manual*.html index.html contents_motif.gif \ next_motif.gif previous_motif.gif contents_motif.svg \ next_motif.svg previous_motif.svg .PHONY: mostlyclean-html clean-html maintainer-clean-html ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets mostlyclean-local: mostlyclean-latex mostlyclean-html mostlyclean-whizard clean-local: clean-latex clean-html maintainer-clean-local: maintainer-clean-latex maintainer-clean-html \ maintainer-clean-whizard maintainer-clean-backup if !DISTRIBUTION install-data-hook: -$(INSTALL) -m 644 manual.pdf $(DESTDIR)$(datarootdir)/doc/whizard -$(INSTALL) -m 644 $(PACKAGE).pdf $(DESTDIR)$(datarootdir)/doc/whizard -$(INSTALL) -m 644 gamelan_manual.pdf $(DESTDIR)$(datarootdir)/doc/whizard uninstall-hook: -rm -f $(DESTDIR)/$(datarootdir)/doc/whizard/manual.pdf -rm -f $(DESTDIR)/$(datarootdir)/doc/whizard/$(PACKAGE).pdf -rm -f $(DESTDIR)/$(datarootdir)/doc/whizard/gamelan_manual.pdf endif ######################################################################## ## The End. ######################################################################## Index: trunk/vamp/share/doc/Makefile.am =================================================================== --- trunk/vamp/share/doc/Makefile.am (revision 8883) +++ trunk/vamp/share/doc/Makefile.am (revision 8884) @@ -1,174 +1,174 @@ # Makefile.am -- ######################################################################## ## ## Process this file with automake to produce Makefile.in # # Copyright (C) 1999-2023 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD 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. # # WHIZARD 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. # ######################################################################## WEBS = \ prelude.nw divisions.nw vamp.nw vampi.nw \ vamp_test.nw vamp_test0.nw application.nw \ vamp_kinds.nw constants.nw exceptions.nw \ tao_random_numbers.nw specfun.nw vamp_stat.nw histograms.nw \ utils.nw linalg.nw products.nw kinematics.nw coordinates.nw \ mpi90.nw postlude.nw if DISTRIBUTION PDFS = vamp.pdf preview.pdf preview2.pdf else PDFS = endif LATEX_STYLES = \ feynmp.sty feynmp.mp \ noweb.sty emp.sty flex.cls thohacks.sty thophys.sty -TEX_FLAGS = "$$TEXINPUTS:$(top_srcdir)/vamp/share/doc" -MP_FLAGS = "$$MPINPUTS:$(top_srcdir)/vamp/share/doc" +TEX_FLAGS = "$(top_srcdir)/vamp/share/doc:$$TEXINPUTS" +MP_FLAGS = "$(top_srcdir)/vamp/share/doc:$$MPINPUTS" EXTRA_DIST = \ tex-comments.sh \ vegas.d vamp.d \ $(LATEX_STYLES) dist_doc_DATA = $(PDFS) if NOWEB_AVAILABLE pdf-local: vamp.pdf preview.pdf preview2.pdf else pdf-local: preview.pdf preview2.pdf endif VPATH = $(srcdir):$(top_builddir)/vamp/src:$(top_srcdir)/vamp/src if NOWEB_AVAILABLE vamp.tex: $(WEBS) @if $(AM_V_P); then :; else echo " NOWEAVE " $@; fi $(AM_V_at)$(NOWEAVE) -filter ./tex-comments -delay -index \ `for i in $^; do case $$i in *.nw) echo $$i;; esac done` \ | $(CPIF) $@ vamp.tex: tex-comments endif NOWEB_AVAILABLE tex-comments: tex-comments.sh cp $< $@ chmod +x $@ preview.pdf: vegas.data vamp.data vegas.data: vegas.d cp $< $@ vamp.data: vamp.d cp $< $@ SUFFIXES = .tex .pdf MPOST_LATEX = TEX=$(LATEX) TEXINPUTS=$(TEX_FLAGS) $(MPOST) if DISTRIBUTION if PDFLATEX_AVAILABLE if CONTEXT_AVAILABLE .tex.pdf: @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; else \ echo " PDFLATEX " $<; TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; fi if MAKEINDEX_AVAILABLE @if $(AM_V_P); then $(MAKEINDEX) -o $*.ind $*.idx; else \ echo " MAKEINDEX " $*.ind $*.idx; $(MAKEINDEX) -q -o $*.ind $*.idx; fi endif MAKEINDEX_AVAILABLE if MPOST_AVAILABLE @if $(AM_V_P); then test -r $*.mp && $(MPOST_LATEX) $*; else \ echo " METAPOST " $*.mp; test -r $*.mp && $(MPOST_LATEX) $* >/dev/null; fi @if $(AM_V_P); then test -r $*pics.mp && MPINPUTS=$(MP_FLAGS) $(MPOST) $*pics; else \ echo " METAPOST " $*pics.mp; \ test -r $*pics.mp && MPINPUTS=$(MP_FLAGS) $(MPOST) $*pics > /dev/null; fi endif MPOST_AVAILABLE @if $(AM_V_P); then TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; else \ echo " PDFLATEX " $<; TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; fi @if $(AM_V_P); then \ if grep -s 'Rerun to get cross-references right.' $*.log; then \ TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $<; \ fi; else \ if grep -s 'Rerun to get cross-references right.' $*.log >/dev/null; then \ echo " PDFLATEX " $< "(for cross-references)"; \ TEXINPUTS=$(TEX_FLAGS) $(PDFLATEX) $< >/dev/null; \ fi; \ fi endif CONTEXT_AVAILABLE endif PDFLATEX_AVAILABLE endif DISTRIBUTION ## Cleanup tasks mostlyclean-latex: -rm -f *.data *.mpx *.[1-9] *.t[1-9] vamp*.mp preview*.mp \ *.out *.log *.aux *.idx *.ilg *.ind *.rcs *.toc \ tex-comments vamp.tex -test "$(srcdir)" != "." && rm -f vamp.pdf \ preview.pdf preview2.pdf clean-latex: maintainer-clean-latex: -rm -f vamp.pdf preview.pdf preview2.pdf if NOWEB_AVAILABLE mostlyclean-vamp: -test "$(srcdir)" != "." && rm -f vamp.pdf \ preview.pdf preview2.pdf maintainer-clean-vamp: else mostlyclean-vamp: maintainer-clean-vamp: endif .PHONY: mostlyclean-latex clean-latex maintainer-clean-latex .PHONY: mostlyclean-vamp maintainer-clean-vamp ## Remove backup files maintainer-clean-backup: -rm -f *~ .PHONY: maintainer-clean-backup ## Register additional clean targets mostlyclean-local: mostlyclean-latex mostlyclean-vamp clean-local: clean-latex maintainer-clean-local: maintainer-clean-latex maintainer-clean-vamp \ maintainer-clean-backup if !DISTRIBUTION install-data-hook: -$(INSTALL) -m 644 vamp.pdf $(DESTDIR)$(datarootdir)/doc/vamp -$(INSTALL) -m 644 preview.pdf $(DESTDIR)$(datarootdir)/doc/vamp -$(INSTALL) -m 644 preview2.pdf $(DESTDIR)$(datarootdir)/doc/vamp uninstall-hook: -rm -f $(DESTDIR)/$(datarootdir)/doc/vamp/vamp.pdf -rm -f $(DESTDIR)/$(datarootdir)/doc/vamp/preview.pdf -rm -f $(DESTDIR)/$(datarootdir)/doc/vamp/preview2.pdf endif ######################################################################## ## The End. ########################################################################