Page MenuHomeHEPForge
Files F3543710

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
This document is not UTF8. It was detected as ISO-8859-1 (Latin 1) and converted to UTF8 for display.
Index: trunk/.gitlab-ci.yml
===================================================================
--- trunk/.gitlab-ci.yml (revision 8371)
+++ trunk/.gitlab-ci.yml (revision 8372)
@@ -1,616 +1,615 @@
stages:
- build
- deploy
- report
- daily
- weekly
- weekly-applications
- weekly-report
variables:
NAGFOR_OPTIONS: "-w=all -gline -C=all -nan -f2008"
GFORTRAN_OPTIONS: "-fbacktrace -fcheck=array-temps,bounds,do,mem,pointer"
JOBS: "-j2"
JOBS_NAGFOR: "-j4"
.default_template: &default_definition
stage: build
before_script:
- ./build_master.sh
- autoreconf
- command -v opam && eval $(opam config env --root=/opt/opam)
- mkdir build || true
- cd build
except:
- production
- schedules
- /^.*xfail.*$/
artifacts:
expire_in: 3 weeks
when: always
paths:
- build/configure.log
- build/make.log
- build/make-install.log
- build/circe2/tests/test-suite.log
- build/omega/tests/test-suite.log
- build/vamp/tests/test-suite.log
- build/tests/unit_tests/test-suite.log
- build/tests/unit_tests/err-output/*
- build/tests/functional_tests/test-suite.log
.docker_template: &docker_definition
variables:
GIT_SSL_NO_VERIFY: "1"
tags:
- docker
# SMALL TEST SUITE (BRANCHES)
gfortran-5.5.0-fully:
<<: *default_definition
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-tools
script:
- export LD_LIBRARY_PATH=/home/whizard/OpenLoops/lib:$LD_LIBRARY_PATH
- ../configure FC=gfortran FCFLAGS="-O0 $GFORTRAN_OPTIONS" F77=gfortran --disable-static --prefix="`pwd`/install" --enable-hoppet --enable-fastjet --enable-openloops --enable-pythia8 > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
<<: *docker_definition
nagfor-6:
<<: *default_definition
script:
- ../configure FC=nagfor FCFLAGS="$NAGFOR_OPTIONS" F77=nagfor --disable-static --prefix="`pwd`/install" --enable-distribution > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS_NAGFOR -s V=0 check
tags:
- nagfor
- latex
ifort-20:
<<: *default_definition
script:
- source /opt/intel/2020/bin/compilervars.sh intel64
- ../configure FC=ifort2020 FCFLAGS="-O1" F77=ifort2020 --disable-static --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
tags:
- ifort
# BIG TEST SUITE (MASTER + TESTING BRANCHES)
.extra_template: &extra_definition
<<: *default_definition
only:
- master
- /^testing.*$/
.distcheck_template: &distcheck_script
script:
- ../configure FC=gfortran FCFLAGS="-O2 $GFORTRAN_OPTIONS" F77=gfortran --enable-distribution --enable-static --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 DISTCHECK_CONFIGURE_FLAGS='FC=gfortran F77=gfortran --enable-distribution --disable-noweb-force' distcheck > make-distcheck.log
.distcheck_template: &distcheck_definition
<<: *default_definition
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-gcc-9.2.0
<<: *distcheck_script
<<: *docker_definition
only:
- master
- /^testing.*$/
artifacts:
expire_in: 3 weeks
when: always
paths:
- build/configure.log
- build/make.log
- build/make-install.log
- build/circe2/tests/test-suite.log
- build/omega/tests/test-suite.log
- build/vamp/tests/test-suite.log
- build/tests/unit_tests/test-suite.log
- build/tests/unit_tests/err-output/*
- build/tests/functional_tests/test-suite.log
- "build/whizard*.tar.gz"
- build/make-distcheck.log
after_script:
- find . -type f -exec chmod 644 {} +
- find . -type d -exec chmod 755 {} +
- rm whizard*/ -rf
distcheck.static.gfortran-9.2.0:
<<: *distcheck_definition
gfortran-6.4.0:
<<: *extra_definition
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-gcc-6.4.0
script:
- ../configure FC=gfortran FCFLAGS="-O0 $GFORTRAN_OPTIONS" F77=gfortran --disable-static --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
<<: *docker_definition
gfortran-7.5.0:
<<: *extra_definition
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-gcc-7.5.0
script:
- ../configure FC=gfortran FCFLAGS="-O0 $GFORTRAN_OPTIONS" F77=gfortran --disable-static --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
<<: *docker_definition
gfortran-8.3.0:
<<: *extra_definition
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-gcc-8.3.0
script:
- ../configure FC=gfortran FCFLAGS="-O0 $GFORTRAN_OPTIONS" F77=gfortran --disable-static --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
<<: *docker_definition
gfortran-9.2.0:
<<: *extra_definition
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-gcc-9.2.0
script:
- ../configure FC=gfortran FCFLAGS="-O0 $GFORTRAN_OPTIONS" F77=gfortran --disable-static --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
<<: *docker_definition
osx.gfortran:
<<: *extra_definition
script:
- ../configure FC=gfortran FCFLAGS="-O0 $GFORTRAN_OPTIONS" F77=gfortran --prefix="`pwd`/install" --enable-distribution --enable-hepmc --enable-lcio --enable-lhapdf --enable-hoppet --enable-fastjet --enable-looptools LOOPTOOLS_DIR=/usr/local/lib --enable-gosam --enable-openloops --enable-recola --enable-pythia8 > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
tags:
- osx
disabled.static.nagfor-6:
<<: *extra_definition
script:
- ../configure --disable-lhapdf --disable-hepmc --disable-lcio --disable-pythia8 --disable-fastjet --disable-hoppet --disable-gosam --disable-openloops --disable-looptools --disable-pythia6 --enable-distribution FC=nagfor FCFLAGS="$NAGFOR_OPTIONS" F77=nagfor --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS_NAGFOR -s V=0 check
tags:
- nagfor
- latex
nagfor-7:
<<: *extra_definition
script:
- ../configure FC=nagfor7 FCFLAGS="$NAGFOR_OPTIONS" F77=nagfor7 --disable-static --prefix="`pwd`/install" --enable-distribution > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS_NAGFOR -s V=0 check
tags:
- nagfor7
- latex
extended.gfortran-5.5.0-fully:
<<: *extra_definition
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-tools
script:
- export LD_LIBRARY_PATH=/home/whizard/OpenLoops/lib:$LD_LIBRARY_PATH
- ../configure --with-precision=extended FC=gfortran FCFLAGS="-O0 $GFORTRAN_OPTIONS" F77=gfortran --disable-static --prefix="`pwd`/install" --enable-hoppet --enable-fastjet --enable-openloops --enable-pythia8 > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
<<: *docker_definition
openmp.gfortran-5.5.0:
<<: *extra_definition
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-gcc-5.5.0
script:
- ../configure --enable-fc-openmp FC=gfortran FCFLAGS="-O1 $GFORTRAN_OPTIONS" F77=gfortran --disable-static --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
<<: *docker_definition
mpi.gfortran-5.5.0:
<<: *extra_definition
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-gcc-5.5.0-openmpi-2.1.1
script:
- ../configure --enable-fc-mpi FC=mpifort FCFLAGS="-O1 $GFORTRAN_OPTIONS" F77=mpifort --disable-static --prefix="`pwd`/install" > configure.log
- sed -i.bak 's/mpirun="mpirun -np 1"/mpirun="mpirun -np 1 --allow-run-as-root"/' tests/functional_tests/run_whizard.sh
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
<<: *docker_definition
parallel.gfortran-5.5.0:
<<: *extra_definition
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-gcc-5.5.0-openmpi-2.1.1
script:
- ../configure --enable-fc-openmp --enable-fc-mpi FC=mpifort FCFLAGS="-O1 $GFORTRAN_OPTIONS" F77=mpifort --disable-static --prefix="`pwd`/install" > configure.log
- sed -i.bak 's/mpirun="mpirun -np 1"/mpirun="mpirun -np 1 --allow-run-as-root"/' tests/functional_tests/run_whizard.sh
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
<<: *docker_definition
ifort-18:
<<: *extra_definition
script:
- source /opt/intel/2018/bin/compilervars.sh intel64
- ../configure FC=ifort2018 F77=ifort2018 --disable-static --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
tags:
- ifort
ifort-19:
<<: *extra_definition
script:
- source /opt/intel/2019/bin/compilervars.sh intel64
- ../configure FC=ifort2019 F77=ifort2019 --disable-static --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
tags:
- ifort
quadruple.ifort-20:
<<: *extra_definition
script:
- source /opt/intel/2020/bin/compilervars.sh intel64
- ../configure --with-precision=quadruple FC=ifort2020 FCFLAGS="-O1" F77=ifort2020 --disable-static --prefix="`pwd`/install" --enable-fastjet --enable-openloops > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
tags:
- ifort
# DEPLOY (MASTER)
.deploy_template: &deploy_definition
stage: deploy
tags:
- deployment
only:
- master
before_script:
- eval `ssh-agent -s`
- ssh-add /nfs/theoc/data1/whizard/sl7/gitlab_runner/id_rsa /nfs/theoc/data1/whizard/sl7/gitlab_runner/id_rsa_runner_wgs
except:
- production
- schedules
- /^.*xfail.*$/
notify slack:
stage: report
tags:
- deployment
only:
- master
before_script:
- eval `ssh-agent -s`
- ssh-add /nfs/theoc/data1/whizard/sl7/gitlab_runner/id_rsa /nfs/theoc/data1/whizard/sl7/gitlab_runner/id_rsa_runner_wgs
when: on_failure
script:
- echo "Build on \`$CI_BUILD_REF_NAME\` failed! Commit \`$(git log -1 --oneline)\` See pipeline $CI_PIPELINE_URL" | slacktee.sh -a "danger" -p --config /nfs/theoc/data1/whizard/sl7/gitlab_runner/.slacktee
deploy to production:
<<: *deploy_definition
environment: production
script:
- export GIT_SSH=/nfs/theoc/data1/whizard/sl7/gitlab_runner/ssh.sh
- git remote set-url --push origin git@gitlab.tp.nt.uni-siegen.de:whizard/development.git
- git checkout master
- git pull
- git checkout production
- git merge master --ff-only
- git push
deploy to public git:
<<: *deploy_definition
environment: public_git
dependencies: []
script:
- export GIT_SSH=/nfs/theoc/data1/whizard/sl7/gitlab_runner/ssh.sh
- git log --format="%h %s" -n 1 HEAD > `pwd`/../git_public.msg
- cd ..
- rm -rf public/
- git clone git@gitlab.tp.nt.uni-siegen.de:whizard/public.git
- rsync -r --delete --log-file=rsync.log --out-format='%i %n%L' --exclude=.git* development/ public
- diff -r --exclude=.git* development public || exit 1
- cp development/.gitignore public/
- mv rsync.log development/
- cd public
- echo -e ".gitignore" >> .gitignore
- echo -e ".gitlab/issue_templates" >> .gitignore
- - echo -e "src/muli/doc/*" >> .gitignore
- echo -e ".gitlab-ci.yml" >> .gitignore
- echo -e "CONTRIBUTING.md" >> .gitignore
- echo -e "synchronize.sh" >> .gitignore
- echo -e "share/debug/*" >> .gitignore
- echo -e "build/*" >> .gitignore
- echo -e "install/*" >> .gitignore
- git add --all
- git diff-index --exit-code HEAD || git commit --file=`pwd`/../git_public.msg
- git push
artifacts:
expire_in: 3 weeks
when: always
paths:
- rsync.log
deploy to svn:
<<: *deploy_definition
environment: svn
script:
- svn co --config-dir /nfs/theoc/data1/whizard/sl7/gitlab_runner/.subversion/ svn+ssh://vcs@phab.hepforge.org/source/whizardsvn/trunk trunk
- cp .git trunk/ -r
- cd trunk
- git status
- git checkout -- .
- git clean -d -f
- svn diff --config-dir /nfs/theoc/data1/whizard/sl7/gitlab_runner/.subversion/ > ../svndiff.log || true
- svn status --config-dir /nfs/theoc/data1/whizard/sl7/gitlab_runner/.subversion/ | grep "^?" | grep -v '.git$' | awk '{print $2}' >| ../svn-add-files.log || true
- svn status --config-dir /nfs/theoc/data1/whizard/sl7/gitlab_runner/.subversion/ | grep "^\!" | grep -v '.git$' | awk '{print $2}' >| ../svn-del-files.log || true
- if test -s ../svn-add-files.log ; then cat ../svn-add-files.log | xargs svn add --config-dir /nfs/theoc/data1/whizard/sl7/gitlab_runner/.subversion/ ; fi
- if test -s ../svn-del-files.log ; then cat ../svn-del-files.log | xargs svn rm --config-dir /nfs/theoc/data1/whizard/sl7/gitlab_runner/.subversion/ ; fi
- git log --format="%h %s" -n 1 HEAD > svn-commit.msg
- svn commit --config-dir /nfs/theoc/data1/whizard/sl7/gitlab_runner/.subversion/ --file=svn-commit.msg
artifacts:
paths:
- svndiff.log
- svn-add-files.log
- svn-del-files.log
# NIGHTLY BUILD (DAILY)
build whizard tarball:
stage: daily
environment: nightly
only:
refs:
- schedules
variables:
- $type == "nightly"
before_script:
- ./build_master.sh
- autoreconf
- command -v opam && eval $(opam config env --root=/opt/opam)
- mkdir build || true
- cd build
script:
- ../configure --enable-distribution FC=nagfor FCFLAGS="$NAGFOR_OPTIONS" F77=nagfor > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 dist > make-dist.log
- mv "$(ls whizard-*.tar.gz)" "$(basename $(ls whizard-*.tar.gz) .tar.gz)-$(date -Idate)-$(git rev-parse --short HEAD).tar.gz"
- ssh whizard@beryllium 'cd tarballs && rm -f whizard-nightly-latest.tar.gz'
- ssh whizard@beryllium 'cd tarballs && (for f in $(ls -1t *.tar.gz | tail -n +5); do rm -f "${f}"; done)'
- rsync whizard*.tar.gz whizard@beryllium:~/tarballs
- ssh whizard@beryllium 'cd tarballs && rm -f *.sig; for f in $(ls -tr1 *.tar.gz); do sha256sum "${f}" > "${f}.sig"; done'
- ssh whizard@beryllium 'cd tarballs && ln -sfn "$(ls -1t whizard-*.tar.gz | head -n1)" whizard-nightly-latest.tar.gz'
- ssh whizard@beryllium 'cd tarballs && ln -sfn "$(ls -1t whizard-*.tar.gz.sig | head -n1)" whizard-nightly-latest.tar.gz.sig'
artifacts:
expire_in: 3 weeks
when: always
paths:
- configure.log
- make.log
- make-dist.log
tags:
- jenkins2
- nagfor
- latex
# WHIZARD IMAGE (WEEKLY)
build whizard image:
stage: weekly
script:
- git clone https://${WHIZARD_DOCKER_USER}:${WHIZARD_DOCKER_PASSWORD}@gitlab.tp.nt.uni-siegen.de/whizard/docker.git
- docker build -t gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-master -f docker/whizard-master/Dockerfile .
- docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD} https://gitlab.tp.nt.uni-siegen.de:4567
- docker push gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-master
tags:
- whizard
only:
refs:
- schedules
variables:
- $type == "weekly"
# GCC TRUNK IMAGE (WEEKLY)
build gcc-trunk image:
stage: weekly
script:
- git clone https://${WHIZARD_DOCKER_USER}:${WHIZARD_DOCKER_PASSWORD}@gitlab.tp.nt.uni-siegen.de/whizard/docker.git
- cd docker/whizard-gcc-trunk
- wget http://mirrors.ctan.org/install/fonts/doublestroke.tds.zip
- docker build --no-cache=true -t gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-gcc-trunk .
- docker login -u ${CI_REGISTRY_USER} -p ${CI_REGISTRY_PASSWORD} gitlab.tp.nt.uni-siegen.de:4567
- docker push gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-gcc-trunk
tags:
- whizard
only:
refs:
- schedules
variables:
- $type == "weekly"
# SUBPACKAGES (WEEKLY)
.subpackage_template: &subpackage_definition
<<: *distcheck_definition
stage: weekly
only:
refs:
- schedules
variables:
- $type == "weekly"
except:
circe1.distcheck.static.gfortran-9.2.0:
<<: *subpackage_definition
before_script:
- command -v opam && eval $(opam config env --root=/opt/opam)
- ./build_master.sh CIRCE1
- autoreconf
- mkdir -p build
- cd build
circe2.distcheck.static.gfortran-9.2.0:
<<: *subpackage_definition
before_script:
- command -v opam && eval $(opam config env --root=/opt/opam)
- ./build_master.sh CIRCE2
- autoreconf
- mkdir -p build
- cd build
vamp.distcheck.static.gfortran-9.2.0:
<<: *subpackage_definition
before_script:
- command -v opam && eval $(opam config env --root=/opt/opam)
- ./build_master.sh VAMP
- autoreconf
- mkdir -p build
- cd build
omega.distcheck.static.gfortran-9.2.0:
<<: *subpackage_definition
before_script:
- command -v opam && eval $(opam config env --root=/opt/opam)
- ./build_master.sh OMEGA
- autoreconf
- mkdir -p build
- cd build
script:
- ../configure FC=gfortran FCFLAGS="-O2 $GFORTRAN_OPTIONS" F77=gfortran --enable-distribution --enable-static --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
- make $JOBS -s V=0 extra-distcheck > make-distcheck.log
whizard.distcheck.static.gfortran-9.2.0:
<<: *subpackage_definition
before_script:
- command -v opam && eval $(opam config env --root=/opt/opam)
- ./build_master.sh
- autoreconf
- mkdir -p build
- cd build
script:
- ../configure FC=gfortran FCFLAGS="-O2 $GFORTRAN_OPTIONS" F77=gfortran --enable-distribution --enable-static --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
- make $JOBS -s V=0 extra-distcheck > make-distcheck.log
# EXAMPLES (WEEKLY)
.examples_template: &examples_definition
stage: weekly-applications
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-master
only:
refs:
- schedules
variables:
- $type == "weekly"
before_script:
- source /home/whizard/GoSam/local/bin/gosam_setup_env.sh
- eval $(opam config env --root=/opt/opam)
- cd /home/whizard/whizard/share/examples
<<: *docker_definition
run matching examples:
<<: *examples_definition
script:
- for s in *Matching*.sin ; do whizard $s; done
run NLO examples:
<<: *examples_definition
script:
- for s in *NLO*OpenLoops.sin ; do whizard $s; done
# - for s in *NLO*GoSam.sin ; do whizard $s; done
run collider examples:
<<: *examples_definition
script:
- for s in HERA_DIS.sin LEP_cc10.sin LEP_higgs.sin W-endpoint.sin Z-lineshape.sin ; do whizard $s; done
run other examples:
<<: *examples_definition
script:
- for s in Zprime.sin casc_dec.sin circe1.sin eeww_polarized.sin fourjetsLO.sin ; do whizard $s; done
# Extended Tests (WEEKLY)
.ext_tests_template: &ext_tests_definition
stage: weekly-applications
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-master
only:
refs:
- schedules
variables:
- $type == "weekly"
before_script:
- source /home/whizard/GoSam/local/bin/gosam_setup_env.sh
- eval $(opam config env --root=/opt/opam)
- cd /home/whizard/whizard/_build/tests
<<: *docker_definition
run extended NLO tests:
<<: *ext_tests_definition
script:
- cd ext_tests_nlo
- make $JOBS -s V=0 check
- cp /home/whizard/whizard/_build/tests/ext_tests_nlo/test-suite.log $CI_PROJECT_DIR/test-suite_ext_nlo.log
artifacts:
expire_in: 3 weeks
when: always
paths:
- test-suite_ext_nlo.log
build whizard with gcc-trunk:
<<: *default_definition
<<: *docker_definition
stage: weekly-applications
image: gitlab.tp.nt.uni-siegen.de:4567/whizard/development:whizard-gcc-trunk
only:
refs:
- schedules
variables:
- $type == "weekly"
except:
dependencies:
script:
- ../configure --disable-static --prefix="`pwd`/install" > configure.log
- make $JOBS -s V=0 > make.log
- make $JOBS -s V=0 install > make-install.log
- make $JOBS -s V=0 check
notify slack weekly:
stage: weekly-report
tags:
- deployment
only:
refs:
- schedules
variables:
- $type == "weekly"
before_script:
- eval `ssh-agent -s`
- ssh-add /nfs/theoc/data1/whizard/sl7/gitlab_runner/id_rsa /nfs/theoc/data1/whizard/sl7/gitlab_runner/id_rsa_runner_wgs
when: on_failure
script:
- echo "Weekly build on \`$CI_BUILD_REF_NAME\` failed! Commit \`$(git log -1 --oneline)\`. See pipeline $CI_PIPELINE_URL" | slacktee.sh -a "warning" -p --config /nfs/theoc/data1/whizard/sl7/gitlab_runner/.slacktee
Index: trunk/src/muli/doc/diagrams.mp
===================================================================
--- trunk/src/muli/doc/diagrams.mp (revision 8371)
+++ trunk/src/muli/doc/diagrams.mp (revision 8372)
@@ -1,151 +0,0 @@
-input common;
-def draw_arr(expr a) =
- begingroup
- save m;
- m=(1+ahlength/(arclength a))/2;
- drawarrow subpath (0,m) of a;
- draw subpath (m,1) of a;
- endgroup;
-enddef;
-
-w=20*xu;
-h=15*yu;
-
-def feyn =
- pair l[];
- pair r[];
- pair v[];
- path p[];
- l1=(0,0);
- l2=(0,h);
- r1=(w,0);
- r2=(w,h/3);
- r3=(w,2*h/3);
- r4=(w,h);
- v1=(w/3,0);
- v2=(2*w/3,h/2);
- v3=(w/3,h);
- p1=fullcircle scaled (3*unit) shifted v1;
- p2=fullcircle scaled (3*unit) shifted v2;
- p3=fullcircle scaled (3*unit) shifted v3;
- draw_arr ((l1 -- v1) cutafter p1);
- draw_arr ((v1 -- r1) cutbefore p1);
- draw_arr ((l2 -- v3) cutafter p3);
- draw_arr ((v3 -- r4) cutbefore p3);
- draw_arr ((v3 -- v2) cutbefore p3 cutafter p2);
- draw_arr ((v1 -- v2) cutbefore p1 cutafter p2);
- draw_arr ((v2 -- r2) cutbefore p2);
- draw_arr ((v2 -- r3) cutbefore p2);
- draw p1;
- draw p2;
- draw p3;
-enddef;
-
-beginfig(1)
- feyn;
- label(TEX("$P_1^{(k)}$"), (l1+v1)/2+(-xu,-yu));
- label(TEX("$P_2^{(k)}$"), (l2+v3)/2+(-xu,yu));
- label(TEX("$P_1^{(k+1)}$"), (v1+r1)/2+(xu,-yu));
- label(TEX("$P_2^{(k+1)}$"), (v3+r4)/2+(xu,yu));
- label(TEX("$\hat{p}_1^{(k)}$"), (v1+v2)/2+(-xu,yu));
- label(TEX("$\hat{p}_2^{(k)}$"), (v3+v2)/2+(-xu,-yu));
- label(TEX("$a^{(k)}$"), (v2+(-2*xu,-1*yu)));
- label(TEX("$b^{(k)}$"), (v2+(-2*xu,1*yu)));
- label(TEX("$c^{(k)}$"), (v2+(2*xu,-1.5*yu)));
- label(TEX("$d^{(k)}$"), (v2+(2*xu,1.5*yu)));
- label(TEX("$f_a^{(k)}$"), v1);
- label(TEX("$\hat\sigma$"), v2);
- label(TEX("$f_b^{(k)}$"), v3);
- pickup pencircle scaled 0pt;
- drawdot(-xu,-yu);
- drawdot(w+xu,h+yu);
-endfig;
-
-beginfig(2)
- feyn;
- label(TEX("$X_1$"), (l1+v1)/2+(-xu,-yu));
- label(TEX("$X_2$"), (l2+v3)/2+(-xu,yu));
- label(TEX("$\xi_1 X_1$"), (v1+v2)/2+(-xu,yu));
- label(TEX("$\xi_2 X_2$"), (v3+v2)/2+(-xu,-yu));
- label(TEX("$1$"), (v2+(-2*xu,-1*yu)));
- label(TEX("$2$"), (v2+(-2*xu,1*yu)));
- label(TEX("$3$"), (v2+(2*xu,-1.5*yu)));
- label(TEX("$4$"), (v2+(2*xu,1.5*yu)));
- label(TEX("$f_1$"), v1);
- label(TEX("$\hat\sigma$"), v2);
- label(TEX("$f_2$"), v3);
- pickup pencircle scaled 0pt;
- drawdot(-xu,-yu);
- drawdot(w+xu,h+yu);
-endfig;
-
-beginfig(3)
- draw (0,unit) -- (4,1)*unit;
- draw (0,0)--((1,0)*unit){dir 0} .. {dir 90}((2,1.5)*unit) ..{dir 0}((3,3)*unit)--(4,3)*unit;
- draw (0,4*unit) -- (4*unit,4*unit);
- drawdot (0,3)*unit;
- drawdot (4,1)*unit;
- label(TEX("$0$"), ((-1,3)*unit));
- label(TEX("$3$"), ((5,1)*unit));
- label(TEX("$3$"), ((-1,1)*unit));
- label(TEX("$4$"), ((5,3)*unit));
- label(TEX("$4$"), ((-1,0)*unit));
- label(TEX("$0$"), ((5,0)*unit));
- label(TEX("$5$"), ((-1,4)*unit));
- label(TEX("$5$"), ((5,4)*unit));
-
- label(TEX("$1$"), ((-2,0.5)*unit));
- draw fullcircle scaled (1.1*unit) shifted ((-2,0.5)*unit);
- label(TEX("$2$"), ((-2,3.5)*unit));
- draw fullcircle scaled (1.1*unit) shifted ((-2,3.5)*unit);
- label(TEX("$3$"), ((6,0.5)*unit));
- draw fullcircle scaled (1.1*unit) shifted ((6,0.5)*unit);
- label(TEX("$4$"), ((6,3.5)*unit));
- draw fullcircle scaled (1.1*unit) shifted ((6,3.5)*unit);
-endfig;
-
-def draw_splitting=
- numeric w,h;
- w=6*xu;
- h=6*yu;
- path p[];
- pair v[];
- v1=(unit,h-unit);
- v2=(w-unit,unit);
- p1=fullcircle scaled (2*unit) shifted v1;
- p2=fullcircle scaled (2*unit) shifted v2;
- v3=(v1--v2) intersectionpoint p1;
- v4=(v1--v2) intersectionpoint p2;
- v5=(v3+v4)/2;
- v6=(w,ypart(v5));
- draw p1;
- draw p2;
- draw v3 -- v4;
- label(TEX("$f$"), v1);
- label(TEX("$\widehat{\sigma}$"), v2);
-enddef;
-
-beginfig(4)
- draw_splitting;
- label(TEX("$1$"), (v5-(0.5,0.5)*unit));
-endfig;
-
-beginfig(5)
- v7=(w/4,h/2);
- v8=(3*w/4,h/2);
- draw v7 -- v8;
- draw (v8+dir(135)*unit) -- v8 --(v8+dir(225)*unit);
- label(TEX("ISR"), (v7+v8+(0,unit))/2);
- pickup pencircle scaled 0pt;
- drawdot (0,0);
- drawdot (w,h);
-endfig;
-
-beginfig(6)
- draw_splitting;
- draw v5--v6;
- label(TEX("$1$"), (v4+v5-(unit,unit))/2);
- label(TEX("$2$"), (v3+v5-(unit,unit))/2);
- label(TEX("$3$"), (v5+v6+(0,unit))/2);
-endfig;
-end;
Index: trunk/src/muli/doc/muli_manual.tex
===================================================================
--- trunk/src/muli/doc/muli_manual.tex (revision 8371)
+++ trunk/src/muli/doc/muli_manual.tex (revision 8372)
@@ -1,26 +0,0 @@
-\documentclass[11pt,DIV16,halfparskip%,draft
-]{scrbook}
-\usepackage[ngerman]{babel}
-\usepackage[utf8x]{inputenc}
-\usepackage[T1]{fontenc}
-\usepackage{xcolor}
-\usepackage{graphicx}
-\usepackage[sumlimits,intlimits,namelimits]{amsmath}
-\usepackage{amssymb,esint}
-\usepackage{amsfonts}
-%\usepackage{wrapfig}
-\usepackage[pdftex]{hyperref}
-\usepackage{fancyvrb}
-\usepackage{booktabs}
-\usepackage{definitions}
-\usepackage{makeidx}
-\usepackage{subfig}
-
-\makeindex
-\begin{document}
-\tableofcontents
-\include{Allgemeines}
-\include{Module}
-\newpage
-\printindex
-\end{document}
Index: trunk/src/muli/doc/common.mp
===================================================================
--- trunk/src/muli/doc/common.mp (revision 8371)
+++ trunk/src/muli/doc/common.mp (revision 8372)
@@ -1,11 +0,0 @@
-outputtemplate := "%j-%c.mps";
-input TEX;
-TEXPRE("%&latex" & char(10) & "\documentclass{article}\begin{document}");
-TEXPOST("\end{document}");
-unit=10;
-xu=unit;
-yu=unit;
-numeric ahangle, ahlength, diag;
-ahangle=30;
-ahlength=10;
-diag=1.4142135623730951;
Index: trunk/src/muli/doc/Schleudergefahr.pdf
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: trunk/src/muli/doc/muli_trapezium.tex
===================================================================
--- trunk/src/muli/doc/muli_trapezium.tex (revision 8371)
+++ trunk/src/muli/doc/muli_trapezium.tex (revision 8372)
@@ -1,1743 +0,0 @@
-\Module{muli\_trapezium}
-%\begin{figure}
-% \centering{\includegraphics{uml-module-tree-5.mps}}
-% \caption{\label{fig:\ThisModule:Types}Klassendiagramm des Moduls \ThisModule}
-%\end{figure}
-In dem Modul muli\_trapezium wird ein Datentyp muli\_trapezium\_type definiert, der eine affin-lineare Approximation von $\overline{S}_{\alpha\beta}(\pperp;s)$, $\mathcal{S}_{\alpha\beta}(\pperp;s)$, $exp[-\mathcal{S}_{\alpha\beta}(\pperp;s)]$ und einen Integrationsfehler für $\mathcal{S}_{\alpha\beta}(\pperp;s)$ für alle 16 Kombinationen von $\{\alpha,\beta\}$ für $\alpha,\beta\in \{g,s,v_d,v_u\}$ bereitstellt.
-
-Weiterhin dir ein abstrakter Datentyp muli\_trapezium\_node\_class definiert, der mehrere Segmente vom Typ muli\_trapezium\_type zusammenfasst und somit eine Approximation der Wirkungsquerschnitte entsprechend der Trapezregel bereitstellt. Daher kommt auch der name des Moduls und der Datentypen.
-
-Für die Auswertung dieser Approximation wird ein Datentyp muli\_trapezium\_tree\_type definiert, der Instanzen der Klasse muli\_trapezium\_node\_class zu einem Binärbaum zusammenstellt. Die Blätter dieses Binärbaums sind jeweils mit ihren linken und rechten Nachbarblättern verbunden, sodass man wahlweise in logarithmischer Zeit ein Blatt von der Wurzel her suchen kann oder die Blätter, sortiert nach $\pperp$ durchlaufen kann.
-
-Für die Verbindungen unter den Blättern wird der Datentyp muli\_trapezium\_list\_type definiert, der auch ohne Binärbaum als Liste verwendet wird. Jedes Blatt eines Baums ist eine Instanz vom Typ muli\_trapezium\_list\_type.
-
-Die Entscheidung für eine affin-lineare Approximation liegt an der Tatsache, dass höhere Polynome transzendente Funktionen im schlimmsten Fall so deutlich unterschätzen können, dass negative approximierte Funktionswerte bei positiven Funktionen auftreten können. In Abbildung \ref{fig:tra:parabel} ist das illustriert.
-\begin{figure}
- \includegraphics{plots-1.mps}
- \caption{\label{fig:tra:parabel}Illustration einer quadratischen Approximation von exp(-x)/x. Die Parabel (blau) wird negativ, obwohl die Funktion (rot) streng positiv ist. Mit der Trapezregel kann das nicht passieren.}
-\end{figure}
-\section{Abhängigkeiten}
-\use{muli\_basic}
-\section{Parameter}
-Für jedes Intervall $[x_l,x_r]$ der approximierten Funktionen $g(x)$ wird deren Funktionswert am rechten Rand r\_value=$f(x_r)$ und die Differenz der Funktionswerte d\_value=$f(x_r)-f(x_l)$ gespeichert. Entsprechend werden die Werte für die negative Stammfunktion (integral) und die daraus berechnete Wahscheinlichkeistfunktion (propability) gespeichert. Schließlich wird ein Integrationsfehler für die Stammfunktion gespeichert. In der Summe macht das value\_dimension=7 Werte, die pro Intervall gespeichert werden müssen. Es wird ein array mit value\_dimension Stellen allokiert, wobei die verschiedenen Werte an der Position *\_index abgelegt werden.
-\begin{Verbatim}
- implicit none
- integer,private,parameter::\MC{value\_dimension}=7
- integer,private,parameter::\MC{r\_value\_index}=1
- integer,private,parameter::\MC{d\_value\_index=}2
- integer,private,parameter::\MC{r\_integral\_index}=3
- integer,private,parameter::\MC{d\_integral\_index}=4
- integer,private,parameter::\MC{r\_propability\_index}=5
- integer,private,parameter::\MC{d\_propability\_index}=6
- integer,private,parameter::\MC{error\_index}=7
-\end{Verbatim}
-\section{Derived Types}
-\TypeDef{muli\_trapezium\_type}
-\begin{Verbatim}
- type,\Extends{measurable\_class} :: muli_trapezium_type
-\end{Verbatim}
-
-dim ist die Dimension des Bildraums, also
-$\overline{S}:\mathbb{R}\to\mathbb{R}^{\dim}$. dim ergibt sich aus der Zahl der Strati (=16) plus eins für die Summe über alle Strati. Die Summe wird in der Null-ten Komponente des Funktionswerte-Arrays gespeichert, damit die Strati nach der üblichen Konvention $[1..n]$ indiziert werden.
-
-r\_position ist der obere Grenze des $\pperp$-Intervalls, d\_position ist die Intervallänge.
-
-measure\_comp ist eine Maßzahl für jedes Intervall, nach der sie in dem Binärbaum sortiert werden. Die Blätter des Baumes sind dann eine geordnete Liste mit aufsteigendem measure\_comp. measure\_comp wird auf r\_position gesetzt.
-
-values ist schließlich die Matrix der Funktionswerte für die verschiedenen Funktionen. Der erste, schnelle Index läuft über die Strati $\{0 .. \dim-1\}$, der zweite, langsame Index läuft über die Menge der Funktionen $\{$r\_value,d\_value,r\_integral,d\_integral,r\_propability,d\_propability,error$\}$
-\begin{Verbatim}
- private
- integer::dim=0
- real(kind=double)::\TC{r\_position}=0D0
- real(kind=double)::\TC{d\_position}=0D0
- real(kind=double)::\TC{measure\_comp}=0D0
- real(kind=double),dimension(:,:),allocatable::\TC{values}
- contains
- \OverridesDeclaration{serializable\_class}
- procedure ::\TbpDec{write\_to\_marker}{muli\_trapezium\_write\_to\_marker}
- procedure ::\TbpDec{read\_from\_marker}{muli\_trapezium\_read\_from\_marker}
- procedure ::\TbpDec{print\_to\_unit}{muli\_trapezium\_print\_to\_unit}
- procedure,nopass ::\TbpDec{get\_type}{muli\_trapezium\_get\_type}
- procedure,nopass ::\TbpDec{verify\_type}{muli\_trapezium\_verify\_type}
- \OverridesDeclaration{measurable\_class}
- procedure::\TbpDec{measure}{muli\_trapezium\_measure}
- \OriginalDeclaration
- ! init/deinit
- procedure::\TbpDec{initialize}{muli\_trapezium\_initialize}
- ! components
- procedure,public::\TbpDec{get\_dimension}{muli\_trapezium\_get\_dimension}
- procedure,public::\TbpDec{get\_l\_position}{muli\_trapezium\_get\_l\_position}
- procedure,public::\TbpDec{get\_r\_position}{muli\_trapezium\_get\_r\_position}
- procedure,public::\TbpDec{get\_d\_position}{muli\_trapezium\_get\_d\_position}
- procedure,public::\TbpDec{get\_l\_value\_array}{muli\_trapezium\_get\_l\_value\_array}
- procedure,public::\TbpDec{get\_l\_value\_element}{muli\_trapezium\_get\_l\_value\_element}
- procedure,public::\TbpDec{get\_r\_value\_array}{muli\_trapezium\_get\_r\_value\_array}
- procedure,public::\TbpDec{get\_r\_value\_element}{muli\_trapezium\_get\_r\_value\_element}
- procedure,public::\TbpDec{get\_d\_value\_array}{muli\_trapezium\_get\_d\_value\_array}
- procedure,public::\TbpDec{get\_d\_value\_element}{muli\_trapezium\_get\_d\_value\_element}
- procedure,public::\TbpDec{get\_l\_integral\_array}{muli\_trapezium\_get\_l\_integral\_array}
- procedure,public::\TbpDec{get\_l\_integral\_element}{muli\_trapezium\_get\_l\_integral\_element}
- procedure,public::\TbpDec{get\_r\_integral\_array}{muli\_trapezium\_get\_r\_integral\_array}
- procedure,public::\TbpDec{get\_r\_integral\_element}{muli\_trapezium\_get\_r\_integral\_element}
- procedure,public::\TbpDec{get\_d\_integral\_array}{muli\_trapezium\_get\_d\_integral\_array}
- procedure,public::\TbpDec{get\_d\_integral\_element}{muli\_trapezium\_get\_d\_integral\_element}
- procedure,public::\TbpDec{get\_l\_propability\_element}{muli\_trapezium\_get\_l\_propability\_element}
- procedure,public::\TbpDec{get\_l\_propability\_array}{muli\_trapezium\_get\_l\_propability\_array}
- procedure,public::\TbpDec{get\_r\_propability\_element}{muli\_trapezium\_get\_r\_propability\_element}
- procedure,public::\TbpDec{get\_r\_propability\_array}{muli\_trapezium\_get\_r\_propability\_array}
- procedure,public::\TbpDec{get\_d\_propability\_element}{muli\_trapezium\_get\_d\_propability\_element}
- procedure,public::\TbpDec{get\_d\_propability\_array}{muli\_trapezium\_get\_d\_propability\_array}
- procedure,public::\TbpDec{get\_error}{muli\_trapezium\_get\_error}
- procedure,public::\TbpDec{get\_error\_sum}{muli\_trapezium\_get\_error\_sum}
- procedure,public::\TbpDec{get\_integral\_sum}{muli\_trapezium\_get\_integral\_sum}
- generic,public::\TbpGen{get\_l\_value}{get\_l\_value\_array,get\_l\_value\_element}
- generic,public::\TbpGen{get\_r\_value}{get\_r\_value\_array,get\_r\_value\_element}
- generic,public::\TbpGen{get\_d\_value}{get\_d\_value\_array,get\_d\_value\_element}
- generic,public::\TbpGen{get\_l\_integral}{get\_l\_integral\_array,get\_l\_integral\_element}
- generic,public::\TbpGen{get\_r\_integral}{get\_r\_integral\_array,get\_r\_integral\_element}
- generic,public::\TbpGen{get\_d\_integral}{get\_d\_integral\_array,get\_d\_integral\_element}
- generic,public::\TbpGen{get\_l\_propability}{get\_l\_propability\_array,get\_l\_propability\_element}
- generic,public::\TbpGen{get\_r\_propability}{get\_r\_propability\_array,get\_r\_propability\_element}
- generic,public::\TbpGen{get\_d\_propability}{get\_d\_propability\_array,get\_d\_propability\_element}
- ! interpolations
- procedure,public::\TbpDec{get\_value\_at\_position}{muli\_trapezium\_get\_value\_at\_position}
- procedure::\TbpDec{set\_r\_value}{muli\_trapezium\_set\_r\_value}
- procedure::\TbpDec{set\_d\_value}{muli\_trapezium\_set\_d\_value}
- procedure::\TbpDec{set\_r\_integral}{muli\_trapezium\_set\_r\_integral}
- procedure::\TbpDec{set\_d\_integral}{muli\_trapezium\_set\_d\_integral}
- procedure::\TbpDec{set\_r\_propability}{muli\_trapezium\_set\_r\_propability}
- procedure::\TbpDec{set\_d\_propability}{muli\_trapezium\_set\_d\_propability}
- procedure::\TbpDec{set\_error}{muli\_trapezium\_set\_error}
- ! tests
- procedure,public::\TbpDec{is\_left\_of}{muli\_trapezium\_is\_left\_of}
- procedure,public::\TbpDec{includes}{muli\_trapezium\_includes}
- ! convert
- procedure ::\TbpDec{to\_node}{muli\_trapezium\_to\_node}
- procedure ::\TbpDec{sum\_up}{muli\_trapezium\_sum\_up}
- ! approximation
- procedure ::\TbpDec{approx\_value}{muli\_trapezium\_approx\_value}
- procedure ::\TbpDec{approx\_value\_n}{muli\_trapezium\_approx\_value\_n}
- procedure ::\TbpDec{approx\_integral}{muli\_trapezium\_approx\_integral}
- procedure ::\TbpDec{approx\_integral\_n}{muli\_trapezium\_approx\_integral\_n}
- procedure ::\TbpDec{approx\_propability}{muli\_trapezium\_approx\_propability}
- procedure ::\TbpDec{approx\_propability\_n}{muli\_trapezium\_approx\_propability\_n}
- procedure ::\TbpDec{approx\_position\_by\_integral}{muli\_trapezium\_approx\_position\_by\_integral}
- procedure ::\TbpDec{split}{muli\_trapezium\_split}
- procedure ::\TbpDec{update}{muli\_trapezium\_update}
- end type muli_trapezium_type
-\end{Verbatim}
-\TypeDef{muli\_trapezium\_node\_class}
-muli\_trapezium\_node\_class ist eine abstake Klasse, die durch die Komonenten left und right wahlweise ein Binärbaum oder eine doppelt-verknüpften Liste sein kann. Welche dieser Ausprägungen vorliegt, hängt von dem Datentyp ab. Jede Instanz der Klasse muli\_trapezium\_node\_class ist entweder vom Typ \TypeRef{muli\_trapezium\_tree\_type} oder vom Typ \TypeRef{muli\_trapezium\_list\_type}. Hier werden alle Methoden definiert, die eine Liste, und ein Baum gemein haben.
-\begin{Verbatim}
- type,Extends{muli\_trapezium\_type},abstract :: muli_trapezium_node_class
-\end{Verbatim}
-\paragraph{Komponenten}
-\begin{Verbatim}
- private
- class(muli_trapezium_node_class), pointer :: \TC{left} => null()
- class(muli_trapezium_node_class), pointer :: \TC{right} => null()
-\end{Verbatim}
-\paragraph{Methoden}
-\begin{Verbatim}
- contains
-! private
- \OverridesDeclaration{measurable\_class}
- procedure,public ::\TbpDec{deserialize\_from\_marker}{muli\_trapezium\_node\_deserialize\_from\_marker}
- \OriginalDeclaration
- procedure(muli_trapezium_append_interface),deferred,public::append
- procedure(muli_trapezium_final_interface),deferred,public :: finalize
- procedure,public ::\TbpDec{nullify}{muli\_trapezium\_node\_nullify}
- procedure,public ::\TbpDec{get\_left}{muli\_trapezium\_node\_get\_left}
- procedure,public ::\TbpDec{get\_right}{muli\_trapezium\_node\_get\_right}
- procedure,public ::\TbpDec{get\_leftmost}{muli\_trapezium\_node\_get\_leftmost}
- procedure,public ::\TbpDec{get\_rightmost}{muli\_trapezium\_node\_get\_rightmost}
- procedure,public ::\TbpDec{decide\_by\_value}{muli\_trapezium\_node\_decide\_by\_value}
- procedure,public ::\TbpDec{decide\_by\_position}{muli\_trapezium\_node\_decide\_by\_position}
- procedure,public ::\TbpDec{decide\_decreasing}{muli\_trapezium\_node\_decide\_decreasing}
- procedure,public :: muli_trapezium_node_to_tree
- procedure,private::\TbpDec{untangle}{muli\_trapezium\_node\_untangle}
- procedure,public ::\TbpDec{apply}{muli\_trapezium\_node\_apply}
- generic,public::\TbpGen{decide}{decide\_by\_value,decide\_by\_position}
- end type muli_trapezium_node_class
-\end{Verbatim}
-\TypeDef{muli\_trapezium\_tree\_type}
-muli\_trapezium\_node\_class in der Ausprägung "Binärbaum".
-\begin{Verbatim}
- type,extends(muli_trapezium_node_class) :: muli_trapezium_tree_type
-\end{Verbatim}
-\paragraph{Komponenten}
-
-down ist ein Zeiger auf das rechteste Blatt von dem linken Nachfolger. Da das Maß eines Blatts gleich r\_position des Blatt ist, gibt down\%measure() die obere Grenze des Intervalls des linken Unterbaums wieder. Bei einer Suche nach dem Blatt, das $\pperp$ enthält, wird also per $\pperp\overset{?}{<}$ down\%measure() entschieden, ob wir nach links oder nach rechts absteigen.
-\begin{Verbatim}
- class(muli_trapezium_node_class), pointer :: \TC{down} => null()
-\end{Verbatim}
-\paragraph{Methoden}
-\begin{Verbatim}
- contains
- \OverridesDeclaration{measurable\_class}
- procedure ::\TbpDec{write\_to\_marker}{muli\_trapezium\_tree\_write\_to\_marker}
- procedure ::\TbpDec{read\_from\_marker}{muli\_trapezium\_tree\_read\_from\_marker}
- procedure ::\TbpDec{print\_to\_unit}{muli\_trapezium\_tree\_print\_to\_unit}
- procedure,nopass ::\TbpDec{get\_type}{muli\_trapezium\_tree\_get\_type}
- procedure,nopass ::\TbpDec{verify\_type}{muli\_trapezium\_tree\_verify\_type}
- \OverridesDeclaration{muli\_trapezium\_node\_class}
- procedure,public ::\TbpDec{nullify}{muli\_trapezium\_tree\_nullify}
- procedure,public ::\TbpDec{finalize}{muli\_trapezium\_tree\_finalize}
- procedure,public ::\TbpDec{decide\_by\_value}{muli\_trapezium\_tree\_decide\_by\_value}
- procedure,public ::\TbpDec{decide\_by\_position}{muli\_trapezium\_tree\_decide\_by\_position}
- procedure,public ::\TbpDec{decide\_decreasing}{muli\_trapezium\_tree\_decide\_decreasing}
- \OriginalDeclaration
- procedure,public ::\TbpDec{get\_left\_list}{muli\_trapezium\_tree\_get\_left\_list}
- procedure,public ::\TbpDec{get\_right\_list}{muli\_trapezium\_tree\_get\_right\_list}
- procedure,public ::\TbpDec{find\_by\_value}{muli\_trapezium\_tree\_find\_by\_value}
- procedure,public ::\TbpDec{find\_by\_position}{muli\_trapezium\_tree\_find\_by\_position}
- procedure,public ::\TbpDec{find\_decreasing}{muli\_trapezium\_tree\_find\_decreasing}
- procedure,public ::\TbpDec{approx\_by\_integral}{muli\_trapezium\_tree\_approx\_by\_integral}
- procedure,public ::\TbpDec{approx\_by\_propability}{muli\_trapezium\_tree\_approx\_by\_propability}
- procedure,public ::\TbpDec{to\_tree}{muli\_trapezium\_tree\_to\_tree}
- generic,public::\TbpGen{find}{find\_by\_value,find\_by\_position}
- procedure::\TbpDec{append}{muli\_trapezium\_tree\_append}
- procedure::\TbpDec{gnuplot}{muli\_trapezium\_tree\_gnuplot}
- end type muli_trapezium_tree_type
-\end{Verbatim}
-\TypeDef{muli\_trapezium\_list\_type}
-muli\_trapezium\_node\_class in der Ausprägung "Liste".
-\begin{Verbatim}
- type,extends(muli_trapezium_node_class) :: muli_trapezium_list_type
-\end{Verbatim}
-\paragraph{Methoden}
-\begin{Verbatim}
- contains
- \OverridesDeclaration{measurable\_class}
- procedure ::\TbpDec{write\_to\_marker}{muli\_trapezium\_list\_write\_to\_marker}
- procedure ::\TbpDec{read\_from\_marker}{muli\_trapezium\_list\_read\_from\_marker}
- procedure ::\TbpDec{read\_target\_from\_marker}{muli\_trapezium\_list\_read\_target\_from\_marker}
- procedure ::\TbpDec{print\_to\_unit}{muli\_trapezium\_list\_print\_to\_unit}
- procedure,nopass ::\TbpDec{get\_type}{muli\_trapezium\_list\_get\_type}
- procedure,nopass ::\TbpDec{verify\_type}{muli\_trapezium\_list\_verify\_type}
- \OriginalDeclaration
- procedure,public ::\TbpDec{finalize}{muli\_trapezium\_list\_finalize}
- procedure,public ::\TbpDec{insert\_right\_a}{muli\_trapezium\_list\_insert\_right\_a}
- generic,public ::\TbpGen{insert\_right}{insert\_right\_a!,insert\_right\_b}
- procedure,public ::\TbpDec{insert\_left\_a}{muli\_trapezium\_list\_insert\_left\_a}
- generic,public ::\TbpGen{insert\_left}{insert\_left\_a!,insert\_left\_b}
- procedure::\TbpDec{append}{muli\_trapezium\_list\_append}
- procedure,public ::\TbpDec{to\_tree}{muli\_trapezium\_list\_to\_tree}
- procedure,public ::\TbpDec{gnuplot}{muli\_trapezium\_list\_gnuplot}
- procedure,public ::\TbpDec{integrate}{muli\_trapezium\_list\_integrate}
- procedure,public ::\TbpDec{check}{muli\_trapezium\_list\_check}
- procedure,public ::\TbpDec{apply}{muli\_trapezium\_list\_apply}
- end type muli_trapezium_list_type
-\end{Verbatim}
-\section{Schnittstellen}
-\begin{Verbatim}
- abstract interface
- subroutine muli_trapezium_append_interface(this,right)
- import muli_trapezium_node_class
- class(muli_trapezium_node_class),intent(inout),target :: this,right
- end subroutine muli_trapezium_append_interface
- subroutine muli_trapezium_final_interface(this)
- import muli_trapezium_node_class
- class(muli_trapezium_node_class),intent(inout) :: this
- end subroutine muli_trapezium_final_interface
- end interface
- \end{Verbatim}
- \Methods
- \MethodsFor{qcd\_2\_2\_type}
- \OverridesSection{serializable\_class}
- \TbpImp{muli\_trapezium\_write\_to\_marker}
- \begin{Verbatim}
- subroutine muli_trapezium_write_to_marker (this,marker,status)
- class(muli_trapezium_type), intent(in) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- ! local variables
- integer::dim
- call marker%mark_begin("muli_trapezium_type")
- call marker%mark("dim",this%dim)
- call marker%mark("r_position",this%r_position)
- call marker%mark("d_position",this%d_position)
- if(allocated(this%values))then
- call marker%mark("values",this%values)
- else
- call marker%mark_null("values")
- end if
- call marker%mark_end("muli_trapezium_type")
- end subroutine muli_trapezium_write_to_marker
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_read\_from\_marker}
-\begin{Verbatim}
- subroutine muli_trapezium_read_from_marker (this,marker,status)
- class(muli_trapezium_type), intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- ! local variables
- integer::dim
- call marker%pick_begin("muli_trapezium_type",status=status)
- call marker%pick("dim",this%dim,status)
- call marker%pick("r_position",this%r_position,status)
- call marker%pick("d_position",this%d_position,status)
- if(allocated(this%values))deallocate(this%values)
- call marker%verify_nothing("values",status)
- if(status==serialize_ok)then
- allocate(this%values(0:this%dim-1,7))
- call marker%pick("values",this%values,status)
- end if
- call marker%pick_end("muli_trapezium_type",status)
- end subroutine muli_trapezium_read_from_marker
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_print\_to\_unit}
-\begin{Verbatim}
- subroutine muli_trapezium_print_to_unit(this,unit,parents,components,peers)
- class(muli_trapezium_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- write(unit,'("Components of muli_trapezium_type:")')
- write(unit,fmt=*)"Dimension: ",this%dim
- write(unit,fmt=*)"Right position: ",this%r_position
- write(unit,fmt=*)"Position step: ",this%d_position
- if(allocated(this%values))then
- if(components>0)then
- write(unit,fmt=*)"Right values: ",muli_trapezium_get_r_value_array(this)
- write(unit,fmt=*)"Value step: ",this%get_d_value()
- write(unit,fmt=*)"Right integrals: ",this%get_r_integral()
- write(unit,fmt=*)"Integral step: ",this%get_d_integral()
- write(unit,fmt=*)"Right propabilities:",this%get_r_propability()
- write(unit,fmt=*)"Propability step: ",this%get_d_propability()
- write(unit,fmt=*)"Errors: ",this%get_error()
- else
- write(unit,fmt=*)"Values are allocated."
- end if
- else
- write(unit,fmt=*)"Values are not allocated."
- end if
- end subroutine muli_trapezium_print_to_unit
-\end{Verbatim}
-\TbpImp{muli\_trapezium\_get\_type}
-\begin{Verbatim}
- pure subroutine muli_trapezium_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="muli_trapezium_type")
- end subroutine muli_trapezium_get_type
-\end{Verbatim}
-\TbpImp{muli\_trapezium\_verify\_type}
-\begin{Verbatim}
- elemental logical function muli_trapezium_verify_type(type) result(match)
- character(*),intent(in)::type
- match=type=="muli_trapezium_type"
- end function muli_trapezium_verify_type
-\end{Verbatim}
-\OverridesSection{measurable\_type}
-\TbpImp{muli\_trapezium\_measure}
-\begin{Verbatim}
- elemental function muli_trapezium_measure(this)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double)::muli_trapezium_measure
- muli_trapezium_measure=this%measure_comp
- end function muli_trapezium_measure
-\end{Verbatim}
-\OriginalSection{muli\_trapezium\_type}
-\TbpImp{muli\_trapezium\_initialize}
-\begin{Verbatim}
- subroutine muli_trapezium_initialize(this,dim,r_position,d_position)
- class(muli_trapezium_type),intent(inout)::this
- integer,intent(in)::dim
- real(kind=double),intent(in)::r_position,d_position
- integer::dim1,dim2
- this%dim=dim
- this%r_position=r_position
- this%d_position=d_position
- if(allocated(this%values))deallocate(this%values)
- allocate(this%values(0:dim-1,value_dimension))
- do dim2=1,value_dimension-1
- do dim1=0,dim-1
- this%values(dim1,dim2)=0D0
- end do
- end do
- do dim1=0,dim-1
- this%values(dim1,value_dimension)=huge(1D0)
- end do
- this%measure_comp=huge(1D0)
- end subroutine muli_trapezium_initialize
-\end{Verbatim}
-
-!!! components !!!
-
-\TbpImp{muli\_trapezium\_get\_dimension}
-\begin{Verbatim}
- elemental function muli_trapezium_get_dimension(this) result(dim)
- class(muli_trapezium_type),intent(in)::this
- integer::dim
- dim=this%dim
- end function muli_trapezium_get_dimension
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_l\_position}
-\begin{Verbatim}
- pure function muli_trapezium_get_l_position(this) result(pos)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double)::pos
- pos=this%r_position-this%d_position
- end function muli_trapezium_get_l_position
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_r\_position}
-\begin{Verbatim}
- pure function muli_trapezium_get_r_position(this) result(pos)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double)::pos
- pos=this%r_position
- end function muli_trapezium_get_r_position
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_d\_position}
-\begin{Verbatim}
- pure function muli_trapezium_get_d_position(this) result(pos)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double)::pos
- pos=this%d_position
- end function muli_trapezium_get_d_position
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_error\_sum}
-\begin{Verbatim}
- pure function muli_trapezium_get_error_sum(this) result(error)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double)::error
- error=sum(this%values(0:this%dim-1,error_index))
- end function muli_trapezium_get_error_sum
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_integral\_sum}
-\begin{Verbatim}
- pure function muli_trapezium_get_integral_sum(this) result(error)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double)::error
- error=sum(this%values(0:this%dim-1,d_integral_index))
- end function muli_trapezium_get_integral_sum
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_l\_value\_element}
-\begin{Verbatim}
- pure function muli_trapezium_get_l_value_element(this,set) result(element)
- class(muli_trapezium_type),intent(in)::this
- integer,intent(in)::set
- real(kind=double)::element
- element=this%values(set,r_value_index)-this%values(set,d_value_index)
- end function muli_trapezium_get_l_value_element
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_l\_value\_array}
-\begin{Verbatim}
- pure function muli_trapezium_get_l_value_array(this) result(subarray)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double),dimension(this%dim)::subarray
- subarray=this%values(0:this%dim-1,r_value_index)-this%values(0:this%dim-1,d_value_index)
- end function muli_trapezium_get_l_value_array
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_r\_value\_element}
-\begin{Verbatim}
- pure function muli_trapezium_get_r_value_element(this,set) result(element)
- class(muli_trapezium_type),intent(in)::this
- integer,intent(in)::set
- real(kind=double)::element
- element=this%values(set,r_value_index)
- end function muli_trapezium_get_r_value_element
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_r\_value\_array}
-\begin{Verbatim}
- pure function muli_trapezium_get_r_value_array(this) result(subarray)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double),dimension(this%dim)::subarray
- subarray=this%values(0:this%dim-1,r_value_index)
- end function muli_trapezium_get_r_value_array
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_d\_value\_element}
-\begin{Verbatim}
- pure function muli_trapezium_get_d_value_element(this,set) result(element)
- class(muli_trapezium_type),intent(in)::this
- integer,intent(in)::set
- real(kind=double)::element
- element=this%values(set,d_value_index)
- end function muli_trapezium_get_d_value_element
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_d\_value\_array}
-\begin{Verbatim}
- pure function muli_trapezium_get_d_value_array(this) result(subarray)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double),dimension(this%dim)::subarray
- subarray=this%values(0:this%dim-1,d_value_index)
- end function muli_trapezium_get_d_value_array
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_l\_integral\_element}
-\begin{Verbatim}
- pure function muli_trapezium_get_l_integral_element(this,set) result(element)
- class(muli_trapezium_type),intent(in)::this
- integer,intent(in)::set
- real(kind=double)::element
- element=this%values(set,r_integral_index)-this%values(set,d_integral_index)
- end function muli_trapezium_get_l_integral_element
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_l\_integral\_array}
-\begin{Verbatim}
- pure function muli_trapezium_get_l_integral_array(this) result(subarray)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double),dimension(this%dim)::subarray
- subarray=this%values(0:this%dim-1,r_integral_index)-this%values(0:this%dim-1,d_integral_index)
- end function muli_trapezium_get_l_integral_array
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_r\_integral\_element}
-\begin{Verbatim}
- pure function muli_trapezium_get_r_integral_element(this,set) result(element)
- class(muli_trapezium_type),intent(in)::this
- integer,intent(in)::set
- real(kind=double)::element
- element=this%values(set,r_integral_index)
- end function muli_trapezium_get_r_integral_element
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_r\_integral\_array}
-\begin{Verbatim}
- pure function muli_trapezium_get_r_integral_array(this) result(subarray)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double),dimension(this%dim)::subarray
- subarray=this%values(0:this%dim-1,r_integral_index)
- end function muli_trapezium_get_r_integral_array
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_d\_integral\_element}
-\begin{Verbatim}
- pure function muli_trapezium_get_d_integral_element(this,set) result(element)
- class(muli_trapezium_type),intent(in)::this
- integer,intent(in)::set
- real(kind=double)::element
- element=this%values(set,d_integral_index)
- end function muli_trapezium_get_d_integral_element
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_d\_integral\_array}
-\begin{Verbatim}
- pure function muli_trapezium_get_d_integral_array(this) result(subarray)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double),dimension(this%dim)::subarray
- subarray=this%values(0:this%dim-1,d_integral_index)
- end function muli_trapezium_get_d_integral_array
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_l\_propability\_element}
-\begin{Verbatim}
- pure function muli_trapezium_get_l_propability_element(this,set) result(element)
- class(muli_trapezium_type),intent(in)::this
- integer,intent(in)::set
- real(kind=double)::element
- element=this%values(set,r_propability_index)-this%values(set,d_propability_index)
- end function muli_trapezium_get_l_propability_element
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_l\_propability\_array}
-\begin{Verbatim}
- pure function muli_trapezium_get_l_propability_array(this) result(subarray)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double),dimension(this%dim)::subarray
- subarray=&
- this%values(0:this%dim-1,r_propability_index)&
- -this%values(0:this%dim-1,d_propability_index)
- end function muli_trapezium_get_l_propability_array
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_r\_propability\_element}
-\begin{Verbatim}
- pure function muli_trapezium_get_r_propability_element(this,set) result(element)
- class(muli_trapezium_type),intent(in)::this
- integer,intent(in)::set
- real(kind=double)::element
- element=this%values(set,r_propability_index)
- end function muli_trapezium_get_r_propability_element
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_r\_propability\_array}
-\begin{Verbatim}
- pure function muli_trapezium_get_r_propability_array(this) result(subarray)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double),dimension(this%dim)::subarray
- subarray=this%values(0:this%dim-1,r_propability_index)
- end function muli_trapezium_get_r_propability_array
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_d\_propability\_array}
-\begin{Verbatim}
- pure function muli_trapezium_get_d_propability_array(this) result(subarray)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double),dimension(this%dim)::subarray
- subarray=this%values(0:this%dim-1,d_propability_index)
- end function muli_trapezium_get_d_propability_array
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_d\_propability\_element}
-\begin{Verbatim}
- pure function muli_trapezium_get_d_propability_element(this,set) result(element)
- class(muli_trapezium_type),intent(in)::this
- integer,intent(in)::set
- real(kind=double)::element
- element=this%values(set,d_propability_index)
- end function muli_trapezium_get_d_propability_element
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_get\_error}
-\begin{Verbatim}
- pure function muli_trapezium_get_error(this) result(error)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double),dimension(this%dim)::error
- error=this%values(0:this%dim-1,error_index)
- end function muli_trapezium_get_error
-\end{Verbatim}
-
- ! interpolation
-
-\TbpImp{muli\_trapezium\_get\_value\_at\_position}
-\begin{Verbatim}
- subroutine muli_trapezium_get_value_at_position(this,pos,subarray)
- class(muli_trapezium_type),intent(in)::this
- real(kind=double),intent(in)::pos
- real(kind=double),dimension(this%dim),intent(out)::subarray
- subarray=this%get_r_value_array()-this%get_d_value()*this%d_position/(this%r_position-pos)
- end subroutine muli_trapezium_get_value_at_position
-\end{Verbatim}
-
- ! write access
-
-\TbpImp{muli\_trapezium\_set\_r\_value}
-\begin{Verbatim}
- subroutine muli_trapezium_set_r_value(this,subarray)
- class(muli_trapezium_type),intent(inout)::this
- real(kind=double),intent(in),dimension(0:this%dim-1)::subarray
- this%values(0:this%dim-1,r_value_index)=subarray
- end subroutine muli_trapezium_set_r_value
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_set\_d\_value}
-\begin{Verbatim}
- subroutine muli_trapezium_set_d_value(this,subarray)
- class(muli_trapezium_type),intent(inout)::this
- real(kind=double),intent(in),dimension(0:this%dim-1)::subarray
- this%values(0:this%dim-1,d_value_index)=subarray
- end subroutine muli_trapezium_set_d_value
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_set\_r\_integral}
-\begin{Verbatim}
- subroutine muli_trapezium_set_r_integral(this,subarray)
- class(muli_trapezium_type),intent(inout)::this
- real(kind=double),intent(in),dimension(0:this%dim-1)::subarray
- this%values(0:this%dim-1,r_integral_index)=subarray
- end subroutine muli_trapezium_set_r_integral
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_set\_d\_integral}
-\begin{Verbatim}
- subroutine muli_trapezium_set_d_integral(this,subarray)
- class(muli_trapezium_type),intent(inout)::this
- real(kind=double),intent(in),dimension(0:this%dim-1)::subarray
- this%values(0:this%dim-1,d_integral_index)=subarray
- end subroutine muli_trapezium_set_d_integral
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_set\_r\_propability}
-\begin{Verbatim}
- subroutine muli_trapezium_set_r_propability(this,subarray)
- class(muli_trapezium_type),intent(inout)::this
- real(kind=double),intent(in),dimension(0:this%dim-1)::subarray
- this%values(0:this%dim-1,r_propability_index)=subarray
- end subroutine muli_trapezium_set_r_propability
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_set\_d\_propability}
-\begin{Verbatim}
- subroutine muli_trapezium_set_d_propability(this,subarray)
- class(muli_trapezium_type),intent(inout)::this
- real(kind=double),intent(in),dimension(0:this%dim-1)::subarray
- this%values(0:this%dim-1,d_propability_index)=subarray
- end subroutine muli_trapezium_set_d_propability
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_set\_error}
-\begin{Verbatim}
- subroutine muli_trapezium_set_error(this,subarray)
- class(muli_trapezium_type),intent(inout)::this
- real(kind=double),intent(in),dimension(0:this%dim-1)::subarray
- this%values(0:this%dim-1,error_index)=subarray
- this%measure_comp=sum(subarray)
- end subroutine muli_trapezium_set_error
-\end{Verbatim}
-
- ! tests
-
-\TbpImp{muli\_trapezium\_is\_left\_of}
-\begin{Verbatim}
- pure function muli_trapezium_is_left_of(this,that) result(is_left)
- logical::is_left
- class(muli_trapezium_type),intent(in)::this,that
- is_left=this%r_position<=that%r_position!-that%d_position
- end function muli_trapezium_is_left_of
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_includes}
-\begin{Verbatim}
- elemental logical function muli_trapezium_includes&
- (this,dim,position,value,integral,propability) result(includes)
- class(muli_trapezium_type),intent(in)::this
- integer,intent(in)::dim
- real(kind=double),intent(in),optional::position,value,integral,propability
- includes=.true.
- if(present(position))then
- if(this%get_l_position()>position.or.position>=this%get_r_position())&
- includes=.false.
- end if
- if(present(value))then
- if(this%get_l_value(dim)>value.or.value>=this%get_r_value(dim))&
- includes=.false.
- end if
- if(present(integral))then
- if(this%get_l_integral(dim)>integral.or.integral>=this%get_r_integral(dim))&
- includes=.false.
- end if
- if(present(propability))then
- if(this%get_l_propability(dim)>propability.or.propability>=this%get_r_propability(dim))&
- includes=.false.
- end if
- end function muli_trapezium_includes
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_update}
-\begin{Verbatim}
- subroutine muli_trapezium_update(this)
- class(muli_trapezium_type),intent(inout) :: this
- real(kind=double),dimension(:),allocatable :: int
- allocate(int(0:this%dim-1),source=this%get_d_integral())
- call this%set_d_integral(-this%d_position*(this%get_r_value_array()-this%get_d_value()/2D0))
- call this%set_error(abs(this%get_d_integral()-int))
-! print('(11(D20.10))'),this%get_d_integral()
- end subroutine muli_trapezium_update
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_split}
-\begin{Verbatim}
- subroutine muli_trapezium_split(this,c_value,c_position,new_node)
- class(muli_trapezium_type),intent(inout) :: this
- real(kind=double),intent(in) :: c_position
- real(kind=double),intent(in),dimension(this%dim) :: c_value
- class(muli_trapezium_type),intent(out),pointer :: new_node
- real(kind=double) :: ndpr,ndpl
- real(kind=double),dimension(:),allocatable::ov,edv
- ndpr=this%r_position-c_position
- ndpl=this%d_position-ndpr
- allocate(ov(0:this%dim-1),&
- source=this%get_r_value_array()-ndpr*this%get_d_value()/this%d_position)
- allocate(edv(0:this%dim-1),source=c_value-ov)
- allocate(new_node)
- call new_node%initialize(dim=this%dim,&
- &r_position=c_position,&
- &d_position=ndpl)
- call new_node%set_r_value(c_value)
- call new_node%set_d_value(this%get_d_value()+c_value-this%get_r_value_array())
- call new_node%set_d_integral(ndpl*(this%get_d_value()-this%get_r_value_array()-c_value)/2D0)
- call new_node%set_error(abs((edv*ndpl)/2D0))
- !new_node%measure_comp=sum(abs((edv*ndpl)/2D0))
- this%d_position=ndpr
- call this%set_d_value(this%get_r_value_array()-c_value)
- call this%set_d_integral(-(ndpr*(this%get_r_value_array()+c_value)/2D0))
- call this%set_error(abs(edv*ndpr/2D0))
- !this%measure_comp=sum(abs(edv*ndpr/2D0))
-! print ('("muli_trapezium_split: new errors:")')
-! print ('(E14.7)'),this%get_error()
-! print ('(E14.7)'),new_node%get_error()
-! print('(11(D20.10))'),new_node%get_d_integral()
-! print('(11(D20.10))'),this%get_d_integral()
- end subroutine muli_trapezium_split
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_approx\_value}
-\begin{Verbatim}
- pure function muli_trapezium_approx_value(this,x) result(val)
- ! returns the values at x
- class(muli_trapezium_type),intent(in) :: this
- real(kind=double),dimension(this%dim) :: val
- real(kind=double), intent(in) :: x
- val = this%get_r_value_array()&
- +(x-this%r_position)*this%get_d_value()/this%d_position
- end function muli_trapezium_approx_value
-\end{Verbatim}
-\TbpImp{muli\_trapezium\_approx\_value\_n}
-\begin{Verbatim}
- elemental function muli_trapezium_approx_value_n(this,x,n) result(val)
- ! returns the value at x
- class(muli_trapezium_type),intent(in) :: this
- real(kind=double)::val
- real(kind=double), intent(in) :: x
- integer,intent(in)::n
- val = this%get_r_value_element(n)&
- +(x-this%r_position)*this%get_d_value_element(n)/this%d_position
- end function muli_trapezium_approx_value_n
-\end{Verbatim}
-\TbpImp{muli\_trapezium\_approx\_integral}
-\begin{Verbatim}
- pure function muli_trapezium_approx_integral(this,x)
- ! returns the integral from x to r_position
- class(muli_trapezium_type),intent(in) :: this
- real(kind=double),dimension(this%dim) :: muli_trapezium_approx_integral
- real(kind=double), intent(in) :: x
- muli_trapezium_approx_integral = &
- &this%get_r_integral()+&
- &((this%r_position-x)*&
- &(-this%get_d_value()*(this%r_position-x)&
- +2*this%d_position*this%get_r_value_array()))/&
- &(2*this%d_position)
- end function muli_trapezium_approx_integral
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_approx\_integral\_n}
-\begin{Verbatim}
- elemental function muli_trapezium_approx_integral_n(this,x,n) result(val)
- ! returns the integral from x to r_position
- class(muli_trapezium_type),intent(in) :: this
- real(kind=double)::val
- real(kind=double), intent(in) :: x
- integer,intent(in)::n
- val = &
- &this%get_r_integral_element(n)+&
- &((this%r_position-x)*&
- &(-this%get_d_value_element(n)*(this%r_position-x)&
- +2*this%d_position*this%get_r_value_element(n)))/&
- &(2*this%d_position)
- end function muli_trapezium_approx_integral_n
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_approx\_propability}
-\begin{Verbatim}
- pure function muli_trapezium_approx_propability(this,x) result(prop)
- ! returns the vlaues at x
- class(muli_trapezium_type),intent(in) :: this
- real(kind=double),dimension(this%dim) :: prop
- real(kind=double), intent(in) :: x
- prop=exp(-this%approx_integral(x))
- end function muli_trapezium_approx_propability
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_approx\_propability\_n}
-\begin{Verbatim}
- elemental function muli_trapezium_approx_propability_n(this,x,n) result(val)
- ! returns the integral from x to r_position
- class(muli_trapezium_type),intent(in) :: this
- real(kind=double)::val
- real(kind=double), intent(in) :: x
- integer,intent(in)::n
- val = exp(-this%approx_integral_n(x,n))
- end function muli_trapezium_approx_propability_n
-\end{Verbatim}
-\TbpImp{muli\_trapezium\_approx\_position\_by\_integral}
-\begin{Verbatim}
- elemental function muli_trapezium_approx_position_by_integral(this,dim,int) result(val)
- class(muli_trapezium_type),intent(in) :: this
- real(kind=double)::val
- integer,intent(in)::dim
- real(kind=double),intent(in)::int
- real(kind=double)::dpdv
- dpdv=(this%d_position/this%values(dim,d_value_index))
- val=this%r_position-dpdv*&
- (this%values(dim,r_value_index)-&
- sqrt(((this%values(dim,r_integral_index)-int)*2D0/dpdv)&
- +this%values(dim,r_value_index)**2))
- end function muli_trapezium_approx_position_by_integral
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_to\_node}
-\begin{Verbatim}
- subroutine muli_trapezium_to_node(this,value,list,tree)
- class(muli_trapezium_type),intent(in) :: this
- real(kind=double),intent(in) :: value
- class(muli_trapezium_list_type),optional,pointer,intent(out) :: list
- class(muli_trapezium_tree_type),optional,pointer,intent(out) :: tree
- if(present(list))then
- allocate(list)
- list%dim=this%dim
- list%r_position=this%r_position
- list%d_position=this%d_position
- allocate(list%values(0:this%dim-1,value_dimension),source=this%values)
- end if
- if(present(tree))then
- allocate(tree)
- tree%dim=this%dim
- tree%r_position=this%r_position
- tree%d_position=this%d_position
- allocate(tree%values(0:this%dim-1,value_dimension),source=this%values)
- end if
- end subroutine muli_trapezium_to_node
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_sum\_up}
-\begin{Verbatim}
- subroutine muli_trapezium_sum_up(this)
- class(muli_trapezium_type),intent(inout) :: this
- integer::i
- if(allocated(this%values))then
- do i=1,7
- this%values(0,i)=sum(this%values(1:this%dim-1,i))
- end do
- end if
- end subroutine muli_trapezium_sum_up
-\end{Verbatim}
-\MethodsFor{muli\_trapezium\_node\_class}
-\TbpImp{muli\_trapezium\_node\_deserialize\_from\_marker}
-\begin{Verbatim}
- subroutine muli_trapezium_node_deserialize_from_marker(this,name,marker)
- class(muli_trapezium_node_class), intent(out) :: this
- character(*),intent(in)::name
- class(marker_type),intent(inout)::marker
- integer(kind=dik)::status
- class(serializable_class),pointer::ser
- allocate(muli_trapezium_tree_type::ser)
- call marker%push_reference(ser)
- allocate(muli_trapezium_list_type::ser)
- call marker%push_reference(ser)
- call serializable_deserialize_from_marker(this,name,marker)
- call marker%pop_reference(ser)
- deallocate(ser)
- call marker%pop_reference(ser)
- deallocate(ser)
- end subroutine muli_trapezium_node_deserialize_from_marker
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_node\_nullify}
-\begin{Verbatim}
- subroutine muli_trapezium_node_nullify(this)
- class(muli_trapezium_node_class),intent(out) :: this
- nullify(this%left)
- nullify(this%right)
- end subroutine muli_trapezium_node_nullify
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_node\_get\_left}
-\begin{Verbatim}
- subroutine muli_trapezium_node_get_left(this,left)
- class(muli_trapezium_node_class),intent(in) :: this
- class(muli_trapezium_node_class),pointer,intent(out) :: left
- left=>this%left
- end subroutine muli_trapezium_node_get_left
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_node\_get\_right}
-\begin{Verbatim}
- subroutine muli_trapezium_node_get_right(this,right)
- class(muli_trapezium_node_class),intent(in) :: this
- class(muli_trapezium_node_class),pointer,intent(out) :: right
- right=>this%right
- end subroutine muli_trapezium_node_get_right
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_node\_get\_leftmost}
-\begin{Verbatim}
- subroutine muli_trapezium_node_get_leftmost(this,node)
- class(muli_trapezium_node_class),intent(in) :: this
- class(muli_trapezium_node_class),pointer,intent(out) :: node
- if (associated(this%left)) then
- node=>this%left
- do while (associated(node%left))
- node=>node%left
- end do
- else
- nullify(node)
- end if
- end subroutine muli_trapezium_node_get_leftmost
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_node\_get\_rightmost}
-\begin{Verbatim}
- subroutine muli_trapezium_node_get_rightmost(this,right)
- class(muli_trapezium_node_class),intent(in) :: this
- class(muli_trapezium_node_class),pointer,intent(out) :: right
- if (associated(this%right)) then
- right=>this%right
- do while (associated(right%right))
- right=>right%right
- end do
- else
- nullify(right)
- end if
- end subroutine muli_trapezium_node_get_rightmost
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_node\_decide\_by\_value}
-\begin{Verbatim}
- subroutine muli_trapezium_node_decide_by_value(this,value,dim,record,node)
- class(muli_trapezium_node_class),intent(in) :: this
- real(kind=double),intent(in)::value
- integer,intent(in)::record,dim
- class(muli_trapezium_node_class),pointer,intent(out) :: node
- if(this%values(dim,record)>value)then
- node=>this%left
- else
- node=>this%right
- end if
- end subroutine muli_trapezium_node_decide_by_value
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_node\_decide\_by\_position}
-\begin{Verbatim}
- subroutine muli_trapezium_node_decide_by_position(this,position,node)
- class(muli_trapezium_node_class),intent(in) :: this
- real(kind=double),intent(in)::position
- class(muli_trapezium_node_class),pointer,intent(out) :: node
- if(this%r_position>position)then
- node=>this%left
- else
- node=>this%right
- end if
- end subroutine muli_trapezium_node_decide_by_position
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_node\_decide\_decreasing}
-\begin{Verbatim}
- subroutine muli_trapezium_node_decide_decreasing(this,value,dim,record,node)
- class(muli_trapezium_node_class),intent(in) :: this
- real(kind=double),intent(in)::value
- integer,intent(in)::record,dim
- class(muli_trapezium_node_class),pointer,intent(out) :: node
- if(this%values(dim,record)<=value)then
- node=>this%left
- else
- node=>this%right
- end if
- end subroutine muli_trapezium_node_decide_decreasing
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_node\_untangle}
-\begin{Verbatim}
- subroutine muli_trapezium_node_untangle(this)
- class(muli_trapezium_node_class),intent(inout),target :: this
- if(associated(this%left))then
- if(associated(this%left%right,this))then
- nullify(this%left%right)
- nullify(this%left)
- end if
- end if
- end subroutine muli_trapezium_node_untangle
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_node\_apply}
-\begin{Verbatim}
- recursive subroutine muli_trapezium_node_apply(this,proc)
- class(muli_trapezium_node_class),intent(inout) :: this
- interface
- subroutine proc(this)
- import muli_trapezium_node_class
- class(muli_trapezium_node_class),intent(inout) :: this
- end subroutine proc
- end interface
- if(associated(this%right))call proc(this%right)
- if(associated(this%left))call proc(this%left)
- call proc(this)
- end subroutine muli_trapezium_node_apply
-\end{Verbatim}
-\MethodsFor{muli\_trapezium\_list\_type}
-\TbpImp{muli\_trapezium\_list\_write\_to\_marker}
-\begin{Verbatim}
- recursive subroutine muli_trapezium_list_write_to_marker (this,marker,status)
- class(muli_trapezium_list_type), intent(in) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- ! local variables
- class(serializable_class),pointer::ser
- call marker%mark_begin("muli_trapezium_list_type")
- call muli_trapezium_write_to_marker(this,marker,status)
- ser=>this%right
- call marker%mark_pointer("right",ser)
- call marker%mark_end("muli_trapezium_list_type")
- end subroutine muli_trapezium_list_write_to_marker
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_list\_read\_from\_marker}
-\begin{Verbatim}
- recursive subroutine muli_trapezium_list_read_from_marker (this,marker,status)
- class(muli_trapezium_list_type), intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- print *,"muli_trapezium_list_read_from_marker:"
- print *,"You cannot deserialize a list with this subroutine."
- print *,"Use muli_trapezium_list_read_target_from_marker instead."
- end subroutine muli_trapezium_list_read_from_marker
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_list\_read\_target\_from\_marker}
-\begin{Verbatim}
- recursive subroutine muli_trapezium_list_read_target_from_marker (this,marker,status)
- class(muli_trapezium_list_type),target,intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- ! local variables
- class(serializable_class),pointer::ser
- call marker%pick_begin("muli_trapezium_list_type",status=status)
- call muli_trapezium_read_from_marker(this,marker,status)
- call marker%pick_pointer("right",ser)
- if(associated(ser))then
- select type(ser)
- class is (muli_trapezium_list_type)
- this%right=>ser
- ser%left=>this
- class default
- nullify(this%right)
- print *,"muli_trapezium_list_read_target_from_marker:"
- print *,"Unexpected type for right component."
- end select
- else
- nullify(this%right)
- end if
- call marker%pick_end("muli_trapezium_list_type",status)
- end subroutine muli_trapezium_list_read_target_from_marker
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_list\_print\_to\_unit}
-\begin{Verbatim}
- recursive subroutine muli_trapezium_list_print_to_unit&
- (this,unit,parents,components,peers)
- class(muli_trapezium_list_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- class(serializable_class),pointer::ser
- if(parents>0)call muli_trapezium_print_to_unit(this,unit,parents-1,components,peers)
- ser=>this%left
- call serialize_print_peer_pointer(ser,unit,-one,-one,-one,"LEFT")
- ser=>this%right
- call serialize_print_peer_pointer(ser,unit,parents,components,peers,"RIGHT")
- end subroutine muli_trapezium_list_print_to_unit
-\end{Verbatim}
-\TbpImp{muli\_trapezium\_list\_get\_type}
-\begin{Verbatim}
- pure subroutine muli_trapezium_list_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="muli_trapezium_list_type")
- end subroutine muli_trapezium_list_get_type
-\end{Verbatim}
-\TbpImp{muli\_trapezium\_list\_verify\_type}
-\begin{Verbatim}
- elemental logical function muli_trapezium_list_verify_type(type) result(match)
- character(*),intent(in)::type
- match=type=="muli_trapezium_list_type"
- end function muli_trapezium_list_verify_type
-\end{Verbatim}
-\TbpImp{muli\_trapezium\_list\_finalize}
-\begin{Verbatim}
- recursive subroutine muli_trapezium_list_finalize(this)
- class(muli_trapezium_list_type),intent(inout)::this
- if (associated(this%right)) then
- call this%right%finalize()
- deallocate(this%right)
- end if
- this%dim=0
- end subroutine muli_trapezium_list_finalize
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_list\_insert\_left\_a}
-\begin{Verbatim}
- subroutine muli_trapezium_list_insert_left_a(this,value,content,new_node)
- class(muli_trapezium_list_type),intent(inout),target :: this
- real(kind=double),intent(in) :: value
- class(muli_trapezium_type),intent(in) :: content
- class(muli_trapezium_list_type),pointer,intent(out) :: new_node
- call content%to_node(value,list=new_node)
- new_node%right=>this
- if(associated(this%left))then
- new_node%left=>this%left
- this%left%right=>new_node
- else
- nullify(new_node%left)
- end if
- this%left=>new_node
- end subroutine muli_trapezium_list_insert_left_a
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_list\_insert\_right\_a}
-\begin{Verbatim}
- subroutine muli_trapezium_list_insert_right_a(this,value,content,new_node)
- class(muli_trapezium_list_type),intent(inout),target :: this
- real(kind=double),intent(in) :: value
- class(muli_trapezium_type),intent(in) :: content
- class(muli_trapezium_list_type),pointer,intent(out) :: new_node
- class(muli_trapezium_list_type),pointer :: tmp_list
- call content%to_node(value,list=tmp_list)
- if(associated(this%right))then
- this%right%left=>tmp_list
- tmp_list%right=>this%right
- else
- nullify(tmp_list%right)
- end if
- this%right=>tmp_list
- tmp_list%left=>this
- new_node=>tmp_list
- end subroutine muli_trapezium_list_insert_right_a
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_list\_append}
-\begin{Verbatim}
- subroutine muli_trapezium_list_append(this,right)
- class(muli_trapezium_list_type),intent(inout),target :: this
- class(muli_trapezium_node_class),intent(inout),target :: right
- this%right=>right
- right%left=>this
- end subroutine muli_trapezium_list_append
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_list\_to\_tree}
-\begin{Verbatim}
- subroutine muli_trapezium_list_to_tree(this,out_tree)
- class(muli_trapezium_list_type),target,intent(in) :: this
- class(muli_trapezium_tree_type),intent(out) :: out_tree
- type(muli_trapezium_tree_type),target :: do_list
- class(muli_trapezium_node_class),pointer :: this_entry,do_list_entry,node
- class(muli_trapezium_tree_type),pointer :: tree1,tree2
- integer :: ite,log,n_deep,n_leaves
- n_leaves=0
- this_entry => this
- count: do while(associated(this_entry))
- n_leaves=n_leaves+1
- this_entry=>this_entry%right
- end do count
- call ilog2(n_leaves,log,n_deep)
- this_entry => this
- do_list_entry => do_list
- deep: do ite=0,n_deep-1
- allocate(tree1)
- tree1%down=>this_entry%right
- allocate(tree2)
- tree2%down=>this_entry
- tree2%left=>this_entry
- tree2%right=>this_entry%right
- tree1%left=>tree2
- this_entry => this_entry%right%right
- do_list_entry%right=>tree1
- do_list_entry=>tree1
- end do deep
- rest: do while(associated(this_entry))
- allocate(tree1)
- tree1%down=>this_entry
- tree1%left=>this_entry
- do_list_entry%right => tree1
- do_list_entry => tree1
- this_entry => this_entry%right
- ite=ite+1
- end do rest
- tree: do while(ite>2)
- do_list_entry => do_list%right
- node=>do_list
- level: do while(associated(do_list_entry))
- node%right=>do_list_entry%right
- node=>do_list_entry%right
- do_list_entry%right=>node%left
- node%left=>do_list_entry
- do_list_entry=>node%right
- ite=ite-1
- end do level
- end do tree
- node=>do_list%right
- select type(node)
- type is (muli_trapezium_tree_type)
- call node%to_tree(out_tree)
- class default
- print *,"muli_trapezium_list_to_tree"
- print *,"unexpeted type for do_list%right"
- end select
- out_tree%right=>out_tree%right%left
- if(allocated(out_tree%values))then
- deallocate(out_tree%values)
- end if
- deallocate(do_list%right%right)
- deallocate(do_list%right)
- end subroutine muli_trapezium_list_to_tree
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_list\_gnuplot}
-\begin{Verbatim}
- subroutine muli_trapezium_list_gnuplot(this,dir)
- class(muli_trapezium_list_type),intent(in),target :: this
- character(len=*),intent(in)::dir
- character(len=*),parameter::val_file="/value.plot"
- character(len=*),parameter::int_file="/integral.plot"
- character(len=*),parameter::err_file="/integral_error.plot"
- character(len=*),parameter::pro_file="/propability.plot"
- character(len=*),parameter::den_file="/density.plot"
- character(len=*),parameter::fmt='(E20.10)'
- class(muli_trapezium_node_class),pointer::list
- integer::val_unit,err_unit,int_unit,pro_unit,den_unit
- list=>this
- call generate_unit(val_unit,100,1000)
- open(val_unit,file=dir//val_file)
- call generate_unit(int_unit,100,1000)
- open(int_unit,file=dir//int_file)
- call generate_unit(err_unit,100,1000)
- open(err_unit,file=dir//err_file)
- call generate_unit(pro_unit,100,1000)
- open(pro_unit,file=dir//pro_file)
- call generate_unit(den_unit,100,1000)
- open(den_unit,file=dir//den_file)
- do while (associated(list))
-! print *,list%r_position,list%get_r_value()
- write(val_unit,fmt,advance='NO')list%r_position
- call write_array(val_unit,list%get_r_value_array(),fmt)
- write(int_unit,fmt,advance='NO')list%r_position
- call write_array(int_unit,list%get_r_integral(),fmt)
- write(err_unit,fmt,advance='NO')list%r_position
- call write_array(err_unit,list%get_error(),fmt)
- write(pro_unit,fmt,advance='NO')list%r_position
- call write_array(pro_unit,list%get_r_propability(),fmt)
- write(den_unit,fmt,advance='NO')list%r_position
- call write_array(den_unit,list%get_r_propability()*list%get_r_value_array(),fmt)
- list=>list%right
- end do
- close(val_unit)
- close(int_unit)
- close(err_unit)
- close(pro_unit)
- close(den_unit)
- contains
- subroutine write_array(unit,array,form)
- integer,intent(in)::unit
- real(kind=double),dimension(:),intent(in)::array
- character(len=*),intent(in)::form
- integer::n
- do n=1,size(array)
- write(unit,form,ADVANCE='NO')array(n)
- flush(unit)
- end do
- write(unit,'("")')
- end subroutine write_array
- end subroutine muli_trapezium_list_gnuplot
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_list\_integrate}
-\begin{Verbatim}
- subroutine muli_trapezium_list_integrate(this,integral_sum,error_sum)
- class(muli_trapezium_list_type),intent(in),target :: this
- real(kind=double),intent(out)::error_sum,integral_sum
- real(kind=double),dimension(:),allocatable::integral
- class(muli_trapezium_node_class),pointer :: node
- allocate(integral(0:this%dim-1))
- call this%get_rightmost(node)
- integral=0D0
- integral_sum=0D0
- error_sum=0D0
- integrate: do while(associated(node))
- node%values(1,r_value_index)=sum(node%values(1:this%dim-1,r_value_index))
- node%values(1,d_value_index)=sum(node%values(1:this%dim-1,d_value_index))
- node%values(1,error_index)=sum(node%values(1:this%dim-1,error_index))
- error_sum=error_sum+node%values(1,error_index)
- call node%set_d_integral(&
- node%get_d_position()*(node%get_d_value()/2D0-node%get_r_value_array()))
- call node%set_r_propability(exp(-integral))
- call node%set_r_integral(integral)
- integral=integral-node%get_d_integral()
- call node%set_d_propability(node%get_r_propability()-exp(-integral))
- call node%get_left(node)
- end do integrate
- integral_sum=integral(1)
- end subroutine muli_trapezium_list_integrate
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_list\_check}
-\begin{Verbatim}
- recursive subroutine muli_trapezium_list_check(this)
- class(muli_trapezium_list_type),intent(in),target :: this
- class(muli_trapezium_node_class),pointer::tn,next
- real(kind=double),parameter::eps=1d-10
- logical::test
- if(associated(this%right))then
- next=>this%right
- test=(this%r_position.le.this%right%get_l_position()+eps)
- print *,"position check: ",test
- if(.not.test)then
- call this%print_parents()
- call next%print_parents()
- end if
- select type (next)
- class is (muli_trapezium_list_type)
- tn=>this
- print *,"structure check: ",associated(tn,next%left)
- print *,"class check: T"
- call next%check()
- class default
- print *,"class check: F"
- end select
- else
- print *,"end of list at ",this%r_position
- end if
- end subroutine muli_trapezium_list_check
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_list\_apply}
-\begin{Verbatim}
- recursive subroutine muli_trapezium_list_apply(this,proc)
- class(muli_trapezium_list_type),intent(inout) :: this
- interface
- subroutine proc(this)
- import muli_trapezium_node_class
- class(muli_trapezium_node_class),intent(inout) :: this
- end subroutine proc
- end interface
- if(associated(this%right))call this%right%apply(proc)
- call proc(this)
- end subroutine muli_trapezium_list_apply
-\end{Verbatim}
-\MethodsFor{muli\_trapezium\_tree\_type}
-\TbpImp{muli\_trapezium\_tree\_write\_to\_marker}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_write_to_marker (this,marker,status)
- class(muli_trapezium_tree_type), intent(in) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- ! local variables
- class(muli_trapezium_list_type),pointer::list
- class(serializable_class),pointer::ser
- call marker%mark_begin("muli_trapezium_tree_type")
- call this%get_left_list(list)
- ser=>list
- call marker%mark_pointer("list",ser)
- call marker%mark_end("muli_trapezium_tree_type")
- end subroutine muli_trapezium_tree_write_to_marker
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_read\_from\_marker}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_read_from_marker (this,marker,status)
- class(muli_trapezium_tree_type), intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- ! local variables
- class(serializable_class),pointer::ser
- call marker%pick_begin("muli_trapezium_tree_type",status=status)
- call marker%pick_pointer("list",ser)
- if(associated(ser))then
- select type(ser)
- class is (muli_trapezium_list_type)
- call ser%to_tree(this)
- class default
- nullify(this%left)
- nullify(this%right)
- nullify(this%down)
- end select
- else
- nullify(this%left)
- nullify(this%right)
- nullify(this%down)
- end if
- call marker%pick_end("muli_trapezium_tree_type",status)
- end subroutine muli_trapezium_tree_read_from_marker
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_print\_to\_unit}
-\begin{Verbatim}
- recursive subroutine muli_trapezium_tree_print_to_unit(this,unit,parents,components,peers)
- class(muli_trapezium_tree_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- class(serializable_class),pointer::ser
- if(parents>0)call muli_trapezium_print_to_unit(this,unit,parents-1,components,peers)
- ser=>this%down
- call serialize_print_peer_pointer(ser,unit,one,zero,one,"DOWN")
- if(associated(this%left))then
- select type(sertmp=>this%left)
- class is(muli_trapezium_list_type)
- ser=>sertmp
- call serialize_print_peer_pointer(ser,unit,parents,components,zero,"LEFT")
- class default
- call serialize_print_peer_pointer(ser,unit,parents,components,peers,"LEFT")
- end select
- else
- write(unit,fmt=*)"Left is not associated."
- end if
- if(associated(this%right))then
- select type(sertmp=>this%right)
- class is(muli_trapezium_list_type)
- ser=>sertmp
- call serialize_print_peer_pointer(ser,unit,parents,components,zero,"RIGHT")
- class default
- call serialize_print_peer_pointer(ser,unit,parents,components,peers,"RIGHT")
- end select
- else
- write(unit,fmt=*)"Right is not associated."
- end if
- end subroutine muli_trapezium_tree_print_to_unit
-\end{Verbatim}
-\TbpImp{muli\_trapezium\_tree\_get\_type}
-\begin{Verbatim}
- pure subroutine muli_trapezium_tree_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="muli_trapezium_tree_type")
- end subroutine muli_trapezium_tree_get_type
-\end{Verbatim}
-\TbpImp{muli\_trapezium\_tree\_verify\_type}
-\begin{Verbatim}
- elemental logical function muli_trapezium_tree_verify_type(type) result(match)
- character(*),intent(in)::type
- match=type=="muli_trapezium_tree_type"
- end function muli_trapezium_tree_verify_type
-\end{Verbatim}
-\OverridesSection{muli\_trapezium\_node\_class}
-\TbpImp{muli\_trapezium\_tree\_nullify}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_nullify(this)
- class(muli_trapezium_tree_type),intent(out) :: this
- call muli_trapezium_node_nullify(this)
- nullify(this%down)
- end subroutine muli_trapezium_tree_nullify
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_get\_left\_list}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_get_left_list(this,list)
- class(muli_trapezium_tree_type),intent(in) :: this
- class(muli_trapezium_list_type),pointer,intent(out) :: list
- class(muli_trapezium_node_class),pointer::node
- call this%get_leftmost(node)
- if(associated(node))then
- select type(node)
- class is (muli_trapezium_list_type)
- list=>node
- class default
- nullify(list)
- end select
- else
- nullify(list)
- end if
- end subroutine muli_trapezium_tree_get_left_list
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_get\_right\_list}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_get_right_list(this,list)
- class(muli_trapezium_tree_type),intent(in) :: this
- class(muli_trapezium_list_type),pointer,intent(out) :: list
- class(muli_trapezium_node_class),pointer::node
- call this%get_rightmost(node)
- if(associated(node))then
- select type(node)
- class is (muli_trapezium_list_type)
- list=>node
- class default
- nullify(list)
- end select
- else
- nullify(list)
- end if
- end subroutine muli_trapezium_tree_get_right_list
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_finalize}
-\begin{Verbatim}
- recursive subroutine muli_trapezium_tree_finalize(this)
- class(muli_trapezium_tree_type),intent(inout) :: this
- if (associated(this%right)) then
- call this%right%untangle()
- call this%right%finalize()
- deallocate(this%right)
- end if
- if (associated(this%left)) then
- call this%left%untangle()
- call this%left%finalize()
- deallocate(this%left)
- end if
- this%dim=0
- end subroutine muli_trapezium_tree_finalize
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_decide\_by\_value}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_decide_by_value(this,value,dim,record,node)
- class(muli_trapezium_tree_type),intent(in) :: this
- real(kind=double),intent(in)::value
- integer,intent(in)::record,dim
- class(muli_trapezium_node_class),pointer,intent(out) :: node
- if(this%down%values(dim,record)>value)then
- node=>this%left
- else
- node=>this%right
- end if
- end subroutine muli_trapezium_tree_decide_by_value
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_decide\_by\_position}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_decide_by_position(this,position,node)
- class(muli_trapezium_tree_type),intent(in) :: this
- real(kind=double),intent(in)::position
- class(muli_trapezium_node_class),pointer,intent(out) :: node
- if(this%down%r_position>position)then
- node=>this%left
- else
- node=>this%right
- end if
- end subroutine muli_trapezium_tree_decide_by_position
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_decide\_decreasing}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_decide_decreasing(this,value,dim,record,node)
- class(muli_trapezium_tree_type),intent(in) :: this
- real(kind=double),intent(in)::value
- integer,intent(in)::record,dim
- class(muli_trapezium_node_class),pointer,intent(out) :: node
- if(this%down%values(dim,record)<=value)then
- node=>this%left
- else
- node=>this%right
- end if
- end subroutine muli_trapezium_tree_decide_decreasing
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_find\_by\_value}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_find_by_value(this,value,dim,record,node)
- class(muli_trapezium_tree_type),intent(in),target :: this
- real(kind=double),intent(in)::value
- integer,intent(in)::record,dim
- class(muli_trapezium_node_class),pointer,intent(out) :: node
- node=>this
- do while(.not.allocated(node%values))
- call node%decide(value,dim,record,node)
- end do
- end subroutine muli_trapezium_tree_find_by_value
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_find\_by\_position}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_find_by_position(this,position,node)
- class(muli_trapezium_tree_type),intent(in),target :: this
- real(kind=double),intent(in)::position
- class(muli_trapezium_node_class),pointer,intent(out) :: node
- node=>this
- do while(.not.allocated(node%values))
- call node%decide(position,node)
- end do
- end subroutine muli_trapezium_tree_find_by_position
-\end{Verbatim}
-\TbpImp{muli\_trapezium\_tree\_find\_decreasing}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_find_decreasing(this,value,dim,node)
- class(muli_trapezium_tree_type),intent(in),target :: this
- real(kind=double),intent(in)::value
- integer,intent(in)::dim
- class(muli_trapezium_node_class),pointer,intent(out) :: node
- node=>this
- do while(.not.allocated(node%values))
- call node%decide_decreasing(value,dim,r_integral_index,node)
- end do
- end subroutine muli_trapezium_tree_find_decreasing
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_approx\_by\_integral}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_approx_by_integral&
- (this,int,dim,in_range,position,value,integral,content)
- class(muli_trapezium_tree_type),intent(in),target :: this
- real(kind=double),intent(in) :: int
- integer,intent(in)::dim
- logical,intent(out) :: in_range
- class(muli_trapezium_node_class),pointer,intent(out),optional :: content
- real(kind=double),intent(out),optional :: position,value,integral
- integer::i
- real(kind=double) :: DINT!,l_prop,r_prop,d_prop
- real(kind=double)::RP,DP,RV,DV,RI!FC = gfortran
- class(muli_trapezium_node_class),pointer :: node
- node=>this
- do while(.not.allocated(node%values))
- call node%decide_decreasing(INT,dim,r_integral_index,node)
- end do
- if( int<=node%values(dim,r_integral_index)-node%values(dim,d_integral_index)&
- &.and.&
- &int>=node%values(dim,r_integral_index))then
- in_range=.true.
- RP=node%r_position!FC = gfortran
- DP=node%d_position!FC = gfortran
- RV=node%values(dim,r_value_index)!FC = gfortran
- DV=node%values(dim,d_value_index)!FC = gfortran
- RI=node%values(dim,r_integral_index)!FC = gfortran
- if (present(position)) then
- DINT=(ri-int)*2D0*dv/dp
- position=rp-(dp/dv)*(rv-sqrt(dint+rv**2))
- end if
- if (present(value)) then
- value=Sqrt(dp*(-2*dv*int + 2*dv*ri + dp*rv**2))/dp
- end if
- if (present(integral)) then
- integral=int
- end if
- if (present(content)) then
- content=>node
- end if
- else
- in_range=.false.
- end if
- end subroutine muli_trapezium_tree_approx_by_integral
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_approx\_by\_propability}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_approx_by_propability&
- (this,prop,dim,in_range,position,value,integral,content)
- class(muli_trapezium_tree_type),intent(in),target :: this
- real(kind=double),intent(in) :: prop
- integer,intent(in)::dim
- logical,intent(out) :: in_range
- class(muli_trapezium_node_class),pointer,intent(out),optional :: content
- real(kind=double),intent(out),optional :: position,value,integral
- integer::i
- real(kind=double) :: INT,DINT,l_prop,r_prop,d_prop
- class(muli_trapezium_node_class),pointer :: node
- if(0D0<prop.and.prop<1D0)then
- node=>this
- INT=-log(prop)
- call muli_trapezium_tree_approx_by_integral&
- (this,int,dim,in_range,position,value,integral,content)
- else
- in_range=.false.
- end if
- end subroutine muli_trapezium_tree_approx_by_propability
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_to\_tree}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_to_tree(this,out_tree)
- class(muli_trapezium_tree_type),intent(in) :: this
- class(muli_trapezium_tree_type),intent(out) :: out_tree
- out_tree%left=>this%left
- out_tree%right=>this%right
- out_tree%down=>this%down
- end subroutine muli_trapezium_tree_to_tree
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_append}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_append(this,right)
- class(muli_trapezium_tree_type),intent(inout),target :: this
- class(muli_trapezium_node_class),intent(inout),target :: right
- print ('("muli_trapezium_tree_append: Not yet implemented.")')
- end subroutine muli_trapezium_tree_append
-\end{Verbatim}
-
-\TbpImp{muli\_trapezium\_tree\_gnuplot}
-\begin{Verbatim}
- subroutine muli_trapezium_tree_gnuplot(this,dir)
- class(muli_trapezium_tree_type),intent(in) :: this
- character(len=*),intent(in)::dir
- class(muli_trapezium_list_type),pointer::list
- call this%get_left_list(list)
- call list%gnuplot(dir)
- end subroutine muli_trapezium_tree_gnuplot
-\end{Verbatim}
-
Index: trunk/src/muli/doc/muli.tex
===================================================================
--- trunk/src/muli/doc/muli.tex (revision 8371)
+++ trunk/src/muli/doc/muli.tex (revision 8372)
@@ -1,1306 +0,0 @@
-\Module{muli}
-\begin{figure}
- \centering{\includegraphics{uml-module-tree-7.mps}}
- \caption{\label{fig:\ThisModule:Types}Klassendiagramm des Moduls \ThisModule}
-\end{figure}
-Dieses Modul dient als Interface für den Interleaved Algorithmus. Es stellt dem Algorithmus Methoden zur Initialisierung und zum Garbage-Collecting, Methoden zur Generierung von $\pperp^{(n+1)}$, und zur Generierung einer vollständigen Wechselwirkung, Methoden zum Austauschen von aktiven Partonen, sowie Methoden zu den Remnant-Strukturfunktionen zur Verfügung.
-
-Alle Parameter des MulI-Algorithmus sowie der komplette aktuelle Zusatand der Remnants, einschließlich der aktiven Shower-Partonen, sind als Komponenten des erweiterten Types \TypeRef{muli\_type} definiert. Der Interleaved-Algorithmus muss also lediglich eine Instanz der Klasse \TypeRef{muli\_type} definieren und deren public Type-Bound-Procedures aufrufen.
-
-\wip{Auf lange Sicht ist es geplant, die Strukturfunktionen in den WHIZARD-Core aufzunehmen. Dann sollte der Core die Funktionalität dieses Moduls weitgehend übernehmen. Zum einen wird dieses Modul dann obsolet, zum anderen müssen die Interfaces des Cores erweitert werden. Der Hauptgrund, warum das noch nicht geschehen ist, ist aber, dass der Core noch nicht Objekt-Orientiert ist. Es kann also keine Instanz von muli\_type an sf\_initialize übergeben werden. Es muss also entweder die Konfiguration dieses Moduls in Form von Modulkomponenten bereitgestellt werden, oder der Core muss lernen, eine Instanzen einer abstrakten PDF-Klasse entgegenzunehmen. Im letzteren Fall muss muli\_type nur diese abstrakte Klasse erweitern.}
-\section{Abhängigkeiten}
-\use{muli\_dsigma}
-\use{muli\_mcint}
-\use{muli\_remnant}
-\section{Parameter}
-Für Diagnose, Testzwecke und Konsistenzprüfungen können die Remnants deaktiviert werden. Wenn auf .false. gesetzt, läuft der Algorithmus trotz Mehrfachwechselwirkungen immer mit den original Proton-PDFs
-\begin{Verbatim}
-logical,parameter::muli_default_modify_pdfs=.true.\MC{muli\_default\_modify\_pdfs}
-\end{Verbatim}
-Da MulI noch nicht in den Core eingebunden ist, hat MulI keinen Zugriff auf die PDF Eigenschaften, so wie sie in den Sindarin-Files eingestellt werden können. Deswegen müssen die Proton-PDFs noch per Hand als Parameter festgelegt werden.
-\begin{Verbatim}
-integer,parameter::muli_default_lhapdf_member=0\MC{muli\_default\_lhapdf\_member}
-character(*),parameter::muli_default_lhapdf_file=&
-"cteq6ll.LHpdf"\MC{muli\_default\_lhapdf\_file}
-\end{Verbatim}
-
-\section{Derived Types}
-\TypeDef{qcd\_2\_2\_type}
-Dieser Datentyp abstrahiert die interne Darstellung einer QCD-$2\rightarrow 2$ Wechselwirkungen und stellt Methoden mit traditionellen Namen zur Verfügung. Da verschiedene Module auf die Eigenschaften der Wechselwirkung zugreifen müssen, aber nur in dem Modul muli alle notwendigen Daten zur Verfügung stehen, ist in dem Modul \ModuleRef{muli\_momentum} eine abstrakte \TypeRef{qcd\_2\_2\_class} definiert, die allen Modulen zur verfügung steht. qcd\_2\_2\_type erweitert diese Klasse und implementiert die vorgeschriebenen Methoden.
-\begin{Verbatim}
-type,\Extends{qcd\_2\_2\_class}::qcd_2_2_type
-\end{Verbatim}
-\paragraph{Komponenten}
-\begin{Verbatim}
-private
-\end{Verbatim}
-Alle gültigen Kombinationen der vier Partonflavor sind in der Modulkomponente\linebreak \CompRef{muli\_interactions}{valid\_processes} durchnummeriert. process\_id gibt diese Nummer wieder und legt damit alle Flavor fest.
-\begin{Verbatim}
-integer::\TC{process\_id}=-1
-\end{Verbatim}
-Alle Kombinationen aus Gluon, Seequark, Valenz-Up-Quark und Valenz-Down-Quark der beiden Partonen im Eingangszustand sind in der Modulkomponente \CompRef{muli\_interactions}{double\_pdf\_kinds} des Moduls \ModuleRef{muli\_interactions} durchnummeriert. integrand\_id gibt diese Nummer wieder und legt damit fest, ob z.B. ein Up-Quark im Eingangszustand ein Seequark oder ein Valenzquark ist. Diese Nummer ist gleichzeitig die Ordnungsnummer des Integrationsstratums $\{\alpha,\beta\}$ für die Generierung der Wechselwirkungsskala in \TbpRef{muli\_type}{generate\_next\_scale}.
-\begin{Verbatim}
-integer::\TC{integrand\_id}=-1
-\end{Verbatim}
-Jedes Parton, dass an einer Wechselwirkung teilnimmt, bekommt eine eindeutige Nummer. Das schließt die Partonen des ISR-Algorithmus mit ein. Diese Nummern sind wichtig, wenn der ISR-Algorithmus ein Teilchen aus der Liste der Teilchen im Eingangszustand (aka aktive Partonen) entfernt, das MulI vorher in diese Liste aufgenommen hat. Über die Parton IDs können diese zugeordnet und in \TbpRef{muli\_type}{replace\_parton} konsistent eliminiert werden. parton\_ids enthält die Nummern der beiden Teilchen im direkten Eingangszustand der MPI Wechselwirkung, also ohne Showerbranchings.
-\begin{Verbatim}
-integer,dimension(2)::\TC{parton\_ids}=[0,0]
-\end{Verbatim}
-Farbflüsse werden intern als Permutation dargestellt, die die Enden von Farblinien auf deren Angfänge abbildet. Eine 2 an dritter Stelle in flow bedeutet, dass eine Farbflusslinie in der zweiten Position beginnt und in der dritten Position endet. Die Positionen 1,2,3,4 entsprechen den Flavorindizes a,b,c,d in \ref{fig:nomen:had}. In \TbpRef{muli\_type}{generate\_flow} werden diese Farbflüsse generiert.
-\begin{Verbatim}
-integer,dimension(4)::\TC{flow}=[0,0,0,0]
-\end{Verbatim}
-momentum\_fractions enthält die dynamischen Impulsvariablen $[\xi_1,\xi_2,\pperp]$, die die Kinematik einer Wechselwirkungen beschreiben, in kartesischen Koordinaten. hyperbolic\_fractions enthält dieselben Impulsvariablen in hyperbolischen Koordinaten $[h_1,h_2,h_3]$. Die Koordinatentransformation ist in \eqref{eq:all:imp:trafo} angegeben.
-\begin{Verbatim}
-real(kind=double),dimension(3)::\TC{momentum\_fractions}=[-1D0,-1D0,-1D0]
-real(kind=double),dimension(3)::\TC{hyperbolic\_fractions}=[-1D0,-1D0,-1D0]
-\end{Verbatim}
-\paragraph{Methoden}
-\begin{Verbatim}
- \OverridesDeclaration{serializable\_class}
- procedure,public::\TbpDec{write\_to\_marker}{qcd\_2\_2\_write\_to\_marker}
- procedure,public::\TbpDec{read\_from\_marker}{qcd\_2\_2\_read\_from\_marker}
- procedure,public::\TbpDec{print\_to\_unit}{qcd\_2\_2\_print\_to\_unit}
- procedure,public,nopass::\TbpDec{get\_type}{qcd\_2\_2\_get\_type}
- \OverridesDeclaration{qcd\_2\_2\_class}
- procedure,public::\TbpDec{get\_process\_id}{qcd\_2\_2\_get\_process\_id}
- procedure,public::\TbpDec{get\_integrand\_id}{qcd\_2\_2\_get\_integrand\_id}
- procedure,public::\TbpDec{get\_diagram\_kind}{qcd\_2\_2\_get\_diagram\_kind}
- procedure,public::\TbpDec{get\_lha\_flavors}{qcd\_2\_2\_get\_lha\_flavors}
- procedure,public::\TbpDec{get\_pdg\_flavors}{qcd\_2\_2\_get\_pdg\_flavors}
- procedure,public::\TbpDec{get\_parton\_id}{qcd\_2\_2\_get\_parton\_id}
- procedure,public::\TbpDec{get\_parton\_kinds}{qcd\_2\_2\_get\_parton\_kinds}
- procedure,public::\TbpDec{get\_pdf\_int\_kinds}{qcd\_2\_2\_get\_pdf\_int\_kinds}
- procedure,public::\TbpDec{get\_momentum\_boost}{qcd\_2\_2\_get\_momentum\_boost}
- procedure,public::\TbpDec{get\_remnant\_momentum\_fractions}{qcd\_2\_2\_get\_remnant\_momentum\_fractions}
- procedure,public::\TbpDec{get\_total\_momentum\_fractions}{qcd\_2\_2\_get\_total\_momentum\_fractions}
- \OriginalDeclaration
- procedure,public::\TbpDec{get\_color\_flow}{qcd\_2\_2\_get\_color\_flow}
- procedure,public::\TbpDec{get\_diagram\_color\_kind}{qcd\_2\_2\_get\_diagram\_color\_kind}
- procedure,public::\TbpDec{get\_io\_kind}{qcd\_2\_2\_get\_io\_kind}
- procedure,public::\TbpDec{get\_hyperbolic\_fractions}{qcd\_2\_2\_get\_hyperbolic\_fractions}
- procedure,public::\TbpDec{get\_color\_correlations}{qcd\_2\_2\_get\_color\_correlations}
- procedure,public::\TbpDecS{qcd\_2\_2\_initialize}
- generic,public::\TbpDec{initialize}{qcd\_2\_2\_initialize}
-\end{Verbatim}
-\TypeDef{muli\_type}
-Der Datentyp muli\_type ist eine Sammlung von allen Daten, die für Generierung von mehrfachen Wechselwirkungen relevant sind. Da Instanzen von muli\_type keine Zeiger enthalten, mit Ausnahme von Zeigen auf Komponenten von sich selbst, und nicht auf dynamische Modulkomponenten zugreifen, können beliebig viele Instanzen von muli\_type erzeugt und parallel verwendet werden. Bloß kann LHAPDF nicht parallel aufgerufen werden.
-
-muli\_type erweitert \TypeRef{qcd\_2\_2\_type}, damit \emph{ist} eine Instanz von muli\_type die aktuelle Wechselwirkung. Die aktuellen Zustände der Remnants sind hingegen Komponenten von muli\_type, sodass andere Varianten von Remnants umgesetzt werden können, ohne diese Modul (entsprechend später den WHIZARD-Core) verändern zu müssen
-
-\wip{Neben den aktuellen Zuständen der Wechselwirkung und der Remnants enthält muli\_type auch einen Importance-Sampler für die Impulsanteile $[\xi_1,\xi_2]$. Dieser ist derzeit nicht auf dem Stand der Dissertation, wo ein gemeinsames Sampling für alle Strati beschrieben wird. Dieses gemeinsame Sampling wäre dann so generisch, dass es nicht mehr eine Komponente von muli\_type sein sollte. Dann könnten mehrere Instancen von muli\_type dasselbe Sampling verwenden. Derzeit ist das Sampling zweifach redundant, nämlich wird für jedes Stratum für jede Instanz von muli\_type ein eigener Sampler allociert. Bei dem aktuellen Stand ist deswegen davon abzuraten, MulI zu parallelisieren.}
-
-
-\begin{Verbatim}
- type,\Extends{qcd\_2\_2\_type}::muli_type
-\end{Verbatim}
-\paragraph{Komponenten}
-\begin{Verbatim}
- private
- \IC{Untere Grenze für die Wechselwirkungsskala}
- real(kind=double)::\TC{GeV2\_scale\_cutoff}
- \IC{Sollen die Strukturfunktionen im Laufe des Algorithmus verändert werden?}
- logical::\TC{modify\_pdfs}=muli_default_modify_pdfs
- \IC{Lag die letzte Wechselwirkungsskala unter GeV2_scale_cutoff?}
- logical::\TC{finished}=.false.
- \IC{Wieviel Zeit haben die einzelnen Teile des Algorithmus benötigt?}
- real(kind=double)::\TC{init\_time}=0D0
- real(kind=double)::\TC{pt\_time}=0D0
- real(kind=double)::\TC{partons\_time}=0D0
- real(kind=double)::\TC{confirm\_time}=0D0
- \IC{Sind die Monte-Carlo-Generatoren bereit zur Generierung von MPI?}
- logical::\TC{initialized}=.false.
- \IC{Wurde eine härteste Wechselwirkung vorgegeben?}
- logical::\TC{initial\_interaction\_given}=.false.
- \IC{Der Mittelwert des hadronischen Wirkungsquerschnitts bei der aktuellen Skala.}
- \IC{Der Monte-Carlo-Generator für [x_1,x_2] verwendet ein vielfaches dieses Werts}
- \IC{als obere Schranke für den Wirkungsquerschnitt.}
- real(kind=double)::\TC{mean}=1D0
- \IC{Die integrierten Wirkungsquerschnitte aller Strati bei der aktuellen Skala.}
- \IC{Der Monte-Carlo-Generator für die nächste Skala verwendet diese Integrale anstelle}
- \IC{der Skala als Startwerte.}
- real(kind=double),dimension(0:16)::\TC{start\_integrals}=&
- [0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0]
- \IC{Der Zufallsgenerator für diese Instanz.}
- type(tao_random_state)::\TC{tao\_rnd}
- \IC{Die Wirkungsquerschnitte und deren Stammfunktionen aller Strati\CompDef{muli\_type}{dsigma}}
- type(\TypeRef{muli\_trapezium\_tree\_type})::\TC{dsigma}
- \IC{Importance-Sampler für alle Strati.\CompDef{muli\_type}{samples}}
- type(\TypeRef{sample\_inclusive\_type})::\TC{samples}
- \IC{Die Remnants der beiden Protonen.}
- type(\TypeRef{pp\_remnant\_type})::\TC{beam}
- \IC{Ein interner Zeiger auf ein Segment der Stammfunktion dsigma, dass die}
- \IC{aktuelle Skala umfasst.}
- class(\TypeRef{muli\_trapezium\_node\_class}),pointer::\TC{node}=>null()
- end type muli_type
-\end{Verbatim}
-\paragraph{Methoden}
-\begin{Verbatim}
- contains
- \OverridesDeclaration{serializable\_class}
- procedure,public::\TbpDec{write\_to\_marker}{muli\_write\_to\_marker}
- procedure,public::\TbpDec{read\_from\_marker}{muli\_read\_from\_marker}
- procedure,public::\TbpDec{print\_to\_unit}{muli\_print\_to\_unit}
- procedure,public,nopass::\TbpDec{get\_type}{muli\_get\_type}
- \OriginalDeclaration
- ! init / final
- procedure,public::muli_initialize
- procedure,public::\TbpDec{apply\_initial\_interaction}{muli\_apply\_initial\_interaction}
- procedure,public::\TbpDec{finalize}{muli\_finalize}
- procedure,public::\TbpDec{stop\_trainer}{muli\_stop\_trainer}
- procedure,public::\TbpDec{reset\_timer}{muli\_reset\_timer}
- procedure,public::\TbpDec{restart}{muli\_restart}
- generic,public:: \TbpDec{initialize}{muli\_initialize}
- ! status query
- procedure,public::\TbpDec{is\_initialized}{muli\_is\_initialized}
- procedure,public::\TbpDec{is\_initial\_interaction\_given}{muli\_is\_initial\_interaction\_given}
- procedure,public::\TbpDec{is\_finished}{muli\_is\_finished}
- ! user interface
- procedure,public::\TbpDec{enable\_remnant\_pdf}{muli\_enable\_remnant\_pdf}
- procedure,public::\TbpDec{disable\_remnant\_pdf}{muli\_disable\_remnant\_pdf}
- procedure,public::\TbpDec{generate\_gev2\_pt2}{muli\_generate\_gev2\_pt2}
- procedure,public::\TbpDec{generate\_partons}{muli\_generate\_partons}
- procedure,public::\TbpDec{generate\_flow}{muli\_generate\_flow}
- procedure,public::\TbpDec{replace\_parton}{muli\_replace\_parton}
- procedure,public::\TbpDec{get\_parton\_pdf}{muli\_get\_parton\_pdf}
- procedure,public::\TbpDec{get\_momentum\_pdf}{muli\_get\_momentum\_pdf}
- procedure,public::\TbpDec{print\_timer}{muli\_print\_timer}
- procedure,public::\TbpDec{generate\_samples}{muli\_generate\_samples}
- ! beam test
- procedure,public::\TbpDec{fake\_interaction}{muli\_fake\_interaction}
- ! private procedures
- procedure,private::\TbpDec{generate\_next\_scale}{muli\_generate\_next\_scale}
- procedure,private::\TbpDec{confirm}{muli\_confirm}
- \end{Verbatim}
-\Methods
-\MethodsFor{qcd\_2\_2\_type}
-\OverridesSection{serializable\_class}
-\TbpImp{qcd\_2\_2\_write\_to\_marker}
-\begin{Verbatim}
-subroutine qcd_2_2_write_to_marker(this,marker,status)
- class(qcd_2_2_type),intent(in)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("qcd_2_2_type")
- call transversal_momentum_write_to_marker(this,marker,status)
- call marker%mark("process_id",this%process_id)
- call marker%mark("integrand_id",this%integrand_id)
- call marker%mark("momentum_fractions",this%momentum_fractions)
- call marker%mark("hyperbolic_fractions",this%hyperbolic_fractions)
- call marker%mark_end("qcd_2_2_type")
- end subroutine qcd_2_2_write_to_marker
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_read\_from\_marker}
-\begin{Verbatim}
- subroutine qcd_2_2_read_from_marker(this,marker,status)
- class(qcd_2_2_type),intent(out)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%pick_begin("qcd_2_2_type",status=status)
- call transversal_momentum_read_from_marker(this,marker,status)
- call marker%pick("process_id",this%process_id,status)
- call marker%pick("integrand_id",this%integrand_id,status)
- call marker%pick("momentum_fractions",this%momentum_fractions,status)
- call marker%pick("hyperbolic_fractions",this%hyperbolic_fractions,status)
- call marker%pick_end("qcd_2_2_type",status=status)
- end subroutine qcd_2_2_read_from_marker
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_print\_to\_unit}
-\begin{Verbatim}
- subroutine qcd_2_2_print_to_unit(this,unit,parents,components,peers)
- class(qcd_2_2_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- integer,dimension(2,4)::flow
- integer::index
- if(parents>zero)&
- call transversal_momentum_print_to_unit(this,unit,parents-1,components,peers)
- write(unit,'("Components of qcd_2_2_type:")')
- write(unit,'("Process id is: ",I3)')this%get_process_id()
- write(unit,'("Integrand id is: ",I3)')this%get_integrand_id()
- if(this%get_integrand_id()>0)then
- write(unit,'("LHA Flavors are: ",4(I3))')this%get_lha_flavors()
- write(unit,'("PDG Flavors are: ",4(I3))')this%get_pdg_flavors()
- write(unit,'("Parton kinds are: ",2(I3))')this%get_parton_kinds()
- write(unit,'("PDF int kinds are: ",2(I3))')this%get_pdf_int_kinds()
- write(unit,'("Diagram kind is: ",2(I3))')this%get_diagram_kind()
- end if
- call this%get_color_correlations(1,index,flow)
- write(unit,'("Color Permutations: ",4(I0))')this%flow
- write(unit,'("Color Connections:")')
- write(unit,'("(",I0,",",I0,")+(",I0,",",I0,")->(",I0,",",I0,")+(",I0,",",I0,")")')flow
- write(unit,'("Evolution scale is: ",E14.7)')this%get_unit2_scale()
- write(unit,'("Momentum boost is: ",E14.7)')this%get_momentum_boost()
- write(unit,'("Remant momentum fractions are: ",2(E14.7))')&
- this%get_remnant_momentum_fractions()
- write(unit,'("Total momentum fractions are: ",2(E14.7))')&
- this%get_total_momentum_fractions()
- end subroutine qcd_2_2_print_to_unit
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_type}
-\begin{Verbatim}
- pure subroutine qcd_2_2_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="qcd_2_2_type")
- end subroutine qcd_2_2_get_type
-\end{Verbatim}
-
-\OverridesSection{qcd\_2\_2\_class}
-\TbpImp{qcd\_2\_2\_get\_process\_id}
-\begin{Verbatim}
- elemental function qcd_2_2_get_process_id(this) result(id)
- class(qcd_2_2_type),intent(in)::this
- integer::id
- id=this%process_id
- end function qcd_2_2_get_process_id
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_integrand\_id}
-\begin{Verbatim}
- elemental function qcd_2_2_get_integrand_id(this) result(id)
- class(qcd_2_2_type),intent(in)::this
- integer::id
- id=this%integrand_id
- end function qcd_2_2_get_integrand_id
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_lha\_flavors}
-\begin{Verbatim}
- pure function qcd_2_2_get_lha_flavors(this) result(lha)
- class(qcd_2_2_type),intent(in)::this
- integer,dimension(4)::lha
- lha=valid_processes(1:4,this%process_id)
- end function qcd_2_2_get_lha_flavors
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_pdg\_flavors}
-\begin{Verbatim}
- pure function qcd_2_2_get_pdg_flavors(this) result(pdg)
- class(qcd_2_2_type),intent(in)::this
- integer,dimension(4)::pdg
- pdg=this%get_lha_flavors()
- where(pdg==0) pdg=21
- end function qcd_2_2_get_pdg_flavors
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_pdf\_int\_kinds}
-\begin{Verbatim}
- pure function qcd_2_2_get_pdf_int_kinds(this) result(kinds)
- class(qcd_2_2_type),intent(in)::this
- integer,dimension(2)::kinds
- kinds=double_pdf_kinds(1:2,this%integrand_id)
- end function qcd_2_2_get_pdf_int_kinds
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_parton\_id}
-\begin{Verbatim}
- elemental function qcd_2_2_get_parton_id(this,n) result(id)
- class(qcd_2_2_type),intent(in)::this
- integer,intent(in)::n
- integer::id
- id=this%parton_ids(n)
- end function qcd_2_2_get_parton_id
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_parton\_kinds}
-\begin{Verbatim}
- pure function qcd_2_2_get_parton_kinds(this) result(kinds)
- class(qcd_2_2_type),intent(in)::this
- integer,dimension(2)::kinds
- kinds=this%get_pdf_int_kinds()
- kinds(1)=parton_kind_of_int_kind(kinds(1))
- kinds(2)=parton_kind_of_int_kind(kinds(2))
- end function qcd_2_2_get_parton_kinds
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_io\_kind}
-\begin{Verbatim}
- elemental function qcd_2_2_get_io_kind(this) result(kind)
- class(qcd_2_2_type),intent(in)::this
- integer::kind
- kind=valid_processes(5,this%process_id)
- end function qcd_2_2_get_io_kind
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_diagram\_kind}
-\begin{Verbatim}
- elemental function qcd_2_2_get_diagram_kind(this) result(kind)
- class(qcd_2_2_type),intent(in)::this
- integer::kind
- kind=valid_processes(6,this%process_id)
- end function qcd_2_2_get_diagram_kind
-\end{Verbatim}
-\OriginalSection{qcd\_2\_2\_type}
-\TbpImp{qcd\_2\_2\_get\_diagram\_color\_kind}
-
-\wa{This is one more hack. Before merging into the interleaved algorithm, muli has only cared for
- summed cross sections, but not for specific color flows. So two different diagrams with equal
- cross sections were summed up to diagram kind 1.
-
- Now muli also generates color flows, so we must devide diagram kind 1 into diagram color kind 0
- and diagram color kind 1.
-}
-
-\begin{Verbatim}
- elemental function qcd_2_2_get_diagram_color_kind(this) result(kind)
- class(qcd_2_2_type),intent(in)::this
- integer::kind
- kind=valid_processes(6,this%process_id)
- if(kind==1)then
- if(product(valid_processes(1:2,this%process_id))>0)then
- kind=0
- end if
- end if
- end function qcd_2_2_get_diagram_color_kind
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_momentum\_boost}
-\wip{Noch nicht implementiert}
-
-\begin{Verbatim}
- elemental function qcd_2_2_get_momentum_boost(this) result(boost)
- class(qcd_2_2_type),intent(in)::this
- real(kind=double)::boost
- boost=-1D0
- end function qcd_2_2_get_momentum_boost
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_hyperbolic\_fractions}
-\begin{Verbatim}
- pure function qcd_2_2_get_hyperbolic_fractions(this) result(fractions)
- class(qcd_2_2_type),intent(in)::this
- real(kind=double),dimension(3)::fractions
- fractions=this%hyperbolic_fractions
- end function qcd_2_2_get_hyperbolic_fractions
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_remnant\_momentum\_fractions}
-\begin{Verbatim}
- pure function qcd_2_2_get_remnant_momentum_fractions(this) result(fractions)
- class(qcd_2_2_type),intent(in)::this
- real(kind=double),dimension(2)::fractions
- fractions=this%momentum_fractions(1:2)
- end function qcd_2_2_get_remnant_momentum_fractions
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_total\_momentum\_fractions}
-\wip{Noch nicht implementiert}
-
-\begin{Verbatim}
- pure function qcd_2_2_get_total_momentum_fractions(this) result(fractions)
- class(qcd_2_2_type),intent(in)::this
- real(kind=double),dimension(2)::fractions
- fractions=[-1D0,-1D0]
- end function qcd_2_2_get_total_momentum_fractions
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_color\_flow}
-\begin{Verbatim}
- pure function qcd_2_2_get_color_flow(this) result(flow)
- class(qcd_2_2_type),intent(in)::this
- integer,dimension(4)::flow
- flow=this%flow
- end function qcd_2_2_get_color_flow
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_get\_color\_correlations}
-Diese Methode generiert Farbflussdiagramme aus der internen Darstellung mittels Permutationen, wie sie in \TbpRef{muli\_type}{generate\_flow} generiert werden. Der Interleaved Algorithmus numeriert alle Farbflüsse, deswegen nehmen wir die aktuelle Anzahl von Farbflüssen mit start\_index entgegen und liefern die neue Anzahl mit final\_index zurück. Die Ordnungszahlen der neu generierten Farblinien laufen dann von start\_index+1 bis einschließlich final\_index.
-
-flow liefert schießlich das Farbflussdiagramm selbst zurück. Das Format von flow sieht vor, dass der zweite Index die Position des Partons im Diagramm wie in \ref{fig:nomen:had} mit $[1,2,3,4]\rightarrow [a,b,c,d]$ beschreibt. Die beiden Stellen flow[:,a] beinhalten die Ordnungszahlen für eine eventuelle Farblinie bzw. eine eventuelle Antifarblinie oder 0 für keine Farblinie.
-\begin{center}
-\parbox{4cm}{\includegraphics{diagrams-3.mps}}\parbox{3cm}{$=\ [4,0,1,2]\ \rightarrow$}\parbox{2cm}{$\left[\begin{matrix}[3,4]\\ [5,0]\\ [3,0]\\ [5,4]\end{matrix}\right]$}
-\end{center}
-Die eingekreisten Zahlen sind die Positionen in flow, die nicht eingekreisten Zahlen sind die Inizes der Farblinien.
-\begin{Verbatim}
- subroutine qcd_2_2_get_color_correlations(this,start_index,final_index,flow)
- class(qcd_2_2_type),intent(in)::this
- integer,intent(in)::start_index
- integer,intent(out)::final_index
- integer,dimension(2,4),intent(out)::flow
- integer::pos,f_end,f_beginning
- final_index=start_index
- \IC{we set all flows to zero. zero means no connection.}
- flow=reshape([0,0,0,0,0,0,0,0],[2,4])
- \IC{look at all four possible ends of color lines.}
- do f_end=1,4
- \IC{the beginning of this potential line is stored in flow. zero means no line.}
- f_beginning=this%flow(f_end)
- \IC{is there a line beginning at f\_beginning and ending at f\_end?}
- if(f_beginning>0)then
- \IC{yes it is. we get a new number for this new line}
- final_index=final_index+1
- \IC{is this line beginning in the initial state?}
- if(f_beginning<3)then
- \IC{yes it is. lets connect the color entry of f\_begin.}
- flow(1,f_beginning)=final_index
- else
- \IC{no, it's the final state. lets connect the anticolor entry of f\_begin.}
- flow(2,f_beginning)=final_index
- end if
- \IC{is this line ending in the final state?}
- if(f_end>2)then
- \IC{yes it is. lets connect the color entry of f\_end.}
- flow(1,f_end)=final_index
- else
- \IC{no, it's the initial state. lets connect the anticolor entry of f\_end.}
- flow(2,f_end)=final_index
- end if
- end if
- end do
- end subroutine qcd_2_2_get_color_correlations
-\end{Verbatim}
-
-\TbpImp{qcd\_2\_2\_initialize}
-Gewöhnliche Initialisierung aller Komponenten.
-\begin{Verbatim}
- subroutine qcd_2_2_initialize(this,gev2_s,process_id,integrand_id,parton_ids,flow,hyp,cart)
- class(qcd_2_2_type),intent(out)::this
- real(kind=double),intent(in)::gev2_s
- integer,intent(in)::process_id,integrand_id
- integer,dimension(2),intent(in)::parton_ids
- integer,dimension(4),intent(in)::flow
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(3),intent(in),optional::cart
- \IC{Generischer Aufruf von transversal\_momentum\_initialize(this,gev2\_s).}
- call this%initialize(gev2_s)
- this%process_id=process_id
- this%integrand_id=integrand_id
- this%parton_ids=parton_ids
- this%flow=flow
- this%hyperbolic_fractions=hyp
- if(present(cart))then
- this%momentum_fractions=cart
- else
- this%momentum_fractions=h_to_c_param(hyp)
- end if
- end subroutine qcd_2_2_initialize
-\end{Verbatim}
-\subsection{Methoden für muli\_type}
-\OverridesSection{serializable\_class}
-\TbpImp{muli\_write\_to\_marker}
-\begin{Verbatim}
- subroutine muli_write_to_marker(this,marker,status)
- class(muli_type),intent(in) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("muli_type")
- call qcd_2_2_write_to_marker(this,marker,status)
- call marker%mark("modify_pdfs",this%modify_pdfs)
- call marker%mark("initialized",this%initialized)
- call marker%mark("initial_interaction_given",this%initial_interaction_given)
- call marker%mark("finished",this%finished)
- call marker%mark("init_time",this%init_time)
- call marker%mark("pt_time",this%pt_time)
- call marker%mark("partons_time",this%partons_time)
- call marker%mark("confirm_time",this%confirm_time)
- call marker%mark_instance(this%dsigma,"dsigma")
- call marker%mark_instance(this%samples,"samples")
- call marker%mark_instance(this%beam,"beam")
- call marker%mark_end("muli_type")
- end subroutine muli_write_to_marker
-\end{Verbatim}
-
-\TbpImp{muli\_read\_from\_marker}
-\begin{Verbatim}
- subroutine muli_read_from_marker(this,marker,status)
- class(muli_type),intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%pick_begin("muli_type",status=status)
- call qcd_2_2_read_from_marker(this,marker,status)
- call marker%pick("modify_pdfs",this%modify_pdfs,status)
- call marker%pick("initialized",this%initialized,status)
- call marker%pick("initial_interaction_given",this%initial_interaction_given,status)
- call marker%pick("finished",this%finished,status)
- call marker%pick("init_time",this%init_time,status)
- call marker%pick("pt_time",this%pt_time,status)
- call marker%pick("partons_time",this%partons_time,status)
- call marker%pick("confirm_time",this%confirm_time,status)
- call marker%pick_instance("dsigma",this%dsigma,status=status)
- call marker%pick_instance("samples",this%samples,status=status)
- call marker%pick_instance("beam",this%beam,status=status)
- call marker%pick_end("muli_type",status)
- end subroutine muli_read_from_marker
-\end{Verbatim}
-
-\TbpImp{muli\_print\_to\_unit}
-\begin{Verbatim}
- subroutine muli_print_to_unit(this,unit,parents,components,peers)
- class(muli_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- if(parents>0)call qcd_2_2_print_to_unit(this,unit,parents-1,components,peers)
- write(unit,fmt="(a)")"Components of muli_type :"
- write(unit,'("Model Parameters:")')
- write(unit,'("GeV2_scale_cutoff : ",E20.10)')this%GeV2_scale_cutoff
- write(unit,'("Modify PDF : ",L1)')this%modify_pdfs
- write(unit,'("PT Chain Status:")')
- write(unit,'("Initialized : ",L1)')this%initialized
- write(unit,'("initial_interaction_given: ",L1)')this%initial_interaction_given
- write(unit,'("Finished : ",L1)')this%finished
- write(unit,'("Exceeded : ",L1)')this%exceeded
- write(unit,'("Generator Internals:")')
- write(unit,'("Mean Value : ",E20.10)')this%mean
- if(components>zero)then
- write(unit,'("Start Integrals : ",16(E20.10))')this%start_integrals(1:16)
- write(unit,'("dsigma Component:")')
- call this%dsigma%print_to_unit(unit,parents,components-1,peers)
- write(unit,'("samples Component:")')
- call this%samples%print_to_unit(unit,parents,components-1,peers)
- write(unit,'("beam Component:")')
- call this%beam%print_to_unit(unit,parents,components-1,peers)
- else
- write(unit,'("Skipping Derived-Type Components.")')
- end if
- end subroutine muli_print_to_unit
-\end{Verbatim}
-
-\TbpImp{muli\_get\_type}
-\begin{Verbatim}
- pure subroutine muli_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="muli_type")
- end subroutine muli_get_type
-\end{Verbatim}
-
-\OriginalSection{muli\_type}
-\TbpImp{muli\_apply\_initial\_interaction}
-MulI kann die härteste Wechselwirkung selbst generieren oder eine bereits generiete Wechselwirkung auf die Remnants übertragen. Mit dieser Methode wird eine extern (üblicherweise durch WHIZARD) generierte Wechselwirkung übertragen.
-
-Vor jedem Aufruf dieser Methode muss *this* durch muli\_initialize initialisiert werden. Es sollten zwischen der Initialisierung und diesem Aufruf keine Wechselwirkungen generiert werden.
-
-\begin{tabular}{rl}
- gev2\_s&invariante Masse des hadronischen Systems vor der Wechselwirkung in GeV$^2$\\
- x1&longitudinaler Impulsanteil des ersten Partons\\
- x2&longitudinaler Impulsanteil des zweiten Partons\\
- pdg\_f1&Flavor des ersten Partons im PDG-Schema\\
- pdg\_f2&Flavor des zweiten Partons im PDG-Schema\\
- n1&Ordnungszahl des ersten Partons\\
- n2&Ordnungszahl des zweiten Partons
-\end{tabular}
-\begin{Verbatim}
- subroutine muli_apply_initial_interaction(this,&
- gev2_s,&
- x1,&
- x2,&
- pdg_f1,&
- pdg_f2,&
- n1,&
- n2)
- class(muli_type),intent(inout)::this
- real(kind=double),intent(in)::Gev2_s,x1,x2
- integer,intent(in)::pdg_f1,pdg_f2,n1,n2
- real(kind=double)::rnd1,rnd2,time
- if(this%initialized)then
- \IC{Timer Start für Benchmarkzwecke.}
- call cpu_time(time)
- this%init_time=this%init_time-time
- \IC{Einige Informationen für Debuggingzwecke.}
- print *,"muli_apply_initial_interaction:"
- print *,"gev2_s=",gev2_s
- print *,"x1=",x1
- print *,"x2=",x2
- print *,"pdg_f1=",pdg_f1
- print *,"pdg_f2=",pdg_f2
- print *,"n1=",n1
- print *,"n2=",n2
-\IC{Aufgrund eines Bugs in gfortran 4.6 konnte ich die tao\_state variable nicht an}
-\IC{andere Module weitergeben und habe stattdessen vorgenerierte Zufallszahlen weitergegeben.}
- call tao_random_number(this%tao_rnd,rnd1)
- call tao_random_number(this%tao_rnd,rnd2)
- \IC{Timer Stop für Benchmarkzwecke.}
- call cpu_time(time)
- this%init_time=this%init_time+time
- \IC{Die nächste Zeile ist der eigentliche Aufruf für das Anpassen der Remnants.}
- \IC{Alles andere in dieser Methode ist Wrapper-Overhead.}
-\end{Verbatim}
-\hack{Muli hat $\pperp$ als Ordnungsparameter, WHIZARD generiert diese Valiable aber nicht. $\pperp$ lässt sich auch nicht eindeutig aus den generierten Variablen ermitteln. Es ließe sich bestenfalls eine Verteilung von $\pperp$ in Abhängigkeit der bekannten Variablen angeben. Hier verwenden wir einen einfacheren Weg und setzen die Obere Schranke $\pperp\leq \hat{s}/4=s x_1 x_2 /4$ für $\pperp$ ein.}
-
-\begin{Verbatim}
- call this%beam%apply_initial_interaction(sqrt(gev2_s),x1,x2,pdg_f1,pdg_f2,n1,n2,&
- sqrt(gev2_s)*x1*x2/2D0,&
- rnd1,rnd2)
- this%initial_interaction_given=.true.
- \IC{Das Program wir sofort beendet, wenn diese Methode uninitialisiert aufgerufen}
- \IC{wird. Das kann kein Bug sein, sondern muss eine falsche Verwendung dieser}
- \IC{Schnittstelle sein.}
- else
- print *,"muli_apply_initial_interaction: call muli_initialize first. STOP"
- STOP
- end if
- end subroutine muli_apply_initial_interaction
-\end{Verbatim}
-
-\TbpImp{muli\_initialize}
-Diese Methode initialisiert eine Instanz vom Typ muli\_type.
-
-\begin{tabular}{rl}
- GeV2\_scale\_cutoff&Skala in GeV$^2$, bei der der Algorithmus beendet wird.\\
- GeV2\_s&invariante Masse des hadronischen Systems in GeV$^2$\\
- muli\_dir&vollständiger Unix-Pfad zu dem Verzeichnis, in dem MulI-Daten liegen.\\
- random\_seed&
-\end{tabular}
-
-\mip{Diese Methode sollte für jede Instanz nur einmal aufgerufen werden. Der Hauptzweck ist, den Monte-Carlo-Generator zu initialisieren, nicht etwa die Remnants zu initialisieren. Da hierfür einige Zeiger allociert werden. ist es ratsam, die Instanz mit muli\_finalize aufzuräumen, wenn man sie nicht mehr benötigt.}
-\begin{Verbatim}
- subroutine muli_initialize(this,&
- GeV2_scale_cutoff,&
- gev2_s,&
- muli_dir,&
- random_seed)
- class(muli_type),intent(out)::this
- real(kind=double),intent(in)::gev2_s,GeV2_scale_cutoff
- character(*),intent(in)::muli_dir
- integer,intent(in),optional::random_seed
- real(kind=double)::time
- logical::exist
- type(muli_dsigma_type)::dsigma_aq
- character(3)::lhapdf_member_c
- \IC{Timer Start für Benchmarkzwecke.}
- call cpu_time(time)
- this%init_time=this%init_time-time
- \IC{Einige Informationen für Debuggingzwecke.}
- print *,"muli_initialize: The MULI modules are still not fully populated, so MULI might &
- &generate some dummy values instead of real Monte Carlo generated interactions."
- print *,"Given Parameters:"
- print *,"GeV2_scale_cutoff=",GeV2_scale_cutoff
- print *,"muli_dir=",muli_dir
- print *,"lhapdf_dir=",""
- print *,"lhapdf_file=",muli_default_lhapdf_file
- print *,"lhapdf_member=",muli_default_lhapdf_member
- print *,""
- \IC{\(\pperp\) wird auf die invariante Masse normiert.}
- call transversal_momentum_initialize(this,gev2_s)
- \IC{Die Remnants werden initialisiert.}
- call this%beam%initialize(&
- muli_dir,&
- lhapdf_dir="",&
- lhapdf_file=muli_default_lhapdf_file,&
- lhapdf_member=muli_default_lhapdf_member)
- this%GeV2_scale_cutoff=GeV2_scale_cutoff
- if(present(random_seed))then
- call tao_random_create(this%tao_rnd,random_seed)
- else
- call tao_random_create(this%tao_rnd,1)
- end if
-\IC{Wir durchsuchen muli\_dir nach vorgenerierten hadronischen Wirkungsquerschnitten.}
-\IC{Dafür wird eine Zeichenkette generiert, die den Namen der LHAPDF-Datei enthält.}
-\IC{Zusätzlich wird aus der lhapdf_member Variable eine Zeichenkette lhapdf_member_c}
-\IC{generiert, denn in jeder xml-Datei können mehrere Wirkungsquerschnitte für}
-\IC{verschiedene lhapdf_member liegen.}
-\end{Verbatim}
-\wip{Ich habe noch nie mehrere Member in einer Datei verwendet. Höchstwahrscheinlich funktioniert es dann auch nicht.}
-
-\begin{Verbatim}
- print *,"looking for previously generated root function..."
- call integer_with_leading_zeros(muli_default_lhapdf_member,3,lhapdf_member_c)
- inquire(file=muli_dir//"/dsigma_"//muli_default_lhapdf_file//".xml",exist=exist)
- if(exist)then
-\IC{Wir haben eine xml Datei zu der richtigen LHAPDF-Datei gefunden. Jetzt}
-\IC{deserialisieren wir die Wirkungsquerschnitte zu dem gewünschten lhapdf_member.}
- print *,"found. Starting deserialization..."
- call this%dsigma%deserialize(&
- name="dsigma_"//muli_default_lhapdf_file//"_"//lhapdf_member_c,&
- file=muli_dir//"/dsigma_"//muli_default_lhapdf_file//".xml")
- print *,"done. Starting generation of plots..."
-\IC{Einige Plots für Debuggingzwecke.}
- call this%dsigma%gnuplot(muli_dir)
- print *,"done."
- else
-\IC{Es wurden keine passenden hadronischen Wirkungsquerschnitte gefunden. Es werden}
-\IC{welche generiert und in muli_dir geschrieben. dsigma_aq ist nur für die Generierung}
-\IC{der Wirkungsquerschnitte relevant, aber nicht für die Generierung der Ereignisse.}
-\IC{dsigma_aq wird nur zu Debugging-Zwecken in muli_dir geschrieben. Die Serialisierung}
-\IC{von dsigma_aq kann also jederzeit gefahrlos herausgenommen werden.}
- print *,"No root function found. Starting generation of root function..."
- call dsigma_aq%generate(GeV2_scale_cutoff,gev2_s,this%dsigma)
- print *,"done. Starting serialization of root function..."
- call this%dsigma%serialize(&
- name="dsigma_"//muli_default_lhapdf_file//"_"//lhapdf_member_c,&
- file=muli_dir//"/dsigma_"//muli_default_lhapdf_file//".xml")
- print *,"done. Starting serialization of generator..."
- call dsigma_aq%serialize(&
- name="dsigma_aq_"//muli_default_lhapdf_file//"_"//lhapdf_member_c,&
- file=muli_dir//"/dsigma_aq_"//muli_default_lhapdf_file//".xml")
- print *,"done. Starting generation of plots..."
- call this%dsigma%gnuplot(muli_dir)
- print *,"done."
- end if
-\IC{Es wird noch nach Daten für das Importance-Sampling gesucht. Ohne diese kann MulI}
-\IC{in seltenen Fällen unendlich langsam werden, wörtlich!}
- print *,""
- print *,"looking for previously generated samples..."
- inquire(file=muli_dir//"/samples.xml",exist=exist)
- if(exist)then
- print *,"found. Starting deserialization..."
- call this%samples%deserialize("samples",muli_dir//"/samples.xml")
- else
- print *,"No samples found. Starting with default initialization."
- call this%samples%initialize(4,int_sizes_all,int_all,1D-2)
- end if
- \IC{Jetzt wird MulI startklar gemacht.}
- call this%restart()
- this%initialized=.true.
- \IC{Timer Stopp für Benchmarkzwecke.}
- call cpu_time(time)
- this%init_time=this%init_time+time
- end subroutine muli_initialize
-\end{Verbatim}
-
-\TbpImp{muli\_finalize}
-\begin{Verbatim}
- subroutine muli_finalize(this)
- class(muli_type),intent(inout)::this
- print *,"muli_finalize"
- nullify(this%node)
- call this%dsigma%finalize()
- call this%samples%finalize()
- call this%beam%finalize()
- end subroutine muli_finalize
-\end{Verbatim}
-
-\TbpImp{muli\_stop\_trainer}
-Trainer ist ein Bertiebsmodus von MulI, in dem das Importance-Sampling in jedem Schritt verfeinert wird. Das Sampling ist darauf optimiert, dass es schnell (also mit wenigen Ereignissen) den MCG beschleunigt, aber nicht darauf optimiert, bei vielen Daten den MCG perfekt zu beschleunigen. Deshalb konvergiert die Geschwindigkeit des MCG gegen eine Grenze und der Trainer-Modus kann abgestellt werden.
-
-\wip{Das hat in der NAG Variante von MulI bereits funktioniert, allerdings musste ich für die gcc-Kompatiblität so tief in den Sampler eingreifen, dass ich ihn komplett neu geschrieben habe. Den Nicht-Trainer-Modus habe ich in der gcc-Version noch nicht umgesetzt, entsprechend ist diese Methode nur ein Dummy für ein nicht-vorhandenes Feature.}
-
-\begin{Verbatim}
- subroutine muli_stop_trainer(this)
- class(muli_type),intent(inout)::this
- print *,"muli_stop_trainer: DUMMY!"
- end subroutine muli_stop_trainer
-\end{Verbatim}
-
-\TbpImp{muli\_reset\_timer}
-\begin{Verbatim}
- subroutine muli_reset_timer(this)
- class(muli_type),intent(inout)::this
- this%init_time=0D0
- this%pt_time=0D0
- this%partons_time=0D0
- this%confirm_time=0D0
- end subroutine muli_reset_timer
-\end{Verbatim}
-
-\TbpImp{muli\_restart}
-Wenn mehrere Ereignisse (Ein Ereignis ist eine Hadron-Hadron-Streuung inklusive ISR und MPI) in einem Programmaufruf generiert werden sollen, dann ist diese Methode und eventuell\linebreak muli\_apply\_initial\_interaction vor jedem neuen Ereignis aufzurufen, aber nicht muli\_initialize.
-\begin{Verbatim}
- subroutine muli_restart(this)
- class(muli_type),intent(inout)::this
-\IC{this%node wird auf das letzte Blatt aus der Binärbaumdarstellung für die hadronischen}
-\IC{Wirkungsquerschnitte gesetzt. Es enthält dann die Wirkungsquerschnitte bei der Startskala}
-\IC{für \(\pperp\).}
-call this%dsigma%get_rightmost(this%node)
-\IC{Die Remnants werden zurückgesetzt.}
- call this%beam%reset()
-\end{Verbatim}
-Offensichtlich ist der $\pperp$-Generator jetzt noch nicht fertig, es können also weitere Werte für $\pperp$ generiert werden. Alle anderen Komponenten werden auf ungültige Werte gesetzt, damit das Programm tendentiell eher abstürtzt als mit willkürlichen Zahlen zu rechnen, falls etwas schiefgeht, wie z.B. eine Nachfrage nach der aktuellen Wechselwirkung, obwohl noch keine generiert wurde. start\_integrals ist widerum eine gültige Initialisierung, denn die Integrale von der aktuellen (= der maximalen) Skala bis zur maximalen Skala sind offensichtlich gleich Null.
-\begin{Verbatim}
- this%finished=.false.
- this%process_id=-1
- this%integrand_id=-1
- this%momentum_fractions=[-1D0,-1D0,1D0]
- this%hyperbolic_fractions=[-1D0,-1D0,1D0]
- this%start_integrals=&
- [0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0]
- end subroutine muli_restart
-\end{Verbatim}
-
-\TbpImp{muli\_is\_initialized}
-\begin{Verbatim}
- elemental function muli_is_initialized(this) result(res)
- logical::res
- class(muli_type),intent(in) :: this
- res=this%initialized
- end function muli_is_initialized
-\end{Verbatim}
-
-\TbpImp{muli\_is\_initial\_interaction\_given}
-\begin{Verbatim}
- elemental function muli_is_initial_interaction_given(this) result(res)
- logical::res
- class(muli_type),intent(in) :: this
- res=this%initial_interaction_given
- end function muli_is_initial_interaction_given
-\end{Verbatim}
-
-\TbpImp{muli\_is\_finished}
-\begin{Verbatim}
- elemental function muli_is_finished(this) result(res)
- logical::res
- class(muli_type),intent(in) :: this
- res=this%finished
- end function muli_is_finished
-\end{Verbatim}
-
-\TbpImp{muli\_enable\_remnant\_pdf}
-Nur für Debugging-Zwecke
-\begin{Verbatim}
- subroutine muli_enable_remnant_pdf(this)
- class(muli_type),intent(inout)::this
- this%modify_pdfs=.true.
- end subroutine muli_enable_remnant_pdf
-\end{Verbatim}
-
-\TbpImp{muli\_disable\_remnant\_pdf}
-Nur für Debugging-Zwecke
-\begin{Verbatim}
- subroutine muli_disable_remnant_pdf(this)
- class(muli_type),intent(inout)::this
- this%modify_pdfs=.false.
- end subroutine muli_disable_remnant_pdf
-\end{Verbatim}
-
-\TbpImp{muli\_generate\_gev2\_pt2}
-Wrapper für die Generierung der nächsten Skala $\pperp$, die eigentliche Arbeit wird in \TbpRef{muli\_type}{generate\_next\_scale} gemacht. Diese Wrapper-Methode nimmt eine beliebige Start-Skala für $\pperp$ entgegen, liefert einen Kandidaten für $\pperp$ zurück und misst die Zeit, die die CPU dafür benötigt hat.
-\begin{Verbatim}
- subroutine muli_generate_gev2_pt2(this,gev2_start_scale,gev2_new_scale)
- class(muli_type),intent(inout)::this
- real(kind=double),intent(in)::gev2_start_scale
- real(kind=double),intent(out)::gev2_new_scale
- real(kind=double)::time
- \IC{Timer Start für Benchmark-Zwecke}
- call cpu_time(time)
- this%pt_time=this%pt_time-time
- \IC{Die aktuelle Skala wird auf den angegebenen Wert gesetzt}
- call this%set_gev2_scale(gev2_start_scale)
- \IC{Mit \TbpRef{muli\_trapezium\_type}{approx\_integral} wird die Stammfunktionen \(\mathcal{S}_{\alpha\beta}\) an}
- \IC{dieser Skala ausgewertet.}
- this%start_integrals=this%node%approx_integral(this%get_unit_scale())
- \IC{Eine neue Wechselwirkungsskala wird MC-generiert.}
- call this%generate_next_scale()
- \IC{Die neue Skala wird zurückgegeben.}
- gev2_new_scale=this%get_gev2_scale()
- \IC{Timer Stopp}
- call cpu_time(time)
- this%pt_time=this%pt_time+time
- end subroutine muli_generate_gev2_pt2
-\end{Verbatim}
-
-\TbpImp{muli\_generate\_flow}
-Generierung einer internen Darstellung eines Farbflussdiagramms für das aktuelle Feynman\-dia\-gramm.
-\begin{Verbatim}
- subroutine muli_generate_flow(this)
- class(muli_type),intent(inout)::this
- integer::rnd
- integer::m,n
- logical,dimension(3)::t
- integer,dimension(4)::tmp_flow
- \IC{we initialize with zeros. a zero means no line ends here.}
- this%flow=[0,0,0,0]
- \IC{we randomly pick a color flow}
- call tao_random_number(this%tao_rnd,rnd)
- \IC{the third position of muli_flow_stats is the sum of all flow wheights of}
- \IC{stratum diagram_kind. so we generate a random number 0 <= m < sum(weights)}
- m=modulo(rnd,muli_flow_stats(3,this%get_diagram_color_kind()))
- \IC{lets visit all color flows of stratum diagram_kind.}
- \IC{the first and second position of muli_flow_stats}
- \IC{tell us the index of the first and the last valid color flow.}
- do n=muli_flow_stats(1,this%get_diagram_color_kind()),&
- muli_flow_stats(2,this%get_diagram_color_kind())
- \IC{now we remove the weight of flow n from our random number.}
- m=m-muli_flows(0,n)
- \IC{this is how we pick a flow.}
- if(m<0)then
- \IC{the actual flow}
- this%flow=muli_flows(1:4,n)
- exit
- end if
- end do
- \IC{the diagram kind contains a primitive diagram and all diagramms which can}
- \IC{be deriven by}
- \IC{(1) global charge conjugation}
- \IC{(2) permutation of the initial state particles}
- \IC{(3) permutation of the final state particles}
- \IC{lets see, what transformations we have got in our actual interaction.}
- t=muli_get_state_transformations(this%get_diagram_color_kind(),this%get_lha_flavors())
- \IC{now we have to apply these transformations to our flow.}
- \IC{(1) means: swap beginning and end of a line. flow is a permutation that maps}
- \IC{ends to their beginnings, so we apply flow to itself:}
- if(t(1))then
- tmp_flow=this%flow
- this%flow=[0,0,0,0]
- do n=1,4
- if(tmp_flow(n)>0)this%flow(tmp_flow(n))=n
- end do
- end if
- if(t(2))then
- \IC{we swap the particles 1 and 2}
- tmp_flow(1)=this%flow(2)
- tmp_flow(2)=this%flow(1)
- tmp_flow(3:4)=this%flow(3:4)
- \IC{we swap the beginnings assigned to particle 1 and 2}
- where(tmp_flow==1)
- this%flow=2
- elsewhere(tmp_flow==2)
- this%flow=1
- elsewhere
- this%flow=tmp_flow
- end where
- end if
- if(t(3))then
- \IC{we swap the particles 3 and 4}
- tmp_flow(1:2)=this%flow(1:2)
- tmp_flow(3)=this%flow(4)
- tmp_flow(4)=this%flow(3)
- \IC{we swap the beginnings assigned to particle 3 and 4}
- where(tmp_flow==3)
- this%flow=4
- elsewhere(tmp_flow==4)
- this%flow=3
- elsewhere
- this%flow=tmp_flow
- end where
- end if
- end subroutine muli_generate_flow
-\end{Verbatim}
-
-\TbpImp{muli\_generate\_partons}
-Generierung der Partonimpulsanteile $[\xi_1, \xi_2]$ sowie der Partonflavor $[a,b,c,d]$, siehe Abschnitt \ref{sec:all:alg:imp}.
-
-Im Wesentlichen ist dies ein Wrapper für \TbpRef{sample\_inclusive\_type}{mcgenerate\_hit} und \TbpRef{muli\_type}{generate\_flow}
-
-n1, n2: Identifikationsnummern der Partonen. Das shower\_interface kümmert sich um die Durchnummerierung der Partonen, deswegen nimmt muli\_generate\_partons diese Nummern entgegen, statt sie zu erzeugen.
-
-x\_proton\_1,x\_proton\_2: Longitudinale Impulsanteile der Partonen, bezogen auf die ursprünglichen Protonimpulse, nicht auf die aktuellen Remnantimpulse.
-
-pdg\_f1,pdg\_f2,pdg\_f3,pdg\_f4: Die Flavor a,b,c,d der Partonen im PDG-Schema.
-\begin{Verbatim}
- subroutine muli_generate_partons(this,n1,n2,x_proton_1,x_proton_2,pdg_f1,pdg_f2,pdg_f3,pdg_f4)
- class(muli_type),intent(inout)::this
- integer,intent(in)::n1,n2
- real(kind=double),intent(out)::x_proton_1,x_proton_2
- integer,intent(out)::pdg_f1,pdg_f2,pdg_f3,pdg_f4
- integer,dimension(4)::pdg_f
- real(kind=double)::time
- !print *,"muli_generate_partons: n1=",n1," n2=",n2
- this%parton_ids(1)=n1
- this%parton_ids(2)=n2
- call cpu_time(time)
- this%partons_time=this%partons_time-time
-\end{Verbatim}
-Mittels \TbpRef{muli\_trapezium\_type}{approx\_value\_n} wird der Mittelwert $\overline{S}_{\alpha\beta}$ ausgewertet. Anschließend werden mittels \TbpRef{sample\_inclusive\_type}{mcgenerate\_hit} die Nummer \emph{process\_id} des Feymandiagramms und die Impulsanteile \emph{momentum\_fractions} der Partonen generiert.
-\begin{Verbatim}
- this%mean=this%node%approx_value_n(this%get_unit_scale(),this%integrand_id)
- call sample_inclusive_mcgenerate_hit(&
- this%samples,&
- this%get_unit2_scale(),&
- this%mean,&
- this%integrand_id,&
- this%tao_rnd,&
- this%process_id,&
- this%momentum_fractions)
-\end{Verbatim}
-Mittels \TbpRef{muli\_type}{generate\_flow} wird ein Farbflussdiagramm generiert.
-\begin{Verbatim}
- call this%generate_flow()
-\end{Verbatim}
-Üblichwerweise (Wenn ich nicht debugge) werden die Remnante mittels \TbpRef{pp\_remnant\_type}{apply\_interaction} die Remnants über die neue Wechselwirkung in Kenntnis gesetzt.
-\begin{Verbatim}
- if(this%modify_pdfs)then
- call cpu_time(time)
- this%partons_time=this%partons_time+time
- this%confirm_time=this%confirm_time-time
- call this%beam%apply_interaction(this)
- call cpu_time(time)
- this%confirm_time=this%confirm_time+time
- this%partons_time=this%partons_time-time
- end if
- x_proton_1=this%momentum_fractions(1)
- x_proton_2=this%momentum_fractions(2)
- pdg_f=this%get_pdg_flavors()
- pdg_f1=pdg_f(1)
- pdg_f2=pdg_f(2)
- pdg_f3=pdg_f(3)
- pdg_f4=pdg_f(4)
- call cpu_time(time)
- this%partons_time=this%partons_time-time
- call qcd_2_2_print_to_unit(this,output_unit,100_dik,100_dik,100_dik)
- end subroutine muli_generate_partons
-\end{Verbatim}
-
-\TbpImp{muli\_replace\_parton}
-Wrapper für die eigentliche Routine \TbpRef{pp\_remnant\_type}{replace\_parton}
-\begin{Verbatim}
- subroutine muli_replace_parton(this,proton_id,old_id,new_id,pdg_f,x_proton,gev_scale)
- class(muli_type),intent(inout)::this
- integer,intent(in)::proton_id,old_id,new_id,pdg_f
- real(kind=double),intent(in)::x_proton,gev_scale
- !print *,"muli_replace_parton(",proton_id,old_id,new_id,pdg_f,x_proton,gev_scale,")"
- if(proton_id==1.or.proton_id==2)then
- call this%beam%replace_parton(proton_id,old_id,new_id,pdg_f,x_proton,gev_scale)
- else
- print *,"muli_replace_parton: proton_id must be 1 or 2, but ",proton_id," was given."
- STOP
- end if
- end subroutine muli_replace_parton
-\end{Verbatim}
-\TbpImp{muli\_get\_momentum\_pdf}
-Wrapper für die eigentliche Routine \TbpRef{pp\_remnant\_type}{momentum\_pdf}
-\begin{Verbatim}
- function muli_get_momentum_pdf(this,x_proton,gev2_scale,n,pdg_f) result(pdf)
- real(kind=double)::pdf
- class(muli_type),intent(in)::this
- real(kind=double),intent(in)::x_proton,gev2_scale
- integer,intent(in)::n,pdg_f
- call this%beam%momentum_pdf(x_proton,gev2_scale,n,pdg_f,pdf)
- end function muli_get_momentum_pdf
-\end{Verbatim}
-\TbpImp{muli\_get\_parton\_pdf}
-Wrapper für die eigentliche Routine \TbpRef{pp\_remnant\_type}{parton\_pdf}
-\begin{Verbatim}
- function muli_get_parton_pdf(this,x_proton,gev2_scale,n,pdg_f) result(pdf)
- real(kind=double)::pdf
- class(muli_type),intent(in)::this
- real(kind=double),intent(in)::x_proton,gev2_scale
- integer,intent(in)::n,pdg_f
- call this%beam%parton_pdf(x_proton,gev2_scale,n,pdg_f,pdf)
- end function muli_get_parton_pdf
-\end{Verbatim}
-
-\TbpImp{muli\_print\_timer}
-\begin{Verbatim}
- subroutine muli_print_timer(this)
- class(muli_type),intent(in) :: this
- print('("Init time: ",E20.10)'),this%init_time
- print('("PT gen time: ",E20.10)'),this%pt_time
- print('("Partons time: ",E20.10)'),this%partons_time
- print('("Confirm time: ",E20.10)'),this%confirm_time
- print('("Overall time: ",E20.10)'),&
- this%init_time+this%pt_time+this%partons_time+this%confirm_time
- end subroutine muli_print_timer
-\end{Verbatim}
-
-\TbpImp{muli\_generate\_next\_scale}
-Hier wird die nächste Wechselwirkungsskala $h_3^{(n+1)}$ generiert. Für jedes Stratum $\{\alpha,\beta\}$ wird die Unterfunktion generate\_single\_pts aufgerufen, um einen Wert $h_{3\alpha\beta}^{(n+1)}$ zu generieren. muli\_generate\_next\_scale setzt dann $h_3^{(n+1)}=\max(h_{3\alpha\beta}^{(n+1)})$. Intern werden normierte Skalen $h_3=\frac{4\pperp}{s}$=pts (pt normiert auf s) verwendet.
-\begin{Verbatim}
- subroutine muli_generate_next_scale(this,integrand_kind)
- class(muli_type),intent(inout)::this
- integer,intent(in),optional::integrand_kind
- real(kind=double)::pts,tmp_pts,rnd
- integer::tmp_int_kind
- class(\TypeRef{muli\_trapezium\_node\_class}),pointer::tmp_node
- pts=-1D0
-\end{Verbatim}
-Das optionale Argument integrand\_kind wird nur für interne Testzwecke verwendet, man sollte es gefahrlos samt der nachfolgenden Konstruktion entfernen können. integrand\_kind ist ein Stratum $\{\alpha,\beta\}$, das vorgegeben werden kann.
-\begin{Verbatim}
- if(present(integrand_kind))then
- call tao_random_number(this%tao_rnd,rnd)
- call generate_single_pts(&
- integrand_kind,&
- this%start_integrals(integrand_kind),&
- this%beam%get_pdf_int_weights(double_pdf_kinds(1:2,integrand_kind)),&
- rnd,&
- this%dsigma,&
- pts,&
- this%node)
- else
-\end{Verbatim}
-Das ist der vorgesehene Weg, hier werden alle Strati mit tmp\_int\_kind durchlaufen. mit\linebreak \TbpRef{pp\_remnant\_type}{get\_pdf\_int\_weights} werden die Wichtungsfaktoren $[W_\alpha,W_\beta]$ angefordert. in \CompRef{muli\_interactions}{double\_pdf\_kinds} ist eine Abbildung $[1..16]\rightarrow\{\alpha,\beta\}$ definiert.
-
-Nach jedem Aufruf von generate\_single\_pts wird überprüft, ob tmp\_pts=$h_{3\alpha\beta}^{(n+1)}$ größer als der bisher größte Wert ist. Wenn ja, wird $h_3^{(n+1)}=h_{3\alpha\beta}^{(n+1)}$ gesetzt.
-
-generate\_single\_pts liefert $h_{3\alpha\beta}=-1$ zurück, wenn $p_{\perp\alpha\beta}<\pperp^{\min}$. Es reicht am Schluss also aus, wenn wir nachsehen, ob $h_3>0$. Wenn nicht, dann ist die Skala $\pperp$ am unteren Ende angekommen und es werden keine weiteren MPI generiert.
-
-tmp\_node zeigt auf das Blatt der approximierten Wirkungsquerschnitte \CompRef{muli\_type}{dsigma}, das $p_{\perp\alpha\beta}$ enthält. Dieses Blatt wird später noch benötigt, wenn aus dem hier generierten Kandidaten eine tatsächliche Wechselwirkung generiert wird.
-\begin{Verbatim}
- do tmp_int_kind=1,16
- call tao_random_number(this%tao_rnd,rnd)
- call generate_single_pts(&
- tmp_int_kind,&
- this%start_integrals(tmp_int_kind),&
- this%beam%get_pdf_int_weights(double_pdf_kinds(1:2,tmp_int_kind)),&
- rnd,&
- this%dsigma,&
- tmp_pts,&
- tmp_node)
- if(tmp_pts>pts)then
- pts=tmp_pts
- this%integrand_id=tmp_int_kind
- this%node=>tmp_node
- end if
- end do
- end if
- if(pts>0)then
- call this%set_unit_scale(pts)
- else
- this%finished=.true.
- end if
- contains
-\end{Verbatim}
-Siehe Abschnitt \ref{sec:all:alg:stra}, \eqref{eq:all:genpt-a}-\eqref{eq:all:genpt-c} mit weight $\rightarrow W_{\alpha}W_{\beta}$, rnd $\rightarrow z$ und arg $\rightarrow \zeta$.
-Wenn $W_{\alpha}W_{\beta}=0$, dann wird keine Skala generiert, weil mindestens einer der beiden beteiligte
-n Beiträge zur Strukturfunktion gleich Null ist.
-
-Mit \TbpRef{muli\_trapezium\_tree\_type}{find\_decreasing} wird \CompRef{muli\_type}{dsigma} nach dem Blatt durchsucht, dessen Bildmenge von $\mathcal{S}_{\alpha\beta}$ den Wert $\zeta$ enthält. Wenn der Funktionswert l\_integral von $\mathcal{S}_{\alpha\beta}$ an der unteren Intervallgrenze kleiner als $\zeta$ ist, dann liegt $\zeta$ tatsächlich nicht in der Bildmenge von $\mathcal{S}_{\alpha\beta}$. Damit ist klar, dass der gesuchte Wert von $\pperp<\pperp^{\min}$ ist und das Ergebnis wird auf den Wert -1 gesetzt. Andernfalls wird mittels \TbpRef{muli\_trapezium\_type}{approx\_position\_by\_integral} die Umkehrfunktion $\mathcal{S}_{\alpha\beta}^{-1}$ ausgewertet.
-\begin{Verbatim}
- subroutine generate_single_pts(int_kind,start_int,weight,rnd,int_tree,pts,node)
- integer,intent(in)::int_kind
- real(kind=double),intent(in)::start_int,weight,rnd
- type(muli_trapezium_tree_type),intent(in)::int_tree
- real(kind=double),intent(out)::pts
- class(muli_trapezium_node_class),pointer,intent(out)::node
- real(kind=double)::arg
- if(weight>0D0)then
- arg=start_int-log(rnd)/weight
- call int_tree%find_decreasing(arg,int_kind,node)
- if(node%get_l_integral(int_kind)>arg)then
- pts=node%approx_position_by_integral(int_kind,arg)
- else
- pts=-1D0
- end if
- else
- pts=-1D0
- end if
- end subroutine generate_single_pts
- end subroutine muli_generate_next_scale
-\end{Verbatim}
-\TbpImp{muli\_confirm}
-Wird nur für Debuggingzwecke in Zusammenhang mit \TbpRef{muli\_type}{generate\_samples} verwendet.
-\begin{Verbatim}
- subroutine muli_confirm(this)
- class(muli_type),intent(inout) :: this
- this%mean=this%node%approx_value_n(this%get_unit_scale(),this%integrand_id)
- this%start_integrals=this%node%approx_integral(this%get_unit_scale())
- end subroutine muli_confirm
-\end{Verbatim}
-
-\TbpImp{muli\_generate\_samples}
-Ein Generator für die Zerlegung des $\{h_1,h_2,h_3\}$-Einheitsquaders, siehe Abschnitt \ref{sec:all:alg:imp}. Diese Methode wird nur für Debugginzwecke verwendet.
-\begin{Verbatim}
- subroutine muli_generate_samples(this,n_total,n_print,integrand_kind,muli_dir,analyse)
- class(muli_type),intent(inout)::this
- integer(kind=dik),intent(in)::n_total,n_print
- integer,intent(in)::integrand_kind
- character(*),intent(in)::muli_dir
- logical,intent(in)::analyse
- integer(kind=dik)::n_inner
-
- class(muli_trapezium_node_class),pointer::start_node=>null()
- class(muli_trapezium_node_class),pointer,save::s_node=>null()
- class(muli_trapezium_node_class),pointer,save::node=>null()
-
- character(2)::prefix
- integer,save::t_slice,t_region,t_proc,t_subproc,t_max_n=0
- integer(kind=dik)::n_t,n_p,n_m
- integer::n,m,u,unit=0
- integer(kind=dik)::n_tries=0
- integer(kind=dik)::n_hits=0
- integer(kind=dik)::n_over=0
- integer(kind=dik)::n_miss=0
- real(kind=double),save,dimension(3)::cart_hit
- integer,save,dimension(4)::t_i_rnd
- real(kind=double),dimension(16)::d_rnd
- real(kind=double),save::t_area,t_dddsigma,t_rnd,t_weight,t_arg
- real(kind=double)::mean=0D0
- real(kind=double)::time=0D0
- real(kind=double)::timepa=0D0
- real(kind=double)::timept=0D0
- real(kind=double)::timet=0D0
- real(kind=double)::pts,s_pts=1D0
- real(kind=double)::pts2=1D0
- real(kind=double)::rnd
- logical::running
- character(3)::num
- integer::success=-1
- integer::chain_length=0
- integer::int_kind
- integer::process_id
- real(kind=double),dimension(0:16)::integral
- call this%print_parents()
- n_tries=one
- n_inner=n_total/n_print
- n_t=zero
- print:do while(n_t<n_total)
- call cpu_time(time)
- timet=-time
- n_p=zero
- inner:do while(n_p<n_print)
- chain_length=0
- call this%restart()
- this%integrand_id=integrand_kind
- call cpu_time(time)
- timept=timept-time
- call this%generate_next_scale(integrand_kind)
- call cpu_time(time)
- timept=timept+time
- chain:do while(.not.this%is_finished())
- chain_length=chain_length+1
- n_p=n_p+1
- call this%confirm()
- call cpu_time(time)
- timepa=timepa-time
- ! print *,this%get_unit2_scale()
- call sample_inclusive_mcgenerate_hit(&
- this%samples,&
- this%get_unit2_scale(),&
- this%mean,&
- this%integrand_id,&
- this%tao_rnd,&
- this%process_id,&
- this%momentum_fractions)
- call cpu_time(time)
- timepa=timepa+time
- timept=timept-time
- call this%generate_next_scale(integrand_kind)
- call cpu_time(time)
- timept=timept+time
- end do chain
- end do inner
- n_t=n_t+n_p
- call this%samples%sum_up()
- call cpu_time(time)
- timet=timet+time
- print *,n_t,"/",n_total
- print *,"time: ",timet
- print *,"pt time: ",timept
- print *,"pa time: ",timepa
- print *,this%samples%n_tries_sum,this%samples%n_hits_sum,this%samples%n_over_sum
- if(this%samples%n_hits_sum>0)then
- print *,(this%samples%n_hits_sum*10000)/this%samples%n_tries_sum,&
- (this%samples%n_over_sum*10000)/this%samples%n_hits_sum
- else
- print *,"no hits"
- end if
- end do print
- call integer_with_leading_zeros(integrand_kind,2,prefix)
- if(analyse)then
- call this%samples%int_kinds(integrand_kind)%analyse(muli_dir,prefix//"_")
- call this%samples%int_kinds(integrand_kind)%serialize(&
- "sample_int_kind_"//prefix,&
- muli_dir//"/sample_int_kind/"//prefix//".xml")
- end if
- call this%samples%int_kinds(integrand_kind)%serialize(&
- "sample_int_kind_"//prefix,&
- muli_dir//"/sample_int_kind/"//prefix//".xml")
- end subroutine muli_generate_samples
-\end{Verbatim}
-
-\TbpImp{muli\_fake\_interaction}
-Wird ebenfalls zu Debuggingzwecken verwendet. So können Wechselwirkungen ohne Verwendung von WHIZARD oder das shower\_interface auf die Remnants übertragen werden.
-\begin{Verbatim}
- subroutine muli_fake_interaction(this,GeV2_scale,x1,x2,process_id,integrand_id,n1,n2,flow)
- class(muli_type),intent(inout)::this
- real(kind=double),intent(in)::Gev2_scale,x1,x2
- integer,intent(in)::process_id,integrand_id,n1,n2
- integer,dimension(4),intent(in),optional::flow
- call this%set_gev2_scale(Gev2_scale)
- this%process_id=process_id
- this%integrand_id=integrand_id
- this%parton_ids=[n1,n2]
- if(present(flow))then
- this%flow=flow
- else
- this%flow=[0,0,0,0]
- end if
- this%momentum_fractions=[x1,x2,this%get_unit2_scale()]
- call this%beam%apply_interaction(this)
- call this%beam%print_all()
- end subroutine muli_fake_interaction
-
-end module muli
-
-\end{Verbatim}
Index: trunk/src/muli/doc/muli_basic.tex
===================================================================
--- trunk/src/muli/doc/muli_basic.tex (revision 8371)
+++ trunk/src/muli/doc/muli_basic.tex (revision 8372)
@@ -1,3356 +0,0 @@
-\Module{muli\_basic}
-\section{Abhängigkeiten}
-\useintrinsic{iso\_fortran\_env}
-\usenodep{kinds}
-\usenodep{iso\_varying\_string, string\_t=>varying\_string}
-\section{Parameter}
-\begin{Verbatim}
- ! bitmodel parameters
- integer,public,parameter::\MC{drk}=double
- integer,public,parameter::\MC{dik}=i64
- integer(kind=dik),public,parameter::\MC{one}=int(1,kind=dik)
- integer(kind=dik),public,parameter::\MC{zero}=int(0,kind=dik)
- ! serialization parameters
- integer(kind=dik),public,parameter::\MC{serialize\_page\_size}=1024
- integer(kind=dik),public,parameter::\MC{serialize\_ok}=0000
- integer(kind=dik),public,parameter::\MC{serialize\_syntax\_error}=1001
- integer(kind=dik),public,parameter::\MC{serialize\_wrong\_tag}=1002
- integer(kind=dik),public,parameter::\MC{serialize\_wrong\_id}=1003
- integer(kind=dik),public,parameter::\MC{serialize\_wrong\_type}=1004
- integer(kind=dik),public,parameter::\MC{serialize\_wrong\_name}=1005
- integer(kind=dik),public,parameter::\MC{serialize\_no\_target}=1006
- integer(kind=dik),public,parameter::\MC{serialize\_no\_pointer}=1007
- integer(kind=dik),public,parameter::\MC{serialize\_wrong\_action}=1008
- integer(kind=dik),public,parameter::\MC{serialize\_unexpected\_content}=1009
- integer(kind=dik),public,parameter::\MC{serialize\_null}=1010
- integer(kind=dik),public,parameter::\MC{serialize\_nothing}=1011
- logical,public,parameter::\MC{serialize\_default\_indent}=.true.
- logical,public,parameter::\MC{serialize\_default\_line\_break}=.true.
- logical,public,parameter::\MC{serialize\_default\_asynchronous}=.false.
- ! private components
- integer(kind=dik),private::\MC{last\_id}=0
- character(len=*),private,parameter::\MC{serialize\_integer\_characters}="-0123456789"
-\end{Verbatim}
-\section{Derived Types}
-\TypeDef{serializable\_class}
-\begin{Verbatim}
- type,public,abstract::serializable_class
- contains
- procedure(ser_write_if),deferred::write_to_marker
- procedure(ser_read_if),deferred::read_from_marker
- procedure(ser_unit),deferred::print_to_unit
- procedure(ser_type),nopass,deferred::get_type
- procedure,nopass::\TbpDec{verify\_type}{serializable\_verify\_type}
- procedure::\TbpDec{read\_target\_from\_marker}{serializable\_read\_target\_from\_marker}
- procedure::\TbpDec{write\_type}{serializable\_write\_type}
- procedure::\TbpDec{print}{serializable\_print}
- procedure::\TbpDec{print\_error}{serializable\_print\_error}
- procedure::\TbpDec{print\_all}{serializable\_print\_all}
- procedure::\TbpDec{print\_little}{serializable\_print\_little}
- procedure::\TbpDec{print\_parents}{serializable\_print\_parents}
- procedure::\TbpDec{print\_components}{serializable\_print\_components}
- procedure::\TbpDec{print\_peers}{serializable\_print\_peers}
- procedure::\TbpDec{serialize\_to\_file}{serializable\_serialize\_to\_file}
- procedure::\TbpDec{serialize\_to\_unit}{serializable\_serialize\_to\_unit}
- procedure::\TbpDec{serialize\_to\_marker}{serializable\_serialize\_to\_marker}
- procedure::\TbpDec{deserialize\_from\_file}{serializable\_deserialize\_from\_file}
- procedure::\TbpDec{deserialize\_from\_unit}{serializable\_deserialize\_from\_unit}
- procedure::\TbpDec{deserialize\_from\_marker}{serializable\_deserialize\_from\_marker}
- generic::\TbpGen{serialize}{serialize\_to\_file,serialize\_to\_unit,serialize\_to\_marker}
- generic::\TbpGen{deserialize}{deserialize\_from\_file,deserialize\_from\_unit,deserialize\_from\_marker}
- end type serializable_class
-\end{Verbatim}
-\TypeDef{measurable\_class}
-\begin{Verbatim}
- type,public,abstract,extends(serializable_class)::measurable_class
- contains
- procedure(measure_int),public,deferred::measure
- end type measurable_class
-\end{Verbatim}
-\TypeDef{identified\_type}
-\begin{Verbatim}
- type,public,\Extends{serializable\_class}::identified_type
- private
- integer(kind=dik)::\TC{id}
- type(string_t)::\TC{name}
- contains
- ! overridden serializable_class procedures
- procedure,public::\TbpDec{write\_to\_marker}{identified\_write\_to\_marker}
- procedure,public::\TbpDec{read\_from\_marker}{identified\_read\_from\_marker}
- procedure,public::\TbpDec{print\_to\_unit}{identified\_print\_to\_unit}
- procedure,public,nopass::\TbpDec{get\_type}{identified\_get\_type}
- procedure,nopass::\TbpDec{verify\_type}{identified\_verify\_type}
- ! new procedures
- procedure,public::\TbpDecS{identified\_initialize}
- procedure,public::\TbpDec{get\_id}{identified\_get\_id}
- procedure,public::\TbpDec{get\_name}{identified\_get\_name}
- generic,public::\TbpGen{initialize}{identified\_initialize}
- end type identified_type
-\end{Verbatim}
-\TypeDef{unique\_type}
-\begin{Verbatim}
- type,public,\Extends{identified\_type}::unique_type
- private
- integer(kind=dik)::\TC{unique\_id}
- contains
- ! overridden serializable_class procedures
- procedure,public,nopass::\TbpDec{get\_type}{unique\_get\_type}
- procedure,nopass::\TbpDec{verify\_type}{unique\_verify\_type}
- procedure,public::\TbpDec{write\_to\_marker}{unique\_write\_to\_marker}
- procedure,public::\TbpDec{read\_from\_marker}{unique\_read\_from\_marker}
- procedure,public::\TbpDec{print\_to\_unit}{unique\_print\_to\_unit}
- ! overridden identified_type procedures
- procedure,public::\TbpDec{identified\_initialize}{unique\_initialize}
- ! new procedures
- procedure,public::\TbpDec{get\_unique\_id}{unique\_get\_unique\_id}
- end type unique_type
-\end{Verbatim}
-\TypeDef{serializable\_ref\_type}
-\begin{Verbatim}
- type,private::serializable_ref_type
- private
- integer(kind=dik)::\TC{id}
- class(\TypeRef{serializable\_class}),pointer::\TC{ref}=>null()
- class(\TypeRef{serializable\_ref\_type}),pointer::\TC{next}=>null()
- contains
- procedure,public::\TbpDec{finalize}{serializable\_ref\_finalize}
- end type serializable_ref_type
-\end{Verbatim}
-\TypeDef{position\_stack\_type}
-\begin{Verbatim}
- type::position_stack_type
- private
- integer(kind=dik),dimension(2)::\TC{position}
- class(\TypeRef{position\_stack\_type}),pointer::\TC{next}=>null()
- contains
- procedure,public::\TbpDec{push\_head}{position\_stack\_push\_head}
- procedure,public::\TbpDec{push\_given}{position\_stack\_push\_given}
- procedure,public::\TbpDecS{position\_stack\_pop}
- procedure,public::\TbpDecS{position\_stack\_drop}
- procedure,public::\TbpDec{nth\_position}{position\_stack\_nth\_position}
- procedure,public::\TbpDec{first}{position\_stack\_first}
- procedure,public::\TbpDec{last}{position\_stack\_last}
- procedure,public::\TbpDec{range}{position\_stack\_range}
- generic,public::\TbpGen{push}{push\_head}
- generic,public::\TbpGen{push}{push\_given}
- generic,public::\TbpGen{pop}{position\_stack\_pop}
- generic,public::\TbpGen{push}{position\_stack\_drop}
- end type position_stack_type
-\end{Verbatim}
-\TypeDef{page\_ring\_type}
-\begin{Verbatim}
- type,public::page_ring_type
- private
- logical::\TC{asynchronous}=serialize_default_asynchronous
- logical::\TC{eof\_reached}=.false.
- integer::\TC{unit}=-1
- integer(kind=dik)::\TC{ring\_size}=2
- integer(kind=dik)::\TC{action}=0
- integer(kind=dik)::\TC{eof\_int}=-1
- integer(kind=dik)::\TC{out\_unit}=output_unit
- integer(kind=dik)::\TC{err\_unit}=error_unit
- integer(kind=dik),dimension(2)::\TC{active\_pages}=[0,-1]
- integer(kind=dik),dimension(2)::\TC{eof\_pos}=[-1,-1]
- type(string_t)::\TC{eof\_string}
- type(\TypeRef{position\_stack\_type})::\TC{position\_stack}
- character(serialize_page_size),dimension(:),allocatable::\TC{ring}
- contains
- ! read access only procedures:
- procedure,public::\TbpDec{open\_for\_read\_access}{page\_ring\_open\_for\_read\_access}
- procedure,public::\TbpDec{read\_page}{page\_ring\_read\_page}
- ! write access only procedures:
- procedure,public::\TbpDec{open\_for\_write\_access}{page\_ring\_open\_for\_write\_access}
- procedure,public::\TbpDec{flush}{page\_ring\_flush}
- procedure,public::\TbpDec{break}{page\_ring\_break}
- ! comparing
- procedure,public::\TbpDec{str\_equal}{page\_ring\_str\_equal}
- ! searching:
- procedure,public::\TbpDec{find\_pure}{page\_ring\_find\_pure}
- generic, public::\TbpGen{find}{page\_ring\_find,page\_ring\_find\_default}
- ! positioning:
- procedure,public::\TbpDec{set\_position}{page\_ring\_set\_position}
- procedure,public::\TbpDec{turn\_page}{page\_ring\_turn\_page}
- procedure,public::\TbpDec{proceed}{page\_ring\_proceed}
- generic, public::\TbpGen{push\_position}{push\_actual\_position,push\_given\_position}
- generic, public::\TbpGen{pop\_position}{pop\_actual\_position,pop\_given\_position}
- generic, public::\TbpGen{get\_position}{page\_ring\_get\_position1,page\_ring\_get\_position2}
- ! printing:
- procedure,public::\TbpDec{print\_to\_unit}{page\_ring\_print\_to\_unit}
- procedure,public::\TbpDec{print\_ring}{page\_ring\_print\_ring}
- procedure,public::\TbpDec{print\_position}{page\_ring\_print\_position}
- ! writing:
- procedure,public::\TbpDec{put}{page\_ring\_put}
- generic, public::\TbpGen{push}{push_string,push_integer,push_integer_dik,push_double,push_integer_array,push_integer_array_dik,push_double_array}
- ! reading:
- procedure,public::\TbpDec{get\_character}{page\_ring\_get\_character}
- procedure,public::\TbpDec{allocate\_substring}{page\_ring\_allocate\_substring}
- procedure,public::\TbpDec{pop\_character}{page\_ring\_pop\_character}
- procedure,public::\TbpDec{pop\_by\_keys}{page\_ring\_pop\_by\_keys}
- generic, public::\TbpGen{substring}{page\_ring\_substring1,page\_ring\_substring2}
- generic, public::\TbpGen{substring\_by\_keys}{page\_ring\_character\_by\_keys,page\_ring\_positions\_by\_keys}
- generic, public::\TbpGen{pop}{pop_string,pop_integer,pop_integer_dik,pop_double,pop_logical,pop_integer_array,pop_integer_array_dik,pop_double_array}
- ! misc:
- procedure,public::\TbpDec{close}{page\_ring\_close}
- procedure,public::\TbpDec{ring\_index}{page\_ring\_ring\_index}
- ! private:
- procedure,private::\TbpDec{activate\_next\_page}{page\_ring\_activate\_next\_page}
- procedure,private::\TbpDec{enlarge}{page\_ring\_enlarge}
- ! specific names for generic procedures:
- procedure,private::\TbpDecS{page\_ring\_substring1}
- procedure,private::\TbpDecS{page\_ring\_substring2}
- procedure,private::\TbpDecS{page\_ring\_character\_by\_keys}
- procedure,private::\TbpDecS{page\_ring\_positions\_by\_keys}
- procedure,private::\TbpDec{push\_string}{page\_ring\_push\_string}
- procedure,private::\TbpDec{push\_integer}{page\_ring\_push\_integer}
- procedure,private::\TbpDec{push\_integer\_dik}{page\_ring\_push\_integer\_dik}
- procedure,private::\TbpDec{push\_integer\_array}{page\_ring\_push\_integer\_array}
- procedure,private::\TbpDec{push\_integer\_array\_dik}{page\_ring\_push\_integer\_array\_dik}
- procedure,private::\TbpDec{push\_double}{page\_ring\_push\_double}
- procedure,private::\TbpDec{push\_double\_array}{page\_ring\_push\_double\_array}
- procedure,private::\TbpDec{pop\_string}{page\_ring\_pop\_string}
- procedure,private::\TbpDec{pop\_integer}{page\_ring\_pop\_integer}
- procedure,private::\TbpDec{pop\_integer\_dik}{page\_ring\_pop\_integer\_dik}
- procedure,private::\TbpDec{pop\_logical}{page\_ring\_pop\_logical}
- procedure,private::\TbpDec{pop\_integer\_array}{page\_ring\_pop\_integer\_array}
- procedure,private::\TbpDec{pop\_integer\_array\_dik}{page\_ring\_pop\_integer\_array\_dik}
- procedure,private::\TbpDec{pop\_double}{page\_ring\_pop\_double}
- procedure,private::\TbpDec{pop\_double\_array}{page\_ring\_pop\_double\_array}
- procedure,private::\TbpDecS{page\_ring\_find}
- procedure,private::\TbpDecS{page\_ring\_find\_default}
-
- procedure,private::\TbpDec{actual\_index}{page\_ring\_actual\_index}
- procedure,private::\TbpDec{actual\_page}{page\_ring\_actual\_page}
- procedure,private::\TbpDec{actual\_offset}{page\_ring\_actual\_offset}
- procedure,private::\TbpDec{actual\_position}{page\_ring\_actual\_position}
- procedure,private::\TbpDec{first\_index}{page\_ring\_first\_index}
- procedure,private::\TbpDec{first\_page}{page\_ring\_first\_page}
- procedure,private::\TbpDec{last\_index}{page\_ring\_last\_index}
- procedure,private::\TbpDec{last\_page}{page\_ring\_last\_page}
- procedure,private::\TbpDec{push\_actual\_position}{page\_ring\_ring\_push\_actual\_position}
- procedure,private::\TbpDec{push\_given\_position}{page\_ring\_ring\_push\_given\_position}
- procedure,private::\TbpDec{pop\_actual\_position}{page\_ring\_ring\_pop\_actual\_position}
- procedure,private::\TbpDec{pop\_given\_position}{page\_ring\_ring\_pop\_given\_position}
- procedure,private::\TbpDecS{page\_ring\_get\_position1}
- procedure,private::\TbpDecS{page\_ring\_get\_position2}
- end type page_ring_type
-\end{Verbatim}
-\TypeDef{marker\_type}
-\begin{Verbatim}
- type,public,extends(page_ring_type)::marker_type
- private
- integer(kind=dik)::\TC{indentation}=0
- integer(kind=dik)::\TC{n\_instances}=0
- logical::\TC{do\_break}=.true.
- logical::\TC{do\_indent}=.false.
- class(\TypeRef{serializable\_ref\_type}),pointer::\TC{heap}=>null()
- class(\TypeRef{serializable\_ref\_type}),pointer::\TC{references}=>null()
- contains
- procedure::\TbpDec{mark\_begin}{marker\_mark\_begin}
- procedure::\TbpDec{mark\_instance\_begin}{marker\_mark\_instance\_begin}
- procedure::\TbpDec{mark\_end}{marker\_mark\_end}
- procedure::\TbpDec{mark\_instance\_end}{marker\_mark\_instance\_end}
- procedure::\TbpDec{mark\_logical}{marker\_mark\_logical}
- procedure::\TbpDec{mark\_integer}{marker\_mark\_integer}
- procedure::\TbpDec{mark\_integer\_array}{marker\_mark\_integer\_array}
- procedure::\TbpDec{mark\_integer\_matrix}{marker\_mark\_integer\_matrix}
- procedure::\TbpDec{mark\_integer\_dik}{marker\_mark\_integer\_dik}
- procedure::\TbpDec{mark\_integer\_array\_dik}{marker\_mark\_integer\_array\_dik}
- procedure::\TbpDec{mark\_integer\_matrix\_dik}{marker\_mark\_integer\_matrix\_dik}
- procedure::\TbpDec{mark\_double}{marker\_mark\_double}
- procedure::\TbpDec{mark\_double\_array}{marker\_mark\_double\_array}
- procedure::\TbpDec{mark\_double\_matrix}{marker\_mark\_double\_matrix}
- procedure::\TbpDec{mark\_string}{marker\_mark\_string}
- procedure::\TbpDec{mark\_instance}{marker\_mark\_instance}
- procedure::\TbpDec{mark\_target}{marker\_mark\_target}
- procedure::\TbpDec{mark\_allocatable}{marker\_mark\_allocatable}
- procedure::\TbpDec{mark\_pointer}{marker\_mark\_pointer}
- procedure::\TbpDec{mark\_null}{marker\_mark\_null}
- procedure::\TbpDec{mark\_nothing}{marker\_mark\_nothing}
- procedure::\TbpDec{mark\_empty}{marker\_mark\_empty}
- procedure::\TbpDec{pick\_begin}{marker\_pick\_begin}
- procedure::\TbpDec{query\_instance\_begin}{marker\_query\_instance\_begin}
- procedure::\TbpDec{pick\_instance\_begin}{marker\_pick\_instance\_begin}
- procedure::\TbpDec{pick\_end}{marker\_pick\_end}
- procedure::\TbpDec{pick\_instance\_end}{marker\_pick\_instance\_end}
- procedure::\TbpDec{pick\_instance}{marker\_pick\_instance}
- procedure::\TbpDec{pick\_target}{marker\_pick\_target}
- procedure::\TbpDec{pick\_allocatable}{marker\_pick\_allocatable}
- procedure::\TbpDec{pick\_pointer}{marker\_pick\_pointer}
- procedure::\TbpDec{pick\_logical}{marker\_pick\_logical}
- procedure::\TbpDec{pick\_integer}{marker\_pick\_integer}
- procedure::\TbpDec{pick\_integer\_array}{marker\_pick\_integer\_array}
- procedure::\TbpDec{pick\_integer\_matrix}{marker\_pick\_integer\_matrix}
- procedure::\TbpDec{pick\_integer\_dik}{marker\_pick\_integer\_dik}
- procedure::\TbpDec{pick\_integer\_array\_dik}{marker\_pick\_integer\_array\_dik}
- procedure::\TbpDec{pick\_integer\_matrix\_dik}{marker\_pick\_integer\_matrix\_dik}
- procedure::\TbpDec{pick\_double}{marker\_pick\_double}
- procedure::\TbpDec{pick\_double\_array}{marker\_pick\_double\_array}
- procedure::\TbpDec{pick\_double\_matrix}{marker\_pick\_double\_matrix}
- procedure::\TbpDec{pick\_string}{marker\_pick\_string}
- generic,public::mark=>mark_logical,&
- mark_integer,mark_integer_array,mark_integer_matrix,&
- mark_integer_dik,mark_integer_array_dik,mark_integer_matrix_dik,&
- mark_double,mark_double_array,mark_double_matrix,mark_string
- generic,public::pick=>pick_logical,&
- pick_integer,pick_integer_array,pick_integer_matrix,&
- pick_integer_dik,pick_integer_array_dik,pick_integer_matrix_dik,&
- pick_double,pick_double_array,pick_double_matrix,pick_string
- procedure::\TbpDec{verify\_nothing}{marker\_verify\_nothing}
- procedure::\TbpDec{indent}{marker\_indent}
- procedure::\TbpDec{push\_heap}{marker\_push\_heap}
- procedure::\TbpDec{pop\_heap}{marker\_pop\_heap}
- procedure::\TbpDec{search\_heap\_by\_id}{marker\_search\_heap\_by\_id}
- procedure::\TbpDec{search\_heap\_by\_ref}{marker\_search\_heap\_by\_ref}
- procedure::\TbpDec{push\_reference}{marker\_push\_reference}
- procedure::\TbpDec{pop\_reference}{marker\_pop\_reference}
- procedure::\TbpDec{reset\_references}{marker\_reset\_references}
- procedure::\TbpDec{search\_reference}{marker\_search\_reference}
- procedure::\TbpDec{reset\_heap}{marker\_reset\_heap}
- procedure::\TbpDec{finalize}{marker\_finalize}
- generic::\TbpGen{search\_heap}{search\_heap\_by\_id}
- generic::\TbpGen{search\_heap}{search\_heap\_by\_ref}
- end type marker_type
-\end{Verbatim}
-\section{Interfaces}
-\begin{Verbatim}
- abstract interface
- elemental function measure_int(this)
- import measurable_class
- import drk
- class(measurable_class),intent(in)::this
- real(kind=drk)::measure_int
- end function measure_int
- end interface
- interface operator(<)
- module procedure measurable_less_measurable
- module procedure measurable_less_double
- end interface
- interface operator(<=)
- module procedure measurable_less_or_equal_measurable
- module procedure measurable_less_or_equal_double
- end interface
- interface operator(==)
- module procedure measurable_equal_measurable
- module procedure measurable_equal_double
- end interface
- interface operator(>=)
- module procedure measurable_equal_or_greater_measurable
- module procedure measurable_equal_or_greater_double
- end interface
- interface operator(>)
- module procedure measurable_greater_measurable
- module procedure measurable_greater_double
- end interface
- abstract interface
- subroutine ser_write_if(this,marker,status)
- import serializable_class
- import marker_type
- import dik
- class(serializable_class),intent(in)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- end subroutine ser_write_if
- end interface
- abstract interface
- subroutine ser_read_if(this,marker,status)
- import serializable_class
- import marker_type
- import dik
- class(serializable_class),intent(out)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- end subroutine ser_read_if
- end interface
- abstract interface
- subroutine ser_unit(this,unit,parents,components,peers)
- import serializable_class
- import dik
- class(serializable_class),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- end subroutine ser_unit
- end interface
- abstract interface
- pure subroutine ser_type(type)
- character(:),allocatable,intent(out)::type
- end subroutine ser_type
- end interface
- interface page_ring_position_is_before
- module procedure &
- page_ring_position_is_before_int_pos,&
- page_ring_position_is_before_pos_pos,&
- page_ring_position_is_before_pos_int
- end interface
-\end{Verbatim}
-\section{Operators}
-\begin{Verbatim}
- public operator(<),operator(<=),operator(>=),operator(>)
- public serialize_print_comp_pointer,serialize_print_peer_pointer&
- &,serialize_print_allocatable
- public identified_initialize,identified_print_to_unit&
- &,identified_read_from_marker,identified_write_to_marker
-
- public serializable_deserialize_from_marker
- public ilog2,generate_unit,integer_with_leading_zeros
-\end{Verbatim}
-\Methods
-\MethodsFor{serializable\_class}
-
-\TbpImp{serializable\_verify\_type}
-\begin{Verbatim}
- elemental logical function serializable_verify_type(type) result(match)
- character(*),intent(in)::type
- match=type=="serializable_class"
- end function serializable_verify_type
-\end{Verbatim}
-
-\TbpImp{serializable\_read\_target\_from\_marker}
-\begin{Verbatim}
- subroutine serializable_read_target_from_marker(this,marker,status)
- ! This is a dummy procedure. Usually, you dont't need to deserialize targets,
- ! so by implementing this dummy we don"t force all descendants to override this
- ! procedure. Then again this is the only way to read targets from markers.
- class(serializable_class),target,intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- print *,"serializable_read_target_from_marker:"
- print *,"This is a dummy procedure. Usually, this message indicates a missing overridden &
- &read_target_from_marker TPB for "
- call this%write_type(output_unit)
- print *,""
- call this%read_from_marker(marker,status)
- end subroutine serializable_read_target_from_marker
-\end{Verbatim}
-
-\TbpImp{serializable\_write\_type}
-\begin{Verbatim}
- subroutine serializable_write_type(this,unit)
- class(serializable_class),intent(in)::this
- integer,intent(in)::unit
- character(:),allocatable::this_type
- call this%get_type(this_type)
- write(unit,fmt='(a)',advance="no")this_type
- end subroutine serializable_write_type
-\end{Verbatim}
-
-\TbpImp{serializable\_print}
-\begin{Verbatim}
- recursive subroutine serializable_print(this,parents,components,peers,unit)
- class(serializable_class),intent(in)::this
- integer(kind=dik),intent(in)::parents,components,peers
- integer,optional::unit
- if(present(unit))then
- write(unit,'("")')
- write(unit,'("Instance of type: ")',advance="no")
- call this%write_type(unit)
- write(unit,fmt='("")')
- call this%print_to_unit(unit,parents,components,peers)
- else
- write(output_unit,'("")')
- write(output_unit,'("Instance of type: ")',advance="no")
- call this%write_type(output_unit)
- write(output_unit,fmt='("")')
- call this%print_to_unit(output_unit,parents,components,peers)
- end if
- end subroutine serializable_print
-\end{Verbatim}
-
-\TbpImp{serializable\_print\_all}
-\begin{Verbatim}
- recursive subroutine serializable_print_all(this,unit)
- class(serializable_class),intent(in)::this
- integer,optional::unit
- if(present(unit))then
- write(unit,'("")')
- write(unit,'("Instance of type: ")',advance="no")
- call this%write_type(unit)
- write(unit,fmt='("")')
- call this%print_to_unit(unit,huge(one),huge(one),huge(one))
- else
- write(output_unit,'("")')
- write(output_unit,'("Instance of type: ")',advance="no")
- call this%write_type(output_unit)
- write(output_unit,fmt='("")')
- call this%print_to_unit(output_unit,huge(one),huge(one),huge(one))
- end if
- end subroutine serializable_print_all
-\end{Verbatim}
-
-\TbpImp{serializable\_print\_little}
-\begin{Verbatim}
- recursive subroutine serializable_print_little(this,unit)
- class(serializable_class),intent(in)::this
- integer,optional::unit
- if(present(unit))then
- write(unit,'("")')
- write(unit,'("Instance of type: ")',advance="no")
- call this%write_type(unit)
- write(unit,fmt='("")')
- call this%print_to_unit(unit,zero,zero,zero)
- else
- write(output_unit,'("")')
- write(output_unit,'("Instance of type: ")',advance="no")
- call this%write_type(output_unit)
- write(output_unit,fmt='("")')
- call this%print_to_unit(output_unit,zero,zero,zero)
- end if
- end subroutine serializable_print_little
-\end{Verbatim}
-
-\TbpImp{serializable\_print\_parents}
-\begin{Verbatim}
- recursive subroutine serializable_print_parents(this)
- class(serializable_class),intent(in)::this
- write(output_unit,'("")')
- write(output_unit,'("Instance of type: ")',advance="no")
- call this%write_type(output_unit)
- write(output_unit,fmt='("")')
- call this%print_to_unit(output_unit,huge(one),zero,zero)
- end subroutine serializable_print_parents
-\end{Verbatim}
-
-\TbpImp{serializable\_print\_components}
-\begin{Verbatim}
- recursive subroutine serializable_print_components(this)
- class(serializable_class),intent(in)::this
- write(output_unit,'("")')
- write(output_unit,'("Instance of type: ")',advance="no")
- call this%write_type(output_unit)
- write(output_unit,fmt='("")')
- call this%print_to_unit(output_unit,zero,huge(one),zero)
- end subroutine serializable_print_components
-\end{Verbatim}
-
-\TbpImp{serializable\_print\_peers}
-\begin{Verbatim}
- recursive subroutine serializable_print_peers(this)
- class(serializable_class),intent(in)::this
- write(output_unit,'("")')
- write(output_unit,'("Instance of type: ")',advance="no")
- call this%write_type(output_unit)
- write(output_unit,fmt='("")')
- call this%print_to_unit(output_unit,zero,zero,huge(one))
- end subroutine serializable_print_peers
-\end{Verbatim}
-
-\TbpImp{serializable\_print\_error}
-\begin{Verbatim}
- recursive subroutine serializable_print_error(this)
- class(serializable_class),intent(in)::this
- call this%print_to_unit(error_unit,zero,zero,zero)
- end subroutine serializable_print_error
-\end{Verbatim}
-
-\TbpImp{serializable\_serialize\_to\_unit}
-\begin{Verbatim}
- subroutine serializable_serialize_to_unit(this,unit,name)
- class(serializable_class),intent(in)::this
- integer, intent(in) :: unit
- character (len=*), intent(in) :: name
- logical::opened
- character(32)::file
- ! gfortran bug
- ! character::stream
- character::write
- type(marker_type)::marker
- ! inquire(unit=unit,opened=opened,stream=stream,write=write)
- inquire(unit=unit,opened=opened,write=write)
- if(opened)then
-! if(stream=="Y")then
- if(write=="Y")then
- print *,"dummy: serializable_serialize_to_unit"
- stop
- else
- print *,"serializable_serialize_to_unit: cannot write to read-only unit."
- end if
-! else
-! print *,"serializable_serialize_to_unit: access kind of unit is not 'stream'."
-! end if
- else
- print *,"serializable_serialize_to_unit: file is not opened."
- end if
- end subroutine serializable_serialize_to_unit
-\end{Verbatim}
-
-\TbpImp{serializable\_serialize\_to\_file}
-\begin{Verbatim}
- subroutine serializable_serialize_to_file(this,name,file)
- class(serializable_class),intent(in)::this
- character (len=*), intent(in) :: file,name
- type(marker_type)::marker
- call marker%open_for_write_access(file)
- print *,"serializable_serialize_to_file: writing xml preamble to ",file
- call marker%activate_next_page()
- call marker%push('<?xml version="1.0"?>')
- call marker%mark_begin(tag="file",name=file)
- flush(marker%unit)
- call this%serialize_to_marker(marker,name)
- call marker%mark_end("file")
- call marker%close()
- call marker%finalize()
- end subroutine serializable_serialize_to_file
-\end{Verbatim}
-
-\TbpImp{serializable\_serialize\_to\_marker}
-\begin{Verbatim}
- recursive subroutine serializable_serialize_to_marker(this,marker,name)
- class(serializable_class),intent(in)::this
- class(marker_type),intent(inout)::marker
- character (len=*), intent(in) :: name
- if(marker%action==1)then
- call marker%mark_instance(this,name)
- else
- print *,"serializable_serialize_to_marker: Marker is not ready for write access. STOP."
- stop
- end if
- end subroutine serializable_serialize_to_marker
-\end{Verbatim}
-
-\TbpImp{serializable\_deserialize\_from\_unit}
-\begin{Verbatim}
- subroutine serializable_deserialize_from_unit(this,unit,name)
- class(serializable_class),intent(inout)::this
- integer, intent(in) :: unit
- character (len=*), intent(in) :: name
- logical::opened
- ! gfortran bug
- ! character::stream
- character::read
- type(marker_type)::marker
- ! inquire(unit=unit,opened=opened,stream=stream,read=read)
- inquire(unit=unit,opened=opened,read=read)
- if(opened)then
-! if(stream=="Y")then
- if(read=="Y")then
- print *,"dummy: serializable_serialize_from_unit"
- stop
- else
- print *,"serializable_serialize_from_unit: cannot write from read-only unit."
- end if
-! else
-! print *,"serializable_serialize_from_unit: access kind of unit is not 'stream'."
-! end if
- else
- print *,"serializable_serialize_from_unit: file is not opened."
- end if
- end subroutine serializable_deserialize_from_unit
-\end{Verbatim}
-
-\TbpImp{serializable\_deserialize\_from\_marker}
-\begin{Verbatim}
- subroutine serializable_deserialize_from_marker(this,name,marker)
- class(serializable_class),intent(out)::this
- character(*),intent(in)::name
- class(marker_type),intent(inout)::marker
- integer(kind=dik)::status
- if(marker%action==2)then
- call marker%pick_instance(name,this,status)
- else
- print *,"serializable_deserialize_from_ring: Ring is not ready for read access. STOP."
- stop
- end if
- end subroutine serializable_deserialize_from_marker
-\end{Verbatim}
-
-\TbpImp{serializable\_deserialize\_from\_file}
-\begin{Verbatim}
- subroutine serializable_deserialize_from_file(this,name,file)
- class(serializable_class),intent(out)::this
- character(*),intent(in)::name,file
- type(marker_type)::marker
- integer(kind=dik),dimension(2)::p1,p2
- call marker%open_for_read_access(file,"</file>")
- marker%eof_int=huge(one)
- marker%eof_pos=page_ring_position(marker%eof_int)
- call marker%read_page()
- call marker%find('<?',skip=2,proceed=.true.,pos=p1)
- call marker%find('?>',skip=3,proceed=.false.,pos=p2)
- if((p1(2)<=0).or.(p2(2)<=0))then
- print *,"no version substring found."
- end if
- call marker%set_position(p2)
- call marker%find('<file ',skip=4,proceed=.true.,pos=p1)
- call marker%find('>',skip=1,proceed=.false.,pos=p2)
- if((p1(2)>0).and.(p2(2)>0))then
- call marker%push_position(p2)
- call marker%find('name="',skip=4,proceed=.true.,pos=p1)
- call marker%find('"',skip=1,proceed=.false.,pos=p2)
- call marker%pop_position()
- else
- print *,"no file header found. STOP."
- STOP
- end if
- call this%deserialize_from_marker(name,marker)
- call marker%close()
- call marker%finalize()
- end subroutine serializable_deserialize_from_file
-\end{Verbatim}
-\MethodsFor{identified\_type}
-\OverridesSection{serializable\_class}
-\TbpImp{identified\_write\_to\_marker}
-\begin{Verbatim}
- subroutine identified_write_to_marker(this,marker,status)
- class(identified_type),intent(in)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("identified_type")
- call marker%mark("name",this%get_name())
- call marker%mark("id",this%get_id())
- call marker%mark_end("identified_type")
- end subroutine identified_write_to_marker
-\end{Verbatim}
-
-\TbpImp{identified\_read\_from\_marker}
-\begin{Verbatim}
- subroutine identified_read_from_marker(this,marker,status)
- class(identified_type),intent(out)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- character(:),allocatable::name
- call marker%pick_begin("identified_type",status=status)
- call marker%pick("name",name,status)
- call marker%pick("id",this%id,status)
- call marker%pick_end("identified_type",status=status)
- this%name=name
- end subroutine identified_read_from_marker
-\end{Verbatim}
-
-\TbpImp{identified\_print\_to\_unit}
-\begin{Verbatim}
- subroutine identified_print_to_unit(this,unit,parents,components,peers)
- class(identified_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- write(unit,'("Components of identified_type:")')
- write(unit,'("Name: ",a)')this%get_name()
- write(unit,'("ID: ",I10)')this%get_id()
- end subroutine identified_print_to_unit
-\end{Verbatim}
-
-\TbpImp{identified\_get\_type}
-\begin{Verbatim}
- pure subroutine identified_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="identified_type")
- end subroutine identified_get_type
-\end{Verbatim}
-
-\TbpImp{identified\_verify\_type}
-\begin{Verbatim}
- elemental logical function identified_verify_type(string)
- character(len=*),intent(in)::string
- identified_verify_type=(string=="identified_type")
- end function identified_verify_type
-\end{Verbatim}
-\OriginalSection{identified\_type}
-\TbpImp{identified\_initialize}
-\begin{Verbatim}
- subroutine identified_initialize(this,id,name)
- class(identified_type),intent(out)::this
- integer(kind=dik),intent(in)::id
- character(len=*),intent(in)::name
- this%name=name
- this%id=id
- end subroutine identified_initialize
-\end{Verbatim}
-
-\TbpImp{identified\_get\_id}
-\begin{Verbatim}
- elemental function identified_get_id(this) result(id)
- class(identified_type),intent(in)::this
- integer(kind=dik)::id
- id=this%id
- end function identified_get_id
-\end{Verbatim}
-
-\TbpImp{identified\_get\_name}
-\begin{Verbatim}
- pure function identified_get_name(this)
- class(identified_type),intent(in)::this
- character(len(this%name))::identified_get_name
- identified_get_name=char(this%name)
- end function identified_get_name
-\end{Verbatim}
-
-\MethodsFor{unique\_type}
-\OverridesSection{serializable\_class}
-\TbpImp{unique\_print\_to\_unit}
-\begin{Verbatim}
- subroutine unique_print_to_unit(this,unit,parents,components,peers)
- class(unique_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- if(parents>0)call identified_print_to_unit(this,unit,parents-1,components&
- &,peers)
- write(unit,'("Unique ID: ",I10)')this%get_unique_id()
- end subroutine unique_print_to_unit
-\end{Verbatim}
-
-\ProcImp{unique\_get\_type}
-\begin{Verbatim}
- pure subroutine unique_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="unique_type")
- end subroutine unique_get_type
-\end{Verbatim}
-
-\ProcImp{unique\_verify\_type}
-\begin{Verbatim}
- elemental logical function unique_verify_type(string)
- character(len=*),intent(in)::string
- unique_verify_type=(string=="unique_type")
- end function unique_verify_type
-\end{Verbatim}
-
-\TbpImp{unique\_write\_to\_marker}
-\begin{Verbatim}
- subroutine unique_write_to_marker(this,marker,status)
- class(unique_type),intent(in)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("unique_type")
- call identified_write_to_marker(this,marker,status)
- call marker%mark("unique_id",this%get_unique_id())
- call marker%mark_end("unique_type")
- end subroutine unique_write_to_marker
-\end{Verbatim}
-
-\TbpImp{unique\_read\_from\_marker}
-\begin{Verbatim}
- subroutine unique_read_from_marker(this,marker,status)
- class(unique_type),intent(out)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%pick_begin("unique_type",status=status)
- call identified_read_from_marker(this,marker,status)
- call marker%pick("unique_id",this%unique_id,status)
- call marker%pick_end("unique_type",status)
- end subroutine unique_read_from_marker
-\end{Verbatim}
-\OriginalSection{unique\_type}
-
-\TbpImp{unique\_initialize}
-\begin{Verbatim}
- subroutine unique_initialize(this,id,name)
- class(unique_type),intent(out)::this
- integer(kind=dik),intent(in)::id
- character(len=*),intent(in)::name
- call identified_initialize(this,id,name)
- last_id=last_id+1
- this%unique_id=last_id
- end subroutine unique_initialize
-\end{Verbatim}
-
-\TbpImp{unique\_get\_unique\_id}
-\begin{Verbatim}
- elemental function unique_get_unique_id(this)
- class(unique_type),intent(in)::this
- integer(kind=dik)::unique_get_unique_id
- unique_get_unique_id=this%unique_id
- end function unique_get_unique_id
-\end{Verbatim}
-\MethodsFor{serializable\_ref\_type}
-\TbpImp{serializable\_ref\_finalize}
-\begin{Verbatim}
- subroutine serializable_ref_finalize(this)
- class(serializable_ref_type),intent(inout)::this
- class(serializable_ref_type),pointer::next
- do while (associated(this%next))
- next=>this%next
- this%next=>next%next
- nullify(next%ref)
- deallocate(next)
- end do
- if(associated(this%ref))nullify(this%ref)
- end subroutine serializable_ref_finalize
-\end{Verbatim}
-\MethodsFor{position\_stack\_type}
-\TbpImp{position\_stack\_push\_head}
-\begin{Verbatim}
- subroutine position_stack_push_head(this)
- class(position_stack_type)::this
- class(position_stack_type),pointer::new
- allocate(new)
- new%next=>this%next
- new%position=this%position
- this%next=>new
- end subroutine position_stack_push_head
-\end{Verbatim}
-
-\TbpImp{position\_stack\_push\_given}
-\begin{Verbatim}
- subroutine position_stack_push_given(this,position)
- class(position_stack_type)::this
- integer(kind=dik),dimension(2),intent(in)::position
- class(position_stack_type),pointer::new
- allocate(new)
- new%next=>this%next
- new%position=position
- this%next=>new
- end subroutine position_stack_push_given
-\end{Verbatim}
-
-\TbpImp{position\_stack\_pop}
-\begin{Verbatim}
- subroutine position_stack_pop(this)
- class(position_stack_type)::this
- class(position_stack_type),pointer::old
- if(associated(this%next))then
- old=>this%next
- this%next=>old%next
- this%position=old%position
- deallocate(old)
- end if
- end subroutine position_stack_pop
-\end{Verbatim}
-
-\TbpImp{position\_stack\_drop}
-\begin{Verbatim}
- subroutine position_stack_drop(this,position)
- class(position_stack_type)::this
- integer(kind=dik),dimension(2),intent(out)::position
- class(position_stack_type),pointer::old
- if(associated(this%next))then
- old=>this%next
- this%next=>old%next
- position=old%position
- deallocate(old)
- else
- position=[0,0]
- end if
- end subroutine position_stack_drop
-\end{Verbatim}
-
-\TbpImp{position\_stack\_nth\_position}
-\begin{Verbatim}
- function position_stack_nth_position(this,n) result(position)
- class(position_stack_type),intent(in)::this
- integer(kind=dik),intent(in)::n
- integer(kind=dik),dimension(2)::position
- class(position_stack_type),pointer::tmp
- integer(kind=dik)::pos
- tmp=>this%next
- pos=n
- do while(associated(tmp).and.pos>0)
- tmp=>tmp%next
- pos=pos-1
- end do
- if(associated(tmp))then
- position=tmp%position
- else
- position=[0,0]
- end if
- end function position_stack_nth_position
-\end{Verbatim}
-
-\TbpImp{position\_stack\_first}
-\begin{Verbatim}
- function position_stack_first(this) result(position)
- class(position_stack_type),intent(in)::this
- integer(kind=dik),dimension(2)::position,tmp_position
- class(position_stack_type),pointer::tmp_stack
- tmp_position=this%position
- tmp_stack=>this%next
- do while(associated(tmp_stack))
- if(page_ring_position_is_before(tmp_stack%position,tmp_position))then
- tmp_position=tmp_stack%position
- end if
- tmp_stack=>tmp_stack%next
- end do
- end function position_stack_first
-\end{Verbatim}
-
-\TbpImp{position\_stack\_last}
-\begin{Verbatim}
- function position_stack_last(this) result(position)
- class(position_stack_type),intent(in)::this
- integer(kind=dik),dimension(2)::position,tmp_position
- class(position_stack_type),pointer::tmp_stack
- tmp_position=this%position
- tmp_stack=>this%next
- do while(associated(tmp_stack))
- if(page_ring_position_is_before(tmp_position,tmp_stack%position))then
- tmp_position=tmp_stack%position
- end if
- tmp_stack=>tmp_stack%next
- end do
- end function position_stack_last
-\end{Verbatim}
-
-\TbpImp{position\_stack\_range}
-\begin{Verbatim}
- pure function position_stack_range(this) result(position)
- class(position_stack_type),intent(in)::this
- integer(kind=dik),dimension(2)::position
- class(position_stack_type),pointer::tmp
- end function position_stack_range
-\end{Verbatim}
-\MethodsFor{page\_ring\_type}
-\TbpImp{page\_ring\_open\_for\_read\_access}
-\begin{Verbatim}
- subroutine page_ring_open_for_read_access(this,file,eof_string,asynchronous)
- class(page_ring_type),intent(inout)::this
- character(*),intent(in)::file,eof_string
- logical,intent(in),optional::asynchronous
- logical::exist
- this%eof_string=eof_string
- inquire(file=file,exist=exist)
- if(exist)then
- this%action=2
- else
- print *,"page_ring_open: File ",file," is opened for read access but &
- &does not exist. STOP."
- STOP
- end if
-
- if(present(asynchronous))this%asynchronous=asynchronous
- if(this%unit<0)call generate_unit(this%unit,100,1000)
- if(this%unit<0)then
- print *,"page_ring_open: No free unit found. STOP."
- STOP
- end if
- this%ring_size=2
- call this%set_position([zero,one])
- this%active_pages=[zero,-one]
- if(allocated(this%ring))deallocate(this%ring)
- allocate(this%ring(zero:this%ring_size-one))
- if(this%asynchronous)then
- open(this%unit,&
- file=file,&
- access="stream",&
- action="read",&
- asynchronous="yes",&
- status="old")
- else
- open(this%unit,&
- file=file,&
- access="stream",&
- action="read",&
- asynchronous="no",&
- status="old")
- end if
- call this%read_page()
- end subroutine page_ring_open_for_read_access
-\end{Verbatim}
-
-\TbpImp{page\_ring\_open\_for\_write\_access}
-\begin{Verbatim}
- subroutine page_ring_open_for_write_access(this,file,asynchronous)
- class(page_ring_type),intent(inout)::this
- character(*),intent(in)::file
- logical,intent(in),optional::asynchronous
- this%action=1
-
- if(present(asynchronous))this%asynchronous=asynchronous
- if(this%unit<0)call generate_unit(this%unit,100,1000)
- if(this%unit<0)then
- print *,"page_ring_open: No free unit found. STOP."
- STOP
- end if
- this%ring_size=2
- call this%set_position([zero,one])
- this%active_pages=[zero,-one]
- if(allocated(this%ring))deallocate(this%ring)
- allocate(this%ring(zero:this%ring_size-one))
-
- if(this%asynchronous)then
- open(this%unit,&
- file=file,&
- access="stream",&
- action="write",&
- asynchronous="yes",&
- status="replace")
- else
- open(this%unit,&
- file=file,&
- access="stream",&
- action="write",&
- asynchronous="no",&
- status="replace")
- end if
- end subroutine page_ring_open_for_write_access
-\end{Verbatim}
-
-\TbpImp{page\_ring\_close}
-\begin{Verbatim}
- subroutine page_ring_close(this)
- class(page_ring_type),intent(inout)::this
- if(this%action==1)then
- call this%flush()
- !call this%print_position()
- if(this%asynchronous)then
- write(this%unit,asynchronous="yes")&
- &this%ring(this%actual_index())(:this%actual_offset()-1)
- else
- write(this%unit,asynchronous="no")&
- &this%ring(this%actual_index())(:this%actual_offset()-1)
- end if
- end if
- close(this%unit)
- end subroutine page_ring_close
-\end{Verbatim}
-
-\TbpImp{page\_ring\_read\_page}
-\begin{Verbatim}
- subroutine page_ring_read_page(this)
- class(page_ring_type),intent(inout)::this
- integer(kind=dik)::iostat
- character(8)::iomsg
- if(.not.this%eof_reached)then
- call page_ring_activate_next_page(this)
- read(this%unit,iostat=iostat)this%ring(this%last_index())
- if(iostat==iostat_end)then
- this%eof_reached=.true.
- this%eof_pos(1)=this%last_page()
- this%eof_pos(2)=index(this%ring(this%last_index()),char(this%eof_string))
- this%eof_pos(2)=this%eof_pos(2)+len(this%eof_string)-1
- this%eof_int=page_ring_ordinal(this%eof_pos)
- end if
- end if
- end subroutine page_ring_read_page
-\end{Verbatim}
-
-\TbpImp{page\_ring\_enlarge}
-\begin{Verbatim}
- subroutine page_ring_enlarge(this)
- class(page_ring_type),intent(inout)::this
- character(serialize_page_size),dimension(:),allocatable::tmp_ring
- integer(kind=dik)::n
- call move_alloc(this%ring,tmp_ring)
- allocate(this%ring(0:this%ring_size*2-1))
- do n=this%active_pages(1),this%active_pages(2)
- this%ring(mod(n,this%ring_size*2))=tmp_ring(mod(n,this%ring_size))
- end do
- this%ring_size=this%ring_size*2
- end subroutine page_ring_enlarge
-\end{Verbatim}
-
-\TbpImp{page\_ring\_print\_to\_unit}
-\begin{Verbatim}
- subroutine page_ring_print_to_unit(this,unit,parents,components,peers)
- class(page_ring_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- write(unit,'("Components of page_ring_type:")')
- print *,"asynchronous: ",this%asynchronous
- print *,"eof reached: ",this%eof_reached
- print *,"ring_size: ",this%ring_size
- print *,"unit: ",this%unit
- print *,"action: ",this%action
- print *,"position: ",this%position_stack%position
- print *,"active_pages: ",this%active_pages
- print *,"file size: ",this%eof_int
- print *,"eof position: ",this%eof_pos
- print *,"eof string: ",char(this%eof_string)
- if(allocated(this%ring))then
- print *,"Ring is allocated."
- if(components>0)call this%print_ring(unit)
- else
- print *,"Ring is not allocated."
- end if
- end subroutine page_ring_print_to_unit
-\end{Verbatim}
-
-\TbpImp{page\_ring\_print\_ring}
-\begin{Verbatim}
- subroutine page_ring_print_ring(this,unit)
- class(page_ring_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik)::n
- write(unit,fmt=*)"Begin of page ring"
- do n=this%active_pages(1),this%active_pages(2)
- write(unit=unit,fmt="('(',I0,')',a)")n,this%ring(mod(n,this%ring_size))
- end do
- write(unit,fmt=*)"End of page ring"
- end subroutine page_ring_print_ring
-\end{Verbatim}
-
-\TbpImp{page\_ring\_push\_string}
-\begin{Verbatim}
- recursive subroutine page_ring_push_string(this,string)
- class(page_ring_type),intent(inout)::this
- character(*),intent(in)::string
- integer(kind=dik)::cut,l
- l=len(string)
- if(l<=serialize_page_size-this%actual_offset()+1)then
- this%ring(this%actual_index())(this%actual_offset():this%actual_offset()+l-1)=string
- if(l==serialize_page_size-this%actual_offset()+1)then
- call this%break()
- call this%flush()
- else
- call this%proceed(l)
- end if
- else
- cut=serialize_page_size-this%actual_offset()+1
- call this%push_string(string(:cut))
- call this%push_string(string(cut+1:))
- end if
- end subroutine page_ring_push_string
-\end{Verbatim}
-
-\TbpImp{page\_ring\_push\_integer\_dik}
-\begin{Verbatim}
- recursive subroutine page_ring_push_integer_dik(this,int)
- class(page_ring_type),intent(inout)::this
- integer(kind=dik),intent(in)::int
- integer(kind=dik)::int1
- if(int<0)then
- call this%push("-")
- call page_ring_push_integer_dik(this,-int)
- else
- if(int>9)call this%push(int/10)
- int1=mod(int,10*one)
- select case (int1)
- case (0)
- call this%push("0")
- case (1)
- call this%push("1")
- case (2)
- call this%push("2")
- case (3)
- call this%push("3")
- case (4)
- call this%push("4")
- case (5)
- call this%push("5")
- case (6)
- call this%push("6")
- case (7)
- call this%push("7")
- case (8)
- call this%push("8")
- case (9)
- call this%push("9")
- end select
- end if
- end subroutine page_ring_push_integer_dik
-\end{Verbatim}
-
-\TbpImp{page\_ring\_push\_integer}
-\begin{Verbatim}
- subroutine page_ring_push_integer(this,in)
- class(page_ring_type),intent(inout)::this
- integer,intent(in)::in
- call page_ring_push_integer_dik(this,int(in,kind=dik))
- end subroutine page_ring_push_integer
-\end{Verbatim}
-
-\TbpImp{page\_ring\_pop\_integer}
-\begin{Verbatim}
- subroutine page_ring_pop_integer(this,in)
- class(page_ring_type),intent(inout)::this
- integer,intent(out)::in
- integer(kind=dik)::in_dik
- call page_ring_pop_integer_dik(this,in_dik)
- in=int(in_dik)
- end subroutine page_ring_pop_integer
-\end{Verbatim}
-
-\TbpImp{page\_ring\_pop\_integer\_dik}
-\begin{Verbatim}
- subroutine page_ring_pop_integer_dik(this,int)
- class(page_ring_type),intent(inout)::this
- integer(kind=dik),intent(out)::int
- integer(kind=dik)::int1
- integer(kind=dik)::sign
- character::c
- int=0
- sign=1
- c=" "
- do while(scan(c,serialize_integer_characters)==0)
- call this%pop_character(c)
- end do
- if(c=="-")then
- sign=-1
- call this%pop_character(c)
- end if
- do while(scan(c,serialize_integer_characters)>0)
- int=int*10
- select case (c)
- case ("1")
- int=int+1
- case ("2")
- int=int+2
- case ("3")
- int=int+3
- case ("4")
- int=int+4
- case ("5")
- int=int+5
- case ("6")
- int=int+6
- case ("7")
- int=int+7
- case ("8")
- int=int+8
- case ("9")
- int=int+9
- end select
- call this%pop_character(c)
- end do
- int=int*sign
- if(c=="<")call this%proceed(-one)
- end subroutine page_ring_pop_integer_dik
-\end{Verbatim}
-
-\TbpImp{page\_ring\_pop\_logical}
-\begin{Verbatim}
- subroutine page_ring_pop_logical(this,l)
- class(page_ring_type),intent(inout)::this
- logical,intent(out)::l
- character(1)::lc
- call this%pop(lc)
- do while(scan(lc,"tTfF")==0)
- call this%pop(lc)
- end do
- read(lc,fmt="(l1)")l
- end subroutine page_ring_pop_logical
-\end{Verbatim}
-
-\TbpImp{page\_ring\_push\_integer\_array\_dik}
-\begin{Verbatim}
- subroutine page_ring_push_integer_array_dik(this,int)
- class(page_ring_type),intent(inout)::this
- integer(kind=dik),dimension(:),intent(in)::int
- integer(kind=dik)::n
- do n=1,size(int)
- call this%push(int(n))
- call this%push(" ")
- end do
- end subroutine page_ring_push_integer_array_dik
-\end{Verbatim}
-
-\TbpImp{page\_ring\_push\_integer\_array}
-\begin{Verbatim}
- subroutine page_ring_push_integer_array(this,int)
- class(page_ring_type),intent(inout)::this
- integer,dimension(:),intent(in)::int
- integer::n
- do n=1,size(int)
- call this%push(int(n))
- call this%push(" ")
- end do
- end subroutine page_ring_push_integer_array
-\end{Verbatim}
-
-\TbpImp{page\_ring\_pop\_integer\_array}
-\begin{Verbatim}
- subroutine page_ring_pop_integer_array(this,int)
- class(page_ring_type),intent(inout)::this
- integer,dimension(:),intent(out)::int
- integer::n
- do n=1,size(int)
- call this%pop(int(n))
- end do
- end subroutine page_ring_pop_integer_array
-\end{Verbatim}
-
-\TbpImp{page\_ring\_pop\_integer\_array\_dik}
-\begin{Verbatim}
- subroutine page_ring_pop_integer_array_dik(this,int)
- class(page_ring_type),intent(inout)::this
- integer(kind=dik),dimension(:),intent(out)::int
- integer(kind=dik)::n
- do n=1,size(int)
- call this%pop(int(n))
- end do
- end subroutine page_ring_pop_integer_array_dik
-\end{Verbatim}
-
-\TbpImp{page\_ring\_push\_double}
-\begin{Verbatim}
- subroutine page_ring_push_double(this,dou)
- class(page_ring_type),intent(inout)::this
- real(kind=drk),intent(in)::dou
- integer(kind=dik)::f
-! print *,"page_ring_push_double: ",dou
- if(dou==0D0)then
- call this%push("0")
- else
- f=int(scale(fraction(dou),digits(dou)),kind=dik)
- call this%push(digits(dou))
- call this%push(":")
- call this%push(f)
- call this%push(":")
- call this%push(exponent(dou))
- end if
- call this%push(" ")
- end subroutine page_ring_push_double
-\end{Verbatim}
-
-\TbpImp{page\_ring\_push\_double\_array}
-\begin{Verbatim}
- subroutine page_ring_push_double_array(this,dou)
- class(page_ring_type),intent(inout)::this
- real(kind=drk),dimension(:),intent(in)::dou
- integer(kind=dik)::n
- do n=1,size(dou)
- call this%push(dou(n))
- end do
- end subroutine page_ring_push_double_array
-\end{Verbatim}
-
-\TbpImp{page\_ring\_pop\_double}
-\begin{Verbatim}
- subroutine page_ring_pop_double(this,dou,skip)
- class(page_ring_type),intent(inout)::this
- real(kind=drk),intent(out)::dou
- logical,optional,intent(in)::skip
- integer(kind=dik)::d,f,e
- call this%pop(d)
- if(d==zero)then
- dou=0D0
- else
- call this%pop(f)
- call this%pop(e)
- dou=set_exponent(scale(real(f,kind=double),-d),e)
- end if
- if(present(skip))then
- if(.not.skip)call this%proceed(-one)
- end if
- end subroutine page_ring_pop_double
-\end{Verbatim}
-
-\TbpImp{page\_ring\_pop\_double\_array}
-\begin{Verbatim}
- subroutine page_ring_pop_double_array(this,dou,skip)
- class(page_ring_type),intent(inout)::this
- real(kind=drk),dimension(:),intent(out)::dou
- logical,optional,intent(in)::skip
- integer(kind=dik)::n
- call this%pop_double(dou(1))
- do n=2,size(dou)
- call this%pop_double(dou(n))
- end do
- if(present(skip))then
- if(.not.skip)call this%proceed(-one)
- end if
- end subroutine page_ring_pop_double_array
-\end{Verbatim}
-
-\TbpImp{page\_ring\_pop\_character}
-\begin{Verbatim}
- subroutine page_ring_pop_character(this,c)
- class(page_ring_type),intent(inout)::this
- character,intent(out)::c
- c=this%ring(this%actual_index())(this%actual_offset():this%actual_offset())
- if(this%actual_offset()==serialize_page_size)call this%read_page
- call this%proceed(one)
- end subroutine page_ring_pop_character
-\end{Verbatim}
-
-\TbpImp{page\_ring\_pop\_string}
-\begin{Verbatim}
- recursive subroutine page_ring_pop_string(this,res)
- class(page_ring_type),intent(inout)::this
- character(len=*),intent(out)::res
- integer(kind=dik)::n,cut
- n=len(res)
- cut=serialize_page_size-this%actual_offset()+1
- if(n<=cut)then
- res=this%ring(this%actual_index())(this%actual_offset():this%actual_offset()+n)
- if(n==cut)then
- call this%read_page
- end if
- call this%proceed(n)
- else
- call page_ring_pop_string(this,res(:cut))
- call page_ring_pop_string(this,res(cut+1:))
- end if
- end subroutine page_ring_pop_string
-\end{Verbatim}
-
-\TbpImp{page\_ring\_substring2}
-\begin{Verbatim}
- pure function page_ring_substring2(this,i1,i2) result(res)
- class(page_ring_type),intent(in)::this
- integer(kind=dik),dimension(2),intent(in)::i1,i2
- character(ring_position_metric2(i1,i2))::res
- integer(kind=dik)::page,pos
- if(i1(1)==i2(1))then
- res=this%ring(mod(i1(1),this%ring_size))(i1(2):i2(2))
- else
- pos=serialize_page_size-i1(2)
- res(1:pos+1)=this%ring(mod(i1(1),this%ring_size))(i1(2):)
- do page=i1(1)+1,i2(1)-1
- res(pos+2:pos+2+serialize_page_size)=this%ring(mod(page,this%ring_size))
- pos=pos+serialize_page_size
- end do
- res(pos+2:pos+1+i2(2))=this%ring(mod(page,this%ring_size))(1:i2(2))
- end if
- end function page_ring_substring2
-\end{Verbatim}
-
-\TbpImp{page\_ring\_substring1}
-\begin{Verbatim}
- pure function page_ring_substring1(this,i) result(res)
- class(page_ring_type),intent(in)::this
- integer(kind=dik),dimension(2,2),intent(in)::i
- character(ring_position_metric1(i))::res
- integer(kind=dik)::page,pos
- if(i(1,1)==i(1,2))then
- res=this%ring(mod(i(1,1),this%ring_size))(i(2,1):i(2,2))
- else
- pos=serialize_page_size-i(2,1)
- res(1:pos+1)=this%ring(mod(i(1,1),this%ring_size))(i(2,1):)
- do page=i(1,1)+1,i(1,1)-1
- res(pos+2:pos+2+serialize_page_size)=this%ring(mod(page,this%ring_size))
- pos=pos+serialize_page_size
- end do
- res(pos+2:pos+1+i(2,2))=this%ring(mod(page,this%ring_size))(1:i(2,2))
- end if
- end function page_ring_substring1
-\end{Verbatim}
-
-\TbpImp{page\_ring\_allocate\_substring}
-\begin{Verbatim}
- subroutine page_ring_allocate_substring(this,p1,p2,string)
- class(page_ring_type),intent(in)::this
- integer(kind=dik),dimension(2),intent(in)::p1,p2
- character(:),allocatable,intent(out)::string
- string=page_ring_substring2(this,p1,p2)
- end subroutine page_ring_allocate_substring
-\end{Verbatim}
-
-\TbpImp{page\_ring\_find\_default}
-\begin{Verbatim}
- subroutine page_ring_find_default(this,exp,skip,proceed,pos)
- class(page_ring_type),intent(inout)::this
- character(*),optional,intent(in)::exp
- integer,intent(in)::skip
- logical,intent(in)::proceed
- integer(kind=dik),dimension(2),intent(out)::pos
- call page_ring_find(this,exp,this%position_stack%position,this%eof_pos,skip,proceed,pos)
- end subroutine page_ring_find_default
-\end{Verbatim}
-
-\TbpImp{page\_ring\_find}
-\begin{Verbatim}
- recursive subroutine page_ring_find(this,exp,start,limit,skip,proceed,pos)
- class(page_ring_type),intent(inout)::this
- integer(kind=dik),dimension(2),intent(in)::start
- integer(kind=dik),dimension(2),intent(in)::limit
- character(*),intent(in)::exp
- integer,intent(in)::skip
- logical,intent(in)::proceed
- integer(kind=dik),dimension(2),intent(out)::pos
- integer(kind=dik)::page,page2,ind
- page=this%ring_index(start(1))
- if(limit(1)==start(1))then
- ind=index(this%ring(page)(start(2):limit(2)),exp)
- if(ind>0)then
- select case (skip)
- case(1)
- pos=[start(1),start(2)+ind-2]
- if(pos(2)==0)then
- pos(1)=pos(1)-1
- pos(2)=serialize_page_size
- end if
- case(2)
- pos=[start(1),start(2)+ind-1]
- case(3)
- pos=[start(1),start(2)+ind+len(exp)-2]
- case(4)
- pos=[start(1),start(2)+ind+len(exp)-1]
- if(pos(1)==this%last_page())call this%read_page()
- if(pos(2)>serialize_page_size)then
- pos(1)=pos(1)+1
- pos(2)=pos(2)-serialize_page_size
- end if
- end select
- if(proceed)call this%set_position(pos)
- else
- print *,"page_ring_find: limit reached."
- pos=[-1,-1]
- end if
- else
- ind=index(this%ring(page)(start(2):),exp)
- if(ind>0)then
- select case (skip)
- case(1)
- pos=[start(1),start(2)+ind-2]
- if(pos(2)==0)then
- pos(1)=pos(1)-1
- pos(2)=serialize_page_size
- end if
- case(2)
- pos=[start(1),start(2)+ind-1]
- case(3)
- pos=[start(1),start(2)+ind+len(exp)-2]
- case(4)
- pos=[start(1),start(2)+ind+len(exp)-1]
- if(pos(1)==this%last_page())call this%read_page()
- if(pos(2)>serialize_page_size)then
- pos(1)=pos(1)+1
- pos(2)=one
- end if
- end select
- if(proceed)call this%set_position(pos)
- else
- if(start(1)+1>this%active_pages(2))then
- call this%read_page()
- page=this%ring_index(start(1))
- end if
- page2=this%ring_index(start(1)+1)
- ind=index(this%ring(page)(serialize_page_size-len(exp)+1:)&
- //this%ring(page2)(:len(exp)),exp)
- if(ind>0)then
- select case (skip)
- case(1)
- pos=[start(1),serialize_page_size-len(exp)+ind-1]
- case(2)
- pos=[start(1),serialize_page_size-len(exp)+ind]
- case(3)
- pos=[start(1)+1,ind-1]
- case(4)
- pos=[start(1)+1,ind]
- end select
- if(pos(2)>serialize_page_size)then
- pos(1)=pos(1)+1
- pos(2)=pos(2)-serialize_page_size
- else
- if(pos(2)<0)then
- pos(1)=pos(1)-1
- pos(2)=pos(2)+serialize_page_size
- end if
- end if
- if(proceed)call this%set_position(pos)
- else
- if(proceed)this%active_pages(1)=this%active_pages(2)
- call page_ring_find(this,exp,[start(1)+one,one],limit,skip,proceed,pos)
- end if
- end if
- end if
- end subroutine page_ring_find
-\end{Verbatim}
-
-\TbpImp{page\_ring\_str\_equal}
-\begin{Verbatim}
- pure logical function page_ring_str_equal(this,string,pos)
- class(page_ring_type),intent(in)::this
- character(*),intent(in)::string
- integer(kind=dik),dimension(2,2),intent(in)::pos
- page_ring_str_equal=string==this%substring(pos)
- end function page_ring_str_equal
-\end{Verbatim}
-
-\TbpImp{page\_ring\_find\_pure}
-\begin{Verbatim}
- pure recursive function page_ring_find_pure(this,exp,start,limit,skip) result(pos)
- class(page_ring_type),intent(in)::this
- integer(kind=dik),dimension(2),intent(in)::start
- integer(kind=dik),dimension(2),intent(in)::limit
- character(*),intent(in)::exp
- integer,optional,intent(in)::skip
- integer(kind=dik),dimension(2)::pos
- integer(kind=dik)::page,page2,ind,actual_skip
- ! Is the starting point before limit?
- if(start(1)<=limit(1))then
- ! Default skip is what you expect from the build-in index function
- if(present(skip))then
- actual_skip=skip
- else
- actual_skip=2
- end if
- page=mod(start(1),this%ring_size)
- ! Does the scanning region end on the page?
- if(start(1)==limit(1))then
- ind=index(this%ring(page)(start(2):limit(2)),exp)
- else
- ind=index(this%ring(page)(start(2):),exp)
- end if
- if(ind>0)then
- ! substring found on first page
- select case (actual_skip)
- case(1)
- pos=[start(1),start(2)+ind-2]
- if(pos(2)==0)then
- pos(1)=pos(1)-1
- pos(2)=serialize_page_size
- end if
- case(2)
- pos=[start(1),start(2)+ind-1]
- case(3)
- pos=[start(1),start(2)+ind+len(exp)-2]
- case(4)
- pos=[start(1),start(2)+ind+len(exp)-1]
- if(pos(2)>serialize_page_size)then
- pos(1)=pos(1)+1
- pos(2)=pos(2)-serialize_page_size
- end if
- end select
- else
- ! Substring not found on first page. Is the next page already read?
- if((start(1)>=limit(1)).or.(start(1)+1>this%active_pages(2)))then
- ! Either the limit is reached or the next page is not ready.
- pos=[0,0]
- else
- ! The next page is available.
- page2=mod(start(1)+1,this%ring_size)
- ! We concatenate the edges. When l is the length of exp, then we want to concat
- ! the l-1 last characters of page one and the first l characters of page two.
- ind=index(this%ring(page)(serialize_page_size-len(exp)+2:)&
- //this%ring(page2)(:len(exp)),exp)
- if(ind>0)then
- select case (actual_skip)
- case(1)
- pos=[start(1),serialize_page_size-len(exp)+ind]
- case(2)
- pos=[start(1),serialize_page_size-len(exp)+ind+1]
- case(3)
- pos=[start(1)+1,ind]
- case(4)
- pos=[start(1)+1,ind+1]
- end select
- else
- ! EXP is not found in the overlap region. We recursively search the next pages.
- pos=page_ring_find_pure(this,exp,[start(one)+one,one],limit,skip)
- end if
- end if
- end if
- else
- ! limit is before start
- pos=[0,0]
- end if
- end function page_ring_find_pure
-\end{Verbatim}
-
-\TbpImp{page\_ring\_positions\_by\_keys}
-\begin{Verbatim}
- pure recursive subroutine page_ring_positions_by_keys&
- (this,exp1,exp2,start,limit,inclusive,length,pos)
- class(page_ring_type),intent(in)::this
- character(*),intent(in)::exp1,exp2
- integer(kind=dik),dimension(2),intent(in)::start,limit
- logical,optional,intent(in)::inclusive
- integer(kind=dik),intent(out),optional::length
- integer(kind=dik),dimension(2,2),intent(out)::pos
- if(inclusive)then
- pos(1:2,1)=this%find_pure(exp1,start,limit,2)
- else
- pos(1:2,1)=this%find_pure(exp1,start,limit,4)
- end if
- !print *,pos1
- if(present(length))then
- length=0
- end if
- if(pos(2,1)>0)then
- if(inclusive)then
- pos(1:2,2)=this%find_pure(exp2,pos(1:2,1),limit,3)
- else
- pos(1:2,2)=this%find_pure(exp2,pos(1:2,1),limit,1)
- end if
- !print *,pos2
- if(pos(2,2)>0)then
- if(present(length))then
- length=ring_position_metric1(pos)
- end if
- end if
- end if
- end subroutine page_ring_positions_by_keys
-\end{Verbatim}
-
-\TbpImp{page\_ring\_character\_by\_keys}
-\begin{Verbatim}
- pure recursive subroutine page_ring_character_by_keys&
- (this,exp1,exp2,start,limit,inclusive,length,string)
- class(page_ring_type),intent(in)::this
- character(*),intent(in)::exp1,exp2
- integer(kind=dik),dimension(2),intent(in)::start,limit
- logical,optional,intent(in)::inclusive
- integer(kind=dik),intent(out),optional::length
- character(:),allocatable,intent(out)::string
- integer(kind=dik),dimension(2,2)::pos
- call this%substring_by_keys(exp1,exp2,start,limit,inclusive,length,pos)
- string=this%substring(pos(:,1),pos(:,2))
- end subroutine page_ring_character_by_keys
-\end{Verbatim}
-
-\TbpImp{page\_ring\_pop\_by\_keys}
-\begin{Verbatim}
- subroutine page_ring_pop_by_keys(this,start,stop,inclusive,res)
- class(page_ring_type),intent(inout)::this
- character(*),intent(in),optional::start
- character(*),intent(in)::stop
- logical,optional,intent(in)::inclusive
- character(len=*),intent(out)::res
- integer(kind=dik),dimension(2)::i1,i2
- if(inclusive)then
- call this%find(start,2,.true.,i1)
- call this%find(stop,3,.false.,i2)
- else
- call this%find(start,4,.true.,i1)
- call this%find(stop,1,.false.,i2)
- end if
- res=this%substring(i1,i2)
- call this%set_position(i2)
- end subroutine page_ring_pop_by_keys
-\end{Verbatim}
-
-\TbpImp{page\_ring\_get\_character}
-\begin{Verbatim}
- elemental function page_ring_get_character(this)
- class(page_ring_type),intent(in)::this
- character::page_ring_get_character
- page_ring_get_character=&
- this%ring(this%actual_index())(this%actual_offset():this%actual_offset())
- end function page_ring_get_character
-\end{Verbatim}
-
-\TbpImp{page\_ring\_break}
-\begin{Verbatim}
- subroutine page_ring_break(this)
- class(page_ring_type),intent(inout)::this
- if(this%actual_page()>=this%active_pages(2))call this%activate_next_page()
- call this%turn_page()
- end subroutine page_ring_break
-\end{Verbatim}
-
-\TbpImp{page\_ring\_turn\_page}
-\begin{Verbatim}
- subroutine page_ring_turn_page(this)
- class(page_ring_type),intent(inout)::this
- this%position_stack%position(1)=this%position_stack%position(1)+1
- this%position_stack%position(2)=1
- end subroutine page_ring_turn_page
-\end{Verbatim}
-
-\TbpImp{page\_ring\_flush}
-\begin{Verbatim}
- subroutine page_ring_flush(this)
- class(page_ring_type),intent(inout)::this
- integer(kind=dik)::page
- do while(this%active_pages(1)<this%actual_page())
- if(this%asynchronous)then
- write(this%unit,asynchronous="yes")this%ring(mod(this%active_pages(1),this%ring_size))
- else
- write(this%unit,asynchronous="no")this%ring(mod(this%active_pages(1),this%ring_size))
- end if
- this%active_pages(1)=this%active_pages(1)+1
- end do
- end subroutine page_ring_flush
-\end{Verbatim}
-
-\TbpImp{page\_ring\_activate\_next\_page}
-\begin{Verbatim}
- subroutine page_ring_activate_next_page(this)
- class(page_ring_type),intent(inout)::this
- if(this%active_pages(2)-this%active_pages(1)+1>=this%ring_size)call this%enlarge
- this%active_pages(2)=this%active_pages(2)+1
- end subroutine page_ring_activate_next_page
-\end{Verbatim}
-
-\TbpImp{page\_ring\_set\_position}
-\begin{Verbatim}
- subroutine page_ring_set_position(this,pos)
- class(page_ring_type),intent(inout)::this
- integer(kind=dik),dimension(2),intent(in)::pos
- this%position_stack%position=pos
- end subroutine page_ring_set_position
-\end{Verbatim}
-
-\TbpImp{page\_ring\_put}
-\begin{Verbatim}
- subroutine page_ring_put(this)
- class(page_ring_type),intent(inout)::this
- end subroutine page_ring_put
-\end{Verbatim}
-
-\TbpImp{page\_ring\_proceed}
-\begin{Verbatim}
- subroutine page_ring_proceed(this,n,deactivate)
- class(page_ring_type),intent(inout)::this
- integer(kind=dik),intent(in)::n
- logical,intent(in),optional::deactivate
- integer(kind=dik)::offset
- offset=this%position_stack%position(2)+n
- do while (offset>serialize_page_size)
- if(this%position_stack%position(1)&
- >=this%active_pages(2))call this%activate_next_page()
- this%position_stack%position(1)=this%position_stack%position(1)+1
- offset=offset-serialize_page_size
- end do
- this%position_stack%position(2)=offset
- if(present(deactivate))then
- if(deactivate)this%active_pages(1)=this%actual_page()
- end if
- end subroutine page_ring_proceed
-\end{Verbatim}
-
-\TbpImp{page\_ring\_print\_position}
-\begin{Verbatim}
- subroutine page_ring_print_position(this)
- class(page_ring_type),intent(inout)::this
- print *,&
- this%actual_position(),&
- this%ring(this%actual_index())(:this%actual_offset()-1),&
- "|",&
- this%ring(this%actual_index())(this%actual_offset():)
- end subroutine page_ring_print_position
-\end{Verbatim}
-
-\TbpImp{page\_ring\_ring\_index}
-\begin{Verbatim}
- elemental integer(kind=dik) function page_ring_ring_index(this,n)
- class(page_ring_type),intent(in)::this
- integer(kind=dik),intent(in)::n
- page_ring_ring_index=mod(n,this%ring_size)
- end function page_ring_ring_index
-\end{Verbatim}
-
-\TbpImp{page\_ring\_ring\_push\_given\_position}
-\begin{Verbatim}
- subroutine page_ring_ring_push_given_position(this,pos)
- class(page_ring_type),intent(inout)::this
- integer(kind=dik),dimension(2),intent(in)::pos
- call this%position_stack%push(pos)
- end subroutine page_ring_ring_push_given_position
-\end{Verbatim}
-
-\TbpImp{page\_ring\_ring\_pop\_actual\_position}
-\begin{Verbatim}
- subroutine page_ring_ring_pop_actual_position(this)
- class(page_ring_type),intent(inout)::this
- call this%position_stack%pop()
- end subroutine page_ring_ring_pop_actual_position
-\end{Verbatim}
-
-\TbpImp{page\_ring\_ring\_push\_actual\_position}
-\begin{Verbatim}
- subroutine page_ring_ring_push_actual_position(this)
- class(page_ring_type),intent(inout)::this
- call this%position_stack%push()
- end subroutine page_ring_ring_push_actual_position
-\end{Verbatim}
-
-\TbpImp{page\_ring\_ring\_pop\_given\_position}
-\begin{Verbatim}
- subroutine page_ring_ring_pop_given_position(this,pos)
- class(page_ring_type),intent(inout)::this
- integer(kind=dik),dimension(2),intent(out)::pos
- call this%position_stack%pop(pos)
- end subroutine page_ring_ring_pop_given_position
-\end{Verbatim}
-
-\TbpImp{page\_ring\_get\_position1}
-\begin{Verbatim}
- pure subroutine page_ring_get_position1(this,pos)
- class(page_ring_type),intent(in)::this
- integer(kind=dik),intent(out)::pos
- pos=page_ring_ordinal(this%position_stack%position)
- end subroutine page_ring_get_position1
-\end{Verbatim}
-
-\TbpImp{page\_ring\_get\_position2}
-\begin{Verbatim}
- pure subroutine page_ring_get_position2(this,pos)
- class(page_ring_type),intent(in)::this
- integer(kind=dik),dimension(2),intent(out)::pos
- pos=this%position_stack%position
- end subroutine page_ring_get_position2
-\end{Verbatim}
-
-\TbpImp{page\_ring\_actual\_index}
-\begin{Verbatim}
- elemental integer(kind=dik) function page_ring_actual_index(this)
- class(page_ring_type),intent(in)::this
- page_ring_actual_index=mod(this%position_stack%position(1),this%ring_size)
- end function page_ring_actual_index
-\end{Verbatim}
-
-\TbpImp{page\_ring\_actual\_page}
-\begin{Verbatim}
- elemental integer(kind=dik) function page_ring_actual_page(this)
- class(page_ring_type),intent(in)::this
- page_ring_actual_page=this%position_stack%position(1)
- end function page_ring_actual_page
-\end{Verbatim}
-
-\TbpImp{page\_ring\_actual\_offset}
-\begin{Verbatim}
- elemental integer(kind=dik) function page_ring_actual_offset(this)
- class(page_ring_type),intent(in)::this
- page_ring_actual_offset=this%position_stack%position(2)
- end function page_ring_actual_offset
-\end{Verbatim}
-
-\TbpImp{page\_ring\_actual\_position}
-\begin{Verbatim}
- pure function page_ring_actual_position(this)
- class(page_ring_type),intent(in)::this
- integer(kind=dik),dimension(2)::page_ring_actual_position
- page_ring_actual_position=this%position_stack%position
- end function page_ring_actual_position
-\end{Verbatim}
-
-\TbpImp{page\_ring\_first\_index}
-\begin{Verbatim}
- elemental integer(kind=dik) function page_ring_first_index(this)
- class(page_ring_type),intent(in)::this
- page_ring_first_index=mod(this%active_pages(1),this%ring_size)
- end function page_ring_first_index
-\end{Verbatim}
-
-\TbpImp{page\_ring\_first\_page}
-\begin{Verbatim}
- elemental integer(kind=dik) function page_ring_first_page(this)
- class(page_ring_type),intent(in)::this
- page_ring_first_page=this%active_pages(1)
- end function page_ring_first_page
-\end{Verbatim}
-
-\TbpImp{page\_ring\_last\_index}
-\begin{Verbatim}
- elemental integer(kind=dik) function page_ring_last_index(this)
- class(page_ring_type),intent(in)::this
- page_ring_last_index=mod(this%active_pages(2),this%ring_size)
- end function page_ring_last_index
-\end{Verbatim}
-
-\TbpImp{page\_ring\_last\_page}
-\begin{Verbatim}
- elemental integer(kind=dik) function page_ring_last_page(this)
- class(page_ring_type),intent(in)::this
- page_ring_last_page=this%active_pages(2)
- end function page_ring_last_page
-\end{Verbatim}
-\MethodsFor{marker\_type}
-
-\TbpImp{marker\_mark\_begin}
-\begin{Verbatim}
- subroutine marker_mark_begin(this,tag,type,name,target,pointer,shape)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::tag
- character(*),intent(in),optional::type,name
- integer(kind=dik),intent(in),optional::target,pointer
- integer,intent(in),dimension(:),optional::shape
- call this%indent()
- call this%push("<")
- call this%push(tag)
- if(present(type))call this%push(' type="'//type//'"')
- if(present(name))call this%push(' name="'//name//'"')
- if(present(target))then
- call this%push(' target="')
- call this%push(target)
- call this%push('"')
- end if
- if(present(pointer))then
- call this%push(' pointer="')
- call this%push(pointer)
- call this%push('"')
- end if
- if(present(shape))then
- call this%push(' shape="')
- call this%push(shape)
- call this%push('"')
- end if
- call this%push(">")
- this%indentation=this%indentation+1
- end subroutine marker_mark_begin
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_instance\_begin}
-\begin{Verbatim}
- subroutine marker_mark_instance_begin(this,ser,name,target,pointer,shape)
- class(marker_type),intent(inout)::this
- class(serializable_class),intent(in)::ser
- character(*),intent(in)::name
- integer(kind=dik),intent(in),optional::target,pointer
- integer,intent(in),dimension(:),optional::shape
- character(:),allocatable::this_type
- call ser%get_type(this_type)
- call this%mark_begin("ser",this_type,name,target,pointer,shape)
- end subroutine marker_mark_instance_begin
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_end}
-\begin{Verbatim}
- subroutine marker_mark_end(this,tag)
- class(marker_type),intent(inout)::this
- character(*),intent(in),optional::tag
- this%indentation=this%indentation-1
- call this%indent()
- if(present(tag))then
- call this%push("</"//tag//">")
- else
- call this%push("</ser>")
- end if
- end subroutine marker_mark_end
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_instance\_end}
-\begin{Verbatim}
- subroutine marker_mark_instance_end(this)
- class(marker_type),intent(inout)::this
- call this%mark_end("ser")
- end subroutine marker_mark_instance_end
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_logical}
-\begin{Verbatim}
- subroutine marker_mark_logical(this,name,content)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- logical,intent(in)::content
- call this%indent()
- call this%push("<"//name//">")
- if(content)then
- call this%push("T")
- else
- call this%push("F")
- end if
- call this%push("</"//name//">")
- end subroutine marker_mark_logical
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_integer}
-\begin{Verbatim}
- subroutine marker_mark_integer(this,name,content)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer,intent(in)::content
- call this%indent()
- call this%push("<"//name//">")
- call this%push(content)
- call this%push("</"//name//">")
- end subroutine marker_mark_integer
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_integer\_array}
-\begin{Verbatim}
- subroutine marker_mark_integer_array(this,name,content)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer,dimension(:),intent(in)::content
- call this%indent()
- call this%push("<"//name//">")
- call this%push(content)
- call this%push("</"//name//">")
- end subroutine marker_mark_integer_array
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_integer\_matrix}
-\begin{Verbatim}
- subroutine marker_mark_integer_matrix(this,name,content)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer,dimension(:,:),intent(in)::content
- integer::n
- integer,dimension(2)::s
- s=shape(content)
- call this%indent()
- call this%push("<"//name//">")
- do n=1,s(2)
- call this%push(content(:,n))
- call this%push(" ")
- end do
- call this%push("</"//name//">")
- end subroutine marker_mark_integer_matrix
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_integer\_dik}
-\begin{Verbatim}
- subroutine marker_mark_integer_dik(this,name,content)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer(kind=dik),intent(in)::content
- call this%indent()
- call this%push("<"//name//">")
- call this%push(content)
- call this%push("</"//name//">")
- end subroutine marker_mark_integer_dik
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_integer\_array\_dik}
-\begin{Verbatim}
- subroutine marker_mark_integer_array_dik(this,name,content)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer(kind=dik),dimension(:),intent(in)::content
- call this%indent()
- call this%push("<"//name//">")
- call this%push(content)
- call this%push("</"//name//">")
- end subroutine marker_mark_integer_array_dik
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_integer\_matrix\_dik}
-\begin{Verbatim}
- subroutine marker_mark_integer_matrix_dik(this,name,content)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer(kind=dik),dimension(:,:),intent(in)::content
- integer::n
- integer,dimension(2)::s
- call this%indent()
- call this%push("<"//name//">")
- do n=1,s(2)
- call this%push(content(:,n))
- call this%push(" ")
- end do
- call this%push("</"//name//">")
- end subroutine marker_mark_integer_matrix_dik
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_double}
-\begin{Verbatim}
- subroutine marker_mark_double(this,name,content)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- real(kind=drk),intent(in)::content
- call this%indent()
- call this%push("<"//name//">")
- call this%push(content)
- call this%push("</"//name//">")
- end subroutine marker_mark_double
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_double\_array}
-\begin{Verbatim}
- subroutine marker_mark_double_array(this,name,content)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- real(kind=drk),dimension(:),intent(in)::content
- call this%indent()
- call this%push("<"//name//">")
- call this%push(content)
- call this%push("</"//name//">")
- end subroutine marker_mark_double_array
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_double\_matrix}
-\begin{Verbatim}
- subroutine marker_mark_double_matrix(this,name,content)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- real(kind=drk),dimension(:,:),intent(in)::content
- integer::n
- integer,dimension(2)::s
- s=shape(content)
- call this%indent()
- call this%push("<"//name//">")
- do n=1,s(2)
- call this%push(content(:,n))
- call this%push(" ")
- end do
- call this%push("</"//name//">")
- end subroutine marker_mark_double_matrix
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_string}
-\begin{Verbatim}
- subroutine marker_mark_string(this,name,content)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name,content
- call this%indent()
- call this%push("<"//name//">")
- call this%push(content)
- call this%push("</"//name//">")
- end subroutine marker_mark_string
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_instance}
-\begin{Verbatim}
- recursive subroutine marker_mark_instance(this,ser,name,target,pointer)
- class(marker_type),intent(inout)::this
- class(serializable_class),intent(in)::ser
- character (len=*), intent(in)::name
- integer(kind=dik),intent(in),optional::target,pointer
- integer(kind=dik)::status
- call this%mark_instance_begin(ser,name,target,pointer)
- call ser%write_to_marker(this,status)
- call this%mark_end("ser")
- end subroutine marker_mark_instance
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_target}
-\begin{Verbatim}
- recursive subroutine marker_mark_target(this,name,ser)
- class(marker_type),intent(inout)::this
- class(serializable_class),target,intent(in)::ser
- character (len=*), intent(in)::name
- this%n_instances=this%n_instances+1
- call this%push_heap(ser,this%n_instances)
- call this%mark_instance(ser,name,target=this%n_instances)
- end subroutine marker_mark_target
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_allocatable}
-\begin{Verbatim}
- subroutine marker_mark_allocatable(this,name,ser)
- class(marker_type),intent(inout)::this
- class(serializable_class),allocatable,intent(in)::ser
- character (len=*), intent(in)::name
- if(allocated(ser))then
- call this%mark_instance(ser,name)
- else
- call this%mark_null(name)
- end if
- end subroutine marker_mark_allocatable
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_pointer}
-\begin{Verbatim}
- recursive subroutine marker_mark_pointer(this,name,ser)
- class(marker_type),intent(inout)::this
- class(serializable_class),pointer,intent(in)::ser
- character(len=*),intent(in)::name
- character(:),allocatable::type
- integer(kind=dik)::p
- if(associated(ser))then
- call this%search_heap(ser,p)
- if(p>0)then
- call ser%get_type(type)
- call this%push('<ser type="')
- call this%push(type)
- call this%push('" name="')
- call this%push(name)
- call this%push('" pointer="')
- call this%push(p)
- call this%push('"/>')
- else
- call this%mark_target(name,ser)
- end if
- else
- call this%mark_null(name)
- end if
- end subroutine marker_mark_pointer
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_null}
-\begin{Verbatim}
- subroutine marker_mark_null(this,name)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- call this%indent()
- call this%push('<ser type="null" name="')
- call this%push(name)
- call this%push('"/>')
- end subroutine marker_mark_null
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_nothing}
-\begin{Verbatim}
- subroutine marker_mark_nothing(this,name)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- call this%indent()
- call this%push('<')
- call this%push(name)
- call this%push('/>')
- end subroutine marker_mark_nothing
-\end{Verbatim}
-
-\TbpImp{marker\_mark\_empty}
-\begin{Verbatim}
- subroutine marker_mark_empty(this,tag,type,name,target,pointer,shape)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::tag
- character(*),intent(in),optional::type,name
- integer(kind=dik),intent(in),optional::target,pointer
- integer,intent(in),dimension(:),optional::shape
- call this%push("<")
- call this%push(tag)
- if(present(type))call this%push(' type="'//type//'"')
- if(present(name))call this%push(' name="'//name//'"')
- if(present(target))then
- call this%push(' target="')
- call this%push(target)
- call this%push('"')
- end if
- if(present(pointer))then
- call this%push(' pointer="')
- call this%push(pointer)
- call this%push('"')
- end if
- if(present(shape))then
- call this%push(' shape="')
- call this%push(shape)
- call this%push('"')
- end if
- call this%push("/>")
- end subroutine marker_mark_empty
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_begin}
-\begin{Verbatim}
- subroutine marker_pick_begin(this,tag,type,name,target,pointer,shape,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::tag
- integer(kind=dik),dimension(2,2),intent(out),optional::type,name
- integer(kind=dik),intent(out),optional::target,pointer
- integer,dimension(:),allocatable,optional,intent(out)::shape
- integer(kind=dik),intent(out)::status
- integer(kind=dik),dimension(2)::p1,p2,p3
- integer(kind=dik)::l
- call this%find("<",skip=4,proceed=.true.,pos=p1)
- call this%find(">",skip=1,proceed=.false.,pos=p2)
- p3=this%find_pure(" ",p1,p2,skip=1)
- if(p3(2)>0)then
- if(this%substring(p1,p3)==tag)then
- status=serialize_ok
- if(present(type))then
- call this%substring_by_keys('type="','"',p3,p2,.false.,l,type)
- if(l<=0)then
- print *,"marker_pick_begin: No type found"
- status=serialize_wrong_type
- end if
- end if
- if(present(name))then
- call this%substring_by_keys('name="','"',p3,p2,.false.,l,name)
- if(l<=0)then
- print *,"marker_pick_begin: No name found"
- status=serialize_wrong_name
- call this%print_position()
- stop
- end if
- end if
- if(present(target))then
- p1=this%find_pure('target="',p3,p2,4)
- if(p1(2)>0)then
- call this%set_position(p1)
- call this%pop(target)
- else
- target=-1
- status=serialize_ok
- end if
- end if
- if(present(pointer))then
- p1=this%find_pure('pointer="',p3,p2,4)
- if(p1(2)>0)then
- call this%set_position(p1)
- call this%pop(pointer)
- else
- pointer=-1
- status=serialize_ok
- end if
- end if
- if(present(shape))then
- p1=this%find_pure('shape="',p3,p2,4)
- if(p1(2)>0)then
- call this%set_position(p1)
- call this%pop(shape)
- else
- status=serialize_ok
- end if
- end if
- else
- print *,"marker_pick_begin: Wrong tag. Expected: "&
- ,tag," Found: ",this%substring(p1,p3)
- status=serialize_wrong_tag
- call this%print_position()
- end if
- else
- if(this%substring(p1,p2)==tag)then
- status=serialize_ok
- else
- print *,"marker_pick_begin: Wrong tag. Expected: "&
- ,tag," Found: ",this%substring(p1,p2)
- status=serialize_wrong_tag
- end if
- end if
- call this%set_position(p2)
- call this%proceed(one*2,.true.)
- end subroutine marker_pick_begin
-\end{Verbatim}
-
-\TbpImp{marker\_query\_instance\_begin}
-\begin{Verbatim}
- subroutine marker_query_instance_begin(this,type,name,target,pointer,shape,status)
- class(marker_type),intent(inout)::this
- integer(kind=dik),dimension(2,2),intent(out),optional::type,name
- integer(kind=dik),intent(out),optional::target,pointer
- integer,dimension(:),allocatable,optional,intent(out)::shape
- integer(kind=dik),intent(out)::status
- call this%pick_begin("ser",type,name,target,pointer,shape,status)
- end subroutine marker_query_instance_begin
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_instance\_begin}
-\begin{Verbatim}
- subroutine marker_pick_instance_begin(this,name,type,target,pointer,shape,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer(kind=dik),dimension(2,2),intent(out),optional::type
- integer(kind=dik),intent(out),optional::target,pointer
- integer,dimension(:),allocatable,optional,intent(out)::shape
- integer(kind=dik),intent(out)::status
- integer(kind=dik),dimension(2,2)::read_name
- call this%query_instance_begin(type,read_name,target,pointer,shape,status)
- if(status==serialize_ok)then
- if(.not.this%str_equal(name,read_name))status=serialize_wrong_name
- end if
- end subroutine marker_pick_instance_begin
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_end}
-\begin{Verbatim}
- subroutine marker_pick_end(this,tag,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::tag
- integer(kind=dik),intent(out)::status
- integer(kind=dik),dimension(2)::p1,p2
- call this%find("</",skip=4,proceed=.true.,pos=p1)
- call this%find(">",skip=1,proceed=.false.,pos=p2)
- if(tag==this%substring(p1,p2))then
- status=serialize_ok
- else
- print *,"marker_pick_end: Wrong tag. Expected: ",tag," Found: ",this%substring(p1,p2)
- print *,"p1=",p1,"p2=",p2
- call this%print_position()
- end if
- call this%set_position(p2)
- call this%proceed(one*2,.true.)
- end subroutine marker_pick_end
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_instance\_end}
-\begin{Verbatim}
- subroutine marker_pick_instance_end(this,status)
- class(marker_type),intent(inout)::this
- integer(kind=dik),intent(out)::status
- call this%pick_end("ser",status)
- end subroutine marker_pick_instance_end
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_instance}
-\begin{Verbatim}
- subroutine marker_pick_instance(this,name,ser,status)
- class(marker_type),intent(inout)::this
- class(serializable_class),intent(out)::ser
- character(*),intent(in)::name
- integer(kind=dik),intent(out)::status
- integer(kind=dik),dimension(2,2)::type,r_name
- call this%pick_begin("ser",type,r_name,status=status)
- if(status==serialize_ok)then
- if(ser%verify_type(this%substring(type)))then
- if(this%str_equal(name,r_name))then
- call ser%read_from_marker(this,status)
- call this%pick_end("ser",status)
- else
- print *,"marker_pick_instance: Name mismatch: Expected: "&
- ,name," Found: ",r_name
- status=serialize_wrong_name
- call this%print_position
- end if
- else
- print *,"marker_pick_instance: Type mismatch: ",type
- call ser%write_type(output_unit)
- print *,""
- status=serialize_wrong_type
- call this%print_position
- end if
- end if
- end subroutine marker_pick_instance
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_target}
-\begin{Verbatim}
- subroutine marker_pick_target(this,name,ser,status)
- class(marker_type),intent(inout)::this
- class(serializable_class),target,intent(out)::ser
- character(*),intent(in)::name
- integer(kind=dik),intent(out)::status
- integer(kind=dik),dimension(2,2)::type,r_name
- integer(kind=dik)::target
- call this%pick_begin("ser",type,r_name,target,status=status)
- if(status==serialize_ok)then
- if(ser%verify_type(this%substring(type)))then
- if(this%str_equal(name,r_name))then
- call ser%read_target_from_marker(this,status)
- if(target>0)call this%push_heap(ser,target)
- else
- print *,"marker_pick_instance: Name mismatch: Expected: "&
- ,name," Found: ",r_name
- status=serialize_wrong_name
- end if
- else
- print *,"marker_pick_instance: Type mismatch: ",type
- status=serialize_wrong_type
- end if
- end if
- call this%pick_end("ser",status)
- end subroutine marker_pick_target
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_allocatable}
-\begin{Verbatim}
- subroutine marker_pick_allocatable(this,name,ser)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- class(serializable_class),allocatable,intent(out)::ser
- class(serializable_class),pointer::ref
- integer(kind=dik),dimension(2,2)::type,r_name
- integer(kind=dik)::status
- call this%pick_begin("ser",type,r_name,status=status)
- if(status==serialize_ok)then
- if(ser%verify_type(this%substring(type)))then
- if(this%str_equal(name,r_name))then
- call this%search_reference(type,ref)
- if(associated(ref))then
- allocate(ser,source=ref)
- call ser%read_from_marker(this,status)
- else
- print *,"marker_pick_allocatable:&
- & Type ",type," not found on reference stack."
- end if
- else
- print *,"marker_pick_instance: Name mismatch: Expected: ",&
- name," Found: ",r_name
- status=serialize_wrong_name
- end if
- else
- print *,"marker_pick_instance: Type mismatch: ",type
- status=serialize_wrong_type
- end if
- end if
- call this%pick_end("ser",status)
- end subroutine marker_pick_allocatable
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_pointer}
-\begin{Verbatim}
- recursive subroutine marker_pick_pointer(this,name,ser)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- class(serializable_class),pointer,intent(out)::ser
- class(serializable_class),pointer::ref
- integer(kind=dik),dimension(2,2)::type,r_name
- integer(kind=dik)::status,t,p
- nullify(ser)
- call this%pick_begin("ser",type,r_name,target=t,pointer=p,status=status)
- if(status==serialize_ok)then
- if(.not.this%str_equal("null",type))then
- if(p>0)then
- call this%search_heap(p,ser)
- else
- call this%search_reference(type,ref)
- if(associated(ref))then
- allocate(ser,source=ref)
- call ser%read_target_from_marker(this,status)
- call this%pick_end("ser",status)
- if(t>0)call this%push_heap(ser,t)
- else
- print *,"marker_pick_pointer:&
- & Type ",type," not found on reference stack."
- end if
- end if
- end if
- end if
- end subroutine marker_pick_pointer
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_logical}
-\begin{Verbatim}
- subroutine marker_pick_logical(this,name,content,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- logical,intent(out)::content
- integer(kind=dik),intent(out)::status
- call this%pick_begin(name,status=status)
- if(status==serialize_ok)then
- call this%pop(content)
- call this%pick_end(name,status)
- end if
- end subroutine marker_pick_logical
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_integer}
-\begin{Verbatim}
- subroutine marker_pick_integer(this,name,content,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer,intent(out)::content
- integer(kind=dik),intent(out)::status
- call this%pick_begin(name,status=status)
- if(status==serialize_ok)then
- call this%pop(content)
- call this%pick_end(name,status)
- end if
- end subroutine marker_pick_integer
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_integer\_array}
-\begin{Verbatim}
- subroutine marker_pick_integer_array(this,name,content,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer,dimension(:),intent(out)::content
- integer(kind=dik),intent(out)::status
- call this%pick_begin(name,status=status)
- if(status==serialize_ok)then
- call this%pop(content)
- call this%pick_end(name,status)
- end if
- end subroutine marker_pick_integer_array
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_integer\_matrix}
-\begin{Verbatim}
- subroutine marker_pick_integer_matrix(this,name,content,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer,dimension(:,:),intent(out)::content
- integer(kind=dik),intent(out)::status
- integer::n
- integer,dimension(2)::s
- s=shape(content)
- call this%pick_begin(name,status=status)
- if(status==serialize_ok)then
- do n=1,s(2)
- call this%pop(content(:,n))
- end do
- call this%pick_end(name,status)
- end if
- end subroutine marker_pick_integer_matrix
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_integer\_dik}
-\begin{Verbatim}
- subroutine marker_pick_integer_dik(this,name,content,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer(kind=dik),intent(out)::content
- integer(kind=dik),intent(out)::status
- call this%pick_begin(name,status=status)
- if(status==serialize_ok)then
- call this%pop(content)
- call this%pick_end(name,status)
- end if
- end subroutine marker_pick_integer_dik
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_integer\_array\_dik}
-\begin{Verbatim}
- subroutine marker_pick_integer_array_dik(this,name,content,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer(kind=dik),dimension(:),intent(out)::content
- integer(kind=dik),intent(out)::status
- call this%pick_begin(name,status=status)
- if(status==serialize_ok)then
- call this%pop(content)
- call this%pick_end(name,status)
- end if
- end subroutine marker_pick_integer_array_dik
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_integer\_matrix\_dik}
-\begin{Verbatim}
- subroutine marker_pick_integer_matrix_dik(this,name,content,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer(kind=dik),dimension(:,:),intent(out)::content
- integer(kind=dik),intent(out)::status
- integer::n
- integer,dimension(2)::s
- s=shape(content)
- call this%pick_begin(name,status=status)
- if(status==serialize_ok)then
- do n=1,s(2)
- call this%pop(content(:,n))
- end do
- call this%pick_end(name,status)
- end if
- end subroutine marker_pick_integer_matrix_dik
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_double}
-\begin{Verbatim}
- subroutine marker_pick_double(this,name,content,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- real(kind=drk),intent(out)::content
- integer(kind=dik),intent(out)::status
- call this%pick_begin(name,status=status)
- if(status==serialize_ok)then
- call this%pop(content)
- call this%pick_end(name,status)
- end if
- end subroutine marker_pick_double
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_double\_array}
-\begin{Verbatim}
- subroutine marker_pick_double_array(this,name,content,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- real(kind=drk),dimension(:),intent(out)::content
- integer(kind=dik),intent(out)::status
- call this%pick_begin(name,status=status)
- if(status==serialize_ok)then
- call this%pop(content)
- call this%pick_end(name,status)
- end if
- end subroutine marker_pick_double_array
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_double\_matrix}
-\begin{Verbatim}
- subroutine marker_pick_double_matrix(this,name,content,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- real(kind=drk),dimension(:,:),intent(out)::content
- integer(kind=dik),intent(out)::status
- integer::n
- integer,dimension(2)::s
- s=shape(content)
- call this%pick_begin(name,status=status)
- if(status==serialize_ok)then
- do n=1,s(2)
- call this%pop(content(:,n))
- end do
- call this%pick_end(name,status)
- end if
- end subroutine marker_pick_double_matrix
-\end{Verbatim}
-
-\TbpImp{marker\_pick\_string}
-\begin{Verbatim}
- subroutine marker_pick_string(this,name,content,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- character(:),allocatable,intent(out)::content
- integer(kind=dik),intent(out)::status
- call this%pick_begin(name,status=status)
- if(status==serialize_ok)then
- call this%pop(content)
- call this%pick_end(name,status)
- end if
- end subroutine marker_pick_string
-\end{Verbatim}
-
-\TbpImp{marker\_verify\_nothing}
-\begin{Verbatim}
- subroutine marker_verify_nothing(this,name,status)
- class(marker_type),intent(inout)::this
- character(*),intent(in)::name
- integer(kind=dik),intent(out)::status
- integer(kind=dik),dimension(2)::p1,p2
- call this%find("<",skip=4,proceed=.false.,pos=p1)
- call this%find(">",1,.false.,p2)
- if(name//"/"==this%substring(p1,p2))then
- status=serialize_nothing
- call this%set_position(p2)
- call this%proceed(one*3,.true.)
- else
- if(name==this%substring(p1,p2))then
- status=serialize_ok
- else
- status=serialize_wrong_tag
- end if
- end if
- end subroutine marker_verify_nothing
-\end{Verbatim}
-
-\TbpImp{marker\_indent}
-\begin{Verbatim}
- subroutine marker_indent(this,step)
- class(marker_type),intent(inout)::this
- integer(kind=dik),optional::step
- if(this%do_break)call this%push(new_line(" "))
- if(this%do_indent)then
- if(present(step))this%indentation=this%indentation+step
- call this%push(repeat(" ",this%indentation))
- end if
- this%active_pages(1)=this%actual_page()
- end subroutine marker_indent
-\end{Verbatim}
-
-\TbpImp{marker\_push\_heap}
-\begin{Verbatim}
- subroutine marker_push_heap(this,ser,id)
- class(marker_type),intent(inout)::this
- class(serializable_class),target,intent(in)::ser
- integer(kind=dik),intent(in)::id
- class(serializable_ref_type),pointer::new_ref
- allocate(new_ref)
- new_ref%next=>this%heap
- new_ref%ref=>ser
- new_ref%id=id
- this%heap=>new_ref
- end subroutine marker_push_heap
-\end{Verbatim}
-
-\TbpImp{marker\_pop\_heap}
-\begin{Verbatim}
- subroutine marker_pop_heap(this,ser)
- class(marker_type),intent(inout)::this
- class(serializable_class),pointer,intent(out)::ser
- class(serializable_ref_type),pointer::old_ref
- if(associated(this%heap))then
- old_ref=>this%heap
- ser=>old_ref%ref
- this%heap=>this%heap%next
- deallocate(old_ref)
- else
- print('("marker_pop_heap: heap_stack is not associated.")')
- end if
- end subroutine marker_pop_heap
-\end{Verbatim}
-
-\TbpImp{marker\_search\_heap\_by\_id}
-\begin{Verbatim}
- subroutine marker_search_heap_by_id(this,id,ser)
- class(marker_type),intent(in)::this
- integer(kind=dik),intent(in)::id
- class(serializable_class),pointer,intent(out)::ser
- class(serializable_ref_type),pointer::ref
- ref=>this%heap
- do while(associated(ref))
- if(id==ref%id)then
- ser=>ref%ref
- exit
- end if
- ref=>ref%next
- end do
- end subroutine marker_search_heap_by_id
-\end{Verbatim}
-
-\TbpImp{marker\_search\_heap\_by\_ref}
-\begin{Verbatim}
- subroutine marker_search_heap_by_ref(this,ref,id)
- class(marker_type),intent(in)::this
- class(serializable_class),pointer,intent(in)::ref
- integer(kind=dik),intent(out)::id
- class(serializable_ref_type),pointer::ref_p
- ref_p=>this%heap
- id=0
- do while(associated(ref_p))
- if(associated(ref,ref_p%ref))then
- id=ref_p%id
- exit
- end if
- ref_p=>ref_p%next
- end do
- end subroutine marker_search_heap_by_ref
-\end{Verbatim}
-
-\TbpImp{marker\_push\_reference}
-\begin{Verbatim}
- subroutine marker_push_reference(this,ser,id)
- class(marker_type),intent(inout)::this
- class(serializable_class),target,intent(in)::ser
- integer(kind=dik),intent(in),optional::id
- class(serializable_ref_type),pointer::new_ref
- allocate(new_ref)
- new_ref%next=>this%references
- new_ref%ref=>ser
- if(present(id))then
- new_ref%id=id
- else
- new_ref%id=-1
- end if
- this%references=>new_ref
- end subroutine marker_push_reference
-\end{Verbatim}
-
-\TbpImp{marker\_pop\_reference}
-\begin{Verbatim}
- subroutine marker_pop_reference(this,ser)
- class(marker_type),intent(inout)::this
- class(serializable_class),pointer,intent(out)::ser
- class(serializable_ref_type),pointer::old_ref
- if(associated(this%references))then
- old_ref=>this%references
- ser=>old_ref%ref
- this%references=>this%references%next
- deallocate(old_ref)
- else
- print('("marker_pop_reference: reference_stack is not associated.")')
- end if
- end subroutine marker_pop_reference
-\end{Verbatim}
-
-\TbpImp{marker\_search\_reference}
-\begin{Verbatim}
- subroutine marker_search_reference(this,type,ser)
- class(marker_type),intent(in)::this
- integer(kind=dik),dimension(2,2),intent(in)::type
- class(serializable_class),pointer,intent(out)::ser
- class(serializable_class),pointer::tmp_ser!nag bug workaround
- class(serializable_ref_type),pointer::ref
- ref=>this%references
- nullify(ser)
- do while(associated(ref))
- tmp_ser=>ref%ref
- if(tmp_ser%verify_type(this%substring(type)))then
- ser=>tmp_ser
- exit
- end if
- ref=>ref%next
- end do
- end subroutine marker_search_reference
-\end{Verbatim}
-
-\TbpImp{marker\_reset\_heap}
-\begin{Verbatim}
- subroutine marker_reset_heap(this)
- class(marker_type),intent(inout)::this
- if(associated(this%heap))then
- call this%heap%finalize()
- deallocate(this%heap)
- end if
- end subroutine marker_reset_heap
-\end{Verbatim}
-
-\TbpImp{marker\_reset\_references}
-\begin{Verbatim}
- subroutine marker_reset_references(this)
- class(marker_type),intent(inout)::this
- if(associated(this%references))then
- call this%references%finalize()
- deallocate(this%references)
- end if
- end subroutine marker_reset_references
-\end{Verbatim}
-
-\TbpImp{marker\_finalize}
-\begin{Verbatim}
- subroutine marker_finalize(this)
- class(marker_type),intent(inout)::this
- call this%reset_heap()
- call this%reset_references()
- end subroutine marker_finalize
-\end{Verbatim}
-\MethodsNTB
-\ProcImp{serialize\_print\_comp\_pointer}
-\begin{Verbatim}
- recursive subroutine serialize_print_comp_pointer(ser,unit,parents,components,peers,name)
- class(serializable_class),pointer,intent(in)::ser
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- character(len=*),intent(in)::name
- if(associated(ser))then
- write(unit,fmt=*)name," is associated."
- if(components>0)then
- write(unit,fmt=*)"Printing components of ",name
- call ser%print_to_unit(unit,parents,components-one,peers)
- else
- write(unit,fmt=*)"Skipping components of ",name
- end if
- else
- write(unit,fmt=*)name," is not associated."
- end if
- end subroutine serialize_print_comp_pointer
-\end{Verbatim}
-
-\ProcImp{serialize\_print\_peer\_pointer}
-\begin{Verbatim}
- recursive subroutine serialize_print_peer_pointer(ser,unit,parents,components,peers,name)
- class(serializable_class),pointer,intent(in)::ser
- integer,intent(in)::unit
- integer(kind=dik)::parents,components,peers
- character(len=*),intent(in)::name
- if(associated(ser))then
- write(unit,fmt=*)name," is associated."
- if(peers>0)then
- write(unit,fmt=*)"Printing components of ",name
- call ser%print_to_unit(unit,parents,components,peers-one)
- else
- write(unit,fmt=*)"Skipping components of ",name
- end if
- else
- write(unit,fmt=*)name," is not associated."
- end if
- end subroutine serialize_print_peer_pointer
-\end{Verbatim}
-
-\ProcImp{serialize\_print\_allocatable}
-\begin{Verbatim}
- subroutine serialize_print_allocatable(ser,unit,parents,components,peers,name)
- class(serializable_class),allocatable,intent(in)::ser
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- character(len=*),intent(in)::name
- if(allocated(ser))then
- write(unit,fmt=*)name," is allocated."
- if(components>0)then
- write(unit,fmt=*)"Printing components of ",name
- call ser%print_to_unit(unit,parents,components-1,peers)
- else
- write(unit,fmt=*)"Skipping components of ",name
- end if
- else
- write(unit,fmt=*)name," is not allocated."
- end if
- end subroutine serialize_print_allocatable
-\end{Verbatim}
-
-\ProcImp{measurable\_less\_measurable}
-\begin{Verbatim}
- elemental function measurable_less_measurable(mea1,mea2)
- class(measurable_class),intent(in)::mea1,mea2
- logical::measurable_less_measurable
- measurable_less_measurable=mea1%measure()<mea2%measure()
- end function measurable_less_measurable
-\end{Verbatim}
-
-\ProcImp{measurable\_less\_double}
-\begin{Verbatim}
- elemental function measurable_less_double(mea1,dou)
- class(measurable_class),intent(in)::mea1
- real(kind=drk),intent(in)::dou
- logical::measurable_less_double
- measurable_less_double=mea1%measure()<dou
- end function measurable_less_double
-\end{Verbatim}
-
-\ProcImp{measurable\_less\_or\_equal\_measurable}
-\begin{Verbatim}
- elemental function measurable_less_or_equal_measurable(mea1,mea2)
- class(measurable_class),intent(in)::mea1,mea2
- logical::measurable_less_or_equal_measurable
- measurable_less_or_equal_measurable=mea1%measure()<=mea2%measure()
- end function measurable_less_or_equal_measurable
-\end{Verbatim}
-
-\ProcImp{measurable\_less\_or\_equal\_double}
-\begin{Verbatim}
- elemental function measurable_less_or_equal_double(mea1,dou)
- class(measurable_class),intent(in)::mea1
- real(kind=drk),intent(in)::dou
- logical::measurable_less_or_equal_double
- measurable_less_or_equal_double=mea1%measure()<=dou
- end function measurable_less_or_equal_double
-\end{Verbatim}
-
-\ProcImp{measurable\_equal\_measurable}
-\begin{Verbatim}
- elemental function measurable_equal_measurable(mea1,mea2)
- class(measurable_class),intent(in)::mea1,mea2
- logical::measurable_equal_measurable
- measurable_equal_measurable=mea1%measure()==mea2%measure()
- end function measurable_equal_measurable
-\end{Verbatim}
-
-\ProcImp{measurable\_equal\_double}
-\begin{Verbatim}
- elemental function measurable_equal_double(mea1,dou)
- class(measurable_class),intent(in)::mea1
- real(kind=drk),intent(in)::dou
- logical::measurable_equal_double
- measurable_equal_double=mea1%measure()==dou
- end function measurable_equal_double
-\end{Verbatim}
-
-\ProcImp{measurable\_equal\_or\_greater\_measurable}
-\begin{Verbatim}
- elemental function measurable_equal_or_greater_measurable(mea1,mea2)
- class(measurable_class),intent(in)::mea1,mea2
- logical::measurable_equal_or_greater_measurable
- measurable_equal_or_greater_measurable=mea1%measure()>=mea2%measure()
- end function measurable_equal_or_greater_measurable
-\end{Verbatim}
-
-\ProcImp{measurable\_equal\_or\_greater\_double}
-\begin{Verbatim}
- elemental function measurable_equal_or_greater_double(mea1,dou)
- class(measurable_class),intent(in)::mea1
- real(kind=drk),intent(in)::dou
- logical::measurable_equal_or_greater_double
- measurable_equal_or_greater_double=mea1%measure()>=dou
- end function measurable_equal_or_greater_double
-\end{Verbatim}
-
-\ProcImp{measurable\_greater\_measurable}
-\begin{Verbatim}
- elemental function measurable_greater_measurable(mea1,mea2)
- class(measurable_class),intent(in)::mea1,mea2
- logical::measurable_greater_measurable
- measurable_greater_measurable=mea1%measure()>mea2%measure()
- end function measurable_greater_measurable
-\end{Verbatim}
-
-\ProcImp{measurable\_greater\_double}
-\begin{Verbatim}
- elemental function measurable_greater_double(mea1,dou)
- class(measurable_class),intent(in)::mea1
- real(kind=drk),intent(in)::dou
- logical::measurable_greater_double
- measurable_greater_double=mea1%measure()>dou
- end function measurable_greater_double
-\end{Verbatim}
-
-\ProcImp{page\_ring\_position}
-\begin{Verbatim}
- pure function page_ring_position(n)
- integer(kind=dik),intent(in)::n
- integer(kind=dik),dimension(2)::page_ring_position
- page_ring_position(2)=mod(n,serialize_page_size)
- page_ring_position(1)=(n-page_ring_position(2))/serialize_page_size
- end function page_ring_position
-\end{Verbatim}
-
-\ProcImp{page\_ring\_ordinal}
-\begin{Verbatim}
- pure integer(kind=dik) function page_ring_ordinal(pos)
- integer(kind=dik),dimension(2),intent(in)::pos
- page_ring_ordinal=pos(1)*serialize_page_size+pos(2)
- end function page_ring_ordinal
-\end{Verbatim}
-
-\ProcImp{page\_ring\_position\_is\_before\_int\_pos}
-\begin{Verbatim}
- pure logical function page_ring_position_is_before_int_pos(m,n)
- integer(kind=dik),intent(in)::m
- integer(kind=dik),dimension(2),intent(in)::n
- if(m<page_ring_ordinal(n))then
- page_ring_position_is_before_int_pos=.true.
- else
- page_ring_position_is_before_int_pos=.false.
- end if
- end function page_ring_position_is_before_int_pos
-\end{Verbatim}
-
-\ProcImp{page\_ring\_position\_is\_before\_pos\_int}
-\begin{Verbatim}
- pure logical function page_ring_position_is_before_pos_int(m,n)
- integer(kind=dik),dimension(2),intent(in)::m
- integer(kind=dik),intent(in)::n
- if(page_ring_ordinal(m)<n)then
- page_ring_position_is_before_pos_int=.true.
- else
- page_ring_position_is_before_pos_int=.false.
- end if
- end function page_ring_position_is_before_pos_int
-\end{Verbatim}
-
-\ProcImp{page\_ring\_position\_is\_before\_pos\_pos}
-\begin{Verbatim}
- pure logical function page_ring_position_is_before_pos_pos(m,n)
- integer(kind=dik),dimension(2),intent(in)::m,n
- if(m(1)<n(1))then
- page_ring_position_is_before_pos_pos=.true.
- else
- if(m(1)>n(1))then
- page_ring_position_is_before_pos_pos=.false.
- else
- if(m(2)<n(2))then
- page_ring_position_is_before_pos_pos=.true.
- else
- page_ring_position_is_before_pos_pos=.false.
- end if
- end if
- end if
- end function page_ring_position_is_before_pos_pos
-\end{Verbatim}
-
-\ProcImp{ring\_position\_increase}
-\begin{Verbatim}
- subroutine ring_position_increase(pos,n)
- integer(kind=dik),dimension(2),intent(inout)::pos
- integer(kind=dik),intent(in)::n
- pos=page_ring_position(page_ring_ordinal(pos)+n)
- end subroutine ring_position_increase
-\end{Verbatim}
-
-\ProcImp{ring\_position\_metric2}
-\begin{Verbatim}
- pure integer(kind=dik) function ring_position_metric2(p1,p2)
- integer(kind=dik),dimension(2),intent(in)::p1,p2
- ring_position_metric2=(p2(1)-p1(1))*serialize_page_size+p2(2)-p1(2)+1
- end function ring_position_metric2
-\end{Verbatim}
-
-\ProcImp{ring\_position\_metric1}
-\begin{Verbatim}
- pure integer(kind=dik) function ring_position_metric1(p)
- integer(kind=dik),dimension(2,2),intent(in)::p
- ring_position_metric1=(p(1,2)-p(1,1))*serialize_page_size+p(2,2)-p(2,1)+1
- end function ring_position_metric1
-\end{Verbatim}
-
-\ProcImp{generate\_unit}
-\begin{Verbatim}
- subroutine generate_unit(unit,min,max)
- integer,intent(out) :: unit
- integer,intent(in),optional :: min,max
- integer :: min_u,max_u
- logical :: is_open
- !print *,"generate_unit"
- unit = -1
- if(present(min))then
- min_u=min
- else
- min_u=10
- end if
- if(present(max))then
- max_u=max
- else
- max_u=huge(max_u)
- end if
- do unit=min_u,max_u
- !print *,"testing ",unit
- inquire(unit,opened=is_open)
- if (.not. is_open) then
- exit
- end if
- end do
- end subroutine generate_unit
-\end{Verbatim}
-
-\ProcImp{ilog2}
-\begin{Verbatim}
- subroutine ilog2(int,exp,rem)
- integer,intent(in) :: int
- integer,intent(out) :: exp,rem
- integer :: count
- count = 2
- exp = 1
- do while (count<int)
- exp=exp+1
- count = ishft(count,1)
- end do
- if (count>int) then
- rem=(int-ishft(count,-1))
- else
- rem=0
- end if
- end subroutine ilog2
-\end{Verbatim}
-
-\ProcImp{character\_is\_in}
-\begin{Verbatim}
- pure logical function character_is_in(c,array)
- character,intent(in)::c
- character,dimension(:),intent(in)::array
- integer(kind=dik)::n
- character_is_in=.false.
- do n=1,size(array)
- if(c==array(n))then
- character_is_in=.true.
- exit
- end if
- end do
- end function character_is_in
-\end{Verbatim}
-
-\ProcImp{integer\_with\_leading\_zeros}
-\begin{Verbatim}
- subroutine integer_with_leading_zeros(number,length,string)
- integer,intent(in) :: number,length
- character(len=*),intent(out) :: string
- integer :: zeros
- character::sign
- if(number==0)then
- string = repeat("0",length)
- else
- if(number>0)then
- zeros=length-floor(log10(real(number)))-1
- if(zeros<0)then
- string=repeat("*",length)
- else
- write(string,fmt='(a,I0)') repeat("0",zeros),number
- end if
- else
- zeros=length-floor(log10(real(-number)))-2
- if(zeros<0)then
- string=repeat("*",length)
- else
- write(string,fmt='(a,a,I0)') "-",repeat("0",zeros),abs(number)
- end if
- end if
- end if
- end subroutine integer_with_leading_zeros
-\end{Verbatim}
Index: trunk/src/muli/doc/uml.mp
===================================================================
--- trunk/src/muli/doc/uml.mp (revision 8371)
+++ trunk/src/muli/doc/uml.mp (revision 8372)
@@ -1,90 +0,0 @@
-outputtemplate := "%j-%c.mps";
-input TEX;
-TEXPRE("%&latex" & char(10) & "\documentclass{article}\begin{document}");
-TEXPOST("\end{document}");
-unit=10;
-xu=unit;
-yu=unit;
-
-path item[][];
-
-def item_path(expr a, b, c)=
- ((subpath (0,(length fullcircle)/2) of fullcircle) scaled (2*unit) rotated 90 shifted (-b*unit,0) --
- (subpath (0,(length fullcircle)/2) of fullcircle) scaled (2*unit) rotated 270 shifted (b*unit,0) -- cycle) shifted (a*unit);
- label(TEX(c), (a*unit));
-enddef;
-
-def decision_path(expr a, b)=
- ((2*unit,0) -- (0,2*unit) -- (-2*unit,0) -- (0,-2*unit) -- cycle) shifted (a*unit);
- label(TEX(b), (a*unit));
-enddef;
-
-def set_begin(expr a)=
- item[xpart(a)][ypart(a)]=fullcircle scaled unit shifted (a*unit);
-enddef;
-
-def set_end(expr a)=
- item[xpart(a)][ypart(a)]=fullcircle scaled unit shifted (a*unit);
-enddef;
-
-def draw_arrow(expr a,b)=
- drawarrow (a*unit -- b*unit);
-enddef;
-
-beginfig(1)
- fill fullcircle scaled unit shifted ((11,36.5)*unit);
- draw_arrow((11,36),(11,35));
- draw item_path((11,34), 5,"initialize");
- draw_arrow((11,33),(11,32));
- draw item_path((11,31), 5,"apply\_initial\_interaction");
- draw_arrow((11,30),(11,29));
- draw item_path((11,28), 5,"generate\_gev2\_pt2");
- draw_arrow((11,27),(11,26));
- draw decision_path((11,24), "$p_{\perp}\!\!<\!t$");
- label(TEX("yes"), ((14,24.5)*unit));
- label(TEX("no"), ((8,24.5)*unit));
- draw((9,24)*unit--(5,24)*unit);
- draw_arrow((5,24),(5,21));
- draw item_path((5,20), 4,"generate\_partons");
- draw_arrow((5,19),(5,18));
- draw item_path((5,17), 4,"get\_correlations");
- draw((13,24)*unit--(17,24)*unit);
- draw_arrow((17,24),(17,19.5));
- draw item_path((17,18.5), 4,"replace\_partons");
- draw (5,16)*unit -- (5,15)*unit;
- draw (17,17.5)*unit -- (17,15)*unit;
- draw (5,15)*unit -- (17,15)*unit;
- draw_arrow((11,15),(11,14));
- draw decision_path((11,12), "\small $p_{\perp}\!\!<\!p_{\perp}^{min}$");
- label(TEX("yes"), ((12,9.5)*unit));
- label(TEX("no"), ((13.5,13)*unit));
- draw_arrow((11,10),(11,9));
- draw decision_path((11,7), "\small $m\!>\!m_E$");
- label(TEX("yes"), ((12,4.5)*unit));
- label(TEX("no"), ((13.5,8)*unit));
- draw_arrow((11,5),(11,4));
- draw item_path((11,3), 4, "finalize");
- draw_arrow((11,2),((11,1)));
- draw fullcircle scaled unit shifted ((11,0.5)*unit);
- fill fullcircle scaled (unit*0.5) shifted ((11,0.5)*unit);
-
- draw_arrow((13,12),(14,12));
- draw item_path((18,12), 3,"replace\_partons");
- draw_arrow((22,12),(23,12));
- draw decision_path((25,12), "\small $t\!\!<\!t^{min}$");
- label(TEX("yes"), ((26,14.5)*unit));
- label(TEX("no"), ((26,9.5)*unit));
- draw ((25,10)*unit -- (25,9)*unit -- (18,9)*unit);
- draw_arrow ((18,9),(18,11));
- draw ((25,14)*unit -- (25,28)*unit);
- draw_arrow ((25,28),(17,28));
-
-
- draw_arrow((13,7),(14,7));
- draw item_path((18,7), 3,"restart");
- draw (22,7)*unit -- (28,7)*unit;
- draw (28,7)*unit -- (28,31)*unit;
- draw_arrow((28,31),(17,31));
-
-endfig;
-end;
Index: trunk/src/muli/doc/plots.mp
===================================================================
--- trunk/src/muli/doc/plots.mp (revision 8371)
+++ trunk/src/muli/doc/plots.mp (revision 8372)
@@ -1,38 +0,0 @@
-input common;
-path pol,exp;
-exp=
-% (1.5, 407.869760669101)*unit--
-% (1.75, 28.697133208502652)*unit--
- (1.9, 5.89768)*unit--
- (2., 2.061153622438558)*unit--
- (2.25, 0.15039092645467825)*unit--
- (2.5, 0.011110355091971216)*unit--
- (2.75, 0.0008290849840322585)*unit--
- (3., 0.00006238415312560117)*unit--
- (3.25, 0)*unit--
- (3.5, 0)*unit--
- (3.75, 0)*unit--
- (4., 0)*unit--
- (4.25, 0)*unit--
- (4.5, 0)*unit;
-pol=(1.5, 3.864585062677451)*unit--
- (1.75, 2.8984621907999855)*unit--
- (2., 2.0611536224385523)*unit--
- (2.25, 1.3526593575931471)*unit--
- (2.5, 0.7729793962637741)*unit--
- (2.75, 0.32211373845043134)*unit--
- (3., 0.00006238415311976553)*unit--
- (3.25, -0.1931746666281633)*unit--
- (3.5, -0.2575974138934196)*unit--
- (3.75, -0.1932058576426403)*unit--
- (4., 0)*unit--
- (4.25, 0.3220201654070074)*unit--
- (4.5, 0.7728546322058705)*unit;
-beginfig(1)
- drawarrow (0,0) -- (6,0)*unit;
- drawarrow (0,0) -- (0,6)*unit;
- draw pol withcolor blue;
- draw exp withcolor red;
-endfig;
-end;
-
Index: trunk/src/muli/doc/Spurwechsel.pdf
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: trunk/src/muli/doc/Makefile
===================================================================
--- trunk/src/muli/doc/Makefile (revision 8371)
+++ trunk/src/muli/doc/Makefile (revision 8372)
@@ -1,35 +0,0 @@
-TEX_SOURCES=$(wildcard *.tex)
-MP_SOURCES=diagrams.mp plots.mp uml-module-tree.mp uml.mp
-MP_TARGETS=$(patsubst %.mp,%-1.mps,$(MP_SOURCES))
-
-.PHONY: remake all clean
-
-remake: $(MP_TARGETS)
- pdflatex muli_manual.tex
-
-all: muli_manual.pdf
-
-muli_manual.pdf: $(TEX_SOURCES) $(MP_TARGETS)
- pdflatex muli_manual.tex
- makeindex muli_manual.idx
- pdflatex muli_manual.tex
-
-%-1.mps: %.mp common.mp
- mpost $<
-
-clean:
- rm -f muli_manual.pdf
- rm -f mptext*
- rm -f mpxerr*
- rm -f *.aux
- rm -f *.mps
- rm -f *.log
- rm -f *.toc
- rm -f *.out
- rm -f *.idx
- rm -f *.ind
- rm -f *.ilg
-
-echo:
- @echo $(MP_SOURCES)
- @echo $(MP_TARGETS)
Index: trunk/src/muli/doc/muli_fibonacci_tree.tex
===================================================================
--- trunk/src/muli/doc/muli_fibonacci_tree.tex (revision 8371)
+++ trunk/src/muli/doc/muli_fibonacci_tree.tex (revision 8372)
@@ -1,2028 +0,0 @@
-\Module{muli\_fibonacci\_tree}
-%\begin{figure}
-% \centering{\includegraphics{uml-module-tree-11.mps}}
-% \caption{\label{fig:\ThisModule:Types}Klassendiagramm des Moduls \ThisModule}
-%\end{figure}
-\section{Abhängigkeiten}
-\use{muli\_basic}
-\section{Parameter}
-\begin{Verbatim}
- character(*),parameter,private :: no_par = "edge={\textbackslash}noparent"
- character(*),parameter,private :: no_ret = "edge={\textbackslash}noreturn"
- character(*),parameter,private :: no_kid = "edge={\textbackslash}nochild"
- character(*),parameter,private :: le_kid = "edge={\textbackslash}childofleave"
-\end{Verbatim}
-
-\section{Derived Types}
-\TypeDef{fibonacci\_node\_type}
-\begin{Verbatim}
- type,\Extends{measurable\_class} :: fibonacci_node_type
-! private
- class(\TypeRef{fibonacci\_node\_type}), pointer :: \TC{up} => null()
- class(\TypeRef{measurable\_class}), pointer :: \TC{down} => null()
- class(\TypeRef{fibonacci\_node\_type}), pointer :: \TC{left} => null()
- class(\TypeRef{fibonacci\_node\_type}), pointer :: \TC{right} => null()
- integer :: depth = 0
- contains
- ! overridden serializable_class procedures
- procedure::\TbpDec{write\_to\_marker}{fibonacci\_node\_write\_to\_marker}
- procedure::\TbpDec{read\_from\_marker}{fibonacci\_node\_read\_from\_marker}
- procedure::\TbpDec{read\_target\_from\_marker}{fibonacci\_node\_read\_target\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{fibonacci\_node\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{fibonacci\_node\_get\_type}
- procedure::\TbpDec{deserialize\_from\_marker}{fibonacci\_node\_deserialize\_from\_marker}
- ! overridden measurable_class procedures
- procedure::\TbpDec{measure}{fibonacci\_node\_measure}
- ! init/final
- procedure,public ::\TbpDec{deallocate\_tree}{fibonacci\_node\_deallocate\_tree}
- procedure,public ::\TbpDec{deallocate\_all}{fibonacci\_node\_deallocate\_all}
-! interface
- procedure,public ::\TbpDec{get\_depth}{fibonacci\_node\_get\_depth}
- procedure,public ::\TbpDec{count\_leaves}{fibonacci\_node\_count\_leaves}
-! public tests
- procedure,public,nopass ::\TbpDec{is\_leave}{fibonacci\_node\_is\_leave}
- procedure,public,nopass ::\TbpDec{is\_root}{fibonacci\_node\_is\_root}
- procedure,public,nopass ::\TbpDec{is\_inner}{fibonacci\_node\_is\_inner}
-! print methods
- procedure,public ::\TbpDec{write\_association}{fibonacci\_node\_write\_association}
- procedure,public ::\TbpDec{write\_contents}{fibonacci\_node\_write\_contents}
- procedure,public ::\TbpDec{write\_values}{fibonacci\_node\_write\_values}
- procedure,public ::\TbpDec{write\_leaves}{fibonacci\_node\_write\_leaves}
- !procedure,public ::\TbpDec{write}{fibonacci\_node\_write\_contents}
-! write methods
- procedure,public ::\TbpDec{write\_pstricks}{fibonacci\_node\_write\_pstricks}
-! elaborated functions
- procedure,public ::\TbpDec{copy\_node}{fibonacci\_node\_copy\_node}
- procedure,public ::\TbpDec{find\_root}{fibonacci\_node\_find\_root}
- procedure,public ::\TbpDec{find\_leftmost}{fibonacci\_node\_find\_leftmost}
- procedure,public ::\TbpDec{find\_rightmost}{fibonacci\_node\_find\_rightmost}
- procedure,public ::\TbpDec{find}{fibonacci\_node\_find}
- procedure,public ::\TbpDec{find\_left\_leave}{fibonacci\_node\_find\_left\_leave}
- procedure,public ::\TbpDec{find\_right\_leave}{fibonacci\_node\_find\_right\_leave}
- procedure,public ::\TbpDec{apply\_to\_leaves}{fibonacci\_node\_apply\_to\_leaves}
- procedure,public ::\TbpDec{apply\_to\_leaves\_rl}{fibonacci\_node\_apply\_to\_leaves\_rl}
-! private procedures: these are unsafe!
- procedure ::\TbpDec{set\_depth}{fibonacci\_node\_set\_depth}
- procedure ::\TbpDec{append\_left}{fibonacci\_node\_append\_left}
- procedure ::\TbpDec{append\_right}{fibonacci\_node\_append\_right}
- procedure ::\TbpDec{replace}{fibonacci\_node\_replace}
- procedure ::\TbpDec{swap}{fibonacci\_node\_swap\_nodes}
- procedure ::\TbpDec{flip}{fibonacci\_node\_flip\_children}
- procedure ::\TbpDec{rip}{fibonacci\_node\_rip}
- procedure ::\TbpDec{remove\_and\_keep\_parent}{fibonacci\_node\_remove\_and\_keep\_parent}
- procedure ::\TbpDec{remove\_and\_keep\_twin}{fibonacci\_node\_remove\_and\_keep\_twin}
- procedure ::\TbpDec{rotate\_left}{fibonacci\_node\_rotate\_left}
- procedure ::\TbpDec{rotate\_right}{fibonacci\_node\_rotate\_right}
- procedure ::\TbpDec{rotate}{fibonacci\_node\_rotate}
- procedure ::\TbpDec{balance\_node}{fibonacci\_node\_balance\_node}
- procedure ::\TbpDec{update\_depth\_save}{fibonacci\_node\_update\_depth\_save}
- procedure ::\TbpDec{update\_depth\_unsave}{fibonacci\_node\_update\_depth\_unsave}
- procedure ::\TbpDec{repair}{fibonacci\_node\_repair}
-! tests: these are save when type is fibonacci_node_type and else unsafe.
- procedure ::\TbpDec{is\_left\_short}{fibonacci\_node\_is\_left\_short}
- procedure ::\TbpDec{is\_right\_short}{fibonacci\_node\_is\_right\_short}
- procedure ::\TbpDec{is\_unbalanced}{fibonacci\_node\_is\_unbalanced}
- procedure ::\TbpDec{is\_left\_too\_short}{fibonacci\_node\_is\_left\_too\_short}
- procedure ::\TbpDec{is\_right\_too\_short}{fibonacci\_node\_is\_right\_too\_short}
- procedure ::\TbpDec{is\_too\_unbalanced}{fibonacci\_node\_is\_too\_unbalanced}
- procedure ::\TbpDec{is\_left\_child}{fibonacci\_node\_is\_left\_child}
- procedure ::\TbpDec{is\_right\_child}{fibonacci\_node\_is\_right\_child}
- end type fibonacci_node_type
-\end{Verbatim}
-\TypeDef{fibonacci\_leave\_type}
-\begin{Verbatim}
- type,\Extends{fibonacci\_node\_type} :: fibonacci_leave_type
-! class(\TypeRef{measurable\_class}),pointer :: \TC{content}
- contains
- ! overridden serializable_class procedures
- procedure::\TbpDec{print\_to\_unit}{fibonacci\_leave\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{fibonacci\_leave\_get\_type}
- procedure,public ::\TbpDec{deallocate\_all}{fibonacci\_leave\_deallocate\_all}
- ! new procedures
- procedure,public ::\TbpDec{pick}{fibonacci\_leave\_pick}
- procedure,public ::\TbpDec{get\_left}{fibonacci\_leave\_get\_left}
- procedure,public ::\TbpDec{get\_right}{fibonacci\_leave\_get\_right}
- procedure,public ::\TbpDec{write\_pstricks}{fibonacci\_leave\_write\_pstricks}
- procedure,public ::\TbpDec{copy\_content}{fibonacci\_leave\_copy\_content}
- procedure,public ::\TbpDec{set\_content}{fibonacci\_leave\_set\_content}
- procedure,public ::\TbpDec{get\_content}{fibonacci\_leave\_get\_content}
- procedure,public,nopass ::\TbpDec{is\_inner}{fibonacci\_leave\_is\_inner}
- procedure,public,nopass ::\TbpDec{is\_leave}{fibonacci\_leave\_is\_leave}
- procedure ::\TbpDec{insert\_leave\_by\_node}{fibonacci\_leave\_insert\_leave\_by\_node}
- procedure ::\TbpDec{is\_left\_short}{fibonacci\_leave\_is\_left\_short}
- procedure ::\TbpDec{is\_right\_short}{fibonacci\_leave\_is\_right\_short}
- procedure ::\TbpDec{is\_unbalanced}{fibonacci\_leave\_is\_unbalanced}
- procedure ::\TbpDec{is\_left\_too\_short}{fibonacci\_leave\_is\_left\_too\_short}
- procedure ::\TbpDec{is\_right\_too\_short}{fibonacci\_leave\_is\_right\_too\_short}
- procedure ::\TbpDec{is\_too\_unbalanced}{fibonacci\_leave\_is\_too\_unbalanced}
- end type fibonacci_leave_type
-\end{Verbatim}
-\TypeDef{fibonacci\_root\_type}
-\begin{Verbatim}
- type,\Extends{fibonacci\_node\_type} :: fibonacci_root_type
- logical::\TC{is\_valid\_c}=.false.
- class(\TypeRef{fibonacci\_leave\_type}),pointer ::\TC{leftmost}=>null()
- class(\TypeRef{fibonacci\_leave\_type}),pointer ::\TC{rightmost}=>null()
- contains
- ! overridden serializable_class procedures
- procedure::\TbpDec{write\_to\_marker}{fibonacci\_root\_write\_to\_marker}
- procedure::\TbpDec{read\_target\_from\_marker}{fibonacci\_root\_read\_target\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{fibonacci\_root\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{fibonacci\_root\_get\_type}
- ! new procedures
- procedure::\TbpDec{get\_leftmost}{fibonacci\_root\_get\_leftmost}
- procedure::\TbpDec{get\_rightmost}{fibonacci\_root\_get\_rightmost}
-! public tests
- procedure,public,nopass ::\TbpDec{is\_root}{fibonacci\_root\_is\_root}
- procedure,public,nopass ::\TbpDec{is\_inner}{fibonacci\_root\_is\_inner}
- procedure,public ::\TbpDec{is\_valid}{fibonacci\_root\_is\_valid}
- procedure,public ::\TbpDec{count\_leaves}{fibonacci\_root\_count\_leaves}
- procedure,public ::\TbpDec{write\_pstricks}{fibonacci\_root\_write\_pstricks}
- procedure,public ::\TbpDec{copy\_root}{fibonacci\_root\_copy\_root}
- procedure,public ::\TbpDec{push\_by\_content}{fibonacci\_root\_push\_by\_content}
- procedure,public ::\TbpDec{push\_by\_leave}{fibonacci\_root\_push\_by\_leave}
- procedure,public ::\TbpDec{pop\_left}{fibonacci\_root\_pop\_left}
- procedure,public ::\TbpDec{pop\_right}{fibonacci\_root\_pop\_right}
- procedure,public ::\TbpDec{merge}{fibonacci\_root\_merge}
- procedure,public ::\TbpDec{set\_leftmost}{fibonacci\_root\_set\_leftmost}
- procedure,public ::\TbpDec{set\_rightmost}{fibonacci\_root\_set\_rightmost}
- procedure,public ::\TbpDec{init\_by\_leave}{fibonacci\_root\_init\_by\_leave}
- procedure,public ::\TbpDec{init\_by\_content}{fibonacci\_root\_init\_by\_content}
- procedure,public ::\TbpDec{reset}{fibonacci\_root\_reset}
- ! init/final
- procedure,public ::\TbpDec{deallocate\_tree}{fibonacci\_root\_deallocate\_tree}
- procedure,public ::\TbpDec{deallocate\_all}{fibonacci\_root\_deallocate\_all}
- procedure ::\TbpDec{is\_left\_child}{fibonacci\_root\_is\_left\_child}
- procedure ::\TbpDec{is\_right\_child}{fibonacci\_root\_is\_right\_child}
- end type fibonacci_root_type
-\end{Verbatim}
-\TypeDef{fibonacci\_stub\_type}
-\begin{Verbatim}
- type,\Extends{fibonacci\_root\_type} :: fibonacci_stub_type
- contains
- ! overridden serializable_class procedures
- procedure,nopass::\TbpDec{get\_type}{fibonacci\_stub\_get\_type}
- ! overridden fibonacci_root_type procedures
- procedure,public ::\TbpDec{push\_by\_content}{fibonacci\_stub\_push\_by\_content}
- procedure,public ::\TbpDec{push\_by\_leave}{fibonacci\_stub\_push\_by\_leave}
- procedure,public ::\TbpDec{pop\_left}{fibonacci\_stub\_pop\_left}
- procedure,public ::\TbpDec{pop\_right}{fibonacci\_stub\_pop\_right}
- end type fibonacci_stub_type
-\end{Verbatim}
-\TypeDef{fibonacci\_leave\_list\_type}
-\begin{Verbatim}
- type fibonacci_leave_list_type
- class(\TypeRef{fibonacci\_leave\_type}),pointer ::\TC{leave}=>null()
- class(\TypeRef{fibonacci\_leave\_list\_type}),pointer :: \TC{next} => null()
- end type fibonacci_leave_list_type
-\end{Verbatim}
-\Methods
-\MethodsFor{fibonacci\_node\_type}
-\OverridesSection{serializable\_class}
-
-\TbpImp{fibonacci\_node\_write\_to\_marker}
-\begin{Verbatim}
- recursive subroutine fibonacci_node_write_to_marker(this,marker,status)
- class(fibonacci_node_type), intent(in) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
-! local variables
- class(serializable_class),pointer::ser
- call marker%mark_begin("fibonacci_node_type")
- ser=>this%left
- call marker%mark_pointer("left",ser)
- ser=>this%right
- call marker%mark_pointer("right",ser)
- ser=>this%xxxx
- call marker%mark_pointer("down",ser)
- call marker%mark_end("fibonacci_node_type")
- end subroutine fibonacci_node_write_to_marker
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_read\_from\_marker}
-\begin{Verbatim}
- recursive subroutine fibonacci_node_read_from_marker (this,marker,status)
- class(fibonacci_node_type), intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- print *,"fibonacci_node_read_from_marker: You cannot deserialize a list with this subroutine."
- print *,"Use fibonacci_node_read_target_from_marker instead."
- end subroutine fibonacci_node_read_from_marker
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_read\_target\_from\_marker}
-\begin{Verbatim}
-recursive subroutine fibonacci_node_read_target_from_marker(this,marker,status)
- class(fibonacci_node_type),target,intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
-! local variables
- class(serializable_class),pointer::ser
- call marker%pick_begin("fibonacci_node_type",status=status)
- call marker%pick_pointer("left",ser)
- if(status==0)then
- select type(ser)
- class is (fibonacci_node_type)
- this%left=>ser
- this%left%up=>this
- end select
- end if
- call marker%pick_pointer("right",ser)
- if(status==0)then
- select type(ser)
- class is (fibonacci_node_type)
- this%right=>ser
- this%right%up=>this
- end select
- end if
- call marker%pick_pointer("down",ser)
- if(status==0)then
- select type(ser)
- class is (measurable_class)
- this%xxxx=>ser
- end select
- end if
- call marker%pick_end("fibonacci_node_type",status)
- end subroutine fibonacci_node_read_target_from_marker
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_get\_type}
-\begin{Verbatim}
- pure subroutine fibonacci_node_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="fibonacci_node_type")
- end subroutine fibonacci_node_get_type
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_deserialize\_from\_marker}
-\begin{Verbatim}
- subroutine fibonacci_node_deserialize_from_marker(this,name,marker)
- class(fibonacci_node_type),intent(out)::this
- character(*),intent(in)::name
- class(marker_type),intent(inout)::marker
- class(serializable_class),pointer::ser
- allocate(fibonacci_leave_type::ser)
- call marker%push_reference(ser)
- allocate(fibonacci_node_type::ser)
- call marker%push_reference(ser)
- call serializable_deserialize_from_marker(this,name,marker)
- call marker%pop_reference(ser)
- deallocate(ser)
- call marker%pop_reference(ser)
- deallocate(ser)
- end subroutine fibonacci_node_deserialize_from_marker
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_print\_to\_unit}
-\begin{Verbatim}
- recursive subroutine fibonacci_node_print_to_unit(this,unit,parents,components,peers)
- class(fibonacci_node_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- class(serializable_class),pointer::ser
- write(unit,'("Components of fibonacci_node_type:")')
- write(unit,'("Depth: ",I22)')this%depth
- write(unit,'("Value: ",E23.16)')this%measure()
- ser=>this%up
- call serialize_print_comp_pointer(ser,unit,parents,-one,-one,"Up: ")
- ser=>this%left
- call serialize_print_peer_pointer(ser,unit,parents,components,peers,"Left: ")
- ser=>this%right
- call serialize_print_peer_pointer(ser,unit,parents,components,peers,"Right: ")
- end subroutine fibonacci_node_print_to_unit
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_measure}
-\begin{Verbatim}
- elemental function fibonacci_node_measure(this)
- class(fibonacci_node_type),intent(in)::this
- real(kind=double)::fibonacci_node_measure
- fibonacci_node_measure=this%down%measure()
- end function fibonacci_node_measure
-\end{Verbatim}
-
- ! init/final
-
-\TbpImp{fibonacci\_node\_deallocate\_tree}
-\begin{Verbatim}
- recursive subroutine fibonacci_node_deallocate_tree(this)
- class(fibonacci_node_type),intent(inout) :: this
- if (associated(this%left)) then
- call this%left%deallocate_tree()
- deallocate(this%left)
- end if
- if (associated(this%right)) then
- call this%right%deallocate_tree()
- deallocate(this%right)
- end if
- call this%set_depth(0)
- end subroutine fibonacci_node_deallocate_tree
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_deallocate\_all}
-\begin{Verbatim}
- recursive subroutine fibonacci_node_deallocate_all(this)
- class(fibonacci_node_type),intent(inout) :: this
- if (associated(this%left)) then
- call this%left%deallocate_all()
- deallocate(this%left)
- end if
- if (associated(this%right)) then
- call this%right%deallocate_all()
- deallocate(this%right)
- end if
- call this%set_depth(0)
- end subroutine fibonacci_node_deallocate_all
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_set\_depth}
-\begin{Verbatim}
- subroutine fibonacci_node_set_depth(this,depth)
- class(fibonacci_node_type),intent(inout) :: this
- integer,intent(in) :: depth
- this%depth=depth
- end subroutine fibonacci_node_set_depth
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_get\_depth}
-\begin{Verbatim}
- elemental function fibonacci_node_get_depth(this)
- class(fibonacci_node_type),intent(in) :: this
- integer :: fibonacci_node_get_depth
- fibonacci_node_get_depth = this%depth
- end function fibonacci_node_get_depth
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_is\_leave}
-\begin{Verbatim}
- elemental function fibonacci_node_is_leave()
- logical :: fibonacci_node_is_leave
- fibonacci_node_is_leave = .false.
- end function fibonacci_node_is_leave
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_is\_root}
-\begin{Verbatim}
- elemental function fibonacci_node_is_root()
- logical :: fibonacci_node_is_root
- fibonacci_node_is_root = .false.
- end function fibonacci_node_is_root
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_is\_inner}
-\begin{Verbatim}
- elemental function fibonacci_node_is_inner()
- logical :: fibonacci_node_is_inner
- fibonacci_node_is_inner = .true.
- end function fibonacci_node_is_inner
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_write\_leaves}
-\begin{Verbatim}
- subroutine fibonacci_node_write_leaves(this,unit)
- class(fibonacci_node_type),intent(in),target :: this
- integer,intent(in),optional :: unit
- call this%apply_to_leaves(fibonacci_leave_write,unit)
- end subroutine fibonacci_node_write_leaves
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_write\_contents}
-\begin{Verbatim}
- subroutine fibonacci_node_write_contents(this,unit)
- class(fibonacci_node_type),intent(in),target :: this
- integer,intent(in),optional :: unit
- call this%apply_to_leaves(fibonacci_leave_write_content,unit)
- end subroutine fibonacci_node_write_contents
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_write\_values}
-\begin{Verbatim}
- subroutine fibonacci_node_write_values(this,unit)
- class(fibonacci_node_type),intent(in),target :: this
- integer,intent(in),optional :: unit
- call this%apply_to_leaves(fibonacci_leave_write_value,unit)
- end subroutine fibonacci_node_write_values
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_write\_association}
-\begin{Verbatim}
- subroutine fibonacci_node_write_association(this,that)
- class(fibonacci_node_type),intent(in),target :: this
- class(fibonacci_node_type),intent(in),target :: that
- if (associated(that%left,this)) then
- write(*,'("this is left child of that")')
- end if
- if (associated(that%right,this)) then
- write(*,'("this is right child of that")')
- end if
- if (associated(that%up,this)) then
- write(*,'("this is parent of that")')
- end if
- if (associated(this%left,that)) then
- write(*,'("that is left child of this")')
- end if
- if (associated(this%right,that)) then
- write(*,'("that is right child of this")')
- end if
- if (associated(this%up,that)) then
- write(*,'("that is parent of this")')
- end if
- end subroutine fibonacci_node_write_association
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_write\_pstricks}
-\begin{Verbatim}
- recursive subroutine fibonacci_node_write_pstricks(this,unitnr)
- class(fibonacci_node_type),intent(in),target :: this
- integer,intent(in) :: unitnr
- if (associated(this%up)) then
- if (associated(this%up%left,this).neqv.(associated(this%up%right,this))) then
- write(unitnr,'("{\textbackslash}begin{psTree}{{\textbackslash}Toval{{\textbackslash}node{",i3,"}{",f9.3,"}}}")')&
- int(this%depth),this%measure()
- else
- write(unitnr,'("{\textbackslash}begin{psTree}{{\textbackslash}Toval[",a,"]{{\textbackslash}node{",i3,"}{",f9.3,"}}}")')&
- no_ret,int(this%depth),this%measure()
- end if
- else
- write(unitnr,'("{\textbackslash}begin{psTree}{{\textbackslash}Toval[",a,"]{{\textbackslash}node{",i3,"}{",f9.3,"}}}")')&
- no_par,int(this%depth),this%measure()
- end if
- if (associated(this%left)) then
- call this%left%write_pstricks(unitnr)
- else
- write(unitnr,'("{\textbackslash}Tr[edge=brokenline]{}")')
- end if
- if (associated(this%right)) then
- call this%right%write_pstricks(unitnr)
- else
- write(unitnr,'("{\textbackslash}Tr[edge=brokenline]{}")')
- end if
- write(unitnr,'("{\textbackslash}end{psTree}")')
- end subroutine fibonacci_node_write_pstricks
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_copy\_node}
-\begin{Verbatim}
- subroutine fibonacci_node_copy_node(this,primitive)
- class(fibonacci_node_type),intent(out) :: this
- class(fibonacci_node_type),intent(in) :: primitive
- this%up => primitive%up
- this%left => primitive%left
- this%right => primitive%right
- this%depth = primitive%depth
- this%down=> primitive%down
- end subroutine fibonacci_node_copy_node
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_find\_root}
-\begin{Verbatim}
- subroutine fibonacci_node_find_root(this,root)
- class(fibonacci_node_type),intent(in),target :: this
- class(fibonacci_root_type),pointer,intent(out) :: root
- class(fibonacci_node_type),pointer :: node
- node=>this
- do while(associated(node%up))
- node=>node%up
- end do
- select type (node)
- class is (fibonacci_root_type)
- root=>node
- class default
- nullify(root)
- print *,"fibonacci_node_find_root: root is not type compatible to&
- & fibonacci_root_type. Retured NULL()."
- end select
- end subroutine fibonacci_node_find_root
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_find\_leftmost}
-\begin{Verbatim}
- subroutine fibonacci_node_find_leftmost(this,leave)
- class(fibonacci_node_type),intent(in), target :: this
- class(fibonacci_leave_type),pointer,intent(out) :: leave
- class(fibonacci_node_type), pointer :: node
- node=>this
- do while(associated(node%left))
- node=>node%left
- end do
- select type (node)
- class is (fibonacci_leave_type)
- leave => node
- class default
- leave => null()
- end select
- end subroutine fibonacci_node_find_leftmost
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_find\_rightmost}
-\begin{Verbatim}
- subroutine fibonacci_node_find_rightmost(this,leave)
- class(fibonacci_node_type),intent(in), target :: this
- class(fibonacci_leave_type),pointer,intent(out) :: leave
- class(fibonacci_node_type), pointer :: node
- node=>this
- do while(associated(node%right))
- node=>node%right
- end do
- select type (node)
- class is (fibonacci_leave_type)
- leave => node
- class default
- leave => null()
- end select
- end subroutine fibonacci_node_find_rightmost
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_find}
-\begin{Verbatim}
- subroutine fibonacci_node_find(this,value,leave)
- class(fibonacci_node_type),intent(in),target :: this
- real(kind=double),intent(in) :: value
- class(fibonacci_leave_type),pointer,intent(out) :: leave
- class(fibonacci_node_type), pointer :: node
- node=>this
- do
- if (node>=value) then
- if (associated(node%left)) then
- node=>node%left
- else
- print *,"fibonacci_node_find: broken tree!"
- leave => null()
- return
- end if
- else
- if (associated(node%right)) then
- node=>node%right
- else
- print *,"fibonacci_node_find: broken tree!"
- leave => null()
- return
- end if
- end if
- select type (node)
- class is (fibonacci_leave_type)
- leave => node
- exit
- end select
- end do
- end subroutine fibonacci_node_find
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_find\_left\_leave}
-\begin{Verbatim}
- subroutine fibonacci_node_find_left_leave(this,leave)
- class(fibonacci_node_type),intent(in),target :: this
- class(fibonacci_node_type),pointer :: node
- class(fibonacci_leave_type),pointer,intent(out) :: leave
- nullify(leave)
- node=>this
- do while (associated(node%up))
- if (associated(node%up%right,node)) then
- node=>node%up%left
- do while (associated(node%right))
- node=>node%right
- end do
- select type (node)
- class is (fibonacci_leave_type)
- leave=>node
- end select
- exit
- end if
- node=>node%up
- end do
- end subroutine fibonacci_node_find_left_leave
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_find\_right\_leave}
-\begin{Verbatim}
- subroutine fibonacci_node_find_right_leave(this,leave)
- class(fibonacci_node_type),intent(in),target :: this
- class(fibonacci_node_type),pointer :: node
- class(fibonacci_leave_type),pointer,intent(out) :: leave
- nullify(leave)
- node=>this
- do while (associated(node%up))
- if (associated(node%up%left,node)) then
- node=>node%up%right
- do while (associated(node%left))
- node=>node%left
- end do
- select type (node)
- class is (fibonacci_leave_type)
- leave=>node
- end select
- exit
- end if
- node=>node%up
- end do
- end subroutine fibonacci_node_find_right_leave
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_replace}
-\begin{Verbatim}
- subroutine fibonacci_node_replace(this,old_node)
- class(fibonacci_node_type),intent(inout),target :: this
- class(fibonacci_node_type),target :: old_node
- if (associated(old_node%up)) then
- if (old_node%is_left_child()) then
- old_node%up%left => this
- else
- if (old_node%is_right_child()) then
- old_node%up%right => this
- end if
- end if
- this%up => old_node%up
- else
- nullify(this%up)
- end if
- end subroutine fibonacci_node_replace
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_swap\_nodes}
-\begin{Verbatim}
- subroutine fibonacci_node_swap_nodes(left,right)
- class(fibonacci_node_type),target,intent(inout) :: left,right
- class(fibonacci_node_type),pointer :: left_left,right_right
- class(measurable_class),pointer::down
- ! swap branches
- left_left =>left%left
- right_right=>right%right
- left%left =>right%right
- right%right=>left_left
- ! repair up components
- right_right%up=>left
- left_left%up =>right
- ! repair down components
- down => left%down
- left%down => right%down
- right%down => down
- end subroutine fibonacci_node_swap_nodes
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_swap\_nodes}
-\begin{Verbatim}
-! subroutine fibonacci_node_swap_nodes(this,that)
-! class(fibonacci_node_type),target :: this
-! class(fibonacci_node_type),pointer,intent(in) :: that
-! class(fibonacci_node_type),pointer :: par_i,par_a
-! par_i => this%up
-! par_a => that%up
-! if (associated(par_i%left,this)) then
-! par_i%left => that
-! else
-! par_i%right => that
-! end if
-! if (associated(par_a%left,that)) then
-! par_a%left => this
-! else
-! par_a%right => this
-! end if
-! this%up => par_a
-! that%up => par_i
-! end subroutine fibonacci_node_swap_nodes
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_flip\_children}
-\begin{Verbatim}
- subroutine fibonacci_node_flip_children(this)
- class(fibonacci_node_type),intent(inout) :: this
- class(fibonacci_node_type),pointer :: child
- child => this%left
- this%left=>this%right
- this%right => child
- end subroutine fibonacci_node_flip_children
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_rip}
-\begin{Verbatim}
- subroutine fibonacci_node_rip(this)
- class(fibonacci_node_type),intent(inout),target :: this
- if (this%is_left_child()) then
- nullify(this%up%left)
- end if
- if (this%is_right_child()) then
- nullify(this%up%right)
- end if
- nullify(this%up)
- end subroutine fibonacci_node_rip
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_remove\_and\_keep\_twin}
-\begin{Verbatim}
- subroutine fibonacci_node_remove_and_keep_twin(this,twin)
- class(fibonacci_node_type),intent(inout),target :: this
- class(fibonacci_node_type),intent(out),pointer :: twin
- class(fibonacci_node_type),pointer :: pa
- if (.not. (this%is_root())) then
- pa=>this%up
- if (.not. pa%is_root()) then
- if (this%is_left_child()) then
- twin => pa%right
- else
- twin => pa%left
- end if
- if (pa%is_left_child()) then
- pa%up%left => twin
- else
- pa%up%right => twin
- end if
- end if
- twin%up => pa%up
- if(associated(this%right))then
- this%right%left=>this%left
- end if
- if(associated(this%left))then
- this%left%right=>this%right
- end if
- nullify(this%left)
- nullify(this%right)
- nullify(this%up)
- deallocate(pa)
- end if
- end subroutine fibonacci_node_remove_and_keep_twin
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_remove\_and\_keep\_parent}
-\begin{Verbatim}
- subroutine fibonacci_node_remove_and_keep_parent(this,pa)
- class(fibonacci_node_type),intent(inout),target :: this
- class(fibonacci_node_type),intent(out),pointer :: pa
- class(fibonacci_node_type),pointer :: twin
- if (.not. (this%is_root())) then
- pa=>this%up
- if (this%is_left_child()) then
- twin => pa%right
- else
- twin => pa%left
- end if
- twin%up=>pa%up
- if (associated(twin%left)) then
- twin%left%up => pa
- end if
- if (associated(twin%right)) then
- twin%right%up => pa
- end if
- call pa%copy_node(twin)
- select type(pa)
- class is (fibonacci_root_type)
- call pa%set_leftmost()
- call pa%set_rightmost()
- end select
- if(associated(this%right))then
- this%right%left=>this%left
- end if
- if(associated(this%left))then
- this%left%right=>this%right
- end if
- nullify(this%left)
- nullify(this%right)
- nullify(this%up)
- deallocate(twin)
- else
- pa=>this
- end if
- end subroutine fibonacci_node_remove_and_keep_parent
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_pick}
-\begin{Verbatim}
- subroutine fibonacci_leave_pick(this)
- class(fibonacci_leave_type),target,intent(inout) :: this
- class(fibonacci_node_type),pointer :: other
- class(fibonacci_root_type),pointer :: root
-! call this%up%print_parents()
- call this%find_root(root)
- if(associated(this%up,root))then
- if(this%up%depth<2)then
- print *,"fibonacci_leave_pick: Cannot pick leave. &
- &Tree must have at least three leaves."
- return
- else
- call this%remove_and_keep_parent(other)
- call other%repair()
- end if
- else
- call this%remove_and_keep_twin(other)
- call other%up%repair()
- end if
- if(associated(root%leftmost,this))call root%set_leftmost()
- if(associated(root%rightmost,this))call root%set_rightmost()
- end subroutine fibonacci_leave_pick
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_append\_left}
-\begin{Verbatim}
- subroutine fibonacci_node_append_left(this,new_branch)
- class(fibonacci_node_type),target :: this
- class(fibonacci_node_type),target :: new_branch
- this%left => new_branch
- new_branch%up => this
- end subroutine fibonacci_node_append_left
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_append\_right}
-\begin{Verbatim}
- subroutine fibonacci_node_append_right(this,new_branch)
- class(fibonacci_node_type),intent(inout),target :: this
- class(fibonacci_node_type),target :: new_branch
- this%right => new_branch
- new_branch%up => this
- end subroutine fibonacci_node_append_right
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_rotate\_left}
-\begin{Verbatim}
- subroutine fibonacci_node_rotate_left(this)
- class(fibonacci_node_type),intent(inout),target :: this
- call this%swap(this%right)
- call this%right%flip()
- call this%right%update_depth_unsave()
- call this%flip()
-! value = this%value
-! this%value = this%left%value
-! this%left%value = value
- end subroutine fibonacci_node_rotate_left
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_rotate\_right}
-\begin{Verbatim}
- subroutine fibonacci_node_rotate_right(this)
- class(fibonacci_node_type),intent(inout),target :: this
- call this%left%swap(this)
- call this%left%flip()
- call this%left%update_depth_unsave()
- call this%flip()
-! value = this%value
-! this%value = this%right%value
-! this%right%value = value
- end subroutine fibonacci_node_rotate_right
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_rotate}
-\begin{Verbatim}
- subroutine fibonacci_node_rotate(this)
- class(fibonacci_node_type),intent(inout),target :: this
- if (this%is_left_short()) then
- call this%rotate_left()
- else
- if (this%is_right_short()) then
- call this%rotate_right()
- end if
- end if
- end subroutine fibonacci_node_rotate
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_balance\_node}
-\begin{Verbatim}
- subroutine fibonacci_node_balance_node(this,changed)
- class(fibonacci_node_type),intent(inout),target :: this
- logical,intent(out) :: changed
- changed=.false.
- if (this%is_left_too_short()) then
- if (this%right%is_right_short()) then
- call this%right%rotate_right
- end if
- call this%rotate_left()
- changed=.true.
- else
- if (this%is_right_too_short()) then
- if (this%left%is_left_short()) then
- call this%left%rotate_left
- end if
- call this%rotate_right()
- changed=.true.
- end if
- end if
- end subroutine fibonacci_node_balance_node
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_update\_depth\_unsave}
-\begin{Verbatim}
- subroutine fibonacci_node_update_depth_unsave(this)
- class(fibonacci_node_type),intent(inout) :: this
- this%depth=max(this%left%depth+1,this%right%depth+1)
- end subroutine fibonacci_node_update_depth_unsave
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_update\_depth\_save}
-\begin{Verbatim}
- subroutine fibonacci_node_update_depth_save(this,updated)
- class(fibonacci_node_type),intent(inout) :: this
- logical,intent(out) :: updated
- integer :: left,right,new_depth
- if (associated(this%left)) then
- left=this%left%depth+1
- else
- left=-1
- end if
- if (associated(this%right)) then
- right=this%right%depth+1
- else
- right=-1
- end if
- new_depth=max(left,right)
- if (this%depth == new_depth) then
- updated = .false.
- else
- this%depth=new_depth
- updated = .true.
- end if
- end subroutine fibonacci_node_update_depth_save
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_repair}
-\begin{Verbatim}
- subroutine fibonacci_node_repair(this)
- class(fibonacci_node_type),intent(inout),target :: this
- class(fibonacci_node_type),pointer:: node
- logical :: new_depth,new_balance
- new_depth = .true.
- node=>this
- do while((new_depth .or. new_balance) .and. (associated(node)))
- call node%balance_node(new_balance)
- call node%update_depth_save(new_depth)
- node=>node%up
- end do
- end subroutine fibonacci_node_repair
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_is\_left\_short}
-\begin{Verbatim}
- elemental logical function fibonacci_node_is_left_short(this)
- class(fibonacci_node_type),intent(in) :: this
- fibonacci_node_is_left_short = (this%left%depth<this%right%depth)
- end function fibonacci_node_is_left_short
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_is\_right\_short}
-\begin{Verbatim}
- elemental logical function fibonacci_node_is_right_short(this)
- class(fibonacci_node_type),intent(in) :: this
- fibonacci_node_is_right_short = (this%right%depth<this%left%depth)
- end function fibonacci_node_is_right_short
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_is\_unbalanced}
-\begin{Verbatim}
- elemental logical function fibonacci_node_is_unbalanced(this)
- class(fibonacci_node_type),intent(in) :: this
- fibonacci_node_is_unbalanced = (this%is_left_short() .or. this%is_right_short())
- end function fibonacci_node_is_unbalanced
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_is\_left\_too\_short}
-\begin{Verbatim}
- elemental logical function fibonacci_node_is_left_too_short(this)
- class(fibonacci_node_type),intent(in) :: this
- fibonacci_node_is_left_too_short = (this%left%depth+1<this%right%depth)
- end function fibonacci_node_is_left_too_short
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_is\_right\_too\_short}
-\begin{Verbatim}
- elemental logical function fibonacci_node_is_right_too_short(this)
- class(fibonacci_node_type),intent(in) :: this
- fibonacci_node_is_right_too_short = (this%right%depth+1<this%left%depth)
- end function fibonacci_node_is_right_too_short
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_is\_too\_unbalanced}
-\begin{Verbatim}
- elemental logical function fibonacci_node_is_too_unbalanced(this)
- class(fibonacci_node_type),intent(in) :: this
- fibonacci_node_is_too_unbalanced = (this%is_left_too_short() .or. this%is_right_too_short())
- end function fibonacci_node_is_too_unbalanced
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_is\_left\_child}
-\begin{Verbatim}
- elemental logical function fibonacci_node_is_left_child(this)
- class(fibonacci_node_type),intent(in),target :: this
- fibonacci_node_is_left_child = associated(this%up%left,this)
- end function fibonacci_node_is_left_child
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_is\_right\_child}
-\begin{Verbatim}
- elemental logical function fibonacci_node_is_right_child(this)
- class(fibonacci_node_type),intent(in),target :: this
- fibonacci_node_is_right_child = associated(this%up%right,this)
- end function fibonacci_node_is_right_child
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_apply\_to\_leaves}
-\begin{Verbatim}
- recursive subroutine fibonacci_node_apply_to_leaves(node,func,unit)
- class(fibonacci_node_type),intent(in),target :: node
- interface
- subroutine func(this,unit)
- import fibonacci_leave_type
- class(fibonacci_leave_type),intent(in),target :: this
- integer,intent(in),optional :: unit
- end subroutine func
- end interface
- integer,intent(in),optional :: unit
- select type (node)
- class is (fibonacci_leave_type)
- call func(node,unit)
- class default
- call node%left%apply_to_leaves(func,unit)
- call node%right%apply_to_leaves(func,unit)
- end select
- end subroutine fibonacci_node_apply_to_leaves
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_apply\_to\_leaves\_rl}
-\begin{Verbatim}
- recursive subroutine fibonacci_node_apply_to_leaves_RL(node,func,unit)
- class(fibonacci_node_type),intent(in),target :: node
- interface
- subroutine func(this,unit)
- import fibonacci_leave_type
- class(fibonacci_leave_type),intent(in),target :: this
- integer,intent(in),optional :: unit
- end subroutine func
- end interface
- integer,intent(in),optional :: unit
- select type (node)
- class is (fibonacci_leave_type)
- call func(node,unit)
- class default
- call node%right%apply_to_leaves_rl(func,unit)
- call node%left%apply_to_leaves_rl(func,unit)
- end select
- end subroutine fibonacci_node_apply_to_leaves_RL
-\end{Verbatim}
-
-\TbpImp{fibonacci\_node\_count\_leaves}
-\begin{Verbatim}
- recursive subroutine fibonacci_node_count_leaves(this,n)
- class(fibonacci_node_type),intent(in) :: this
- integer,intent(out) :: n
- integer::n1,n2
- if(associated(this%left).and.associated(this%right)) then
- call fibonacci_node_count_leaves(this%left,n1)
- call fibonacci_node_count_leaves(this%right,n2)
- n=n1+n2
- else
- n=1
- end if
- end subroutine fibonacci_node_count_leaves
-\end{Verbatim}
-
-\MethodsFor{fibonacci\_root\_type}
-\TbpImp{fibonacci\_root\_write\_to\_marker}
-\begin{Verbatim}
- SUBROUTINE fibonacci_root_write_to_marker(this,marker,status)
- CLASS(fibonacci_root_type), INTENT(IN) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
-! call marker%mark_begin("FIBONACCI_ROOT_TYPE")
- call fibonacci_node_write_to_marker(this,marker,status)
-! marker%mark_end("FIBONACCI_ROOT_TYPE")
- end SUBROUTINE fibonacci_root_write_to_marker
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_read\_target\_from\_marker}
-\begin{Verbatim}
- SUBROUTINE fibonacci_root_read_target_from_marker(this,marker,status)
- CLASS(fibonacci_root_type),target,INTENT(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
-! call marker%pick_begin("FIBONACCI_ROOT_TYPE",status)
- call fibonacci_node_read_from_marker(this,marker,status)
- call this%find_leftmost(this%leftmost)
- call this%find_rightmost(this%rightmost)
-! call marker%pick_end("FIBONACCI_ROOT_TYPE",status)
- end SUBROUTINE fibonacci_root_read_target_from_marker
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_print\_to\_unit}
-\begin{Verbatim}
- subroutine fibonacci_root_print_to_unit(this,unit,parents,components,peers)
- class(fibonacci_root_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- class(serializable_class),pointer::ser
- if(parents>0)call fibonacci_node_print_to_unit(this,unit,parents-1,components,peers)
- write(unit,'("Components of fibonacci_root_type:")')
- ser=>this%leftmost
- call serialize_print_peer_pointer(ser,unit,parents,components,min(peers,one),"Leftmost: ")
- ser=>this%rightmost
- call serialize_print_peer_pointer(ser,unit,parents,components,min(peers,one),"Rightmost:")
- end subroutine fibonacci_root_print_to_unit
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_get\_type}
-\begin{Verbatim}
- pure subroutine fibonacci_root_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="fibonacci_root_type")
- end subroutine fibonacci_root_get_type
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_get\_leftmost}
-\begin{Verbatim}
- subroutine fibonacci_root_get_leftmost(this,leftmost)
- class(fibonacci_root_type),intent(in)::this
- class(fibonacci_leave_type),pointer::leftmost
- leftmost=>this%leftmost
- end subroutine fibonacci_root_get_leftmost
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_get\_rightmost}
-\begin{Verbatim}
- subroutine fibonacci_root_get_rightmost(this,rightmost)
- class(fibonacci_root_type),intent(in)::this
- class(fibonacci_leave_type),pointer::rightmost
- rightmost=>this%rightmost
- end subroutine fibonacci_root_get_rightmost
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_is\_inner}
-\begin{Verbatim}
- elemental function fibonacci_root_is_inner()
- logical::fibonacci_root_is_inner
- fibonacci_root_is_inner=.false.
- end function fibonacci_root_is_inner
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_is\_root}
-\begin{Verbatim}
- elemental function fibonacci_root_is_root()
- logical::fibonacci_root_is_root
- fibonacci_root_is_root=.true.
- end function fibonacci_root_is_root
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_is\_valid}
-\begin{Verbatim}
- elemental function fibonacci_root_is_valid(this)
- class(fibonacci_root_type),intent(in) :: this
- logical :: fibonacci_root_is_valid
- fibonacci_root_is_valid=this%is_valid_c
- end function fibonacci_root_is_valid
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_count\_leaves}
-\begin{Verbatim}
- subroutine fibonacci_root_count_leaves(this,n)
- class(fibonacci_root_type),intent(in) :: this
- integer,intent(out) :: n
- n=0
- call fibonacci_node_count_leaves(this,n)
- end subroutine fibonacci_root_count_leaves
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_write\_pstricks}
-\begin{Verbatim}
- subroutine fibonacci_root_write_pstricks(this,unitnr)
- class(fibonacci_root_type),intent(in),target :: this
- integer,intent(in) :: unitnr
- logical :: is_opened
- character :: is_sequential,is_formatted,is_writeable
- print *,"pstricks"
- inquire(unitnr,opened=is_opened,&
- &sequential=is_sequential,formatted=is_formatted,write=is_writeable)
- if (is_opened) then
- if (is_sequential=="Y" .and. is_formatted=="Y" .and. is_writeable=="Y") then
- write(unitnr,'("{\textbackslash}begin{psTree}{{\textbackslash}Toval[linecolor=blue]{{\textbackslash}node{",i3,"}{",f9.3,"}}}")')&
- this%depth,this%measure()
- if (associated(this%leftmost)) then
- call this%leftmost%write_pstricks(unitnr)
- else
- write(unitnr,'("{\textbackslash}Tr[",a,"]{}")') no_kid
- end if
- if (associated(this%left)) then
- call this%left%write_pstricks(unitnr)
- else
- write(unitnr,'("{\textbackslash}Tr[",a,"]{}")') no_kid
- end if
- if (associated(this%right)) then
- call this%right%write_pstricks(unitnr)
- else
- write(unitnr,'("{\textbackslash}Tr[",a,"]{}")') no_kid
- end if
- if (associated(this%rightmost)) then
- call this%rightmost%write_pstricks(unitnr)
- else
- write(unitnr,'("{\textbackslash}Tr[",a,"]{}")') no_kid
- end if
- write(unitnr,'("{\textbackslash}end{psTree}")')
- write(unitnr,'("\textbackslash\textbackslash")')
- else
- print '("fibonacci_node_write_pstricks: Unit ",I2," is not opened properly.")',unitnr
- print '("No output is written to unit.")'
- end if
- else
- print '("fibonacci_node_write_pstricks: Unit ",I2," is not opened.")',unitnr
- print '("No output is written to unit.")'
- end if
- end subroutine fibonacci_root_write_pstricks
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_copy\_root}
-\begin{Verbatim}
- subroutine fibonacci_root_copy_root(this,primitive)
- class(fibonacci_root_type),intent(out) :: this
- class(fibonacci_root_type),intent(in) :: primitive
- call fibonacci_node_copy_node(this,primitive)
- this%leftmost => primitive%leftmost
- this%rightmost => primitive%rightmost
- end subroutine fibonacci_root_copy_root
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_push\_by\_content}
-\begin{Verbatim}
- subroutine fibonacci_root_push_by_content(this,content)
- class(fibonacci_root_type),target,intent(inout) :: this
- class(measurable_class),target,intent(in)::content
- class(fibonacci_leave_type),pointer :: node
-! print *,"fibonacci_root_push_by_content: ",content%measure()
- allocate(node)
- node%down=>content
- call this%push_by_leave(node)
- end subroutine fibonacci_root_push_by_content
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_push\_by\_leave}
-\begin{Verbatim}
- ! this is a workaround for BUG 44696. This subroutine is a merge of
- ! fibonacci_tree_push_by_node
- ! fibonacci_node_find
- ! fibonacci_leave_insert_leave_by_node
- subroutine fibonacci_root_push_by_leave(this,new_leave)
- class(fibonacci_root_type),target,intent(inout) :: this
- class(fibonacci_leave_type),pointer,intent(inout) :: new_leave
- class(fibonacci_leave_type),pointer :: old_leave
- class(fibonacci_node_type), pointer :: node,new_node,leave_c
- if (new_leave<=this%leftmost) then
- old_leave=>this%leftmost
- this%leftmost=>new_leave
- node=>old_leave%up
- call fibonacci_node_spawn&
- (new_node,new_leave,old_leave,old_leave%left,old_leave%right)
- call node%append_left(new_node)
- else
- if (new_leave>this%rightmost) then
- old_leave=>this%rightmost
- this%rightmost=>new_leave
- node=>old_leave%up
- call fibonacci_node_spawn&
- (new_node,old_leave,new_leave,old_leave%left,old_leave%right)
- call node%append_right(new_node)
- else
- node=>this
- do
- if (new_leave<=node) then
- leave_c=>node%left
- select type (leave_c)
- class is (fibonacci_leave_type)
- if(new_leave<=leave_c)then
- call fibonacci_node_spawn&
- (new_node,new_leave,leave_c,leave_c%left,leave_c%right)
- else
- call fibonacci_node_spawn&
- (new_node,leave_c,new_leave,leave_c%left,leave_c%right)
- end if
- call node%append_left(new_node)
- exit
- class default
- node=>node%left
- end select
- else
- leave_c=>node%right
- select type (leave_c)
- class is (fibonacci_leave_type)
- if(new_leave<=leave_c)then
- call fibonacci_node_spawn&
- (new_node,new_leave,leave_c,leave_c%left,leave_c%right)
- else
- call fibonacci_node_spawn&
- (new_node,leave_c,new_leave,leave_c%left,leave_c%right)
- end if
- call node%append_right(new_node)
- exit
- class default
- node=>node%right
- end select
- end if
- end do
- end if
- end if
- call node%repair()
- end subroutine fibonacci_root_push_by_leave
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_pop\_left}
-\begin{Verbatim}
- subroutine fibonacci_root_pop_left(this,leave)
- class(fibonacci_root_type),intent(inout),target :: this
- class(fibonacci_leave_type),pointer,intent(out) :: leave
- class(fibonacci_node_type),pointer :: parent,grand
- !write(11,fmt=*)"fibonacci root pop left\\"!PSTRICKS
- !flush(11)!PSTRICKS
- leave => this%leftmost
- if (this%left%depth>=1) then
- parent => leave%up
- grand=>parent%up
- grand%left => parent%right
- parent%right%up=>grand
- deallocate(parent)
- parent=>grand%left
- if (.not.parent%is_leave())then
- parent=>parent%left
- end if
- select type (parent)
- class is (fibonacci_leave_type)
- this%leftmost => parent
- class default
- print *,"fibonacci_root_pop_left: ERROR: leftmost is no leave."
- call parent%print_all()
- STOP
- end select
- !call this%write_pstricks(11)!PSTRICKS
- !flush(11)!PSTRICKS
- !write(11,fmt=*)"fibonacci node repair\\"!PSTRICKS
- !flush(11)!PSTRICKS
- call grand%repair()
- else
- if (this%left%depth==0.and.this%right%depth==1) then
- parent => this%right
- parent%right%up=>this
- parent%left%up=>this
- this%left=>parent%left
- this%right=>parent%right
- this%depth=1
- deallocate(parent)
- parent=>this%left
- select type (parent)
- class is (fibonacci_leave_type)
- this%leftmost => parent
- end select
- this%down=>this%leftmost%down
- end if
- end if
- nullify(leave%right%left)
- nullify(leave%up)
- nullify(leave%right)
- nullify(this%leftmost%left)
- !call this%write_pstricks(11)!PSTRICKS
- !flush(11)!PSTRICKS
- end subroutine fibonacci_root_pop_left
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_pop\_right}
-\begin{Verbatim}
- subroutine fibonacci_root_pop_right(this,leave)
- class(fibonacci_root_type),intent(inout),target :: this
- class(fibonacci_leave_type),pointer,intent(out) :: leave
- class(fibonacci_node_type),pointer :: parent,grand
- leave => this%rightmost
- if (this%right%depth>=1) then
- parent => leave%up
- grand=>parent%up
- grand%right => parent%left
- parent%left%up=>grand
- deallocate(parent)
- parent=>grand%right
- if (.not.parent%is_leave())then
- parent=>parent%right
- end if
- select type (parent)
- class is (fibonacci_leave_type)
- this%rightmost => parent
- class default
- print *,"fibonacci_root_pop_left: ERROR: leftmost is no leave."
- call parent%print_all()
- STOP
- end select
- call grand%repair()
- else
- if (this%right%depth==0.and.this%left%depth==1) then
- parent => this%left
- parent%left%up=>this
- parent%right%up=>this
- this%right=>parent%right
- this%left=>parent%left
- this%depth=1
- deallocate(parent)
- parent=>this%right
- select type (parent)
- class is (fibonacci_leave_type)
- this%rightmost => parent
- end select
- this%down=>this%rightmost%down
- end if
- end if
- end subroutine fibonacci_root_pop_right
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_merge}
-\begin{Verbatim}
- subroutine fibonacci_root_merge(this_tree,that_tree,merge_tree)
- ! I neither used nor revised this procedure for a long time, so it might be broken.
- class(fibonacci_root_type),intent(in) :: this_tree
- class(fibonacci_root_type),intent(in) :: that_tree
- class(fibonacci_root_type),pointer,intent(out) :: merge_tree
- class(fibonacci_leave_type),pointer :: this_leave,that_leave,old_leave
- type(fibonacci_leave_list_type),target :: leave_list
- class(fibonacci_leave_list_type),pointer :: last_leave
- integer :: n_leaves
- if (associated(this_tree%leftmost).and.associated(that_tree%leftmost)) then
- n_leaves=1
- this_leave=>this_tree%leftmost
- that_leave=>that_tree%leftmost
- if (this_leave < that_leave) then
- allocate(leave_list%leave,source=this_leave)
- call this_leave%find_right_leave(this_leave)
- else
- allocate(leave_list%leave,source=that_leave)
- call that_leave%find_right_leave(that_leave)
- end if
- last_leave=>leave_list
- do while (associated(this_leave).and.associated(that_leave))
- if (this_leave < that_leave) then
- old_leave=>this_leave
- call this_leave%find_right_leave(this_leave)
- else
- old_leave=>that_leave
- call that_leave%find_right_leave(that_leave)
- end if
- allocate(last_leave%next)
- last_leave=>last_leave%next
- allocate(last_leave%leave,source=old_leave)
- n_leaves=n_leaves+1
- end do
- if (associated(this_leave)) then
- old_leave=>this_leave
- else
- old_leave=>that_leave
- end if
- do while (associated(old_leave))
- allocate(last_leave%next)
- last_leave=>last_leave%next
- allocate(last_leave%leave,source=old_leave)
- n_leaves=n_leaves+1
- call old_leave%find_right_leave(old_leave)
- end do
- allocate(merge_tree)
- call fibonacci_root_list_to_tree(merge_tree,n_leaves,leave_list)
- else
- n_leaves=0
- end if
- if(associated(leave_list%next)) then
- last_leave=>leave_list%next
- do while (associated(last_leave%next))
- leave_list%next=>last_leave%next
- deallocate(last_leave)
- last_leave=>leave_list%next
- end do
- deallocate(last_leave)
- end if
- end subroutine fibonacci_root_merge
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_set\_leftmost}
-\begin{Verbatim}
- subroutine fibonacci_root_set_leftmost(this)
- class(fibonacci_root_type) :: this
- call this%find_leftmost(this%leftmost)
- end subroutine fibonacci_root_set_leftmost
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_set\_rightmost}
-\begin{Verbatim}
- subroutine fibonacci_root_set_rightmost(this)
- class(fibonacci_root_type) :: this
- call this%find_rightmost(this%rightmost)
- end subroutine fibonacci_root_set_rightmost
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_init\_by\_leave}
-\begin{Verbatim}
- subroutine fibonacci_root_init_by_leave(this,left_leave,right_leave)
- class(fibonacci_root_type),target,intent(out) :: this
- class(fibonacci_leave_type),target,intent(in) :: left_leave,right_leave
- if (left_leave <= right_leave) then
- this%left => left_leave
- this%right => right_leave
- this%leftmost => left_leave
- this%rightmost => right_leave
- else
- this%left => right_leave
- this%right => left_leave
- this%leftmost => right_leave
- this%rightmost => left_leave
- end if
- this%left%up => this
- this%right%up => this
- this%down=>this%leftmost%down
- this%depth = 1
- this%leftmost%right=>this%rightmost
- this%rightmost%left=>this%leftmost
- this%is_valid_c=.true.
- end subroutine fibonacci_root_init_by_leave
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_init\_by\_content}
-\begin{Verbatim}
- subroutine fibonacci_root_init_by_content(this,left_content,right_content)
- class(fibonacci_root_type),target,intent(out) :: this
- class(measurable_class),intent(in),target :: left_content,right_content
- call fibonacci_root_reset(this)
- print *,"fibonacci_root_init_by_content: ",left_content%measure(),right_content%measure()
- if (left_content<right_content) then
- call this%leftmost%set_content(left_content)
- call this%rightmost%set_content(right_content)
- else
- call this%leftmost%set_content(right_content)
- call this%rightmost%set_content(left_content)
- end if
- this%down=>this%leftmost%down
- this%is_valid_c=.true.
- end subroutine fibonacci_root_init_by_content
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_reset}
-\begin{Verbatim}
- subroutine fibonacci_root_reset(this)
- class(fibonacci_root_type),target,intent(inout) :: this
- call fibonacci_root_deallocate_tree(this)
- allocate (this%leftmost)
- allocate (this%rightmost)
- this%depth=1
- this%leftmost%depth=0
- this%rightmost%depth=0
- this%left=>this%leftmost
- this%right=>this%rightmost
- this%left%up=>this
- this%right%up=>this
- this%leftmost%right=>this%rightmost
- this%rightmost%left=>this%leftmost
- end subroutine fibonacci_root_reset
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_deallocate\_tree}
-\begin{Verbatim}
- recursive subroutine fibonacci_root_deallocate_tree(this)
- class(fibonacci_root_type),intent(inout) :: this
- call fibonacci_node_deallocate_tree(this)
- nullify(this%leftmost)
- nullify(this%rightmost)
- end subroutine fibonacci_root_deallocate_tree
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_deallocate\_all}
-\begin{Verbatim}
- recursive subroutine fibonacci_root_deallocate_all(this)
- class(fibonacci_root_type),intent(inout) :: this
- call fibonacci_node_deallocate_all(this)
- nullify(this%leftmost)
- nullify(this%rightmost)
- end subroutine fibonacci_root_deallocate_all
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_is\_left\_child}
-\begin{Verbatim}
- elemental logical function fibonacci_root_is_left_child(this)
- class(fibonacci_root_type),target,intent(in) :: this
- fibonacci_root_is_left_child = .false.
- end function fibonacci_root_is_left_child
-\end{Verbatim}
-
-\TbpImp{fibonacci\_root\_is\_right\_child}
-\begin{Verbatim}
- elemental logical function fibonacci_root_is_right_child(this)
- class(fibonacci_root_type),target,intent(in) :: this
- fibonacci_root_is_right_child = .false.
- end function fibonacci_root_is_right_child
-\end{Verbatim}
-
-\MethodsFor{fibonacci\_stub\_type}
-\TbpImp{fibonacci\_stub\_get\_type}
-\begin{Verbatim}
- pure subroutine fibonacci_stub_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="fibonacci_stub_type")
- end subroutine fibonacci_stub_get_type
-\end{Verbatim}
-
-\TbpImp{fibonacci\_stub\_push\_by\_content}
-\begin{Verbatim}
- subroutine fibonacci_stub_push_by_content(this,content)
- class(fibonacci_stub_type),target,intent(inout) :: this
- class(measurable_class),target,intent(in)::content
- class(fibonacci_leave_type),pointer::leave
- allocate(leave)
- call leave%set_content(content)
- call this%push_by_leave(leave)
- end subroutine fibonacci_stub_push_by_content
-\end{Verbatim}
-
-\TbpImp{fibonacci\_stub\_push\_by\_leave}
-\begin{Verbatim}
- subroutine fibonacci_stub_push_by_leave(this,new_leave)
- class(fibonacci_stub_type),target,intent(inout) :: this
- class(fibonacci_leave_type),pointer,intent(inout) :: new_leave
- class(fibonacci_leave_type),pointer::old_leave
- if(this%depth<1)then
- if(associated(this%leftmost))then
- old_leave=>this%leftmost
- call this%init_by_leave(old_leave,new_leave)
- else
- this%leftmost=>new_leave
- end if
- else
- call fibonacci_root_push_by_leave(this,new_leave)
- end if
- end subroutine fibonacci_stub_push_by_leave
-\end{Verbatim}
-
-\TbpImp{fibonacci\_stub\_pop\_left}
-\begin{Verbatim}
- subroutine fibonacci_stub_pop_left(this,leave)
- class(fibonacci_stub_type),intent(inout),target :: this
- class(fibonacci_leave_type),pointer,intent(out) :: leave
- if(this%depth<2)then
- if(this%depth==1)then
- leave=>this%leftmost
- this%leftmost=>this%rightmost
- nullify(this%rightmost)
- nullify(this%right)
- nullify(this%left)
- this%depth=0
- this%is_valid_c=.false.
- else
- if(associated(this%leftmost))then
- leave=>this%leftmost
- nullify(this%leftmost)
- end if
- end if
- else
- call fibonacci_root_pop_left(this,leave)
- end if
- end subroutine fibonacci_stub_pop_left
-\end{Verbatim}
-
-\TbpImp{fibonacci\_stub\_pop\_right}
-\begin{Verbatim}
- subroutine fibonacci_stub_pop_right(this,leave)
- class(fibonacci_stub_type),intent(inout),target :: this
- class(fibonacci_leave_type),pointer,intent(out) :: leave
- if(this%depth<2)then
- if(this%depth==1)then
- this%is_valid_c=.false.
- if(associated(this%rightmost))then
- leave=>this%rightmost
- nullify(this%rightmost)
- nullify(this%right)
- else
- if(associated(this%leftmost))then
- leave=>this%leftmost
- nullify(this%leftmost)
- nullify(this%left)
- else
- nullify(leave)
- end if
- end if
- end if
- else
- call fibonacci_root_pop_right(this,leave)
- end if
- end subroutine fibonacci_stub_pop_right
-\end{Verbatim}
-
-\MethodsFor{fibonacci\_leave\_type}
-
-\TbpImp{fibonacci\_leave\_get\_type}
-\begin{Verbatim}
- pure subroutine fibonacci_leave_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="fibonacci_leave_type")
- end subroutine fibonacci_leave_get_type
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_print\_to\_unit}
-\begin{Verbatim}
- subroutine fibonacci_leave_print_to_unit(this,unit,parents,components,peers)
- class(fibonacci_leave_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- class(serializable_class),pointer::ser
- if(parents>0)call fibonacci_node_print_to_unit(this,unit,parents-one,components,-one)
- write(unit,'("Components of fibonacci_leave_type:")')
- ser=>this%down
- call serialize_print_comp_pointer(ser,unit,parents,components,peers,"Content:")
- end subroutine fibonacci_leave_print_to_unit
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_get\_left}
-\begin{Verbatim}
- subroutine fibonacci_leave_get_left(this,leave)
- class(fibonacci_leave_type),intent(in) :: this
- class(fibonacci_leave_type),intent(out),pointer :: leave
- class(fibonacci_node_type),pointer::node
- node=>this%left
- select type(node)
- class is (fibonacci_leave_type)
- leave=>node
- end select
- end subroutine fibonacci_leave_get_left
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_get\_right}
-\begin{Verbatim}
- subroutine fibonacci_leave_get_right(this,leave)
- class(fibonacci_leave_type),intent(in) :: this
- class(fibonacci_leave_type),intent(out),pointer :: leave
- class(fibonacci_node_type),pointer::node
-! print *,"fibonacci_leave_get_right"
-! call this%down%print_little
- if(associated(this%right))then
- node=>this%right
-! call node%down%print_little
- select type(node)
- class is (fibonacci_leave_type)
- leave=>node
- end select
- else
-! print *,"no right leave"
- nullify(leave)
- end if
- end subroutine fibonacci_leave_get_right
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_deallocate\_all}
-\begin{Verbatim}
- subroutine fibonacci_leave_deallocate_all(this)
- class(fibonacci_leave_type),intent(inout) :: this
- if (associated(this%down)) then
- deallocate(this%down)
- end if
- end subroutine fibonacci_leave_deallocate_all
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_write\_pstricks}
-\begin{Verbatim}
- subroutine fibonacci_leave_write_pstricks(this,unitnr)
- class(fibonacci_leave_type),intent(in),target :: this
- integer,intent(in) :: unitnr
- write(unitnr,'("{\textbackslash}begin{psTree}{{\textbackslash}Toval[linecolor=green]{{\textbackslash}node{",i3,"}{",f9.3,"}}}")')&
- this%depth,this%measure()
- if (associated(this%left)) then
- write(unitnr,'("{\textbackslash}Tr[",a,"]{}")') le_kid
- end if
- if (associated(this%right)) then
- write(unitnr,'("{\textbackslash}Tr[",a,"]{}")') le_kid
- end if
- write(unitnr,'("{\textbackslash}end{psTree}")')
- end subroutine fibonacci_leave_write_pstricks
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_insert\_leave\_by\_node}
-\begin{Verbatim}
- subroutine fibonacci_leave_insert_leave_by_node(this,new_leave)
- class(fibonacci_leave_type),target,intent(inout) :: this,new_leave
- class(fibonacci_node_type),pointer :: parent,new_node
- parent=>this%up
- !print *,associated(this%left),associated(this%right)
- if(this<new_leave)then
- call fibonacci_node_spawn(new_node,this,new_leave,this%left,this%right)
- !print *,"Repair! ",this%measure(),new_leave%measure()
- else
- call fibonacci_node_spawn(new_node,new_leave,this,this%left,this%right)
- end if
- if(associated(parent%left,this))then
- call parent%append_left(new_node)
- else
- call parent%append_right(new_node)
- end if
- call parent%repair()
- end subroutine fibonacci_leave_insert_leave_by_node
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_copy\_content}
-\begin{Verbatim}
- subroutine fibonacci_leave_copy_content(this,content)
- class(fibonacci_leave_type) :: this
- class(measurable_class),intent(in) :: content
- allocate(this%down,source=content)
- end subroutine fibonacci_leave_copy_content
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_set\_content}
-\begin{Verbatim}
- subroutine fibonacci_leave_set_content(this,content)
- class(fibonacci_leave_type) :: this
- class(measurable_class),target,intent(in) :: content
- this%down => content
- end subroutine fibonacci_leave_set_content
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_get\_content}
-\begin{Verbatim}
- subroutine fibonacci_leave_get_content(this,content)
- class(fibonacci_leave_type),intent(in) :: this
- class(measurable_class),pointer :: content
- content => this%down
- end subroutine fibonacci_leave_get_content
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_is\_inner}
-\begin{Verbatim}
- elemental logical function fibonacci_leave_is_inner()
- fibonacci_leave_is_inner = .false.
- end function fibonacci_leave_is_inner
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_is\_leave}
-\begin{Verbatim}
- elemental logical function fibonacci_leave_is_leave()
- fibonacci_leave_is_leave = .true.
- end function fibonacci_leave_is_leave
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_is\_left\_short}
-\begin{Verbatim}
- elemental logical function fibonacci_leave_is_left_short(this)
- class(fibonacci_leave_type),intent(in) :: this
- fibonacci_leave_is_left_short = .false.
- end function fibonacci_leave_is_left_short
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_is\_right\_short}
-\begin{Verbatim}
- elemental logical function fibonacci_leave_is_right_short(this)
- class(fibonacci_leave_type),intent(in) :: this
- fibonacci_leave_is_right_short = .false.
- end function fibonacci_leave_is_right_short
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_is\_unbalanced}
-\begin{Verbatim}
- elemental logical function fibonacci_leave_is_unbalanced(this)
- class(fibonacci_leave_type),intent(in) :: this
- fibonacci_leave_is_unbalanced = .false.
- end function fibonacci_leave_is_unbalanced
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_is\_left\_too\_short}
-\begin{Verbatim}
- elemental logical function fibonacci_leave_is_left_too_short(this)
- class(fibonacci_leave_type),intent(in) :: this
- fibonacci_leave_is_left_too_short = .false.
- end function fibonacci_leave_is_left_too_short
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_is\_right\_too\_short}
-\begin{Verbatim}
- elemental logical function fibonacci_leave_is_right_too_short(this)
- class(fibonacci_leave_type),intent(in) :: this
- fibonacci_leave_is_right_too_short = .false.
- end function fibonacci_leave_is_right_too_short
-\end{Verbatim}
-
-\TbpImp{fibonacci\_leave\_is\_too\_unbalanced}
-\begin{Verbatim}
- elemental logical function fibonacci_leave_is_too_unbalanced(this)
- class(fibonacci_leave_type),intent(in) :: this
- fibonacci_leave_is_too_unbalanced = .false.
- end function fibonacci_leave_is_too_unbalanced
-\end{Verbatim}
-\MethodsNTB
-
-\ProcImp{fibonacci\_leave\_write\_content}
-\begin{Verbatim}
- subroutine fibonacci_leave_write_content(this,unit)
- class(fibonacci_leave_type),intent(in),target :: this
- integer,optional,intent(in)::unit
- call this%down%print_all(unit)
- end subroutine fibonacci_leave_write_content
-\end{Verbatim}
-
-\ProcImp{fibonacci\_leave\_write}
-\begin{Verbatim}
- subroutine fibonacci_leave_write(this,unit)
- class(fibonacci_leave_type),intent(in),target :: this
- integer,optional,intent(in)::unit
- call this%print_all(unit)
- end subroutine fibonacci_leave_write
-\end{Verbatim}
-
-\ProcImp{fibonacci\_leave\_write\_value}
-\begin{Verbatim}
- subroutine fibonacci_leave_write_value(this,unit)
- class(fibonacci_leave_type),intent(in),target :: this
- integer,intent(in),optional::unit
- if(present(unit))then
- write(unit,fmt=*)this%measure()
- else
- print *,this%measure()
- end if
-! call this%print_little(unit)
- end subroutine fibonacci_leave_write_value
-\end{Verbatim}
-
-\ProcImp{fibonacci\_node\_spawn}
-\begin{Verbatim}
- subroutine fibonacci_node_spawn&
- (new_node,left_leave,right_leave,left_left_leave,right_right_leave)
- class(fibonacci_node_type),pointer,intent(out) :: new_node
- class(fibonacci_leave_type),target,intent(inout) :: left_leave,right_leave
- class(fibonacci_node_type),pointer,intent(inout) :: left_left_leave,right_right_leave
- allocate(new_node)
- new_node%depth=1
- if(associated(left_left_leave))then
- left_left_leave%right=>left_leave
- left_leave%left=>left_left_leave
- else
- nullify(left_leave%left)
- end if
- if(associated(right_right_leave))then
- right_right_leave%left=>right_leave
- right_leave%right=>right_right_leave
- else
- nullify(right_leave%right)
- end if
- new_node%left=>left_leave
- new_node%right=>right_leave
- new_node%down=>left_leave%down
- new_node%depth=1
- left_leave%up=>new_node
- right_leave%up=>new_node
- left_leave%right=>right_leave
- right_leave%left=>left_leave
- end subroutine fibonacci_node_spawn
-\end{Verbatim}
-
-\ProcImp{fibonacci\_root\_list\_to\_tree}
-\begin{Verbatim}
- subroutine fibonacci_root_list_to_tree(this,n_leaves,leave_list_target)
- class(fibonacci_root_type),target :: this
- integer,intent(in) :: n_leaves
- type(fibonacci_leave_list_type),target,intent(in) :: leave_list_target
-! class(fibonacci_root_type),pointer,intent(out) :: tree
- integer:: depth,n_deep,n_merge
- class(fibonacci_node_type),pointer :: node
- class(fibonacci_leave_list_type),pointer :: leave_list
- class(fibonacci_leave_type),pointer::content
- real(kind=double) :: up_value
- leave_list=>leave_list_target
- call ilog2(n_leaves,depth,n_deep)
- n_deep=n_deep*2
- n_merge=0
- this%depth=depth
- node=>this
- outer: do
- do while(depth>1)
- depth=depth-1
- allocate(node%left)
- node%left%up=>node
- node=>node%left
- node%depth=depth
- end do
- node%left=>leave_list%leave
- node%down=>leave_list%leave%down
- leave_list=>leave_list%next
- node%right=>leave_list%leave
- content => leave_list%leave
- leave_list=>leave_list%next
- n_merge=n_merge+2
- inner: do
- if (associated(node%up)) then
- if (node%is_left_child()) then
- if (n_merge==n_deep.and.depth==1) then
- node=>node%up
- node%right=>leave_list%leave
- node%right%up=>node
- node%down=>content%down
- content=>leave_list%leave
- leave_list=>leave_list%next
- n_merge=n_merge+1
- cycle
- end if
- exit inner
- else
- node=>node%up
- depth=depth+1
- end if
- else
- exit outer
- end if
- end do inner
- node=>node%up
- node%down=>content%down
- allocate(node%right)
- node%right%up => node
- node=>node%right
- if (n_deep==n_merge) then
- depth=depth-1
- end if
- node%depth=depth
- end do outer
- call this%set_leftmost
- call this%set_rightmost
- end subroutine fibonacci_root_list_to_tree
-\end{Verbatim}
-
Index: trunk/src/muli/doc/Module.tex
===================================================================
--- trunk/src/muli/doc/Module.tex (revision 8371)
+++ trunk/src/muli/doc/Module.tex (revision 8372)
@@ -1,12 +0,0 @@
-\part{Module}
-\input{muli}
-\input{muli_momentum}
-\input{muli_remnant}
-\input{muli_dsigma}
-\input{muli_aq}
-\input{muli_trapezium}
-\input{muli_fibonacci_tree}
-\input{muli_interactions}
-\input{muli_mcint}
-\input{muli_cuba}
-\input{muli_basic}
Index: trunk/src/muli/doc/Allgemeines.tex
===================================================================
--- trunk/src/muli/doc/Allgemeines.tex (revision 8371)
+++ trunk/src/muli/doc/Allgemeines.tex (revision 8372)
@@ -1,263 +0,0 @@
-\part{Allgemeines}
-\begin{figure}
- \includegraphics[scale=0.75,angle=90]{uml-module-tree-1.mps}
-\end{figure}
-\chapter{Nomenklatur}
-\begin{figure}
- \includegraphics{diagrams-1.mps}
- \includegraphics{diagrams-2.mps}
- \caption{\label{fig:nomen:had}Links: Impulsvariablen $P_x$ der Remnants, Impulsvariablen $\hat{p}_x$ der Partonen und Flavorindizes $a^{(k)},b^{(k)},c^{(k)},d^{(k)}$ der Partonen in der $k$-ten Iteration des Multiple Interactions Algorithmus. Rechts: Die Prozeduren zur Generierung der Ereignisse kennen üblicherweise nicht die Ordnungszahl $k$ nur einen Teil der Impulsinformation, nämlich die hadronischen Impulsanteile $X$ mit $P^{(k)}=XP$ und die partonischen Impulsanteile $\xi$ mit $\hat{p}^{(k)}=\xi P^{(k)}=x P$. Anstatt der Flavorindizes $a^{(k)},b^{(k)},c^{(k)},d^{(k)}$ ist die festgelegte Position in dem Flavorquadrupel eingetragen.}
-\end{figure}
-\section{n-te Wechselwirkung}
-Durch den Algorithmus werden iterativ harte, partonische, treelevel, QCD $2\rightarrow 2$ Wechselwirkungen mit absteigenden Wechselwirkungsskalen $\pperp^{(n)}$ generiert. Variablen, die nach jeder harten Wechselwirkung einen neuen Wert erhalten, führen die Ordnungszahl $n$ der aktuellen Wechselwirkung hochgestellt in runden Klammern, um Verwechslungen mit Potenzen zu vermeiden.
-
-Diese Ordnungszahl wird mit $k$ bezeichnet, wenn sie sich nicht auf die aktuelle Wechselwirkung bezieht, sondern Summations- oder Produktindex über alle bisherigen Wechselwirkungen ist. Die Ordnungszahl der letzten Wechselwirkung wird mit $N$ notiert. Bevor eine harte Wechselwirkung stattfindet, ist die Ordnungszahl gleich Null und kann weggelassen werden.
-\section{Impulse}
-Die Viererimpulse der Remnants sind $P_1^{(n)}$ bzw. $P_2^{(n)}$ für das erste bzw. das zweite Proton. Die Viererimpulse der Partonen sind $\hat{p}_1^{(n)}$ bzw. $\hat{p}_2^{(n)}$ für das erste bzw. das zweite Proton. Die Viererimpulse der Teilchen im Endzustand der partonischen Wechselwirkung sind für MulI nicht von Bedeutung.
-
-Die Kinematik eines partonischen Ereignisses wird vollständig durch das kartesische Quadrupel $p_{\cart}^{(n)}=\left[x_1^{(n)},x_2^{(n)},\pperp^{(n)};s^{(n)}\right]$ bzw. das hyperbolische Quadrupel $p_{\hyp}^{(n)}=\left[h_1^{(n)},h_2^{(n)},h_3^{(n)};s^{(n)}\right]$ definiert. Die entsprechende Koordinatentransformation ist in \eqref{eq:all:imp:trafo} angegeben. Es wird nicht zwischen der Bjorken-Scaling-Variable $x$ und dem Impulsanteil mit $xP=\hat{p}$ unterschieden. Wir nehmen an, dass die kinetische Energie der Protonen viel größer als die Ruhemasse der Protonen ist. In diesem Grenzwert stimmen beide Variablen überein.
-\section{Flavor}
-Quarks und Gluonen der $n$-ten harten Wechselwirkung haben Flavorindizes $a^{(n)}, b^{(n)},c^{(n)},d^{(n)}$, wobei $a$ das Flavor des Partons aus dem Remnant 1 und $b$ das Flavor des Partons aus dem Remnant 2 ist. Wenn nicht anders angegeben, wird das LHAPDF-Schema verwendet, mit $[\overline{t},\overline{b},\overline{c},\overline{s},\overline{u},\overline{d},g,d,u,s,c,b,t]=[-6,-5,-4,-3,-2,-1,0,1,2,3,4,5,6]$.
-\section{Strukturfunktionen}
-\mip{Strukturfunktionen $f(x,\mu)$ sind in diesem Dokument synonym zu Flavor-Strukturfunktionen, die Impuls-Strukturfunktionen ergeben sich dann aus $xf(x,\mu)$. Im Gegensatz dazu liefert evolvePDF aus LHAPDF die Impulsstrukturfunktion. MulI hat diesbezüglich die gleiche Konvention wie die Builtin-PDFs aus WHIZARD, welche ebenfalls Flavor-PDFs liefern.}
-
-Da beide Remnants eine verscheidene Historie haben können, sind im Allgemeinen auch beide Remnant-Strukturfunktionen verschieden. Die Zugehörigkeit wird durch den Flavorindex $a$ für das erste und $b$ für das zweite Proton notiert. Wir verzichten auf die Indizierung der Flavorindizes, also $a^{(n)}\rightarrow a$, da die Strukturfunktionen bereits Ordnungsindizes ${(n)}$ haben. Wir erhalten $f_a^{(n)}\big(x_1^{(n)},\mu_F^{(n)}\big)$ für das erste Proton und $f_b^{(n)}\big(x_2^{(n)},\mu_F^{(n)}\big)$ für das zweite Proton.
-
-\wip{Derzeit sind im Modul \ModuleRef{muli\_remnant} Proton-Strukturfunktionen fest implementiert, es können also ohne Eingriff in den Code z.B. keine Proton-Antiproton Streuungen generiert werden. Allerdings sollte die Verallgemeinerung auf Hadronen mit maximal zwei verschiedenen Valenzquarks kaum Probleme bereiten, da die Infrastruktur des Moduls nicht geändert werden muss.}
-
-\section{Wirkungsquerschnitte}
-Wie die Strukturfunktionen ändern sich auch die Wirkungsquerschnitte $\sigma$ mit jeder Iteration. Allerdings können wir die Abhängigkeit komplett in die Änderung der invarianten Masse $s^{(n)}$ der $n$-ten Iteration absorbieren. Wir notieren also keinen Ordnungsindex $(n)$, sondern fügen die invariante Masse als Parameter durch ein Semikolon getrennt in die Liste der Argumente ein. Wir erhalten für den hadronischen Wirkungsquerschnitt ${\sigma}$
-\begin{equation}
- {\sigma}_{ab\rightarrow cd}^{(n)}\left(x_1^{(n)},x_2^{(n)},\pperp^{(n)}\right)
- ={\sigma}_{ab\rightarrow cd}\left(x_1^{(n)},x_2^{(n)},\pperp^{(n)};s^{(n)}\right).
-\end{equation}
-Der hadronische Wirkungsquerschnitt $\sigma$ bezieht sich auf das Streuereignis, wie in Abbildung \ref{fig:nomen:had} dargestellt. Der partonische Wirkungsquerschnitt hingegen ist $\widehat{\sigma}$.
-\section{Übersicht}
-\begin{align}
- s&=s^{(1)}=P_1\cdot P_2\\
- s^{(n)}&=P_1^{(n)}\cdot P_2^{(n)}\\
- \hat{p}_1^{(n)}&=P_1^{(n)}x_1^{(n)}\\
- P_1^{(n+1)}&=P_1^{(n)}\big(1-x_1^{(n)}\big)\\
- X^{(n)}&=\prod_{k=1}^{n}\left(1-x^{(k)}\right)\\
- P_1^{(n+1)}&=X_1^{(n)}P^{(1)}\\
- \pperp&=\frac{\hat{t}\hat{u}}{\hat{s}}
-\end{align}
-\chapter{Der Algorithmus}
-Der Algorithmus ist in meiner Dissertation in Kapitel 5 bereits dokumentiert, deswegen werde ich hier nicht alle Aspekte wiederholen. In der Dissertation wird allerdings nicht sorgfältig zwischen fertigen und geplanten Eigenschaften getrennt, deswegen gebe ich hier einen groben Überblick über den aktuellen Stand.
-
-MulI wird derzeit ausschließlich von dem shower\_interface aus dem interleaved Branch aus dem schmidtboschmann Verzeichnis des WHIZARD-Repositories aufgerufen. Es ist noch kein MulI-Code in den WHIZARD-Core übertragen worden, stattdessen sind alle relevanten Daten in einem erweiterten Datentyp \TypeRef{muli\_type} gekapselt. \TypeRef{muli\_type} stellt ebenfalls eine vollständige Schnittstelle bereit, um MPI zu generieren und Remnant-PDFs abzurufen. Die derzeit verwendeten Methoden dieser Schnittstelle sind in Tabelle \ref{tab:all:interface} aufgeführt.
-\begin{table}
-\begin{center}
-\begin{tabular}{ll}
-Generischer Name & Spezifischer Name\\
-\midrule
-\TbpRef{muli\_type}{initialize} & \ProcRef{muli\_initialize}\\
-\TbpRef{muli\_type}{restart} & \ProcRef{muli\_restart}\\
-\TbpRef{muli\_type}{finalize} & \ProcRef{muli\_finalize}\\
-\TbpRef{muli\_type}{apply\_initial\_interaction} & \ProcRef{muli\_apply\_initial\_interaction}\\
-\TbpRef{muli\_type}{generate\_gev2\_pt2} & \ProcRef{muli\_generate\_gev2\_pt2}\\
-\TbpRef{muli\_type}{generate\_partons} & \ProcRef{muli\_generate\_partons}\\
-\TbpRef{qcd\_2\_2\_type}{get\_color\_correlations} & \ProcRef{qcd\_2\_2\_get\_color\_correlations}\\
-\TbpRef{muli\_type}{replace\_parton} & \ProcRef{muli\_replace\_parton}\\
-\TbpRef{muli\_type}{get\_parton\_pdf} & \ProcRef{muli\_get\_parton\_pdf}\\
-\TbpRef{muli\_type}{get\_momentum\_pdf} & \ProcRef{muli\_get\_momentum\_pdf}
-\end{tabular}
-\caption{\label{tab:all:interface}Die Methoden der MulI Schnittstelle für den Interleaved-Algorithmus.}
-\end{center}
-\end{table}
-\begin{figure}
-\begin{center}
-\includegraphics{uml-1.mps}
-\end{center}
-\caption{Flussdiagramm des Interleaved-Algorithmus. Eingetragen sind ausschließlich die Aufrufe der MulI-Schnittstelle, mit Ausnahme von get\_parton\_pdf und get\_momentum\_pdf, da diese nur für Interna des Partonshowers relevant sind und das Diagramm unnötig kompliziert machen würden. Die Generierung der Showerskalen und -Teilchen ist hier nicht dargestellt. Parallel zu generate\_gev2\_pt2 wird von dem ISR-Modul eine Showerskala $t$ generiert und unmittelbar vor replace\_parton wird von dem ISR-Modul ein neues Showerteilchen generiert, dass durch replace\_parton in die Beschreibung des Remnants aufgenommen wird. $m_E$ ist die Zahl der zu generierenden Events.}
-\end{figure}
-\section{Stratified Sampling}
-\label{sec:all:alg:stra}
-Die Wahrscheinlichkeit dafür, dass die Wechselwirkung aus dem Stratum $\{\alpha,\beta\}$ mit der größten Skala $\pperp\leq\pperp^{(n-1)}$ bei der Skala $\pperp^{(n-1)}$ stattfindet, ist durch
-\begin{equation}
-\mathcal{P}_{\text{next},a,b}^{(n)}\left(\pperp^{(n)};\pperp^{(n-1)}\!\!,s^{(n)}\right):=\exp\left[W_a^{(n)}W_b^{(n)}
-\left[
-\mathcal{S}_{\alpha\beta}\left(\pperp^{(n)};s^{(n)}\right)
--
-\mathcal{S}_{\alpha\beta}\left(\pperp^{(n-1)};s^{(n)}\right)
-\right]
-\right]\label{eq:imp:pnextab}
-\end{equation}
-gegeben. $s^{(n)}$ ist die invariante Masse des Remnant-Remnant-Systems, $W_\alpha^{(n)}$ und $W_\beta^{(n)}$ sind die Wichtungsfaktoren des Stratums $\alpha$ bzw. $\beta$ und $\mathcal{S}_{\alpha\beta}$ ist das Stammstratum mit
-\begin{equation}
- \mathcal{S}_{\alpha\beta}\left(\pperp^{(n)};s^{(n)}\right):=\int_{\pperp^{\max}}^{\pperp^{(n)}}\der\pperp\overline{S}_{\alpha\beta}\left(\pperp;s^{(n)}\right)\label{eq:all:strati_root_def}.
-\end{equation}
-Das Stammstratum ist demnach eine negative Stammfunktion des integrierten Stratums $\overline{S}_{\alpha\beta}$ mit ${\pperp^{\max}}=s/4$ und
-\begin{equation}
- \overline{S}_{\alpha\beta}\left(\pperp;s^{(n)}\right):=\int_{x_{\min}}^{1}\der x_1\int_{x_{\min}}^{1}\der x_2\ S_{\alpha\beta}\left(x_1,x_2,\pperp;s^{(n)}\right)\label{eq:imp:double_strati_int}.
-\end{equation}
-Schließlich sind die Branchingstrati $S_{\alpha\beta}$ mit
-\begin{equation}
- S_{\alpha\beta}:=\frac{1}{\sigma_{\nd}}\sum_{k\in S_a}\sum_{l\in S_b}\sum_{m,n}\frac{\partial^3\sigma_{kl\to mn}\left(x_1,x_2,\pperp;s\right)}{\partial x_1\ \partial x_2\ \partial \pperp}
-\end{equation}
-als bedingte Wahrscheinlichkeit dafür definiert, dass eine hadronische Wechselwirkung aus dem Stratum $\{\alpha,\beta\}$ stattfindet, gegeben dass eine nicht-diffraktive hadronische Wechselwirkung stattfindet. $\sigma_{\nd}$ ist der totale, nicht-diffraktive Wirkungsquerschnitt und einer der freien Parameter des MPI-Modells. Die einfachen Strati $S_a$ sind in Tabelle \ref{tab:all:strati:strati} dargestellt.
-
-\wip{In Tabelle \eqref{tab:all:strati:strati} sind zwei Varianten angegeben. In der ersten fehlen offensichtlich die Quasivalezquarks. Diese werden zwar vollkommen korrekt in den Remnant-Strukturfunktionen berücksichtigt, werden aber für die eigentliche Generierung der MPI aus technischen Gründen komplett ignoriert. In der Dissertation ist in Kapitel 5.2 ein Vorschlag gemacht, wie Quasivalenzquarks mitgenommen werden können. Diese Umsetzung bedeutet aber einen erheblichen Eingriff in den Quellcode.}
-
-
-\begin{table}
-\begin{center}
-\subfloat[]{
-\begin{tabular}{ccc}
- Stratum&Name&Partonen\\
- \midrule
- $S_1$&Gluon&$g$\\
- $S_2$&See&$\{q^S:\ \forall q\}$\\
- $S_3$&Valenz-Down&$d^V$\\
- $S_4$&Valenz-Up&$u^V$
-\end{tabular}}\qquad
-\subfloat[]{
-\begin{tabular}{ccc}
- Stratum&Name&Partonen\\
- \midrule
- $S_1$&Gluon&$g$\\
- $S_2$&See&$\{q^S:\ \forall q\}$\\
- $S_3$&Valenz-Down&$d^V$\\
- $S_4$&Valenz-Up&$u^V$\\
- $S_5$&Quasivalenz&$\{q^Q:\ \forall q\}$
-\end{tabular}}
-\end{center}
-\caption{\label{tab:all:strati:strati}(a): Strati zur Berechnung der nächsten Skala. (b) Strati für die Wichtungsfaktoren in \eqref{eq:all:rem:sumrule}}
-\end{table}
-In \CompRef{muli\_interactions}{valid\_processes} ist für jedes Feynmandiagramm in der fünften Komponente valid\_processes(5,:) die Nummer des Stratums eingetragen, zu dem das Diagramm gehört.
-
-\mip{Die einfachen Strati $S_\alpha$ heißen im Quellcode pdf\_int\_kind. Sie sind in \CompRef{muli\_interactions}{pdf\_int\_kind\_gluon} und folgende definiert. Entsprechend sind die doppelten Strati $\{\alpha,\beta\}$ in \CompRef{muli\_interactions}{double\_pdf\_kinds} hinterlegt.}
-
-Wir bestimmen die nächste Skala des Stratums $\{\alpha,\beta\}$ über
-\begin{equation}
- \label{eq:all:genpt-a}
- \widehat{p}_{\perp,a,b}^{(n)}=\mathcal{S}_{\alpha\beta}^{-1}\left(\ \cdot\ ;s^{(n)}\right)\left(\zeta_{\alpha\beta}^{(n)}\right)
-\end{equation}
-mit
-\begin{equation}
- \label{eq:all:genpt-b}
- \zeta_{\alpha\beta}^{(n)}:=
- \frac{
- \ln(z_{\alpha\beta}^{(n)})
- }
- {W_a^{(n)}W_b^{(n)}}
- +
- \mathcal{S}_{\alpha\beta}\left(\pperp^{(n-1)};s^{(n)}\right)
- =
- \mathcal{S}_{\alpha\beta}\left(\pperp^{(n)};s^{(n)}\right)
-\end{equation}
-und
-\begin{equation}
- \label{eq:all:genpt-c}
- z_{\alpha\beta}^{(n)} \in (0,1],\quad \text{zufällig und gleichverteilt.}
-\end{equation}
-Durch einsetzen von $s^{(n)}$ in $\mathcal{S}_{\alpha\beta}$ erhalten wir eine einstellige, umkehrbare Funktion $\mathcal{S}_{\alpha\beta}\left(\ \cdot\ ;s^{(n)}\right)$. Somit ist $\mathcal{S}_{\alpha\beta}^{-1}\left(\ \cdot\ ;s^{(n)}\right)\left(\zeta_{\alpha\beta}^{(n)}\right)$ eben diese Umkehrfunktion, ausgewertet bei $\zeta_{\alpha\beta}^{(n)}$.
-
-Der größte Wert von $\widehat{p}_{\perp,a,b}^{(n)}$ unter allen Strati ist die neue Skala $\widehat{p}_{\perp}^{(n)}$, das Stratum mit der größten Skala ist das neue Stratum $\{\alpha^{(n)},\beta^{(n)}\}$
-
-\wip{Die Stammstrati in \eqref{eq:all:strati_root_def} hängen offensichtlich von der aktuellen hadronischen invarianten Masse $s^{(n)}$ ab. Derzeit werden die $\mathcal{S}_{\alpha\beta}$ aber als eindimensionale Funktionen in \CompRef{muli\_type}{dsigma} ohne $s$-Abhängigkeit gespeichert. Geht man zu einer zweidimensionalen Dastellung über, dann kommt man zu den Performance- und Speicherproblemen, die in der Dissertation in Kapitel 5.2 beschrieben sind. Dynamische Werte von $s^{(n)}$ sind also nicht durch einen trivialen Patch implementierbar. Das Problem wird teilweise dadurch entschärft, dass die Skala später auf die invariante Masse normiert wird. Quotienten $\pperp/s$ werden also korrekt behandelt, nur durch Faktoren von $s$ ohne $\pperp$ werden die Matrixelemente inkonsistent.}
-\section{Importance Sampling}\label{sec:all:alg:imp}
-Das Stratum $\{\alpha,\beta\}$ sowie die Skala $\pperp$ liegen fest. Wie auch in der Dissertation unterdrücken wir hier die Indizes $^{(n)}$, da hier nur Werte aus der aktuellen Iteration vorkommen. Wir generieren die hyperbolischen Impulsanteile $h_1,h_2$, indem wir die Gleichung
-\begin{equation}
- zs\overline{S}_{ab}\left(\pperp(h_3,s^{(n)}),s^{(n)}\right)\overset{?}{<}H_{ab}\left(h_1,h_2,h_3,s^{(n)}\right)
-\end{equation}
-mit
-\begin{equation}
- h_1,h_2,z\in(0,1],\quad \text{zufällig und gleichverteilt}
-\end{equation}
-solange mit neu generierten $h_1,h_2,z$ auswerten, bis sie erfüllt ist. $H$ ist eine regularisierte Form der divergenten Branchingstrati $S$, mit
-\begin{equation}
- H_{ab}\left(h_1,h_2,h_3,s^{(n)}\right)=S_{ab}\left(x_1(h_1,h_2),x_2(h_1,h_2),\pperp(h_1,h_2,s^{(n)}),s^{(n)}\right)\left(\frac{\partial h_1}{\partial x_1}\frac{\partial h_2}{\partial x_2}-\frac{\partial h_1}{\partial x_2}\frac{\partial h_2}{\partial x_1}\right)
-\end{equation}
-und
-\begin{align}\label{eq:all:imp:trafo}
- h_1&:=\frac{x_1x_2 - h_3}{(1 - h_3)^{1/4}}\\
- h_2&:=\frac{1+(x_2^2 - x_1^2)^{1/3}}{2}\\
- h_3&:=\frac{4\pperp}{\widehat{s}^{(n)}}\\
- x_1&=\sqrt{\sqrt{(h_1^4(1-h_3)+h_3)^2+(4(h_2-1/2)^3)^2}-4(h_2-1/2)^3}\\
- x_2&=\sqrt{\sqrt{(h_1^4(1-h_3)+h_3)^2+(4(h_2-1/2)^3)^2}+4(h_2-1/2)^3}\\
- \pperp&=\frac{h_3\widehat{s}^{(n)}}{4}.
-\end{align}
-$\overline{S}_{ab}$ ist der Mittelwert von $H_{ab}$, gemittelt über $h_1$ und $h_2$. Mit dem willkürlichen reellen Faktor $s$ wird $s\overline{S}_{ab}$ damit zu einer, von $\pperp$ abhängigen, Majorante von $H_{ab}$.
-
-Um $H$ noch weiter zu glätten, wird in \CompRef{muli\_type}{samples} eine Einteilung des $\{h_1,h_2,h_3\}$-Einheits\-quaders und Unterquader abgelegt. Dabei wird der Quader zuerst so in $h_3$-Richtung in endlich viele Scheiben geschnitten, dass das Integral über $H$ in jeder Scheibe etwa gleich ist. Anschließend wird jede Scheibe simultan in $h_1$ und $h_2$ so in Unterquader zerlegt, dass das Integral über jedes dieser Unterquader etwa gleich groß ist und die Varianz in jedem Unterquader klein wird. Jeder Unterquader hat einen Index $q_i$ und einen Flächeninhalt in der $h_1-h_2$-Ebene von $a_i$.
-
-Weiterhin werden alle Feynmandiagramme, die in dem Stratus $\{\alpha,\beta\}$ enthalten sind, mit einem Wicht\-ungs\-faktor $d_j$ versehen. Die tatsächliche Vorgehensweise zur Generierung der Impulse und der Flavor ist dann wie folgt:
-
-\begin{enumerate}
- \item Es wird ein Diagramm mit der Wahrscheinlichkeit $W_j/\sum_k W_k$ gewählt.
- \item Es wird zufällig und gleichverteilt ein Quader $q_i$ mit der Fläche $a_i$ aus derjenigen Scheibe gewählt, die $h_3$ enthält.
- \item Es werden zufällig und gleichverteilt reelle Zahlen $h_1,h_2$ und $z$ aus dem Einheitsintervall gewählt
- \item Es wird
- \begin{equation}\label{eq:all:importance}
- zsW_j\overline{S}_{ab}\left(\pperp(h_3,s^{(n)}),s^{(n)}\right)\overset{?}{<}a_iH_{ab}\left(h_1,h_2,h_3,s^{(n)}\right)
- \end{equation}
- ausgewertet und bei 1 begonnen, bis die Ungleichung erfüllt ist.
- \item
- Aus $h_1$ und $h_2$ ergeben sich die Impulsanteile $x_1$ und $x_2$, aus dem Diagramm $j$ ergeben sich die Flavor $a,b,c$ und $d$.
-\end{enumerate}
-\section{Remnants}
-Abweichend von der Dissertation (Gl. 4.49) werden hier fünf verschiedene Wichtungsfaktoren für die vier Strati $\{$Gluon, See, Valenz-down, Valenz-up, Quasivalenz$\}$ zugelassen:
-\begin{equation}
- \begin{split}
- 1=\\
- W_G^{(n)}\int_{\xi_{\min}^{(n)}}^{1}\der \xi^{(n)}f_g(\xi^{(n)},Q^2)+\\
- +W_S^{(n)}\sum_q\int_{\xi_{\min}^{(n)}}^{1}\der \xi^{(n)}f_{q^{S}}(\xi^{(n)},Q^2)+\\
- +\sum_qW_{q^V}^{(n)}\frac{N_{q^V}^{(n)}}{N_{q^V}^{(0)}}\int_{\xi_{\min}^{(n)}}^{1}\der \xi^{(n)}f_q^v(\xi^{(n)},Q^2)+\\
- +W_Q^{(n)}\sum_q\int_{\xi_{\min}^{(n)}}^{1}\der \xi^{(n)}f_q^Q(\xi^{(n)},Q^2)\label{eq:all:rem:sumrule}
- \end{split}
-\end{equation}
-Da wir nur eine Gleichung für vier Wichtungsfaktoren haben, müssen wir weitere Beziehungen festlegen. Durch den Parameter \CompRef{muli\_remnant}{remnant\_weight\_model} wird entschieden, welche Wichtungsfaktoren auf Eins gesetzt werden. Die jeweils anderen werden gleich gesetzt. Für das Quadrupel $[W_G,W_S,W_{d^V},W_{u^V},W_Q]$ erhalten wir:
-
-\begin{table}
- \begin{center}
- \begin{tabular}{cc}
- remnant\_weight\_model&$[W_G,W_S,W_d,W_u,W_Q]$\\
- \midrule
- $0$&$[1,\ 1,\ 1,\ 1,\ 1\ ]$\\
- $1$&$[w,w,w,w,w]$\\
- $2$&$[w,w,1,\ 1,\ 1\ ]$\\
- $3$&$[1,\ 1,\ w,w,w]$\\
- $4$&$[1,\ w,1,\ 1,\ w]$
- \end{tabular}
- \end{center}
- \caption{\label{tab:all:rem:weight_models}remnant\_weight\_models}
-\end{table}
-In \eqref{eq:all:rem:sumrule} eingesetzt kann $w$ eindeutig bestimmt werden.
-
-\mip{Für remnant\_weight\_model=0 ist \eqref{eq:all:rem:sumrule} nicht lösbar, es ist also streng genommen kein gültiges Wichtungsmodell. Stattdessen wird dadurch die Gewichtung deaktiviert.}
-
-\section{Programmfluss}
-Die einzeilnen Methoden sind ausführlich in \ModuleRef{muli} beschrieben. Wir geben hier nur eine kurze Übersicht an:
-\begin{itemize}
-\item initialize
-
- Der Monte-Carlo-Generator von MulI und die Datenstruktur der Proton-Remnants werden initialisiert.
-\item apply\_initial\_interaction
-
- Eine von WHIZARD generierte harte Wechselwirkung wird an MulI übergeben. Die Remnants werden entsprechend angepasst.
-\item generate\_gev2\_pt2
-
- Mittels \eqref{eq:all:genpt-a} wird eine Skala $\widehat{p}_{\perp,a,b}^{(n)}$ und ein Stratum $\{\alpha^{(n)},\beta^{(n)}\}$ generiert.
-\item generate\_partons
-
- Mittels \eqref{eq:all:importance} werden die Impulsanteile $x_1$ und $x_2$ und die Flavor $a,b,c$ und $d$ generiert. Außerdem wird eine interne Darstellung der Farbflüsse generiert.
-\item get\_correlations
-
-Die interne Darstellung der Farbflüsse wird in der vom shower\_interface gewünschten Form von Farbkorrelationen ausgegeben.
-\item replace\_parton
-
- Der ISR-Algorithmus hat ein Branching eines aktiven Showerteilchens generiert. Dieses Showerteilchen ist fortan kein aktives Teilchen mehr, sondern ein inneres Teilchen der perturbativen Wechselwirkung. Entsprechend muss es durch replace\_parton in der Beschreibung des Remnants durch das neue aktive Teilchen ersetzt werden. Siehe Abbildung \ref{fig:all:flow:isr}
- \begin{figure}
- \begin{center}
- \includegraphics{diagrams-4.mps}\includegraphics{diagrams-5.mps}\includegraphics{diagrams-6.mps}
- \caption{\label{fig:all:flow:isr}Ersetzung des aktiven ISR-Partons durch den ISR-Algorithmus. Links: Durch die härteste WW wurde ein Parton aus dem Hadron entfert. Dieses Parton ist ein "`aktives"' Parton, da ISR-Branchings für dieses Teilchen generiert werden. Alle Teilchen, die jemals generiert werden, bekommen eine eindeutige Nummer, hier die Nummer 1. Die Eigenschaften des Remants und des Teichens \#1 müssen in der Summe die Eigenschaften des Protons ergeben. Rechts: Durch den ISR-Algorithmus wurde ein Branching der Teilches \#1 erzeugt. Das Mutterparton hat die Nummer 2 bekommen, das andere Tochterparton hat die Nummer 3 bekommen. Jetzt müssen die Eigenschaften des Remnants und des Teilchens \#2 in der Summe die Eigenschaften des Protons ergeben. In diesem Sinne müssen wir das Teilchen \#1 wieder "`zurücklegen"' und das Teilchen \#2 "`herausnehmen"'.}
- \end{center}
- \end{figure}
-\item restart
-
- Es werden einige interne Variablen zurückgesetzt, wie z.B. das "finished"-Flag. Außerdem werden die Remnants zurückgesetzt.
-\item finalize
-
- Der Monte-Carlo-Generator von MulI, die vorgenerierten Wirkungsquerschnitte und die Remnants werden deallociert.
-\end{itemize}
Index: trunk/src/muli/doc/uneben.pdf
===================================================================
--- trunk/src/muli/doc/uneben.pdf (revision 8371)
+++ trunk/src/muli/doc/uneben.pdf (revision 8372)
@@ -1,72 +0,0 @@
-%PDF-1.5
-%µí®û
-3 0 obj
-<< /Length 4 0 R
- /Filter /FlateDecode
->>
-stream
-xœeR;O1ìý+¶FbcïËv›)R
-Ò¢ÑEE¡àï3öÙD€N'ßܾfÆû”
-çß=}ù•éþ9eϏÊ,ôø ïßt÷?2ýNFßé #ëzÞY]›
-IYs¿ÄI¸4Û°pnAÞ8uìRÉ+‡£®Ñ\Q­QÚÐÙDv®±¹"W3÷6ÚEït!-ì¦Hªj¤Âa£{ÉBI•«·…Phܪ/¨Î=ú.‹9âlyPĜ°&^(E3ŸN²;yK6yÓÎ
-k–)Œ¥ø†=|tìëݦÌmú‹[9ÅƟê'*ÜK›”‡¨Lúˆ—Ô³¯oLùŸf+ ^eÑA<O•À
-{¦Nð.「]N¦§—æõ-ì\`û.…M0f5>†Ý|Ín¾*œ8Ù®Ì-ÐûÖëz±%~YVæC*ØW\a]N-Â֖8‘æ+|ùœÿçjm></ ®²8¡ ±vÖP‹žúÏt@ã¨A XP|4 ˜mùѹžw€åÉ1£u®aèìdE†-g#­kñ­O^jBÒçê¢TqH`QæG¿ƒD¸ÙŒB~;(i}¯oz÷^0¼¸M¯4½Ëg
-endstream
-endobj
-4 0 obj
- 469
-endobj
-2 0 obj
-<<
- /ExtGState <<
- /a0 << /CA 1 /ca 1 >>
- >>
->>
-endobj
-5 0 obj
-<< /Type /Page
- /Parent 1 0 R
- /MediaBox [ 0 0 67.514877 59.353832 ]
- /Contents 3 0 R
- /Group <<
- /Type /Group
- /S /Transparency
- /CS /DeviceRGB
- >>
- /Resources 2 0 R
->>
-endobj
-1 0 obj
-<< /Type /Pages
- /Kids [ 5 0 R ]
- /Count 1
->>
-endobj
-6 0 obj
-<< /Creator (cairo 1.10.2 (http://cairographics.org))
- /Producer (cairo 1.10.2 (http://cairographics.org))
->>
-endobj
-7 0 obj
-<< /Type /Catalog
- /Pages 1 0 R
->>
-endobj
-xref
-0 8
-0000000000 65535 f
-0000000867 00000 n
-0000000583 00000 n
-0000000015 00000 n
-0000000561 00000 n
-0000000655 00000 n
-0000000932 00000 n
-0000001059 00000 n
-trailer
-<< /Size 8
- /Root 7 0 R
- /Info 6 0 R
->>
-startxref
-1111
-%%EOF
Index: trunk/src/muli/doc/muli_momentum.tex
===================================================================
--- trunk/src/muli/doc/muli_momentum.tex (revision 8371)
+++ trunk/src/muli/doc/muli_momentum.tex (revision 8372)
@@ -1,324 +0,0 @@
-\Module{muli\_momentum}
-%\begin{figure}
-% \centering{\includegraphics{uml-module-tree-6.mps}}
-% \caption{\label{fig:\ThisModule:Types}Klassendiagramm des Moduls \ThisModule}
-%\end{figure}
-\section{Abhängigkeiten}
-\use{muli\_basic}
-\section{Derived Types}
-\TypeDef{transversal\_momentum\_type}
-Dieser Datentyp abstrahiert den Entwicklungsparameter $\pperp$. Intern wird $\pperp$ durch die Komponente \LocalVar{momentum} dargestellt. Dieser enthält die fünf Einträge $\big[s, \sqrt{\pperp}, \pperp, \sqrt{4*\pperp/s}, 4*\pperp/s\big]$. Für jeden Eintrag werden get und set Methoden bereitgestellt. Wenn statt eines Werts von $\pperp$ eine Instanz vom Typ \LocalVar{transversal\_momentum\_type} übergeben wird, werden Fehler durch falsche Einheiten vermieden.
-
-Nach MulI-Konvention wird die Einheit immer vor den Namen der Variable gestellt, also GeV\_scale für $\sqrt{\pperp}$ und GeV2\_scale für $\pperp$ usw. Hier wird bei dimensionslosen Größen $\sim\sqrt{\pperp}$ das Prefix unit und bei dimensionslosen Größen $\sim\pperp$ das prefix unit2 vorangestellt, damit immer klar ist, was gemeint ist.
-
-\LocalVar{MaxScale} ist der größtmögliche Wert für $\pperp$, mit $\pperp^{\max}=s/2$.
-
-\wip{Die invariante Masse $s$ wird hier \LocalVar{initial\_cme} genannt. Letzteres ist die invariante Masse des Proton-Proton-Systems vor der ersten (WHIZARD) Wechselwirkung. Das spiegelt die Tatsache wider, dass dynamische Energieen der Remnants noch nicht implementiert sind. Dieser Datentyp ist der richtige Ort, um die aktuelle CME zu speichern. Da alle anderen Module auf die get-Methoden dieses Moduls zurückgreifen, sollte es ausreichen, die interne Darstellung hier anzupassen.}
-
-\begin{Verbatim}
-implicit none
- type,\Extends{serializable\_class}::transversal_momentum_type
- private
- real(kind=drk),dimension(0:4)::\TC{momentum}=[0D0,0D0,0D0,0D0,0D0]
- contains
- \OverridesDeclaration{serializable\_class}
- procedure,public::\TbpDec{write\_to\_marker}{transversal\_momentum\_write\_to\_marker}
- procedure,public::\TbpDec{read\_from\_marker}{transversal\_momentum\_read\_from\_marker}
- procedure,public::\TbpDec{print\_to\_unit}{transversal\_momentum\_print\_to\_unit}
- procedure,public,nopass::\TbpDec{get\_type}{transversal\_momentum\_get\_type}
- \OriginalDeclaration{transversal\_momentum\_type}
- procedure,public::\TbpDec{get\_gev\_initial\_cme}{transversal\_momentum\_get\_gev\_initial\_cme}
- procedure,public::\TbpDec{get\_gev\_max\_scale}{transversal\_momentum\_get\_gev\_max\_scale}
- procedure,public::\TbpDec{get\_gev2\_max\_scale}{transversal\_momentum\_get\_gev2\_max\_scale}
- procedure,public::\TbpDec{get\_gev\_scale}{transversal\_momentum\_get\_gev\_scale}
- procedure,public::\TbpDec{get\_gev2\_scale}{transversal\_momentum\_get\_gev2\_scale}
- procedure,public::\TbpDec{get\_unit\_scale}{transversal\_momentum\_get\_unit\_scale}
- procedure,public::\TbpDec{get\_unit2\_scale}{transversal\_momentum\_get\_unit2\_scale}
- procedure,public::\TbpDec{set\_gev\_initial\_cme}{transversal\_momentum\_set\_gev\_initial\_cme}
- procedure,public::\TbpDec{set\_gev\_max\_scale}{transversal\_momentum\_set\_gev\_max\_scale}
- procedure,public::\TbpDec{set\_gev2\_max\_scale}{transversal\_momentum\_set\_gev2\_max\_scale}
- procedure,public::\TbpDec{set\_gev\_scale}{transversal\_momentum\_set\_gev\_scale}
- procedure,public::\TbpDec{set\_gev2\_scale}{transversal\_momentum\_set\_gev2\_scale}
- procedure,public::\TbpDec{set\_unit\_scale}{transversal\_momentum\_set\_unit\_scale}
- procedure,public::\TbpDec{set\_unit2\_scale}{transversal\_momentum\_set\_unit2\_scale}
- procedure,public::\TbpDecS{transversal\_momentum\_initialize}
- generic,public::\TbpDec{initialize}{transversal\_momentum\_initialize}
- end type transversal_momentum_type
-\end{Verbatim}
-\TypeDef{qcd\_2\_2\_class}
-Abstrakte Klasse, die eine QCD-2$\rightarrow$2-Wechselwirkung abstrahiert. \TypeRef{pp\_remnant\_type} greift auf Eigenschaften einer solchen Wechselwirkung zurück, allerdings werden die Methoden in dem Modul \ModuleRef{muli} implementiert, auf das \ModuleRef{muli\_remnant} keinen Zugriff hat. Zwar könnte man dieses Problem durch eine andere Hierarchie von Modulen lösen, aber ich nehme an, dass dieses Problem wieder auftaucht, wenn die Remnants als WHIZARD-Strukturfunktionen implementiert werden. Deswegen habe ich diese Lösung gewählt.
-\begin{Verbatim}
- type,Extends{transversal\_momentum\_type},abstract::qcd_2_2_class
- contains
- procedure(qcd_get_int),deferred::\TbpDef{get\_process\_id}
- procedure(qcd_get_int),deferred::\TbpDef{get\_integrand\_id}
- procedure(qcd_get_int),deferred::\TbpDef{get\_diagram\_kind}
- procedure(qcd_get_int_4),deferred::\TbpDef{get\_lha\_flavors}
- procedure(qcd_get_int_4),deferred::\TbpDef{get\_pdg\_flavors}
- procedure(qcd_get_int_by_int),deferred::\TbpDef{get\_parton\_id}
- procedure(qcd_get_int_2),deferred::\TbpDef{get\_parton\_kinds}
- procedure(qcd_get_int_2),deferred::\TbpDef{get\_pdf\_int\_kinds}
- procedure(qcd_get_drk),deferred::\TbpDef{get\_momentum\_boost}
- procedure(qcd_get_drk_2),deferred::\TbpDef{get\_remnant\_momentum\_fractions}
- procedure(qcd_get_drk_2),deferred::\TbpDef{get\_total\_momentum\_fractions}
- end type qcd_2_2_class
-\end{Verbatim}
-\section{Interfaces}
-\begin{Verbatim}
- abstract interface
- subroutine qcd_none(this)
- import qcd_2_2_class
- class(qcd_2_2_class),target,intent(in)::this
- end subroutine qcd_none
- elemental function qcd_get_drk(this)
- use muli_basic, only: drk
- import qcd_2_2_class
- class(qcd_2_2_class),intent(in)::this
- real(kind=drk)::qcd_get_drk
- end function qcd_get_drk
- pure function qcd_get_drk_2(this)
- use muli_basic, only: drk
- import qcd_2_2_class
- class(qcd_2_2_class),intent(in)::this
- real(kind=drk),dimension(2)::qcd_get_drk_2
- end function qcd_get_drk_2
- pure function qcd_get_drk_3(this)
- use muli_basic, only: drk
- import qcd_2_2_class
- class(qcd_2_2_class),intent(in)::this
- real(kind=drk),dimension(3)::qcd_get_drk_3
- end function qcd_get_drk_3
- elemental function qcd_get_int(this)
- use muli_basic, only: drk
- import qcd_2_2_class
- class(qcd_2_2_class),intent(in)::this
- integer::qcd_get_int
- end function qcd_get_int
- elemental function qcd_get_int_by_int(this,n)
- use muli_basic, only: drk
- import qcd_2_2_class
- class(qcd_2_2_class),intent(in)::this
- integer,intent(in)::n
- integer::qcd_get_int_by_int
- end function qcd_get_int_by_int
- pure function qcd_get_int_2(this)
- use muli_basic, only: drk
- import qcd_2_2_class
- class(qcd_2_2_class),intent(in)::this
- integer,dimension(2)::qcd_get_int_2
- end function qcd_get_int_2
- pure function qcd_get_int_4(this)
- use muli_basic, only: drk
- import qcd_2_2_class
- class(qcd_2_2_class),intent(in)::this
- integer,dimension(4)::qcd_get_int_4
- end function qcd_get_int_4
- end interface
-\end{Verbatim}
-\Methods
-\MethodsFor{transversal\_momentum\_type}
-\OverridesSection{serializable\_class}
-\TbpImp{transversal\_momentum\_write\_to\_marker}
-\begin{Verbatim}
- subroutine transversal_momentum_write_to_marker(this,marker,status)
- class(transversal_momentum_type),intent(in)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("transversal_momentum_type")
- call marker%mark("gev_momenta",this%momentum(0:1))
- call marker%mark_end("transversal_momentum_type")
- end subroutine transversal_momentum_write_to_marker
-\end{Verbatim}
-\TbpImp{transversal\_momentum\_read\_from\_marker}
-\begin{Verbatim}
- subroutine transversal_momentum_read_from_marker(this,marker,status)
- class(transversal_momentum_type),intent(out)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%pick_begin("transversal_momentum_type",status=status)
- call marker%pick("gev_momenta",this%momentum(0:1),status)
- this%momentum(2:4)=[&
- this%momentum(1)**2,&
- this%momentum(1)/this%momentum(0),&
- (this%momentum(1)/this%momentum(0))**2]
- call marker%pick_end("transversal_momentum_type",status=status)
- end subroutine transversal_momentum_read_from_marker
-\end{Verbatim}
-\TbpImp{transversal\_momentum\_print\_to\_unit}
-\begin{Verbatim}
- subroutine transversal_momentum_print_to_unit(this,unit,parents,components,peers)
- class(transversal_momentum_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- write(unit,'("Components of transversal_momentum_type:")')
- write(unit,fmt='("Actual energy scale:")')
- write(unit,fmt='("Max scale (MeV) :",E20.10)')this%momentum(0)
- write(unit,fmt='("Scale (MeV) :",E20.10)')this%momentum(1)
- write(unit,fmt='("Scale^2 (MeV^2) :",E20.10)')this%momentum(2)
- write(unit,fmt='("Scale normalized :",E20.10)')this%momentum(3)
- write(unit,fmt='("Scale^2 normalized:",E20.10)')this%momentum(4)
- end subroutine transversal_momentum_print_to_unit
- \end{Verbatim}
-\TbpImp{transversal\_momentum\_get\_type}
-\begin{Verbatim}
- pure subroutine transversal_momentum_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="transversal_momentum_type")
- end subroutine transversal_momentum_get_type
-\end{Verbatim}
-\OriginalSection{transversal\_momentum\_type}
-\TbpImp{transversal\_momentum\_get\_gev\_initial\_cme}
-\begin{Verbatim}
- elemental function transversal_momentum_get_gev_initial_cme(this) result(scale)
- class(transversal_momentum_type),intent(in)::this
- real(kind=drk)::scale
- scale=this%momentum(0)*2D0
- end function transversal_momentum_get_gev_initial_cme
-\end{Verbatim}
-\TbpImp{transversal\_momentum\_get\_gev\_max\_scale}
-
-\TbpImp{transversal\_momentum\_get\_gev\_max\_scale}
-\begin{Verbatim}
- elemental function transversal_momentum_get_gev_max_scale(this) result(scale)
- class(transversal_momentum_type),intent(in)::this
- real(kind=drk)::scale
- scale=this%momentum(0)
- end function transversal_momentum_get_gev_max_scale
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_get\_gev2\_max\_scale}
-\begin{Verbatim}
- elemental function transversal_momentum_get_gev2_max_scale(this) result(scale)
- class(transversal_momentum_type),intent(in)::this
- real(kind=drk)::scale
- scale=this%momentum(0)**2
- end function transversal_momentum_get_gev2_max_scale
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_get\_gev\_scale}
-\begin{Verbatim}
- elemental function transversal_momentum_get_gev_scale(this) result(scale)
- class(transversal_momentum_type),intent(in)::this
- real(kind=drk)::scale
- scale=this%momentum(1)
- end function transversal_momentum_get_gev_scale
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_get\_gev2\_scale}
-\begin{Verbatim}
- elemental function transversal_momentum_get_gev2_scale(this) result(scale)
- class(transversal_momentum_type),intent(in)::this
- real(kind=drk)::scale
- scale=this%momentum(2)
- end function transversal_momentum_get_gev2_scale
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_get\_unit\_scale}
-\begin{Verbatim}
- elemental function transversal_momentum_get_unit_scale(this) result(scale)
- class(transversal_momentum_type),intent(in)::this
- real(kind=drk)::scale
- scale=this%momentum(3)
- end function transversal_momentum_get_unit_scale
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_get\_unit2\_scale}
-\begin{Verbatim}
- elemental function transversal_momentum_get_unit2_scale(this) result(scale)
- class(transversal_momentum_type),intent(in)::this
- real(kind=drk)::scale
- scale=this%momentum(4)
- end function transversal_momentum_get_unit2_scale
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_set\_gev\_initial\_cme}
-\begin{Verbatim}
- subroutine transversal_momentum_set_gev_initial_cme(this,new_gev_initial_cme)
- class(transversal_momentum_type),intent(inout)::this
- real(kind=drk),intent(in) :: new_gev_initial_cme
- this%momentum(0) = new_gev_initial_cme/2D0
- this%momentum(3) = this%momentum(1)/this%momentum(0)
- this%momentum(4) = this%momentum(3)**2
- end subroutine transversal_momentum_set_gev_initial_cme
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_set\_gev\_max\_scale}
-\begin{Verbatim}
- subroutine transversal_momentum_set_gev_max_scale(this,new_gev_max_scale)
- class(transversal_momentum_type),intent(inout)::this
- real(kind=drk),intent(in) :: new_gev_max_scale
- this%momentum(0) = new_gev_max_scale
- this%momentum(3) = this%momentum(1)/this%momentum(0)
- this%momentum(4) = this%momentum(3)**2
- end subroutine transversal_momentum_set_gev_max_scale
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_set\_gev2\_max\_scale}
-\begin{Verbatim}
- subroutine transversal_momentum_set_gev2_max_scale(this,new_gev2_max_scale)
- class(transversal_momentum_type),intent(inout)::this
- real(kind=drk),intent(in) :: new_gev2_max_scale
- this%momentum(0) = sqrt(new_gev2_max_scale)
- this%momentum(3) = this%momentum(1)/this%momentum(0)
- this%momentum(4) = this%momentum(3)**2
- end subroutine transversal_momentum_set_gev2_max_scale
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_set\_gev\_scale}
-\begin{Verbatim}
- subroutine transversal_momentum_set_gev_scale(this,new_gev_scale)
- class(transversal_momentum_type),intent(inout)::this
- real(kind=drk),intent(in) :: new_gev_scale
- this%momentum(1) = new_gev_scale
- this%momentum(2) = new_gev_scale**2
- this%momentum(3) = new_gev_scale/this%momentum(0)
- this%momentum(4) = this%momentum(3)**2
- end subroutine transversal_momentum_set_gev_scale
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_set\_gev2\_scale}
-\begin{Verbatim}
- subroutine transversal_momentum_set_gev2_scale(this,new_gev2_scale)
- class(transversal_momentum_type),intent(inout)::this
- real(kind=drk),intent(in) :: new_gev2_scale
- this%momentum(1) = sqrt(new_gev2_scale)
- this%momentum(2) = new_gev2_scale
- this%momentum(3) = this%momentum(1)/this%momentum(0)
- this%momentum(4) = this%momentum(3)**2
- end subroutine transversal_momentum_set_gev2_scale
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_set\_unit\_scale}
-\begin{Verbatim}
- subroutine transversal_momentum_set_unit_scale(this,new_unit_scale)
- class(transversal_momentum_type),intent(inout)::this
- real(kind=drk),intent(in) :: new_unit_scale
- this%momentum(1) = new_unit_scale*this%momentum(0)
- this%momentum(2) = this%momentum(1)**2
- this%momentum(3) = new_unit_scale
- this%momentum(4) = this%momentum(3)**2
- end subroutine transversal_momentum_set_unit_scale
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_set\_unit2\_scale}
-\begin{Verbatim}
- subroutine transversal_momentum_set_unit2_scale(this,new_unit2_scale)
- class(transversal_momentum_type),intent(inout)::this
- real(kind=drk),intent(in) :: new_unit2_scale
- this%momentum(3) = sqrt(new_unit2_scale)
- this%momentum(4) = new_unit2_scale
- this%momentum(1) = this%momentum(3)*this%momentum(0)
- this%momentum(2) = this%momentum(1)**2
- end subroutine transversal_momentum_set_unit2_scale
-\end{Verbatim}
-
-\TbpImp{transversal\_momentum\_initialize}
-\begin{Verbatim}
- subroutine transversal_momentum_initialize(this,gev2_s)
- class(transversal_momentum_type),intent(out)::this
- real(kind=drk),intent(in)::gev2_s
- real(kind=drk)::gev_s
- gev_s=sqrt(gev2_s)
- this%momentum=[gev_s/2D0,gev_s/2D0,gev2_s/4D0,1D0,1D0]
- end subroutine transversal_momentum_initialize
-\end{Verbatim}
Index: trunk/src/muli/doc/icons.mp
===================================================================
--- trunk/src/muli/doc/icons.mp (revision 8371)
+++ trunk/src/muli/doc/icons.mp (revision 8372)
@@ -1,8 +0,0 @@
-input common;
-
-beginfig(1)
- numeric unit;
- unit=7;
- draw_extends((0,0),(0,1),(0,0));
-endfig;
-end;
Index: trunk/src/muli/doc/muli_aq.tex
===================================================================
--- trunk/src/muli/doc/muli_aq.tex (revision 8371)
+++ trunk/src/muli/doc/muli_aq.tex (revision 8372)
@@ -1,802 +0,0 @@
-\Module{muli\_aq}
-%\begin{figure}
-% \centering{\includegraphics{uml-module-tree-3.mps}}
-% \caption{\label{fig:\ThisModule:Types}Klassendiagramm des Moduls \ThisModule}
-%\end{figure}
-aq ist eine Abkürzung für adaptive Quadratur. Mit aq\_class kann für eine beliebige Funktion $f:\mathbb{R}\rightarrow\mathbb{R}^n$ die Quasistammfunktion $F(x)=\int_x^1 f(y)\ \der\!y$ mittels adaptiver Quadratur ausgewertet und als Binärbaum von Segmenten $s_j=[x_{j-1},x_j]$ gespeichert werden. Zu jedem Segment werden $f(x_j),F(x_j)$ und $\exp[-F(x_j)]$ gespeichert.
-
-$f$ wird mit der Trapezregel approximiert, entsprechend wird $F$ durch Parabeln approximiert. Dennoch ist die Approximation von $F$ nicht gleich Simpsons Regel, denn wir haben nur zwei Stützstellen $x_{j-1}$ und $x_j$ für jede Parabel.
-
-Der Integrationsfehler $delta$ $\delta^\prime$ bzw. $\delta^\prime$ ergibt sich bei der Spaltung des Segments $s_j$ in zwei Untersegmente $s_j^\prime=[x_{j-1},y]$ und $s_j^{\prime\prime}=[y,x_j]$ durch die Differenz des alten und des neuen Integrals:
-\begin{align}
- \delta^{\prime}&=\left|\frac{\big(f(y)-f_j(y)\big)\big(x_{j-1}-y\big)}{2}\right|\\
- \delta^{\prime\prime}&=\left|\frac{\big(f(y)-f_j(y)\big)\big(x_j-y\big)}{2}\right|
-\end{align}
-mit der alten Approximation $f_j$ des alten Segments $j$
-\begin{equation}
- f_j(y)=f(x_j)-y\ \frac{f(x_j)-f(x_{j-1})}{x_j-x_{j-1}}.
-\end{equation}
-\section{Abhängigkeiten}
-\use{muli\_basic}
-\use{muli\_cuba}
-\use{muli\_trapezium}
-\use{muli\_fibonacci\_tree}
-\section{Derived Types}
-\TypeDef{aq\_class}
-\begin{Verbatim}
- type,\Extends{identified\_type},abstract :: aq_class
- ! private
- \IC{Erweiterungen müssen durch is\_deferred\_initialised signalisieren, dass sie bereit sind.}
- logical :: \TC{is\_deferred\_initialised} = .false.
- \IC{Ist \CompRef{aq\_class}{err\_tree} bereit?}
- logical :: \TC{is\_error\_tree\_initialised} = .false.
- \IC{Wurden die internen Fehlerziele bestimmt?}
- logical :: \TC{is\_goal\_set} = .false.
- \IC{Ist alles bereit zur Integration?}
- logical :: \TC{is\_initialised} = .false.
- \IC{Wurde die Integration durchgeführt?}
- logical :: \TC{is\_run} = .false.
- \IC{Wurde das Fehlerziel erreicht?}
- logical :: \TC{is\_goal\_reached} = .false.
- \IC{Wurde \CompRef{aq\_class}{err\_tree} nach \CompRef{aq\_class}{int\_list} konvertiert?}
- logical :: \TC{is\_integrated} = .false.
- \IC{Die aktuelle Anzahl von Segmenten}
- integer(kind=dik) :: \TC{n\_nodes} = 0
- \IC{Die maximale Anzahl von Segmenten}
- integer(kind=dik) :: \TC{max\_nodes} = 10000
- \IC{Die Dimension von f}
- integer :: \TC{dim\_integral} = 1
- \IC{Das gegebene absolute Fehlerziel}
- real(kind=double) :: \TC{abs\_error\_goal} = 0D0
- \IC{Das gegebene relative Fehlerziel}
- real(kind=double) :: \TC{rel\_error\_goal} = 0.1D0
- \IC{Das berechnete absolute Fehlerziel, basierend auf der aktuellen}
- \IC{Schätzung des Integrals}
- real(kind=double) :: \TC{scaled\_error\_goal} = 0.0D0
- \IC{Schätzung des Integrals F(x_min)}
- real(kind=double) :: \TC{integral} = 1D0
- \IC{Aktueller absoluter Integrationsfehler}
- real(kind=double) :: \TC{integral\_error} = 0D0
- \IC{Integrationsintervall}
- real(kind=double),dimension(2) :: \TC{region} = (/0D0,1D0/)
- \IC{Zu Debuggingzwecken wird die Historie des Integrationsfehlers gespeichert.}
- \IC{Wenn die Historie oszilliert, dann ist der Fehler in f, also in der}
- \IC{Cuba-Integration zu groß.}
- real(kind=double),dimension(:,:),allocatable :: \TC{convergence}
- \IC{time stamps um die Performance des Allgorithmus zu überwachen.}
- real(kind=double) :: \TC{total\_time} = 0
- real(kind=double) :: \TC{loop\_time} = 0
- real(kind=double) :: \TC{int\_time} = 0
- real(kind=double) :: \TC{cuba\_time} = 0
- real(kind=double) :: \TC{init\_time} = 0
- real(kind=double) :: \TC{cpu\_time} = 0
-
- \IC{These variables *must* be initialised before the main loop may be called.}
- \IC{Additionaly the nodes and segments should be preprocessed by first_run}
- \IC{before the main loop may be called.}
-
- \IC{Das tatsächliche Fehlerziel.}
- real(kind=double) :: \TC{error\_goal} = 0D0
- \IC{Während der Integration werden die Segmente des Integranden nach ihrem}
- \IC{Integrationsfehler sortiert in diesem Binärbaum gespeichert.}
- class(\TypeRef{fibonacci\_root\_type}),pointer ::\TC{err\_tree}=>null()
- \IC{Nach erfolgreicher Integration werden die Segmente nach dem Skalenparameter}
- \IC{sortiert in dieser Liste gespeichert.}
- class(\TypeRef{muli\_trapezium\_list\_type}),pointer ::\TC{int\_list}=>null()
- contains
- \OverridesDeclaration{serializable\_class}
- procedure::\TbpDec{write\_to\_marker}{aq\_write\_to\_marker}
- procedure::\TbpDec{read\_from\_marker}{aq\_read\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{aq\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{aq\_get\_type}
- procedure::\TbpDec{deserialize\_from\_marker}{aq\_deserialize\_from\_marker}
- \OriginalDeclaration
- procedure :: aq_initialize
- generic ::\TbpDec{initialize}{aq\_initialize}
- procedure ::\TbpDec{print\_times}{aq\_print\_times}
- procedure ::\TbpDec{write\_convergence}{aq\_write\_convergence}
- ! init/ de-init
- procedure ::\TbpDec{reset}{aq\_reset}
- procedure ::\TbpDec{dealloc\_trees}{aq\_dealloc\_trees}
- procedure ::\TbpDec{finalize}{aq\_dealloc\_trees}
- procedure ::\TbpDec{init\_error\_tree}{aq\_init\_error\_tree}
- procedure ::\TbpDec{set\_rel\_goal}{aq\_set\_rel\_goal}
- procedure ::\TbpDec{set\_abs\_goal}{aq\_set\_abs\_goal}
- procedure ::\TbpDec{set\_goal}{aq\_set\_goal}
- procedure ::\TbpDec{check\_init}{aq\_check\_init}
- ! calculation
- procedure ::\TbpDec{main\_loop}{aq\_main\_loop}
- procedure ::\TbpDec{run}{aq\_run}
- procedure ::\TbpDec{integrate}{aq\_integrate}
- ! deferred
- procedure(evaluate_if),deferred :: evaluate
- end type aq_class
-\end{Verbatim}
-\section{Interfaces}
-\begin{Verbatim}
- interface
- subroutine evaluate_if(this,x,y)
- use kinds!NODEP!
- import aq_class
- class(aq_class),intent(inout) :: this
- real(kind=double), intent(in) :: x
- real(kind=double), intent(out) ,dimension(:):: y
- end subroutine evaluate_if
- \end{Verbatim}
-\Methods
-\MethodsFor{aq\_class}
-\OverridesSection{serializable\_class}
-
-\TbpImp{aq\_write\_to\_marker}
-\begin{Verbatim}
- subroutine aq_write_to_marker(this,marker,status)
- class(aq_class), intent(in) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- class(serializable_class),pointer::ser
- call marker%mark_begin("aq_class")
- call identified_write_to_marker(this,marker,status)
- call marker%mark("is_deferred_initialised",this&
- &%is_deferred_initialised)
- call marker%mark("is_error_tree_initialised",this&
- &%is_error_tree_initialised)
- call marker%mark("is_goal_set",this%is_goal_set)
- call marker%mark("is_initialised",this%is_initialised)
- call marker%mark("is_run",this%is_run)
- call marker%mark("is_goal_reached",this%is_goal_reached)
- call marker%mark("is_integrated",this%is_integrated)
- call marker%mark("n_nodes",this%n_nodes)
- call marker%mark("max_nodes",this%max_nodes)
- call marker%mark("dim_integral",this%dim_integral)
- call marker%mark("abs_error_goal",this%abs_error_goal)
- call marker%mark("rel_error_goal",this%rel_error_goal)
- call marker%mark("scaled_error_goal",this%scaled_error_goal)
- call marker%mark("error_goal",this%error_goal)
- call marker%mark("integral",this%integral)
- call marker%mark("integral_error",this%integral_error)
- call marker%mark("region",this%region(1:2))
- ser=>this%err_tree
- call marker%mark_pointer("err_tree",ser)
- ser=>this%int_list
- call marker%mark_pointer("int_list",ser)
- call marker%mark_end("aq_class")
- end subroutine aq_write_to_marker
-\end{Verbatim}
-
-\TbpImp{aq\_read\_from\_marker}
-\begin{Verbatim}
- subroutine aq_read_from_marker(this,marker,status)
- class(aq_class), intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- class(serializable_class),pointer::ser
- call marker%pick_begin("aq_class",status=status)
- call identified_read_from_marker(this,marker,status)
- call marker%pick("is_deferred_initialised",this%is_deferred_initialised&
- &,status)
- call marker%pick("is_error_tree_initialised",this&
- &%is_error_tree_initialised,status)
- call marker%pick("is_goal_set",this%is_goal_set,status)
- call marker%pick("is_initialised",this%is_initialised,status)
- call marker%pick("is_run",this%is_run,status)
- call marker%pick("is_goal_reached",this%is_goal_reached,status)
- call marker%pick("is_integrated",this%is_integrated,status)
- call marker%pick("n_nodes",this%n_nodes,status)
- call marker%pick("max_nodes",this%max_nodes,status)
- call marker%pick("dim_integral",this%dim_integral,status)
- call marker%pick("abs_error_goal",this%abs_error_goal,status)
- call marker%pick("rel_error_goal",this%rel_error_goal,status)
- call marker%pick("scaled_error_goal",this%scaled_error_goal,status)
- call marker%pick("error_goal",this%error_goal,status)
- call marker%pick("integral",this%integral,status)
- call marker%pick("integral_error",this%integral_error,status)
- call marker%pick("region",this%region(1:2),status)
- call marker%pick_pointer("err_tree",ser)
- if(associated(ser))then
- select type(ser)
- class is (fibonacci_root_type)
- this%err_tree=>ser
- class default
- nullify(this%err_tree)
- end select
- end if
- call marker%pick_pointer("int_list",ser)
- if(associated(ser))then
- select type(ser)
- class is (muli_trapezium_list_type)
- this%int_list=>ser
- class default
- nullify(this%int_list)
- end select
- end if
- call marker%pick_end("aq_class",status)
- end subroutine aq_read_from_marker
-\end{Verbatim}
-
-\TbpImp{aq\_print\_to\_unit}
-\begin{Verbatim}
- subroutine aq_print_to_unit(this,unit,parents,components,peers)
- class(aq_class),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- integer::ite
- class(serializable_class),pointer::ser
- if(parents>0)call identified_print_to_unit(this,unit,parents-1,components&
- &,peers)
- write(unit,'("Components of aq_class")')
- write(unit,'(a,L1)')"Deferred class initialised: ",this&
- &%is_deferred_initialised
- write(unit,'(a,L1)')"Error tree initialised: ",this&
- &%is_error_tree_initialised
- write(unit,'(a,L1)')"Accuracy goal set: ",this%is_goal_set
- write(unit,'(a,L1)')"Ready for run: ",this%is_initialised
- write(unit,'(a,L1)')"Is run: ",this%is_run
- write(unit,'(a,L1)')"Accuracy goal reached: ",this%is_goal_reached
- write(unit,'(a,L1)')"Integral calculated: ",this%is_integrated
- write(unit,'(a,I10)')"Number of nodes: ",this%n_nodes
- write(unit,'(a,I10)')"Maximal number of nodes: ",this%max_nodes
- write(unit,'(a,I10)')"Dimension of integral: ",this%dim_integral
- write(unit,'(a,E20.10)')"Given abs. error goal: ",this%abs_error_goal
- write(unit,'(a,E20.10)')"Given rel. error goal: ",this%rel_error_goal
- write(unit,'(a,E20.10)')"Guessed abs error goal:",this%scaled_error_goal
- write(unit,'(a,E20.10)')"Actual abs error goal: ",this%error_goal
- write(unit,'(a,E20.10)')"Integral ",this%integral
- write(unit,'(a,E20.10)')"Estimated abs. error: ",this%integral_error
- write(unit,'(a,E10.5,a,E10.5,a)')"Integration region = (",this%region(1)&
- &," : ",this%region(2),")"
- ser=>this%err_tree
- call serialize_print_comp_pointer(ser,unit,parents,components,peers&
- &,"error tree")
- ser=>this%int_list
- call serialize_print_comp_pointer(ser,unit,parents,components,peers&
- &,"integral list")
- end subroutine aq_print_to_unit
-\end{Verbatim}
-
-\TbpImp{aq\_get\_type}
-\begin{Verbatim}
- pure subroutine aq_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="aq_type")
- end subroutine aq_get_type
-\end{Verbatim}
-
-\TbpImp{aq\_deserialize\_from\_marker}
-\begin{Verbatim}
- subroutine aq_deserialize_from_marker(this,name,marker)
- class(aq_class),intent(out)::this
- character(*),intent(in)::name
- class(marker_type),intent(inout)::marker
- class(serializable_class),pointer::ser
- allocate(muli_trapezium_type::ser)
- call marker%push_reference(ser)
- allocate(fibonacci_root_type::ser)
- call marker%push_reference(ser)
- allocate(fibonacci_leave_type::ser)
- call marker%push_reference(ser)
- allocate(fibonacci_node_type::ser)
- call marker%push_reference(ser)
- call serializable_deserialize_from_marker(this,name,marker)
- call marker%pop_reference(ser)
- deallocate(ser)
- call marker%pop_reference(ser)
- deallocate(ser)
- call marker%pop_reference(ser)
- deallocate(ser)
- call marker%pop_reference(ser)
- deallocate(ser)
- end subroutine aq_deserialize_from_marker
-\end{Verbatim}
-\OriginalSection{aq\_class}
-\TbpImp{aq\_initialize}
-\begin{Verbatim}
- subroutine aq_initialize(this,id,name,goal,max_nodes,dim,init)
- class(aq_class),intent(out) :: this
- integer(kind=dik),intent(in)::id,max_nodes
- integer,intent(in)::dim
- character,intent(in)::name
- real(kind=double)::goal
- real(kind=double),dimension(:),intent(in)::init
- call identified_initialize(this,id,name)
- this%rel_error_goal = goal!1d-4
- this%max_nodes=max_nodes
- call this%init_error_tree(dim,init)
- end subroutine aq_initialize
-\end{Verbatim}
-\TbpImp{aq\_print\_times}
-\begin{Verbatim}
- subroutine aq_print_times(this)
- class(aq_class),intent(in) :: this
- print '(a,E20.10)',"Initialization time: ",this%init_time
- print '(a,E20.10)',"Main loop time: ",this%loop_time
- print '(a,E20.10)',"Integration time: ",this%int_time
- print '(a,E20.10)',"Overall run time: ",this%total_time
- print '(a,E20.10)',"Cuba integration time:",this%cuba_time
- end subroutine aq_print_times
-\end{Verbatim}
-\TbpImp{aq\_write\_convergence}
-\begin{Verbatim}
- subroutine aq_write_convergence(this,unit)
- class(aq_class),intent(in) :: this
- integer,intent(in)::unit
- integer,dimension(2)::s
- integer::node
- if(allocated(this%convergence))then
- s=shape(this%convergence)
- do node=1,s(2)
- write(unit,fmt=*)node,this%convergence(1:2,node)
- end do
- end if
- end subroutine aq_write_convergence
-\end{Verbatim}
-! init/ de-init
-
-\TbpImp{aq\_reset}
-\begin{Verbatim}
- subroutine aq_reset(this)
- class(aq_class) :: this
- this%is_deferred_initialised = .false.
- this%is_error_tree_initialised = .false.
- this%is_goal_set = .false.
- this%is_initialised = .false.
- this%is_run = .false.
- this%is_goal_reached = .false.
- this%is_integrated = .false.
- this%n_nodes = 0
- this%max_nodes = 10000
- this%dim_integral=1
- this%abs_error_goal = 1D0
- this%rel_error_goal = 0.1D0
- this%scaled_error_goal = 0.0D0
- this%error_goal = 0.0D0
- this%integral = 0D0
- this%integral_error = 0D0
- this%region = (/0D0,1D0/)
- this%total_time = 0
- this%loop_time = 0
- this%int_time = 0
- this%init_time = 0
- call this%dealloc_trees()
- end subroutine aq_reset
-\end{Verbatim}
-\TbpImp{aq\_check\_init}
-\begin{Verbatim}
- subroutine aq_check_init(this)
- class(aq_class) :: this
- this%is_initialised = this%is_error_tree_initialised .and. this%is_deferred_initialised
- end subroutine aq_check_init
-\end{Verbatim}
-\TbpImp{aq\_dealloc\_trees}
-\begin{Verbatim}
- subroutine aq_dealloc_trees(this)
- class(aq_class) :: this
- if(associated(this%err_tree))then
- call this%err_tree%deallocate_all()
- deallocate(this%err_tree)
- end if
- if(associated(this%int_list))then
- call this%int_list%finalize()
- deallocate(this%int_list)
- end if
- end subroutine aq_dealloc_trees
-\end{Verbatim}
-
-\TbpImp{aq\_init\_error\_tree}
-\begin{Verbatim}
- subroutine aq_init_error_tree(this,dim_integral,x_array)
- class(aq_class) :: this
- \IC{Wie viele Einträge hat der Rückgabewert von evaluate?}
- integer,intent(in)::dim_integral
- \IC{Eine geordnete Liste von Skalenparametern}
- real(kind=double), dimension(:), intent(in) :: x_array
- \IC{(x_j - x_\{j-1\})/2}
- real(kind=double) :: center
- \IC{Die Funktionswerte am linken Rand, in der Mitte und am rechten Rand des Intervalls.}
- real(kind=double), dimension(:),allocatable::l_val,c_val,r_val
- \IC{Jedes der gegebenen Intervalle wird in zwei Unterintervalle zerlegt, um eine}
- \IC{Abschätzung des Integrationsfehlees zu bekommen. In left\_node und right\_node}
- \IC{werden diese Intervalle gespeichert und in den Binärbaum eingefügt.}
- class(\TypeRef{muli\_trapezium\_type}),pointer :: left_node => null()
- class(\TypeRef{muli\_trapezium\_type}),pointer :: right_node => null()
- \IC{Die Anzahl der gegebenen x-Werte und die Nummer des aktuellen x-Werts.}
- integer :: x_size,pos
- \IC{Timer Start}
- call cpu_time(this%init_time)
- \IC{Signalisieren, dass die Bäume in einem undefinierten Zustand sind.}
- this%is_initialised=.false.
- this%integral=0D0
- this%dim_integral=dim_integral
- x_size = size(x_array)
- if (x_size<2) then
- write (*,'("aq_init_error_tree: I need at least two real values")')
- else
- \IC{In der Null-Komponente wird die Summe aller anderen Einträge gespeichert.}
- allocate(l_val(0:dim_integral-1))
- allocate(c_val(0:dim_integral-1))
- allocate(r_val(0:dim_integral-1))
- \IC{Der Integrationsbereich wird festgelegt.}
- this%region=(/x_array(1),x_array(x_size)/)
- if (x_size<3) then
- \IC{Wir haben nur ein Startsegment, das sich über den gesamten Integrationsbereich}
- \IC{erstreckt. Wir Teilen in der Mitte, denn der Binärbaum}
- \IC{\CompRef{aq\_class}{error\_tree} muss mindestens zwei Blätter haben.}
- center=(x_array(2)-x_array(1))/2D0
- \IC{Wir fordern die Funktionswerte an.}
- call this%evaluate(x_array(1),l_val)
- call this%evaluate(center, c_val)
- call this%evaluate(x_array(2),r_val)
- \IC{Wir erzeugen ein neues Segment [x\_1,c].}
- allocate(left_node)
- call left_node%initialize(&
- &dim=dim_integral,&
- &r_position=center,&
- &d_position=center-x_array(1))
- call left_node%set_r_value(c_val)
- call left_node%set_d_value(c_val-l_val)
- \IC{Wir erzeugen ein neues Segment [c,x\_2].}
- allocate(right_node)
- call right_node%initialize(&
- &dim=dim_integral,&
- &r_position=x_array(2),&
- &d_position=x_array(2)-center)
- call right_node%set_r_value(r_val)
- call right_node%set_d_value(r_val-c_val)
- else
- \IC{wir haben genügend x-Werte, um einen minimalen Baum}
- \IC{\CompRef{aq\_class}{error\_tree} mit zwei Blättern zu initialisieren.}
- call this%evaluate(x_array(1),l_val)
- call this%evaluate(x_array(2),c_val)
- call this%evaluate(x_array(3),r_val)
- allocate(left_node)
- call left_node%initialize(&
- &dim=dim_integral,&
- &r_position=x_array(2),&
- &d_position=x_array(2)-x_array(1))
- call left_node%set_r_value(c_val)
- call left_node%set_d_value(c_val-l_val)
- allocate(right_node)
- call right_node%initialize(&
- &dim=dim_integral,&
- &r_position=x_array(3),&
- &d_position=x_array(3)-x_array(2))
- call right_node%set_r_value(r_val)
- call right_node%set_d_value(r_val-c_val)
- end if
- \IC{Die beiden Startblätter des Baums werden bereitgemacht}
- call left_node%update()
- call right_node%update()
- \IC{Der Wert für das Integral über diese Blätter wird abgeschätzt.}
- this%integral=sum(left_node%get_d_integral()+right_node%get_d_integral())
- if (.not. associated(this%err_tree)) then
- allocate(this%err_tree)
- end if
- \IC{Debugging}
- print *,left_node%measure()
- print *,right_node%measure()
- \IC{Der Baum wird mit den beiden Blättern initialisiert.}
- call this%err_tree%init_by_content(left_node,right_node)
- \IC{Wenn wir noch mehr Segmente haben, dann werden sie in den Baum aufgenommen.}
- if (x_size > 3) then
- do pos=4,x_size
- \IC{Fortschrittsanzeige. Die Intagrationen können einige Minuten dauern.}
- print *,"aq_init_error_tree",pos,"/",x_size
- \IC{Wir merken uns den Funktionswert am rechen Rand des letzten Segments.}
- \IC{Das ist der neue linke Funktionswert des neuen Segments.}
- l_val=right_node%get_r_value_array()
- \IC{Wir forden den Funktionswert am rechten Rand des neuen Intervalls an.}
- call this%evaluate(x_array(pos),r_val)
- \IC{Ein Missbrauch der Variablen, c\_val ist jetzt die Intervallänge.}
- c_val=r_val-l_val
- allocate(right_node)
- call right_node%initialize(&
- &dim=dim_integral,&
- &r_position=x_array(pos),&
- &d_position=x_array(pos)-x_array(pos-1))
- call right_node%set_r_value(r_val)
- call right_node%set_d_value(c_val)
- call right_node%update()
- call this%err_tree%push_by_content(right_node)
- \IC{Das Gesamtintegral wird um das Integral über das neue Segment erhöht.}
- this%integral=this%integral+sum(right_node%get_d_integral())
- end do
- \IC{So viele Blätter hat der Baum jetzt.}
- this%n_nodes = x_size
- end if
- \IC{Der Baum ist wieder in einem definierten Zustand.}
- this%is_error_tree_initialised=.true.
- end if
- \IC{Da wir jetzt eine erste Abschätzung für das Integral haben, können wir}
- \IC{eine Abschätzung für das absolute Fehlerziel machen.}
- call this%set_goal()
- \IC{Damit ist alles Bereit für die adaptive Integration.}
- this%is_initialised=.true.
- \IC{Timer Stopp}
- call cpu_time(this%cpu_time)
- this%init_time=this%cpu_time-this%init_time
- this%cuba_time=this%init_time
- \IC{Debugging: Ab jetzt schreiben wir den aktuellen Integrationsfehler mit.}
- allocate(this%convergence(2,this%n_nodes:this%max_nodes))
- end subroutine aq_init_error_tree
-\end{Verbatim}
-\TbpImp{aq\_set\_abs\_goal}
-\begin{Verbatim}
- subroutine aq_set_abs_goal(this,goal)
- class(aq_class) :: this
- real(kind=double) :: goal
- this%abs_error_goal = goal
- call this%set_goal
- end subroutine aq_set_abs_goal
-\end{Verbatim}
-\TbpImp{aq\_set\_rel\_goal}
-\begin{Verbatim}
- subroutine aq_set_rel_goal(this,goal)
- class(aq_class) :: this
- real(kind=double) :: goal
- this%rel_error_goal = goal
- call this%set_goal
- end subroutine aq_set_rel_goal
-\end{Verbatim}
-\TbpImp{aq\_set\_goal}
-Die angegebenen Fehlerziele werden auf Konsistenz geprüft. Aus dem relativen Fehler wird mithilfe der aktuellen Abschätzung des Integrals ein absoluter Fehler scaled\_error\_goal berechnet. Das Minimum aus abs\_error\_goal und scaled\_error\_goal wird das tatsächliche absulute Fehlerziel error\_goal.
-\begin{Verbatim}
- subroutine aq_set_goal(this)
- class(aq_class) :: this
- this%scaled_error_goal = this%rel_error_goal*abs(this%integral)
- if ((this%scaled_error_goal==0D0).and.(this%abs_error_goal==0D0)) then
- this%is_goal_set = .false.
- this%error_goal = 0D0
- else
- if (this%scaled_error_goal == 0D0) then
- this%error_goal = this%abs_error_goal
- else
- if (this%abs_error_goal == 0D0) then
- this%error_goal = this%scaled_error_goal
- else
- this%error_goal = max(this%scaled_error_goal,this%abs_error_goal)
- end if
- end if
- if (this%error_goal > 0D0) then
- this%is_goal_set = .true.
- else
- this%is_goal_set = .false.
- end if
- end if
- end subroutine aq_set_goal
-\end{Verbatim}
-! calculation
-
-\TbpImp{aq\_main\_loop}
-Die eigentliche adaptive Quadratur findet in dieser Prozedur statt.
-\begin{Verbatim}
- subroutine aq_main_loop(this)
- ! unsafe, when n_nodes < 4
- class(aq_class) :: this
- \IC{Das Blatt mit dem größten Integrationsfehler}
- class(\TypeRef{fibonacci\_leave\_type}), pointer :: rightmost
-
- class(\TypeRef{measurable\_class}), pointer :: content
- class(\TypeRef{muli\_trapezium\_type}),pointer :: new_node
- \IC{Wurde die maximale Anzahl von Blättern erreicht?}
- logical :: limit = .false.
- \IC{Die Stelle, bei der das Segment geteilt wird.}
- real(kind=double) :: center
- \IC{Der Funktionswert an dieser Stelle.}
- real(kind=double),dimension(:),allocatable::c_val
- allocate(c_val(0:this%dim_integral-1))
- loop:do
- \IC{Wir holen uns das Blatt mit den größten Integrationsfehler.}
- call this%err_tree%pop_right(rightmost)
- \IC{Wenn diese Bedingung erfüllt ist, dann ist auch der gesammte Fehler}
- \IC{kleiner als this\%error\_goal}
- if (rightmost < this%error_goal/this%n_nodes) then
- this%is_goal_reached = .true.
- exit loop
- else
- \IC{Wir holen uns das Integrationssegment aus dem Blatt.}
- call rightmost%get_content(content)
- \IC{Zugriff auf die speziellen Methoden von \TypeRef{muli\_trapezium\_type}}
- select type (content)
- class is (muli_trapezium_type)
- \IC{Fortschrittsanzeige}
- print&
- ('("nodes: ",I5," error: ",E14.7," goal: ",E14.7," node at: ",E14.7,"-",E14.7)'),&
- this%n_nodes,&
- rightmost%measure()*this%n_nodes,&
- this%error_goal,&
- content%get_l_position(),&
- content%get_r_position()
- \IC{Debugging: Wir schreiben den Forschritt in den Abbruchbedingung mit.}
- this%convergence(1,this%n_nodes)=this%error_goal/this%n_nodes
- this%convergence(2,this%n_nodes)=rightmost%measure()
- \IC{Wir wollen das Segment in der Mitte teilen.}
- center = content%get_r_position()-content%get_d_position()/2D0
- call cpu_time(this%cpu_time)
- this%cuba_time=this%cuba_time-this%cpu_time
- \IC{Wir fordern den Funktionswert in der Mitte des Segments an.}
- call this%evaluate(center,c_val)
- call cpu_time(this%cpu_time)
- this%cuba_time=this%cuba_time+this%cpu_time
- \IC{Wir teilen das Segment in zwei neue Segmente.}
- \IC{Siehe \TbpRef{muli\_trapezium\_type}{split}}
- call content%split(c_val,center,new_node)
- \IC{content ist das rechte Segment und immer noch in rightmost enthalten.}
- \IC{Wir können also das Blatt rightmost wieder in den Baum einfügen.}
- call this%err_tree%push_by_leave(rightmost)
- \IC{Fur das linke Segment new\_node muss noch ein neues Blatt erzeugt werden.}
- call this%err_tree%push_by_content(new_node)
- end select
- this%n_nodes=this%n_nodes+1
- \IC{Wenn die maximale Zahl von Blättern erreicht ist, dann müssen wir erfolglos aufhören.}
- if (this%n_nodes > this%max_nodes) then
- limit = .true.
- exit loop
- end if
- end if
- end do loop
- \IC{Ein Blatt halten wir noch in der Hand, wir legen es in den Baum zurück.}
- call this%err_tree%push_by_leave(rightmost)
- end subroutine aq_main_loop
-\end{Verbatim}
-
-\TbpImp{aq\_run}
-Wrapper für \ProcRef{aq\_main\_loop}.
-\begin{Verbatim}
- subroutine aq_run(this)
- class(aq_class) :: this
- call cpu_time(this%total_time)
- if (.not. this%is_error_tree_initialised) then
- call this%init_error_tree(this%dim_integral,this%region)
- end if
- this%is_run = .false.
- this%is_goal_reached = .false.
- call aq_main_loop(this)
- this%is_run = .true.
- call cpu_time(this%cpu_time)
- this%total_time=this%cpu_time-this%total_time
- end subroutine aq_run
-\end{Verbatim}
-
-\TbpImp{aq\_integrate}
-Die eigentliche Integration ist schon fertig, aber die Integrationssegmente sind nach Integrationsfehler sortiert. Wir wollen jetzt einen Binärbaum erzeugen, in dem die Segmente nach den x-Werten sortiert sind.
-\begin{Verbatim}
- subroutine aq_integrate(this,int_tree)
- class(aq_class) :: this
- class(\TypeRef{muli\_trapezium\_node\_class}),pointer :: node
- type(\TypeRef{muli\_trapezium\_tree\_type}),intent(out)::int_tree
- real(kind=double) :: sum
- this%is_integrated=.false.
- this%integral_error=0D0
- if (this%is_run) then
- call cpu_time(this%int_time)
- \IC{Umsortieren}
- call fibonacci_tree_resort_and_convert_to_trapezium_list&
- (this%err_tree,this%int_list)
- \IC{Die Integrale über die einzelnen Segmente aufaddieren}
- call muli_trapezium_list_integrate(this%int_list,this%integral,this%integral_error)
- \IC{Einen Baum aus der Liste machen}
- call this%int_list%to_tree(int_tree)
- this%is_integrated=.true.
- call cpu_time(this%cpu_time)
- this%int_time=this%cpu_time-this%int_time
- end if
- end subroutine aq_integrate
-\end{Verbatim}
-\MethodsNTB
-\ProcImp{fibonacci\_tree\_resort\_and\_convert\_to\_trapezium\_list}
-\begin{Verbatim}
- recursive subroutine fibonacci_tree_resort_and_convert_to_trapezium_list&
- (fib_tree,lin_list)
- \IC{usually, the tree is sorted by the sum of errors.}
- \IC{now it shall be sorted by the right position.}
- class(\TypeRef{fibonacci\_node\_type}),intent(in) :: fib_tree
- class(\TypeRef{fibonacci\_node\_type}),pointer :: leave
- class(\TypeRef{muli\_trapezium\_list\_type}),pointer,intent(out) :: lin_list
- class(\TypeRef{muli\_trapezium\_list\_type}),pointer :: left_list,right_list
- class(\TypeRef{muli\_trapezium\_node\_class}),pointer :: left_node,right_node,last_node
- class(\TypeRef{measurable\_class}),pointer :: content
- \IC{When at least one branch of the tree is itself a tree, i.e. each branch has}
- \IC{got at least two leaves, then process each branch and merge the results.}
- if (fib_tree%depth>1) then
- call fibonacci_tree_resort_and_convert_to_trapezium_list(fib_tree%left,left_list)
- call fibonacci_tree_resort_and_convert_to_trapezium_list(fib_tree%right,right_list)
- \IC{Now we got two sortet lists.}
- \IC{Which one's leftmost node has got the lowest value of "r_position"?}
- \IC{That one shall be the beginning of the merged list "lin_list".}
- if(left_list%is_left_of(right_list))then
- lin_list => left_list
- call left_list%get_right(left_node)
- right_node=>right_list
- else
- lin_list => right_list
- left_node=>left_list
- call right_list%get_right(right_node)
- end if
- last_node=>lin_list
- \IC{Everything is prepared for the algorithm: lin_list is the beginning of the}
- \IC{sorted list, last_node is it's end. left_node and right_node are the leftmost}
- \IC{nodes of the remainders of left_list and right_list. The latter will get}
- \IC{stripped from left to right, until one of them ends.}
- do while(associated(left_node).and.associated(right_node))
- if (left_node%is_left_of(right_node)) then
- call last_node%append(left_node)
- call last_node%get_right(last_node)
- call left_node%get_right(left_node)
- else
- call last_node%append(right_node)
- call last_node%get_right(last_node)
- call right_node%get_right(right_node)
- end if
- end do
- \IC{Either left_list or right_list is completely merged into lin_list. The other}
- \IC{one gets appended to lin_list.}
- if (associated(left_node)) then
- call last_node%append(left_node)
- else
- call last_node%append(right_node)
- end if
- \IC{It's done.}
- else
- \IC{The tree has got two leaves at most. Is it more than one?}
- if (fib_tree%depth == 0) then
- \IC{Here fib_tree is a single leave with an allocated "content" componet of}
- \IC{type muli_trapezium_type. If "content" is not type compatible with}
- \IC{muli_trapezium_type, then this whole conversion cannot succeed. }
- \IC{We allocate a new node of type muli_trapezium_list_type. This list does}
- \IC{not contain the content of fib_tree, it *IS* a copy of the content, for}
- \IC{muli_trapezium_list_type is an extension of muli_trapezium_type.}
- select type (fib_tree)
- class is (fibonacci_leave_type)
- call fib_tree%get_content(content)
- select type (content)
- class is (muli_trapezium_type)
- call muli_trapezium_to_node(content,content%get_r_position(),list=lin_list)
- class default
- print *,"fibonacci_tree_resort_and_convert_to_trapezium_list: &
- &Content of fibonacci_tree is not type compatible to &
- &muli_trapezium_type"
- end select
- end select
- else
- \IC{Each branch of fib_tree is a single leave. We could call this soubroutine}
- \IC{for each branch, but we do copy and paste for each branch instead.}
- leave=>fib_tree%left
- select type (leave)
- class is (fibonacci_leave_type)
- call leave%get_content(content)
- select type (content)
- class is (muli_trapezium_type)
- call muli_trapezium_to_node(content,content%get_r_position(),list=left_list)
- class default
- print *,"fibonacci_tree_resort_and_convert_to_trapezium_list: &
- &Content of fibonacci_tree is not type compatible to &
- &muli_trapezium_type"
- end select
- end select
- leave=>fib_tree%right
- select type (leave)
- class is (fibonacci_leave_type)
- call leave%get_content(content)
- select type (content)
- class is (muli_trapezium_type)
- call muli_trapezium_to_node%
- (content,content%get_r_position(),list=right_list)
- class default
- print *,"fibonacci_tree_resort_and_convert_to_trapezium_list: &
- &Content of fibonacci_tree is not type compatible to &
- &muli_trapezium_type"
- end select
- end select
- \IC{Finally we append one list to the other, the lowest value of "r_position"}
- \IC{comes first.}
- if (left_list%is_left_of(right_list)) then
- call left_list%append(right_list)
- lin_list=>left_list
- else
- call right_list%append(left_list)
- lin_list=>right_list
- end if
- end if
- end if
- end subroutine fibonacci_tree_resort_and_convert_to_trapezium_list
-\end{Verbatim}
-
Index: trunk/src/muli/doc/muli_interactions.tex
===================================================================
--- trunk/src/muli/doc/muli_interactions.tex (revision 8371)
+++ trunk/src/muli/doc/muli_interactions.tex (revision 8372)
@@ -1,1880 +0,0 @@
-\Module{muli\_interactions}
-%\begin{figure}
-% \centering{\includegraphics{uml-module-tree-12.mps}}
-% \caption{\label{fig:\ThisModule:Types}Klassendiagramm des Moduls \ThisModule}
-%\end{figure}
-\section{Abhängigkeiten}
-\use{muli\_momentum}
-\section{Parameter}
-\begin{Verbatim}
- implicit none
- !process parameters
- integer,parameter::hadron_A_kind=2212 ! Proton
- integer,parameter::hadron_B_kind=-2212 ! Anti Proton
- integer,dimension(4),parameter::parton_kind_of_int_kind=[1,1,2,2]
- real(kind=double), parameter :: b_sigma_tot_all = 100 !mb PDG
- real(kind=double), parameter :: b_sigma_tot_nd = 0.5*b_sigma_tot_all !phys.rev.d v49 n5 1994
- real(kind=double), parameter :: gev_cme_tot = 14000 !total center of mass energie
- real(kind=double), parameter :: gev2_cme_tot = gev_cme_tot**2 !s
- real(kind=double), parameter :: gev_pt_max = gev_cme_tot/2D0
- real(kind=double), parameter :: gev2_pt_max = gev2_cme_tot/4D0
- !model parameters
- real(kind=double), parameter :: gev_pt_min = 8D-1
- real(kind=double), parameter :: gev2_pt_min = gev_pt_min**2
- real(kind=double), parameter :: pts_min = gev_pt_min/gev_pt_max
- real(kind=double), parameter :: pts2_min = gev2_pt_min/gev2_pt_max
- real(kind=double), parameter :: gev_p_t_0 = 2.0
- real(kind=double), parameter :: gev2_p_t_0 = gev_p_t_0**2
- real(kind=double), parameter :: norm_p_t_0 = gev_p_t_0/gev_pt_max
- real(kind=double), parameter :: norm2_p_t_0 = gev2_p_t_0/gev2_pt_max
- !mathematical constants
- real(kind=double),private,parameter :: pi = 3.14159265
- real(kind=double),parameter :: euler = exp(1D0)
- !physical constants
- real(kind=double), parameter :: gev2_mbarn = 0.389379304D0
- real(kind=double), parameter :: const_pref=pi*gev2_mbarn/(gev2_cme_tot*b_sigma_tot_nd)
- !parton kind parameters
- integer,parameter,public::lha_flavor_at=-6
- integer,parameter,public::lha_flavor_ab=-5
- integer,parameter,public::lha_flavor_ac=-4
- integer,parameter,public::lha_flavor_as=-3
- integer,parameter,public::lha_flavor_au=-2
- integer,parameter,public::lha_flavor_ad=-1
- integer,parameter,public::lha_flavor_g=0
- integer,parameter,public::lha_flavor_d=1
- integer,parameter,public::lha_flavor_u=2
- integer,parameter,public::lha_flavor_s=3
- integer,parameter,public::lha_flavor_c=4
- integer,parameter,public::lha_flavor_b=5
- integer,parameter,public::lha_flavor_t=6
- integer,parameter,public::pdg_flavor_at=-6
- integer,parameter,public::pdg_flavor_ab=-5
- integer,parameter,public::pdg_flavor_ac=-4
- integer,parameter,public::pdg_flavor_as=-3
- integer,parameter,public::pdg_flavor_au=-2
- integer,parameter,public::pdg_flavor_ad=-1
- integer,parameter,public::pdg_flavor_g=21
- integer,parameter,public::pdg_flavor_d=1
- integer,parameter,public::pdg_flavor_u=2
- integer,parameter,public::pdg_flavor_s=3
- integer,parameter,public::pdg_flavor_c=4
- integer,parameter,public::pdg_flavor_b=5
- integer,parameter,public::pdg_flavor_t=6
- integer,parameter,public::parton_kind_sea=1
- integer,parameter,public::parton_kind_valence=2
- integer,parameter,public::parton_kind_sea_and_valence=3
- integer,parameter,public::parton_kind_twin=4
- integer,parameter,public::parton_kind_sea_and_twin=5
- integer,parameter,public::parton_kind_valence_and_twin=6
- integer,parameter,public::parton_kind_all=7
- integer,parameter,public::\MC{pdf\_int\_kind\_undef}=0
- integer,parameter,public::\MC{pdf\_int\_kind\_gluon}=1
- integer,parameter,public::\MC{pdf\_int\_kind\_sea}=2
- integer,parameter,public::\MC{pdf\_int\_kind\_val\_down}=3
- integer,parameter,public::\MC{pdf\_int\_kind\_val\_up}=4
- integer,parameter,public::\MC{pdf\_int\_kind\_twin}=5
- character(len=2),dimension(-6:6),parameter :: integer_parton_names = &
- &["-6","-5","-4","-3","-2","-1","00","+1","+2","+3","+4","+5","+6"]
- character,dimension(-6:6),parameter :: traditional_parton_names = &
- &["T","B","C","S","U","D","g","d","u","s","c","b","t"]
- !ps polynom coefficients
- ! evolution variable is pt2s/(x1*x2)
- real(kind=double),dimension(1:4,1:5),parameter :: phase_space_coefficients_in&
- = reshape(source=[&
- & 6144D0, -4608D0, +384D0, 0D0,&
- & 6144D0, -5120D0, +384D0, 0D0,&
- & 6144D0, -2048D0, +128D0, -576D0,&
- &13824D0, -9600D0, +1056D0, 0D0,&
- &31104D0,-19872D0, +2160D0, +486D0],&
- &shape=[4,5])
-
- ! evolution variable is pt2s/(x1*x2)
- real(kind=double),dimension(1:4,1:8),parameter :: phase_space_coefficients_inout&
- = reshape(source=[&
- &3072, -2304, +192, 0, &
- &6144, -5120, +384, 0, &
- &0, 0, 192, -96, &
- &3072, -2048, +192, -96, &
- &0, 2048, -2176, +576, &
- &0, 288, -306, +81, &
- &6912, -4800, +528, 0, &
- &31104,-23328, +5832, -486],&
- &shape=[4,8])
-
- integer,dimension(1:4,0:8),parameter :: inout_signatures = reshape(source=[&
- 1, 1, 1, 1,&!1a
- -1, 1,-1, 1,&!1b
- 1, 1, 1, 1,&!2
- 1,-1, 1,-1,&!3
- 1,-1, 1,-1,&!4
- 1,-1, 0, 0,&!5
- 0, 0, 1,-1,&!6
- 1, 0, 1, 0,&!7
- 0, 0, 0, 0],&
- shape=[4,9])
-
- integer,dimension(6,-234:234),parameter::\MC{valid\_processes}=reshape([&
- -6, -6, -6, -6, 2, 2,&!-234
- -6, -5, -6, -5, 1, 1,&!-233
- -6, -5, -5, -6, 1, 1,&!-232
- -6, -4, -6, -4, 1, 1,&!-231
- -6, -4, -4, -6, 1, 1,&!-230
- -6, -3, -6, -3, 1, 1,&!-229
- -6, -3, -3, -6, 1, 1,&!-228
- -6, -2, -6, -2, 1, 1,&!-227
- -6, -2, -2, -6, 1, 1,&!-226
- -6, -1, -6, -1, 1, 1,&!-225
- -6, -1, -1, -6, 1, 1,&!-224
- -6, 0, -6, 0, 4, 7,&!-223
- -6, 0, 0, -6, 4, 7,&!-222
- -6, 1, -6, 1, 1, 1,&!-221
- -6, 1, 1, -6, 1, 1,&!-220
- -6, 2, -6, 2, 1, 1,&!-219
- -6, 2, 2, -6, 1, 1,&!-218
- -6, 3, -6, 3, 1, 1,&!-217
- -6, 3, 3, -6, 1, 1,&!-216
- -6, 4, -6, 4, 1, 1,&!-215
- -6, 4, 4, -6, 1, 1,&!-214
- -6, 5, -6, 5, 1, 1,&!-213
- -6, 5, 5, -6, 1, 1,&!-212
- -6, 6, -6, 6, 3, 4,&!-211
- -6, 6, -5, 5, 3, 3,&!-210
- -6, 6, -4, 4, 3, 3,&!-209
- -6, 6, -3, 3, 3, 3,&!-208
- -6, 6, -2, 2, 3, 3,&!-207
- -6, 6, -1, 1, 3, 3,&!-206
- -6, 6, 0, 0, 3, 5,&!-205
- -6, 6, 1, -1, 3, 3,&!-204
- -6, 6, 2, -2, 3, 3,&!-203
- -6, 6, 3, -3, 3, 3,&!-202
- -6, 6, 4, -4, 3, 3,&!-201
- -6, 6, 5, -5, 3, 3,&!-200
- -6, 6, 6, -6, 3, 4,&!-199
- -5, -6, -6, -5, 1, 1,&!-198
- -5, -6, -5, -6, 1, 1,&!-197
- -5, -5, -5, -5, 2, 2,&!-196
- -5, -4, -5, -4, 1, 1,&!-195
- -5, -4, -4, -5, 1, 1,&!-194
- -5, -3, -5, -3, 1, 1,&!-193
- -5, -3, -3, -5, 1, 1,&!-192
- -5, -2, -5, -2, 1, 1,&!-191
- -5, -2, -2, -5, 1, 1,&!-190
- -5, -1, -5, -1, 1, 1,&!-189
- -5, -1, -1, -5, 1, 1,&!-188
- -5, 0, -5, 0, 4, 7,&!-187
- -5, 0, 0, -5, 4, 7,&!-186
- -5, 1, -5, 1, 1, 1,&!-185
- -5, 1, 1, -5, 1, 1,&!-184
- -5, 2, -5, 2, 1, 1,&!-183
- -5, 2, 2, -5, 1, 1,&!-182
- -5, 3, -5, 3, 1, 1,&!-181
- -5, 3, 3, -5, 1, 1,&!-180
- -5, 4, -5, 4, 1, 1,&!-179
- -5, 4, 4, -5, 1, 1,&!-178
- -5, 5, -6, 6, 3, 3,&!-177
- -5, 5, -5, 5, 3, 4,&!-176
- -5, 5, -4, 4, 3, 3,&!-175
- -5, 5, -3, 3, 3, 3,&!-174
- -5, 5, -2, 2, 3, 3,&!-173
- -5, 5, -1, 1, 3, 3,&!-172
- -5, 5, 0, 0, 3, 5,&!-171
- -5, 5, 1, -1, 3, 3,&!-170
- -5, 5, 2, -2, 3, 3,&!-169
- -5, 5, 3, -3, 3, 3,&!-168
- -5, 5, 4, -4, 3, 3,&!-167
- -5, 5, 5, -5, 3, 4,&!-166
- -5, 5, 6, -6, 3, 3,&!-165
- -5, 6, -5, 6, 1, 1,&!-164
- -5, 6, 6, -5, 1, 1,&!-163
- -4, -6, -6, -4, 1, 1,&!-162
- -4, -6, -4, -6, 1, 1,&!-161
- -4, -5, -5, -4, 1, 1,&!-160
- -4, -5, -4, -5, 1, 1,&!-159
- -4, -4, -4, -4, 2, 2,&!-158
- -4, -3, -4, -3, 1, 1,&!-157
- -4, -3, -3, -4, 1, 1,&!-156
- -4, -2, -4, -2, 1, 1,&!-155
- -4, -2, -2, -4, 1, 1,&!-154
- -4, -1, -4, -1, 1, 1,&!-153
- -4, -1, -1, -4, 1, 1,&!-152
- -4, 0, -4, 0, 4, 7,&!-151
- -4, 0, 0, -4, 4, 7,&!-150
- -4, 1, -4, 1, 1, 1,&!-149
- -4, 1, 1, -4, 1, 1,&!-148
- -4, 2, -4, 2, 1, 1,&!-147
- -4, 2, 2, -4, 1, 1,&!-146
- -4, 3, -4, 3, 1, 1,&!-145
- -4, 3, 3, -4, 1, 1,&!-144
- -4, 4, -6, 6, 3, 3,&!-143
- -4, 4, -5, 5, 3, 3,&!-142
- -4, 4, -4, 4, 3, 4,&!-141
- -4, 4, -3, 3, 3, 3,&!-140
- -4, 4, -2, 2, 3, 3,&!-139
- -4, 4, -1, 1, 3, 3,&!-138
- -4, 4, 0, 0, 3, 5,&!-137
- -4, 4, 1, -1, 3, 3,&!-136
- -4, 4, 2, -2, 3, 3,&!-135
- -4, 4, 3, -3, 3, 3,&!-134
- -4, 4, 4, -4, 3, 4,&!-133
- -4, 4, 5, -5, 3, 3,&!-132
- -4, 4, 6, -6, 3, 3,&!-131
- -4, 5, -4, 5, 1, 1,&!-130
- -4, 5, 5, -4, 1, 1,&!-129
- -4, 6, -4, 6, 1, 1,&!-128
- -4, 6, 6, -4, 1, 1,&!-127
- -3, -6, -6, -3, 1, 1,&!-126
- -3, -6, -3, -6, 1, 1,&!-125
- -3, -5, -5, -3, 1, 1,&!-124
- -3, -5, -3, -5, 1, 1,&!-123
- -3, -4, -4, -3, 1, 1,&!-122
- -3, -4, -3, -4, 1, 1,&!-121
- -3, -3, -3, -3, 2, 2,&!-120
- -3, -2, -3, -2, 1, 1,&!-119
- -3, -2, -2, -3, 1, 1,&!-118
- -3, -1, -3, -1, 1, 1,&!-117
- -3, -1, -1, -3, 1, 1,&!-116
- -3, 0, -3, 0, 4, 7,&!-115
- -3, 0, 0, -3, 4, 7,&!-114
- -3, 1, -3, 1, 1, 1,&!-113
- -3, 1, 1, -3, 1, 1,&!-112
- -3, 2, -3, 2, 1, 1,&!-111
- -3, 2, 2, -3, 1, 1,&!-110
- -3, 3, -6, 6, 3, 3,&!-109
- -3, 3, -5, 5, 3, 3,&!-108
- -3, 3, -4, 4, 3, 3,&!-107
- -3, 3, -3, 3, 3, 4,&!-106
- -3, 3, -2, 2, 3, 3,&!-105
- -3, 3, -1, 1, 3, 3,&!-104
- -3, 3, 0, 0, 3, 5,&!-103
- -3, 3, 1, -1, 3, 3,&!-102
- -3, 3, 2, -2, 3, 3,&!-101
- -3, 3, 3, -3, 3, 4,&!-100
- -3, 3, 4, -4, 3, 3,&! -99
- -3, 3, 5, -5, 3, 3,&! -98
- -3, 3, 6, -6, 3, 3,&! -97
- -3, 4, -3, 4, 1, 1,&! -96
- -3, 4, 4, -3, 1, 1,&! -95
- -3, 5, -3, 5, 1, 1,&! -94
- -3, 5, 5, -3, 1, 1,&! -93
- -3, 6, -3, 6, 1, 1,&! -92
- -3, 6, 6, -3, 1, 1,&! -91
- -2, -6, -6, -2, 1, 1,&! -90
- -2, -6, -2, -6, 1, 1,&! -89
- -2, -5, -5, -2, 1, 1,&! -88
- -2, -5, -2, -5, 1, 1,&! -87
- -2, -4, -4, -2, 1, 1,&! -86
- -2, -4, -2, -4, 1, 1,&! -85
- -2, -3, -3, -2, 1, 1,&! -84
- -2, -3, -2, -3, 1, 1,&! -83
- -2, -2, -2, -2, 2, 2,&! -82
- -2, -1, -2, -1, 1, 1,&! -81
- -2, -1, -1, -2, 1, 1,&! -80
- -2, 0, -2, 0, 4, 7,&! -79
- -2, 0, 0, -2, 4, 7,&! -78
- -2, 1, -2, 1, 1, 1,&! -77
- -2, 1, 1, -2, 1, 1,&! -76
- -2, 2, -6, 6, 3, 3,&! -75
- -2, 2, -5, 5, 3, 3,&! -74
- -2, 2, -4, 4, 3, 3,&! -73
- -2, 2, -3, 3, 3, 3,&! -72
- -2, 2, -2, 2, 3, 4,&! -71
- -2, 2, -1, 1, 3, 3,&! -70
- -2, 2, 0, 0, 3, 5,&! -69
- -2, 2, 1, -1, 3, 3,&! -68
- -2, 2, 2, -2, 3, 4,&! -67
- -2, 2, 3, -3, 3, 3,&! -66
- -2, 2, 4, -4, 3, 3,&! -65
- -2, 2, 5, -5, 3, 3,&! -64
- -2, 2, 6, -6, 3, 3,&! -63
- -2, 3, -2, 3, 1, 1,&! -62
- -2, 3, 3, -2, 1, 1,&! -61
- -2, 4, -2, 4, 1, 1,&! -60
- -2, 4, 4, -2, 1, 1,&! -59
- -2, 5, -2, 5, 1, 1,&! -58
- -2, 5, 5, -2, 1, 1,&! -57
- -2, 6, -2, 6, 1, 1,&! -56
- -2, 6, 6, -2, 1, 1,&! -55
- -1, -6, -6, -1, 1, 1,&! -54
- -1, -6, -1, -6, 1, 1,&! -53
- -1, -5, -5, -1, 1, 1,&! -52
- -1, -5, -1, -5, 1, 1,&! -51
- -1, -4, -4, -1, 1, 1,&! -50
- -1, -4, -1, -4, 1, 1,&! -49
- -1, -3, -3, -1, 1, 1,&! -48
- -1, -3, -1, -3, 1, 1,&! -47
- -1, -2, -2, -1, 1, 1,&! -46
- -1, -2, -1, -2, 1, 1,&! -45
- -1, -1, -1, -1, 2, 2,&! -44
- -1, 0, -1, 0, 4, 7,&! -43
- -1, 0, 0, -1, 4, 7,&! -42
- -1, 1, -6, 6, 3, 3,&! -41
- -1, 1, -5, 5, 3, 3,&! -40
- -1, 1, -4, 4, 3, 3,&! -39
- -1, 1, -3, 3, 3, 3,&! -38
- -1, 1, -2, 2, 3, 3,&! -37
- -1, 1, -1, 1, 3, 4,&! -36
- -1, 1, 0, 0, 3, 5,&! -35
- -1, 1, 1, -1, 3, 4,&! -34
- -1, 1, 2, -2, 3, 3,&! -33
- -1, 1, 3, -3, 3, 3,&! -32
- -1, 1, 4, -4, 3, 3,&! -31
- -1, 1, 5, -5, 3, 3,&! -30
- -1, 1, 6, -6, 3, 3,&! -29
- -1, 2, -1, 2, 1, 1,&! -28
- -1, 2, 2, -1, 1, 1,&! -27
- -1, 3, -1, 3, 1, 1,&! -26
- -1, 3, 3, -1, 1, 1,&! -25
- -1, 4, -1, 4, 1, 1,&! -24
- -1, 4, 4, -1, 1, 1,&! -23
- -1, 5, -1, 5, 1, 1,&! -22
- -1, 5, 5, -1, 1, 1,&! -21
- -1, 6, -1, 6, 1, 1,&! -20
- -1, 6, 6, -1, 1, 1,&! -19
- 0, -6, -6, 0, 4, 7,&! -18
- 0, -6, 0, -6, 4, 7,&! -17
- 0, -5, -5, 0, 4, 7,&! -16
- 0, -5, 0, -5, 4, 7,&! -15
- 0, -4, -4, 0, 4, 7,&! -14
- 0, -4, 0, -4, 4, 7,&! -13
- 0, -3, -3, 0, 4, 7,&! -12
- 0, -3, 0, -3, 4, 7,&! -11
- 0, -2, -2, 0, 4, 7,&! -10
- 0, -2, 0, -2, 4, 7,&! -9
- 0, -1, -1, 0, 4, 7,&! -8
- 0, -1, 0, -1, 4, 7,&! -7
- 0, 0, -6, 6, 5, 6,&! -6
- 0, 0, -5, 5, 5, 6,&! -5
- 0, 0, -4, 4, 5, 6,&! -4
- 0, 0, -3, 3, 5, 6,&! -3
- 0, 0, -2, 2, 5, 6,&! -2
- 0, 0, -1, 1, 5, 6,&! -1
- 0, 0, 0, 0, 5, 8,&! 0
- 0, 0, 1, -1, 5, 6,&! 1
- 0, 0, 2, -2, 5, 6,&! 2
- 0, 0, 3, -3, 5, 6,&! 3
- 0, 0, 4, -4, 5, 6,&! 4
- 0, 0, 5, -5, 5, 6,&! 5
- 0, 0, 6, -6, 5, 6,&! 6
- 0, 1, 0, 1, 4, 7,&! 7
- 0, 1, 1, 0, 4, 7,&! 8
- 0, 2, 0, 2, 4, 7,&! 9
- 0, 2, 2, 0, 4, 7,&! 10
- 0, 3, 0, 3, 4, 7,&! 11
- 0, 3, 3, 0, 4, 7,&! 12
- 0, 4, 0, 4, 4, 7,&! 13
- 0, 4, 4, 0, 4, 7,&! 14
- 0, 5, 0, 5, 4, 7,&! 15
- 0, 5, 5, 0, 4, 7,&! 16
- 0, 6, 0, 6, 4, 7,&! 17
- 0, 6, 6, 0, 4, 7,&! 18
- 1, -6, -6, 1, 1, 1,&! 19
- 1, -6, 1, -6, 1, 1,&! 20
- 1, -5, -5, 1, 1, 1,&! 21
- 1, -5, 1, -5, 1, 1,&! 22
- 1, -4, -4, 1, 1, 1,&! 23
- 1, -4, 1, -4, 1, 1,&! 24
- 1, -3, -3, 1, 1, 1,&! 25
- 1, -3, 1, -3, 1, 1,&! 26
- 1, -2, -2, 1, 1, 1,&! 27
- 1, -2, 1, -2, 1, 1,&! 28
- 1, -1, -6, 6, 3, 3,&! 29
- 1, -1, -5, 5, 3, 3,&! 30
- 1, -1, -4, 4, 3, 3,&! 31
- 1, -1, -3, 3, 3, 3,&! 32
- 1, -1, -2, 2, 3, 3,&! 33
- 1, -1, -1, 1, 3, 4,&! 34
- 1, -1, 0, 0, 3, 5,&! 35
- 1, -1, 1, -1, 3, 4,&! 36
- 1, -1, 2, -2, 3, 3,&! 37
- 1, -1, 3, -3, 3, 3,&! 38
- 1, -1, 4, -4, 3, 3,&! 39
- 1, -1, 5, -5, 3, 3,&! 40
- 1, -1, 6, -6, 3, 3,&! 41
- 1, 0, 0, 1, 4, 7,&! 42
- 1, 0, 1, 0, 4, 7,&! 43
- 1, 1, 1, 1, 2, 2,&! 44
- 1, 2, 1, 2, 1, 1,&! 45
- 1, 2, 2, 1, 1, 1,&! 46
- 1, 3, 1, 3, 1, 1,&! 47
- 1, 3, 3, 1, 1, 1,&! 48
- 1, 4, 1, 4, 1, 1,&! 49
- 1, 4, 4, 1, 1, 1,&! 50
- 1, 5, 1, 5, 1, 1,&! 51
- 1, 5, 5, 1, 1, 1,&! 52
- 1, 6, 1, 6, 1, 1,&! 53
- 1, 6, 6, 1, 1, 1,&! 54
- 2, -6, -6, 2, 1, 1,&! 55
- 2, -6, 2, -6, 1, 1,&! 56
- 2, -5, -5, 2, 1, 1,&! 57
- 2, -5, 2, -5, 1, 1,&! 58
- 2, -4, -4, 2, 1, 1,&! 59
- 2, -4, 2, -4, 1, 1,&! 60
- 2, -3, -3, 2, 1, 1,&! 61
- 2, -3, 2, -3, 1, 1,&! 62
- 2, -2, -6, 6, 3, 3,&! 63
- 2, -2, -5, 5, 3, 3,&! 64
- 2, -2, -4, 4, 3, 3,&! 65
- 2, -2, -3, 3, 3, 3,&! 66
- 2, -2, -2, 2, 3, 4,&! 67
- 2, -2, -1, 1, 3, 3,&! 68
- 2, -2, 0, 0, 3, 5,&! 69
- 2, -2, 1, -1, 3, 3,&! 70
- 2, -2, 2, -2, 3, 4,&! 71
- 2, -2, 3, -3, 3, 3,&! 72
- 2, -2, 4, -4, 3, 3,&! 73
- 2, -2, 5, -5, 3, 3,&! 74
- 2, -2, 6, -6, 3, 3,&! 75
- 2, -1, -1, 2, 1, 1,&! 76
- 2, -1, 2, -1, 1, 1,&! 77
- 2, 0, 0, 2, 4, 7,&! 78
- 2, 0, 2, 0, 4, 7,&! 79
- 2, 1, 1, 2, 1, 1,&! 80
- 2, 1, 2, 1, 1, 1,&! 81
- 2, 2, 2, 2, 2, 2,&! 82
- 2, 3, 2, 3, 1, 1,&! 83
- 2, 3, 3, 2, 1, 1,&! 84
- 2, 4, 2, 4, 1, 1,&! 85
- 2, 4, 4, 2, 1, 1,&! 86
- 2, 5, 2, 5, 1, 1,&! 87
- 2, 5, 5, 2, 1, 1,&! 88
- 2, 6, 2, 6, 1, 1,&! 89
- 2, 6, 6, 2, 1, 1,&! 90
- 3, -6, -6, 3, 1, 1,&! 91
- 3, -6, 3, -6, 1, 1,&! 92
- 3, -5, -5, 3, 1, 1,&! 93
- 3, -5, 3, -5, 1, 1,&! 94
- 3, -4, -4, 3, 1, 1,&! 95
- 3, -4, 3, -4, 1, 1,&! 96
- 3, -3, -6, 6, 3, 3,&! 97
- 3, -3, -5, 5, 3, 3,&! 98
- 3, -3, -4, 4, 3, 3,&! 99
- 3, -3, -3, 3, 3, 4,&! 100
- 3, -3, -2, 2, 3, 3,&! 101
- 3, -3, -1, 1, 3, 3,&! 102
- 3, -3, 0, 0, 3, 5,&! 103
- 3, -3, 1, -1, 3, 3,&! 104
- 3, -3, 2, -2, 3, 3,&! 105
- 3, -3, 3, -3, 3, 4,&! 106
- 3, -3, 4, -4, 3, 3,&! 107
- 3, -3, 5, -5, 3, 3,&! 108
- 3, -3, 6, -6, 3, 3,&! 109
- 3, -2, -2, 3, 1, 1,&! 110
- 3, -2, 3, -2, 1, 1,&! 111
- 3, -1, -1, 3, 1, 1,&! 112
- 3, -1, 3, -1, 1, 1,&! 113
- 3, 0, 0, 3, 4, 7,&! 114
- 3, 0, 3, 0, 4, 7,&! 115
- 3, 1, 1, 3, 1, 1,&! 116
- 3, 1, 3, 1, 1, 1,&! 117
- 3, 2, 2, 3, 1, 1,&! 118
- 3, 2, 3, 2, 1, 1,&! 119
- 3, 3, 3, 3, 2, 2,&! 120
- 3, 4, 3, 4, 1, 1,&! 121
- 3, 4, 4, 3, 1, 1,&! 122
- 3, 5, 3, 5, 1, 1,&! 123
- 3, 5, 5, 3, 1, 1,&! 124
- 3, 6, 3, 6, 1, 1,&! 125
- 3, 6, 6, 3, 1, 1,&! 126
- 4, -6, -6, 4, 1, 1,&! 127
- 4, -6, 4, -6, 1, 1,&! 128
- 4, -5, -5, 4, 1, 1,&! 129
- 4, -5, 4, -5, 1, 1,&! 130
- 4, -4, -6, 6, 3, 3,&! 131
- 4, -4, -5, 5, 3, 3,&! 132
- 4, -4, -4, 4, 3, 4,&! 133
- 4, -4, -3, 3, 3, 3,&! 134
- 4, -4, -2, 2, 3, 3,&! 135
- 4, -4, -1, 1, 3, 3,&! 136
- 4, -4, 0, 0, 3, 5,&! 137
- 4, -4, 1, -1, 3, 3,&! 138
- 4, -4, 2, -2, 3, 3,&! 139
- 4, -4, 3, -3, 3, 3,&! 140
- 4, -4, 4, -4, 3, 4,&! 141
- 4, -4, 5, -5, 3, 3,&! 142
- 4, -4, 6, -6, 3, 3,&! 143
- 4, -3, -3, 4, 1, 1,&! 144
- 4, -3, 4, -3, 1, 1,&! 145
- 4, -2, -2, 4, 1, 1,&! 146
- 4, -2, 4, -2, 1, 1,&! 147
- 4, -1, -1, 4, 1, 1,&! 148
- 4, -1, 4, -1, 1, 1,&! 149
- 4, 0, 0, 4, 4, 7,&! 150
- 4, 0, 4, 0, 4, 7,&! 151
- 4, 1, 1, 4, 1, 1,&! 152
- 4, 1, 4, 1, 1, 1,&! 153
- 4, 2, 2, 4, 1, 1,&! 154
- 4, 2, 4, 2, 1, 1,&! 155
- 4, 3, 3, 4, 1, 1,&! 156
- 4, 3, 4, 3, 1, 1,&! 157
- 4, 4, 4, 4, 2, 2,&! 158
- 4, 5, 4, 5, 1, 1,&! 159
- 4, 5, 5, 4, 1, 1,&! 160
- 4, 6, 4, 6, 1, 1,&! 161
- 4, 6, 6, 4, 1, 1,&! 162
- 5, -6, -6, 5, 1, 1,&! 163
- 5, -6, 5, -6, 1, 1,&! 164
- 5, -5, -6, 6, 3, 3,&! 165
- 5, -5, -5, 5, 3, 4,&! 166
- 5, -5, -4, 4, 3, 3,&! 167
- 5, -5, -3, 3, 3, 3,&! 168
- 5, -5, -2, 2, 3, 3,&! 169
- 5, -5, -1, 1, 3, 3,&! 170
- 5, -5, 0, 0, 3, 5,&! 171
- 5, -5, 1, -1, 3, 3,&! 172
- 5, -5, 2, -2, 3, 3,&! 173
- 5, -5, 3, -3, 3, 3,&! 174
- 5, -5, 4, -4, 3, 3,&! 175
- 5, -5, 5, -5, 3, 4,&! 176
- 5, -5, 6, -6, 3, 3,&! 177
- 5, -4, -4, 5, 1, 1,&! 178
- 5, -4, 5, -4, 1, 1,&! 179
- 5, -3, -3, 5, 1, 1,&! 180
- 5, -3, 5, -3, 1, 1,&! 181
- 5, -2, -2, 5, 1, 1,&! 182
- 5, -2, 5, -2, 1, 1,&! 183
- 5, -1, -1, 5, 1, 1,&! 184
- 5, -1, 5, -1, 1, 1,&! 185
- 5, 0, 0, 5, 4, 7,&! 186
- 5, 0, 5, 0, 4, 7,&! 187
- 5, 1, 1, 5, 1, 1,&! 188
- 5, 1, 5, 1, 1, 1,&! 189
- 5, 2, 2, 5, 1, 1,&! 190
- 5, 2, 5, 2, 1, 1,&! 191
- 5, 3, 3, 5, 1, 1,&! 192
- 5, 3, 5, 3, 1, 1,&! 193
- 5, 4, 4, 5, 1, 1,&! 194
- 5, 4, 5, 4, 1, 1,&! 195
- 5, 5, 5, 5, 2, 2,&! 196
- 5, 6, 5, 6, 1, 1,&! 197
- 5, 6, 6, 5, 1, 1,&! 198
- 6, -6, -6, 6, 3, 4,&! 199
- 6, -6, -5, 5, 3, 3,&! 200
- 6, -6, -4, 4, 3, 3,&! 201
- 6, -6, -3, 3, 3, 3,&! 202
- 6, -6, -2, 2, 3, 3,&! 203
- 6, -6, -1, 1, 3, 3,&! 204
- 6, -6, 0, 0, 3, 5,&! 205
- 6, -6, 1, -1, 3, 3,&! 206
- 6, -6, 2, -2, 3, 3,&! 207
- 6, -6, 3, -3, 3, 3,&! 208
- 6, -6, 4, -4, 3, 3,&! 209
- 6, -6, 5, -5, 3, 3,&! 210
- 6, -6, 6, -6, 3, 4,&! 211
- 6, -5, -5, 6, 1, 1,&! 212
- 6, -5, 6, -5, 1, 1,&! 213
- 6, -4, -4, 6, 1, 1,&! 214
- 6, -4, 6, -4, 1, 1,&! 215
- 6, -3, -3, 6, 1, 1,&! 216
- 6, -3, 6, -3, 1, 1,&! 217
- 6, -2, -2, 6, 1, 1,&! 218
- 6, -2, 6, -2, 1, 1,&! 219
- 6, -1, -1, 6, 1, 1,&! 220
- 6, -1, 6, -1, 1, 1,&! 221
- 6, 0, 0, 6, 4, 7,&! 222
- 6, 0, 6, 0, 4, 7,&! 223
- 6, 1, 1, 6, 1, 1,&! 224
- 6, 1, 6, 1, 1, 1,&! 225
- 6, 2, 2, 6, 1, 1,&! 226
- 6, 2, 6, 2, 1, 1,&! 227
- 6, 3, 3, 6, 1, 1,&! 228
- 6, 3, 6, 3, 1, 1,&! 229
- 6, 4, 4, 6, 1, 1,&! 230
- 6, 4, 6, 4, 1, 1,&! 231
- 6, 5, 5, 6, 1, 1,&! 232
- 6, 5, 6, 5, 1, 1,&! 233
- 6, 6, 6, 6, 2, 2&! 234
-],[6,469])
-
-
- integer,dimension(2,0:16),parameter::\MC{double\_pdf\_kinds}=reshape([&
- &0,0,&
- &1,1,&
- &1,2,&
- &1,3,&
- &1,4,&
- &2,1,&
- &2,2,&
- &2,3,&
- &2,4,&
- &3,1,&
- &3,2,&
- &3,3,&
- &3,4,&
- &4,1,&
- &4,2,&
- &4,3,&
- &4,4&
- &],[2,17])
- integer,parameter,dimension(371)::int_all=[&
- & -6, -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5, 6, -14, -13, -12, -11, -10,&
- & -9, -8, -7, 7, 8, 9, 10, 11, 12, 13, 14, 7, 8, 9, 10, -151, -150, -115,&
- &-114, -79, -78, -43, -42, 42, 43, 78, 79, 114, 115, 150, 151, -158, -157, -156, -155, -154,&
- &-153, -152, -149, -148, -147, -146, -145, -144, -143, -142, -141, -140, -139, -138, -137, -136, -135, -134,&
- &-133, -132, -131, -122, -121, -120, -119, -118, -117, -116, -113, -112, -111, -110, -109, -108, -107, -106,&
- &-105, -104, -103, -102, -101, -100, -99, -98, -97, -96, -95, -86, -85, -84, -83, -82, -81, -80,&
- & -77, -76, -75, -74, -73, -72, -71, -70, -69, -68, -67, -66, -65, -64, -63, -62, -61, -60,&
- & -59, -50, -49, -48, -47, -46, -45, -44, -41, -40, -39, -38, -37, -36, -35, -34, -33, -32,&
- & -31, -30, -29, -28, -27, -26, -25, -24, -23, 23, 24, 25, 26, 27, 28, 29, 30, 31,&
- & 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 44, 45, 46, 47, 48, 49, 50, 59,&
- & 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77,&
- & 80, 81, 82, 83, 84, 85, 86, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105,&
- & 106, 107, 108, 109, 110, 111, 112, 113, 116, 117, 118, 119, 120, 121, 122, 131, 132, 133,&
- & 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 152, 153,&
- & 154, 155, 156, 157, 158, -149, -148, -113, -112, -77, -76, -41, -40, -39, -38, -37, -36, -35,&
- & -34, -33, -32, -31, -30, -29, 44, 80, 81, 116, 117, 152, 153, -147, -146, -111, -110, -75,&
- & -74, -73, -72, -71, -70, -69, -68, -67, -66, -65, -64, -63, -28, -27, 45, 46, 82, 118,&
- & 119, 154, 155, 42, 43, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35,&
- & 36, 37, 38, 39, 40, 41, 44, 45, 46, 47, 48, 49, 50, 44, 45, 46, 78, 79,&
- & 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76,&
- & 77, 80, 81, 82, 83, 84, 85, 86, 80, 81, 82]
-
- integer,parameter,dimension(16)::int_sizes_all=[13,16,2,2,16,208,26,26,2,26,1,2,2,26,2,1]
-
- integer,parameter,dimension(3,0:8)::muli_flow_stats=&
- reshape([&
- 1, 2,4,&
- 3, 4,4,&
- 5, 6,8,&
- 7, 8,4,&
- 9,10,8,&
- 11,16,16,&
- 17,22,16,&
- 23,28,16,&
- 29,52,96],&
- [3,9])
-
- integer,parameter,dimension(0:4,52)::muli_flows=&
- reshape([&
- 3,0,0,1,2,&!1a
- 1,0,0,2,1,&
- 1,2,0,0,3,&!1b
- 3,3,0,0,2,&
- 4,0,0,1,2,&!2
- 4,0,0,2,1,&
- 3,2,0,0,3,&!3
- 1,3,0,0,2,&
- 4,2,0,0,3,&!4
- 4,3,0,0,2,&
- 4,0,1,3,4,&!5
- 4,0,1,4,3,&
- 2,0,3,1,4,&
- 2,0,4,1,3,&
- 2,0,3,4,1,&
- 2,0,4,3,1,&
- 4,1,2,4,0,&!6
- 2,1,4,2,0,&
- 4,2,1,4,0,&
- 2,4,1,2,0,&
- 2,2,4,1,0,&
- 2,4,2,1,0,&
- 2,0,1,2,4,&!7
- 2,0,1,4,2,&
- 4,0,2,1,4,&
- 4,0,4,1,2,&
- 2,0,2,4,1,&
- 2,0,4,2,1,&
- 9,1,2,3,4,&!8
- 5,1,2,4,3,&
- 5,1,3,2,4,&
- 3,1,4,2,3,&
- 3,1,3,4,2,&
- 5,1,4,3,2,&
- 5,2,1,3,4,&
- 5,2,1,4,3,&
- 3,3,1,2,4,&
- 3,4,1,2,3,&
- 3,3,1,4,2,&
- 3,4,1,3,2,&
- 3,2,3,1,4,&
- 3,2,4,1,3,&
- 5,3,2,1,4,&
- 3,4,2,1,3,&
- 5,3,4,1,2,&
- 3,4,3,1,2,&
- 3,2,3,4,1,&
- 3,2,4,3,1,&
- 3,3,2,4,1,&
- 5,4,2,3,1,&
- 3,3,4,2,1,&
- 5,4,3,2,1],&
- [5,52])
-\end{Verbatim}
-\section{Interfaces}
-\begin{Verbatim}
- abstract interface
- function trafo_in(in)
- use kinds!NODEP!
- real(kind=double),dimension(3)::trafo_in
- real(kind=double),dimension(3),intent(in)::in
- end function trafo_in
- end interface
- abstract interface
- pure function coord_scalar_in(hyp)
- use kinds!NODEP!
- real(kind=double)::coord_scalar_in
- real(kind=double),dimension(3),intent(in)::hyp
- end function coord_scalar_in
- end interface
- abstract interface
- subroutine coord_hcd_in(hyp,cart,denom)
- use kinds!NODEP!
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(3),intent(out)::cart
- real(kind=double),intent(out)::denom
- end subroutine coord_hcd_in
- end interface
- interface
- pure function alphaspdf(Q)
- use kinds!NODEP!
- real(kind=double)::alphaspdf
- real(kind=double),intent(in)::Q
- end function alphaspdf
- end interface
- interface
- pure subroutine evolvepdf(x,q,f)
- use kinds!NODEP!
- real(kind=double),intent(in)::x,q
- real(kind=double),intent(out),dimension(-6:6)::f
- end subroutine evolvepdf
- end interface
- real(kind=double)::pts2_scale
-\end{Verbatim}
-\Methods
-\ProcImp{muli\_get\_state\_transformations(inout\_kind,lha\_flavors) result}
-\begin{Verbatim}
- pure function muli_get_state_transformations(inout_kind,lha_flavors) result(transformations)
- integer,intent(in)::inout_kind
- integer,dimension(4),intent(in)::lha_flavors
- integer,dimension(4)::signature
- logical,dimension(3)::transformations
- where(lha_flavors>0)
- signature=1
- elsewhere(lha_flavors<0)
- signature=-1
- elsewhere
- signature=0
- end where
- !print *,"inout_kind=",inout_kind
- !print *,"lha_flavors=",lha_flavors
- !print *,"signature",signature
- if(&
- (sum(inout_signatures(1:2,inout_kind))==sum(signature(1:2))).and.&
- (sum(inout_signatures(3:4,inout_kind))==sum(signature(3:4)))&
- )then
- transformations(1)=.false.
- else
- transformations(1)=.true.
- signature=-signature
- end if
- if(all(inout_signatures(1:2,inout_kind)==signature(1:2)))then
- transformations(2)=.false.
- else
- transformations(2)=.true.
- end if
- if(all(inout_signatures(3:4,inout_kind)==signature(3:4)))then
- transformations(3)=.false.
- else
- transformations(3)=.true.
- end if
- !print *,"signature",signature
- !print *,"transformations=",transformations
- end function muli_get_state_transformations
-\end{Verbatim}
-
-\ProcImp{id}
-\begin{Verbatim}
- pure function id(a)
- real(kind=double),dimension(:),intent(in)::a
- real(kind=double),dimension(size(a))::id
- id=a
- end function id
-\end{Verbatim}
-
-\ProcImp{h\_to\_c\_ort}
-\begin{Verbatim}
- pure function h_to_c_ort(hyp)
- real(kind=double),dimension(3)::h_to_c_ort
- real(kind=double),dimension(3),intent(in)::hyp
- h_to_c_ort=&
- &[sqrt(sqrt(((hyp(1)*(1D0-hyp(3)))+hyp(3))**2+(hyp(2)-(5D-1))**2)&
- -(hyp(2)-(5D-1)))&
- &,sqrt(sqrt(((hyp(1)*(1D0-hyp(3)))+hyp(3))**2+(hyp(2)-(5D-1))**2)&
- +(hyp(2)-(5D-1)))&
- &,hyp(3)]
- end function h_to_c_ort
-\end{Verbatim}
-
-\ProcImp{c\_to\_h\_ort}
-\begin{Verbatim}
- pure function c_to_h_ort(cart)
- real(kind=double),dimension(3)::c_to_h_ort
- real(kind=double),dimension(3),intent(in)::cart
- c_to_h_ort=[(cart(3)-(cart(1)*cart(2)))/(cart(3)-1D0),&
- (1D0 - cart(1)**2 + cart(2)**2)/2D0,cart(3)]
- end function c_to_h_ort
-\end{Verbatim}
-
-\ProcImp{h\_to\_c\_noparam}
-\begin{Verbatim}
- pure function h_to_c_noparam(hyp)
- real(kind=double),dimension(2)::h_to_c_noparam
- real(kind=double),dimension(2),intent(in)::hyp
- h_to_c_noparam=&
- &[sqrt(sqrt(hyp(1)**8+(((hyp(2)-(5D-1))**3)*4)**2)-((hyp(2)-(5D-1))**3)*4)&
- &,sqrt(sqrt(hyp(1)**8+(((hyp(2)-(5D-1))**3)*4)**2)+((hyp(2)-(5D-1))**3)*4)]
- end function h_to_c_noparam
-\end{Verbatim}
-
-\ProcImp{c\_to\_h\_noparam}
-\begin{Verbatim}
- pure function c_to_h_noparam(cart)
- real(kind=double),dimension(2)::c_to_h_noparam
- real(kind=double),dimension(2),intent(in)::cart
- c_to_h_noparam=&
- &[sqrt(sqrt(cart(1)*cart(2)))&
- &,(1D0+sign(abs((cart(2)**2) - (cart(1)**2))**(1/3D0),cart(2)-cart(1)))/2D0]
- end function c_to_h_noparam
-\end{Verbatim}
-
-\ProcImp{h\_to\_c\_param}
-\begin{Verbatim}
- pure function h_to_c_param(hyp)
- real(kind=double),dimension(3)::h_to_c_param
- real(kind=double),dimension(3),intent(in)::hyp
- h_to_c_param=&
- &[sqrt(sqrt((((hyp(1)**4)*(1D0-hyp(3)))+hyp(3))**2+(((hyp(2)-(5D-1))**3)*4)**2)&
- -((hyp(2)-(5D-1))**3)*4)&
- &,sqrt(sqrt((((hyp(1)**4)*(1D0-hyp(3)))+hyp(3))**2+(((hyp(2)-(5D-1))**3)*4)**2)&
- +((hyp(2)-(5D-1))**3)*4)&
- &,hyp(3)]
- end function h_to_c_param
-\end{Verbatim}
-
-\ProcImp{c\_to\_h\_param}
-\begin{Verbatim}
- pure function c_to_h_param(cart)
- real(kind=double),dimension(3)::c_to_h_param
- real(kind=double),dimension(3),intent(in)::cart
- c_to_h_param=&
- &[(((cart(1)*cart(2)) - cart(3))/(1D0 - cart(3)))**(1/4D0)&
- &,(1D0+sign(abs((cart(2)**2) - (cart(1)**2))**(1/3D0),cart(2)-cart(1)))/2D0&
- &,cart(3)]
- end function c_to_h_param
-\end{Verbatim}
-
-\ProcImp{h\_to\_c\_smooth}
-\begin{Verbatim}
- pure function h_to_c_smooth(hyp)
- real(kind=double),dimension(3)::h_to_c_smooth
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double)::h2
- h2=(((hyp(2)-5D-1)**3)*4D0+hyp(2)-5D-1)/2D0
- h_to_c_smooth=&
- &[sqrt(sqrt((((hyp(1)**4)*(1D0-hyp(3)))+hyp(3))**2+h2**2)-h2)&
- &,sqrt(sqrt((((hyp(1)**4)*(1D0-hyp(3)))+hyp(3))**2+h2**2)+h2)&
- &,hyp(3)]
- end function h_to_c_smooth
-\end{Verbatim}
-
-\ProcImp{c\_to\_h\_smooth}
-\begin{Verbatim}
- pure function c_to_h_smooth(cart)
- real(kind=double),dimension(3)::c_to_h_smooth
- real(kind=double),dimension(3),intent(in)::cart
- c_to_h_smooth=&
- [((product(cart(1:2))-cart(3))/(1D0-cart(3)))**(1/4D0),&
- (3D0-3D0**(2D0/3)/&
- (-9D0*cart(1)**2 + 9D0*cart(2)**2 + sqrt(3D0+81D0*(cart(1)**2-cart(2)**2)**2))&
- **(1D0/3)&
- + 3**(1D0/3)*(-9D0*cart(1)**2 + 9D0*cart(2)**2 + sqrt(3D0 + 81D0*(cart(1)**2&
- - cart(2)**2)**2))**(1D0/3))/6D0,cart(3)]
- end function c_to_h_smooth
-\end{Verbatim}
-
-\ProcImp{h\_to\_c\_ort\_def}
-\begin{Verbatim}
- pure function h_to_c_ort_def(hyp)
- real(kind=double),dimension(3)::h_to_c_ort_def
- real(kind=double),dimension(3),intent(in)::hyp
- h_to_c_ort_def=h_to_c_ort([hyp(1),hyp(2),pts2_scale])
- end function h_to_c_ort_def
-\end{Verbatim}
-
-\ProcImp{c\_to\_h\_ort\_def}
-\begin{Verbatim}
- pure function c_to_h_ort_def(cart)
- real(kind=double),dimension(3)::c_to_h_ort_def
- real(kind=double),dimension(3),intent(in)::cart
- c_to_h_ort_def=c_to_h_ort([cart(1),cart(2),pts2_scale])
- end function c_to_h_ort_def
-\end{Verbatim}
-
-\ProcImp{h\_to\_c\_param\_def}
-\begin{Verbatim}
- pure function h_to_c_param_def(hyp)
- real(kind=double),dimension(3)::h_to_c_param_def
- real(kind=double),dimension(3),intent(in)::hyp
- h_to_c_param_def=h_to_c_param([hyp(1),hyp(2),pts2_scale])
- end function h_to_c_param_def
-\end{Verbatim}
-
-\ProcImp{c\_to\_h\_param\_def}
-\begin{Verbatim}
- pure function c_to_h_param_def(cart)
- real(kind=double),dimension(3)::c_to_h_param_def
- real(kind=double),dimension(3),intent(in)::cart
- if(product(cart(1:2))>=pts2_scale)then
- c_to_h_param_def=c_to_h_param([cart(1),cart(2),pts2_scale])
- else
- c_to_h_param_def=[-1D0,-1D0,-1D0]
- end if
- end function c_to_h_param_def
-\end{Verbatim}
-
-\ProcImp{h\_to\_c\_smooth\_def}
-\begin{Verbatim}
- pure function h_to_c_smooth_def(hyp)
- real(kind=double),dimension(3)::h_to_c_smooth_def
- real(kind=double),dimension(3),intent(in)::hyp
- h_to_c_smooth_def=h_to_c_smooth([hyp(1),hyp(2),pts2_scale])
- end function h_to_c_smooth_def
-\end{Verbatim}
-
-\ProcImp{c\_to\_h\_smooth\_def}
-\begin{Verbatim}
- pure function c_to_h_smooth_def(cart)
- real(kind=double),dimension(3)::c_to_h_smooth_def
- real(kind=double),dimension(3),intent(in)::cart
- if(product(cart(1:2))>=pts2_scale)then
- c_to_h_smooth_def=c_to_h_smooth([cart(1),cart(2),pts2_scale])
- else
- c_to_h_smooth_def=[-1D0,-1D0,-1D0]
- end if
- end function c_to_h_smooth_def
-\end{Verbatim}
-
-\ProcImp{voxel\_h\_to\_c\_ort}
-\begin{Verbatim}
- pure function voxel_h_to_c_ort(hyp)
- real(kind=double)::voxel_h_to_c_ort
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double)::T,TH1
- T=1D0-hyp(3)
- TH1=T*(1D0-hyp(1))
- voxel_h_to_c_ort=Sqrt(T**2/(5D0-4D0*(1D0-hyp(2))*hyp(2)-4D0*(2D0-TH1)*TH1))
- end function voxel_h_to_c_ort
-\end{Verbatim}
-
-\ProcImp{voxel\_c\_to\_h\_ort}
-\begin{Verbatim}
- pure function voxel_c_to_h_ort(cart)
- real(kind=double)::voxel_c_to_h_ort
- real(kind=double),dimension(3),intent(in)::cart
- real(kind=double)::P
- P=product(cart(1:2))
- if(P>cart(3))then
- voxel_c_to_h_ort=(cart(1)**2 + cart(2)**2)/(1D0-cart(3))
- else
- voxel_c_to_h_ort=0D0
- end if
- end function voxel_c_to_h_ort
-\end{Verbatim}
-
-\ProcImp{voxel\_h\_to\_c\_noparam}
-\begin{Verbatim}
- pure function voxel_h_to_c_noparam(hyp)
- real(kind=double)::voxel_h_to_c_noparam
- real(kind=double),dimension(3),intent(in)::hyp
- voxel_h_to_c_noparam=&
- 12D0*Sqrt((hyp(1)**6*(1D0-2D0*hyp(2))**4)/(4*hyp(1)**8+(1D0-2D0*hyp(2))**6))
- end function voxel_h_to_c_noparam
-\end{Verbatim}
-
-\ProcImp{voxel\_c\_to\_h\_noparam}
-\begin{Verbatim}
- pure function voxel_c_to_h_noparam(cart)
- real(kind=double)::voxel_c_to_h_noparam
- real(kind=double),dimension(3),intent(in)::cart
- real(kind=double)::P
- voxel_c_to_h_noparam=(cart(1)**2+cart(2)**2)/(12D0*(cart(1)*cart(2))**(3D0/4D0)&
- *(cart(2)**2+cart(1)**2)**(2D0/3D0))
- end function voxel_c_to_h_noparam
-\end{Verbatim}
-
-\ProcImp{voxel\_h\_to\_c\_param}
-\begin{Verbatim}
- pure function voxel_h_to_c_param(hyp)
- real(kind=double)::voxel_h_to_c_param
- real(kind=double),dimension(3),intent(in)::hyp
- voxel_h_to_c_param=12*Sqrt((hyp(1)**6*(1D0-2D0*hyp(2))**4*(hyp(3)-1D0)**2)&
- /((1D0-2D0*hyp(2))**6+4D0*(hyp(3)-(hyp(1)**4*(hyp(3)-1D0)))**2))
- end function voxel_h_to_c_param
-\end{Verbatim}
-
-\ProcImp{voxel\_c\_to\_h\_param}
-\begin{Verbatim}
- pure function voxel_c_to_h_param(cart)
- real(kind=double)::voxel_c_to_h_param
- real(kind=double),dimension(3),intent(in)::cart
- real(kind=double)::P,T,CP,CM
- P=product(cart(1:2))
- if(P>cart(3))then
- P=P-cart(3)
- CP=cart(1)**2+cart(2)**2
- CM=abs(cart(2)**2-cart(1)**2)
- T=1-cart(3)
- voxel_c_to_h_param=(Cp*sqrt(sqrt(P/T)))/(12*Cm**(2D0/3D0)*P)
- else
- voxel_c_to_h_param=0D0
- end if
- end function voxel_c_to_h_param
-\end{Verbatim}
-
-\ProcImp{voxel\_h\_to\_c\_smooth}
-\begin{Verbatim}
- pure function voxel_h_to_c_smooth(hyp)
- real(kind=double)::voxel_h_to_c_smooth
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double)::T
- T=1D0-hyp(3)
- voxel_h_to_c_smooth=&
- &8D0*(hyp(1)**3*(1D0+3D0*(hyp(2)-1D0)*hyp(2))*T)&
- &/sqrt((1D0-2D0*hyp(2)*(2D0+hyp(2)*(2D0*hyp(2)-3D0)))**2+4D0*(1D0+(hyp(1)**4-1D0)*T)**2)
- end function voxel_h_to_c_smooth
-\end{Verbatim}
-
-\ProcImp{voxel\_c\_to\_h\_smooth}
-\begin{Verbatim}
- pure function voxel_c_to_h_smooth(cart)
- real(kind=double)::voxel_c_to_h_smooth
- real(kind=double),dimension(3),intent(in)::cart
- real(kind=double)::P,S,T,CM,CP
- P=product(cart(1:2))
- if(P>cart(3))then
- P=P-cart(3)
- CP=cart(1)**2+cart(2)**2
- CM=cart(2)**2-cart(1)**2
- T=1-cart(3)
- S=sqrt(3D0+81D0*cm**2)
- voxel_c_to_h_smooth=(3D0**(1D0/3D0)*Cp*(3D0**(1D0/3D0)+(9D0*Cm+S)**(2D0/3D0))&
- *sqrt(sqrt(P/T)))/(4D0*P*S*(9D0*Cm+S)**(1D0/3D0))
- else
- voxel_c_to_h_smooth=0D0
- end if
-end function voxel_c_to_h_smooth
-\end{Verbatim}
-
-!
-
-\ProcImp{voxel\_h\_to\_c\_ort\_def}
-\begin{Verbatim}
- pure function voxel_h_to_c_ort_def(hyp)
- real(kind=double)::voxel_h_to_c_ort_def
- real(kind=double),dimension(3),intent(in)::hyp
- voxel_h_to_c_ort_def=voxel_h_to_c_ort(hyp)
- end function voxel_h_to_c_ort_def
-\end{Verbatim}
-
-\ProcImp{voxel\_c\_to\_h\_ort\_def}
-\begin{Verbatim}
- pure function voxel_c_to_h_ort_def(cart)
- real(kind=double)::voxel_c_to_h_ort_def
- real(kind=double),dimension(3),intent(in)::cart
- voxel_c_to_h_ort_def=voxel_c_to_h_ort(cart)
- end function voxel_c_to_h_ort_def
-\end{Verbatim}
-
-\ProcImp{voxel\_h\_to\_c\_param\_def}
-\begin{Verbatim}
- pure function voxel_h_to_c_param_def(hyp)
- real(kind=double)::voxel_h_to_c_param_def
- real(kind=double),dimension(3),intent(in)::hyp
- voxel_h_to_c_param_def=voxel_h_to_c_param(hyp)
- end function voxel_h_to_c_param_def
-\end{Verbatim}
-
-\ProcImp{voxel\_c\_to\_h\_param\_def}
-\begin{Verbatim}
- pure function voxel_c_to_h_param_def(cart)
- real(kind=double)::voxel_c_to_h_param_def
- real(kind=double),dimension(3),intent(in)::cart
- voxel_c_to_h_param_def=voxel_c_to_h_param(cart)
- end function voxel_c_to_h_param_def
-\end{Verbatim}
-
-\ProcImp{voxel\_h\_to\_c\_smooth\_def}
-\begin{Verbatim}
- pure function voxel_h_to_c_smooth_def(hyp)
- real(kind=double)::voxel_h_to_c_smooth_def
- real(kind=double),dimension(3),intent(in)::hyp
- voxel_h_to_c_smooth_def=voxel_h_to_c_smooth(hyp)
- end function voxel_h_to_c_smooth_def
-\end{Verbatim}
-
-\ProcImp{voxel\_c\_to\_h\_smooth\_def}
-\begin{Verbatim}
- pure function voxel_c_to_h_smooth_def(cart)
- real(kind=double)::voxel_c_to_h_smooth_def
- real(kind=double),dimension(3),intent(in)::cart
- voxel_c_to_h_smooth_def=voxel_c_to_h_smooth(cart)
- end function voxel_c_to_h_smooth_def
-\end{Verbatim}
-
-\ProcImp{denom\_cart}
-\begin{Verbatim}
- pure function denom_cart(cart)
- real(kind=double)::denom_cart
- real(kind=double),dimension(3),intent(in)::cart
- denom_cart=1D0/(864D0*Sqrt(cart(3)**3*(1D0-cart(3)/product(cart(1:2)))))
- end function denom_cart
-\end{Verbatim}
-
-\ProcImp{denom\_ort}
-\begin{Verbatim}
- pure function denom_ort(hyp)
- real(kind=double)::denom_ort
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double)::Y,P
- Y=(1D0-2D0*hyp(2))**2
- P=1D0-hyp(3)
- if(hyp(1)>0D0.and.hyp(3)>0D0)then
- denom_ort=sqrt((P + (-1 + Hyp(1))*P**2)&
- /(746496*hyp(1)*hyp(3)**3*(4*(1 + (-1 + hyp(1))*P)**2 + Y)))
-
- else
- denom_ort=0D0
- end if
- end function denom_ort
-\end{Verbatim}
-
-\ProcImp{denom\_param}
-\begin{Verbatim}
- pure function denom_param(hyp)
- real(kind=double)::denom_param
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double)::X,Y,P
- X=hyp(1)**4
- Y=1D0-2D0*hyp(2)
- P=1D0-hyp(3)
- if(hyp(3)>0D0)then
- denom_param=sqrt((P*(1+P*(X-1))*Sqrt(X)*Y**4)/(5184*(4*(1+P*(X-1))**2+Y**6)*hyp(3)**3))
- else
- denom_param=0D0
- end if
- end function denom_param
-\end{Verbatim}
-
-\ProcImp{denom\_param\_reg}
-\begin{Verbatim}
- pure function denom_param_reg(hyp)
- real(kind=double)::denom_param_reg
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double)::X,Y,P
- X=hyp(1)**4
- Y=1D0-2D0*hyp(2)
- P=1D0-hyp(3)
- if(hyp(3)>0D0)then
- denom_param_reg=sqrt((P*(1+P*(X-1))*Sqrt(X)*Y**4)&
- /(5184*(4*(1+P*(X-1))**2+Y**6)*(hyp(3)+norm2_p_t_0)**3))
- else
- denom_param_reg=0D0
- end if
- end function denom_param_reg
-\end{Verbatim}
-
-\ProcImp{denom\_smooth}
-\begin{Verbatim}
- pure function denom_smooth(hyp)
- real(kind=double)::denom_smooth
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double)::X,Y,P
- X=hyp(1)**2
- Y=(1D0-2D0*hyp(2))**2
- P=1D0-hyp(3)
- if(hyp(3)>0D0)then
- denom_smooth=sqrt((P*X*(1 + P*(-1 + X**2))*(1 + 3*Y)**2)/(46656*hyp(3)**3&
- *(16*(1 + P*(-1 + X**2))**2 + Y + 2*Y**2 + Y**3)))
- else
- denom_smooth=0D0
- end if
- end function denom_smooth
-\end{Verbatim}
-
-\ProcImp{denom\_smooth\_reg}
-\begin{Verbatim}
- pure function denom_smooth_reg(hyp)
- real(kind=double)::denom_smooth_reg
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double)::X,Y,P
- X=hyp(1)**2
- Y=(1D0-2D0*hyp(2))**2
- P=1D0-hyp(3)
- if(hyp(3)>0D0)then
- denom_smooth_reg=&
- sqrt((P*X*(1 + P*(-1 + X**2))*(1 + 3*Y)**2)&
- /(46656*(hyp(3)+norm2_p_t_0)**3&
- *(16*(1 + P*(-1 + X**2))**2 + Y + 2*Y**2 + Y**3)))
- else
- denom_smooth_reg=0D0
- end if
- end function denom_smooth_reg
-\end{Verbatim}
-
-\ProcImp{denom\_cart\_save}
-\begin{Verbatim}
- pure function denom_cart_save(cart)
- real(kind=double)::denom_cart_save
- real(kind=double),dimension(3),intent(in)::cart
- if(product(cart(1:2))>cart(3))then
- denom_cart_save=denom_cart(cart)
- else
- denom_cart_save=0D0
- end if
- end function denom_cart_save
-\end{Verbatim}
-
-\ProcImp{denom\_ort\_save}
-\begin{Verbatim}
- pure function denom_ort_save(hyp)
- real(kind=double)::denom_ort_save
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double)::Y,Z,W
- real(kind=double),dimension(3)::cart
- cart=h_to_c_ort(hyp)
- if(cart(1)>1D0.or.cart(2)>1D0)then
- denom_ort_save=0D0
- else
- denom_ort_save=denom_ort(hyp)
- end if
- end function denom_ort_save
-\end{Verbatim}
-
-\ProcImp{denom\_param\_save}
-\begin{Verbatim}
- pure function denom_param_save(hyp)
- real(kind=double)::denom_param_save
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double)::Y,Z,W
- real(kind=double),dimension(3)::cart
- cart=h_to_c_param(hyp)
- if(cart(1)>1D0.or.cart(2)>1D0)then
- denom_param_save=0D0
- else
- denom_param_save=denom_param(hyp)
- end if
- end function denom_param_save
-\end{Verbatim}
-
-! pure
-\ProcImp{denom\_smooth\_save}
-\begin{Verbatim}
- function denom_smooth_save(hyp)
- real(kind=double)::denom_smooth_save
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double)::Y,Z,W
- real(kind=double),dimension(3)::cart
- cart=h_to_c_smooth(hyp)
- if(cart(1)>1D0.or.cart(2)>1D0)then
- denom_smooth_save=0D0
- else
- denom_smooth_save=denom_smooth(hyp)
- end if
- end function denom_smooth_save
-\end{Verbatim}
-
-\ProcImp{denom\_cart\_cuba\_int}
-\begin{Verbatim}
- subroutine denom_cart_cuba_int(d_cart,cart,d_denom,denom,pt2s)
- real(kind=double),dimension(3),intent(in)::cart
- real(kind=double),dimension(1),intent(out)::denom
- real(kind=double),intent(in) :: pt2s
- integer,intent(in)::d_cart,d_denom
- denom(1)=denom_cart_save([cart(1),cart(2),pt2s])
- end subroutine denom_cart_cuba_int
-\end{Verbatim}
-
-\ProcImp{denom\_ort\_cuba\_int}
-\begin{Verbatim}
- subroutine denom_ort_cuba_int(d_hyp,hyp,d_denom,denom,pt2s)
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(1),intent(out)::denom
- real(kind=double),intent(in) :: pt2s
- integer,intent(in)::d_hyp,d_denom
- denom(1)=denom_ort_save([hyp(1),hyp(2),pt2s])
- end subroutine denom_ort_cuba_int
-\end{Verbatim}
-
-\ProcImp{denom\_param\_cuba\_int}
-\begin{Verbatim}
- subroutine denom_param_cuba_int(d_hyp,hyp,d_denom,denom,pt2s)
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(1),intent(out)::denom
- real(kind=double),intent(in) :: pt2s
- integer,intent(in)::d_hyp,d_denom
- denom(1)=denom_param_save([hyp(1),hyp(2),pt2s])
- end subroutine denom_param_cuba_int
-\end{Verbatim}
-
-\ProcImp{denom\_smooth\_cuba\_int}
-\begin{Verbatim}
- subroutine denom_smooth_cuba_int(d_hyp,hyp,d_denom,denom,pt2s)
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(1),intent(out)::denom
- real(kind=double),intent(in) :: pt2s
- integer,intent(in)::d_hyp,d_denom
- denom(1)=denom_smooth_save([hyp(1),hyp(2),pt2s])
- end subroutine denom_smooth_cuba_int
-\end{Verbatim}
-
-\ProcImp{coordinates\_hcd\_cart}
-\begin{Verbatim}
- subroutine coordinates_hcd_cart(hyp,cart,denom)
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(3),intent(out)::cart
- real(kind=double),intent(out)::denom
- cart=hyp
- denom=denom_cart_save(cart)
- end subroutine coordinates_hcd_cart
-\end{Verbatim}
-
-\ProcImp{coordinates\_hcd\_ort}
-\begin{Verbatim}
- subroutine coordinates_hcd_ort(hyp,cart,denom)
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(3),intent(out)::cart
- real(kind=double),intent(out)::denom
- cart=h_to_c_ort(hyp)
- denom=denom_ort(hyp)
- end subroutine coordinates_hcd_ort
-\end{Verbatim}
-
-\ProcImp{coordinates\_hcd\_param}
-\begin{Verbatim}
- subroutine coordinates_hcd_param(hyp,cart,denom)
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(3),intent(out)::cart
- real(kind=double),intent(out)::denom
- cart=h_to_c_param(hyp)
- denom=denom_param(hyp)
- end subroutine coordinates_hcd_param
-\end{Verbatim}
-
-\ProcImp{coordinates\_hcd\_param\_reg}
-\begin{Verbatim}
- subroutine coordinates_hcd_param_reg(hyp,cart,denom)
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(3),intent(out)::cart
- real(kind=double),intent(out)::denom
- cart=h_to_c_param(hyp)
- denom=denom_param_reg(hyp)
- end subroutine coordinates_hcd_param_reg
-\end{Verbatim}
-
-\ProcImp{coordinates\_hcd\_smooth}
-\begin{Verbatim}
- subroutine coordinates_hcd_smooth(hyp,cart,denom)
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(3),intent(out)::cart
- real(kind=double),intent(out)::denom
- cart=h_to_c_smooth(hyp)
- denom=denom_smooth(hyp)
- end subroutine coordinates_hcd_smooth
-\end{Verbatim}
-
-\ProcImp{coordinates\_hcd\_smooth\_reg}
-\begin{Verbatim}
- subroutine coordinates_hcd_smooth_reg(hyp,cart,denom)
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(3),intent(out)::cart
- real(kind=double),intent(out)::denom
- cart=h_to_c_smooth(hyp)
- denom=denom_smooth_reg(hyp)
- end subroutine coordinates_hcd_smooth_reg
-\end{Verbatim}
-
-\ProcImp{pdf\_in\_in\_kind}
-\begin{Verbatim}
- pure function pdf_in_in_kind(process_id,double_pdf_id,c1,c2,gev_pt)
- real(kind=double)::pdf_in_in_kind
- real(kind=double),intent(in)::c1,c2,gev_pt
- integer,intent(in)::process_id,double_pdf_id
- real(kind=double)::pdf1,pdf2
- call single_pdf(valid_processes(1,process_id),&
- double_pdf_kinds(1,double_pdf_id),&
- c1,&
- gev_pt,&
- pdf1)
- call single_pdf(valid_processes(2,process_id),&
- double_pdf_kinds(2,double_pdf_id),&
- c2,&
- gev_pt,&
- pdf2)
- pdf_in_in_kind=pdf1*pdf2
- contains
- pure subroutine single_pdf(flavor,pdf_kind,c,gev_pt,pdf)
- integer,intent(in)::flavor,pdf_kind
- real(kind=double),intent(in)::c,gev_pt
- real(kind=double),intent(out)::pdf
- real(kind=double),dimension(-6:6)::lha_pdf
- call evolvePDF(c,gev_pt,lha_pdf)
- select case(pdf_kind)
- case(1)
- pdf=lha_pdf(0)
- case(2)
- if(flavor==1.or.flavor==2)then
- pdf=lha_pdf(-flavor)
- else
- pdf=lha_pdf(flavor)
- end if
- case(3)
- pdf=lha_pdf(1)-lha_pdf(-1)
- case(4)
- pdf=lha_pdf(2)-lha_pdf(-2)
- end select
- end subroutine single_pdf
- end function pdf_in_in_kind
-\end{Verbatim}
-
-\ProcImp{ps\_io\_pol}
-\begin{Verbatim}
- elemental function ps_io_pol(process_io_id,pt2shat)
- real(kind=double)::ps_io_pol
- integer,intent(in)::process_io_id
- real(kind=double),intent(in)::pt2shat
- ps_io_pol=dot_product(&
- [1D0,pt2shat,pt2shat**2,pt2shat**3]&
- ,phase_space_coefficients_inout(1:4,valid_processes(6,process_io_id)))
- end function ps_io_pol
-\end{Verbatim}
-
-\ProcImp{interactions\_dddsigma}
-\begin{Verbatim}
- pure subroutine interactions_dddsigma(process_id,double_pdf_id,hyp,cart,dddsigma)
- real(kind=double),intent(out)::dddsigma
- integer,intent(in)::process_id,double_pdf_id
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(3),intent(out)::cart
- real(kind=double)::a,pt2shat,gev_pt
- cart=h_to_c_param(hyp)
- a=product(cart(1:2))
- if(cart(1)<=1D0.and.cart(2)<=1D0)then
- pt2shat=hyp(3)/a
- gev_pt=sqrt(hyp(3))*gev_pt_max
-! print *,process_id,pt2shat
- dddsigma=&
- &const_pref&
- &*alphasPDF(gev_pt)**2&
- &*ps_io_pol(process_id,pt2shat)&
- &*pdf_in_in_kind(process_id,double_pdf_id,cart(1),cart(2),gev_pt)&
- &*denom_param(hyp)&
- &/a
- else
- dddsigma=0D0
- end if
- end subroutine interactions_dddsigma
-\end{Verbatim}
-
-\ProcImp{interactions\_dddsigma\_reg}
-\begin{Verbatim}
- pure subroutine interactions_dddsigma_reg(process_id,double_pdf_id,hyp,cart,dddsigma)
- real(kind=double),intent(out)::dddsigma
- integer,intent(in)::process_id,double_pdf_id
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(3),intent(out)::cart
- real(kind=double)::a,pt2shat,gev_pt,gev2_pt
- cart=h_to_c_param(hyp)
- a=product(cart(1:2))
- if(cart(1)<=1D0.and.cart(2)<=1D0)then
- pt2shat=hyp(3)/a
- gev_pt=sqrt(hyp(3))*gev_pt_max
- gev2_pt=hyp(3)*gev2_pt_max
-! print *,process_id,pt2shat
- dddsigma=&
- &const_pref&
- &*alphasPDF(sqrt(gev2_pt+gev2_p_t_0))**2&
- &*ps_io_pol(process_id,pt2shat)&
- &*pdf_in_in_kind(process_id,double_pdf_id,cart(1),cart(2),gev_pt)&
- &*denom_param_reg(hyp)&
- &/a
- else
- dddsigma=0D0
- end if
- end subroutine interactions_dddsigma_reg
-\end{Verbatim}
-
-\ProcImp{interactions\_dddsigma\_print}
-\begin{Verbatim}
- subroutine interactions_dddsigma_print(process_id,double_pdf_id,hyp,cart,dddsigma)
- real(kind=double),intent(out)::dddsigma
- integer,intent(in)::process_id,double_pdf_id
- real(kind=double),dimension(3),intent(in)::hyp
- real(kind=double),dimension(3),intent(out)::cart
- real(kind=double)::a,pt2shat,gev_pt
- cart=h_to_c_param(hyp)
- a=product(cart(1:2))
- if(cart(1)<=1D0.and.cart(2)<=1D0)then
- pt2shat=hyp(3)/a
- gev_pt=sqrt(hyp(3))*gev_pt_max
-! print *,process_id,pt2shat
- dddsigma=&
- &const_pref&
-! &*alphasPDF(gev_pt)**2&
- &*ps_io_pol(process_id,pt2shat)&
- &*pdf_in_in_kind(process_id,double_pdf_id,cart(1),cart(2),gev_pt)&
- &*denom_param(hyp)&
- &/a
- else
- dddsigma=0D0
- end if
- write(11,fmt=*)dddsigma,pt2shat,&
- pdf_in_in_kind(process_id,double_pdf_id,cart(1),cart(2),&
- gev_pt),ps_io_pol(process_id,pt2shat),const_pref,denom_param(hyp),a
- flush(11)
- end subroutine interactions_dddsigma_print
-\end{Verbatim}
-
-\ProcImp{interactions\_dddsigma\_cart}
-\begin{Verbatim}
- pure subroutine interactions_dddsigma_cart(process_id,double_pdf_id,cart,dddsigma)
- real(kind=double),intent(out)::dddsigma
- integer,intent(in)::process_id,double_pdf_id
- real(kind=double),dimension(3),intent(in)::cart
- real(kind=double)::a,pt2shat,gev_pt
- a=product(cart(1:2))
- if(cart(1)<=1D0.and.cart(2)<=1D0)then
- pt2shat=cart(3)/a
- gev_pt=sqrt(cart(3))*gev_pt_max
-! print *,process_id,pt2shat
- dddsigma=&
- &const_pref&
- &*alphasPDF(gev_pt)**2&
- &*ps_io_pol(process_id,pt2shat)&
- &*pdf_in_in_kind(process_id,double_pdf_id,cart(1),cart(2),gev_pt)&
- &*denom_cart(cart)&
- &/a
- else
- dddsigma=0D0
- end if
- end subroutine interactions_dddsigma_cart
-\end{Verbatim}
-
-\ProcImp{cuba\_gg\_me\_smooth}
-\begin{Verbatim}
- subroutine cuba_gg_me_smooth(d_hyp,hyp,d_me,me,pt2s)
- integer,intent(in)::d_hyp,d_me
- real(kind=double),dimension(d_hyp),intent(in)::hyp
- real(kind=double),dimension(1),intent(out)::me
- real(kind=double),dimension(3)::cart
- real(kind=double),intent(in)::pt2s
- real(kind=double)::p,p2
- if(d_hyp==3)then
- p=hyp(3)
- p2=hyp(3)**2
- else
- if(d_hyp==2)then
- p=sqrt(pt2s)
- p2=pt2s
- end if
- end if
- cart=h_to_c_smooth([hyp(1),hyp(2),p2])
- if(p>pts_min.and.product(cart(1:2))>p2)then
- me(1)=&
- &const_pref&
- &*alphasPDF(p*gev_pt_max)**2&
- &*ps_io_pol(109,p2)&
- &*pdf_in_in_kind(109,11,cart(1),cart(2),p2)&
- &*denom_smooth([hyp(1),hyp(2),p2])&
- &/product(cart(1:2))
- else
- me(1)=0D0
- end if
- end subroutine cuba_gg_me_smooth
-\end{Verbatim}
-
-\ProcImp{cuba\_gg\_me\_param}
-\begin{Verbatim}
- subroutine cuba_gg_me_param(d_hyp,hyp,d_me,me,pt2s)
- integer,intent(in)::d_hyp,d_me
- real(kind=double),dimension(d_hyp),intent(in)::hyp
- real(kind=double),dimension(1),intent(out)::me
- real(kind=double),dimension(3)::cart
- real(kind=double),intent(in)::pt2s
- real(kind=double)::p,p2
- if(d_hyp==3)then
- p=hyp(3)
- p2=hyp(3)**2
- else
- if(d_hyp==2)then
- p=sqrt(pt2s)
- p2=pt2s
- end if
- end if
- cart=h_to_c_param([hyp(1),hyp(2),p2])
- if(p>pts_min.and.product(cart(1:2))>p2)then
- me(1)=&
- &const_pref&
- &*alphasPDF(p*gev_pt_max)**2&
- &*ps_io_pol(109,p2)&
- &*pdf_in_in_kind(109,11,cart(1),cart(2),p2)&
- &*denom_param([hyp(1),hyp(2),p2])&
- &/product(cart(1:2))
- else
- me(1)=0D0
- end if
- end subroutine cuba_gg_me_param
-\end{Verbatim}
-
-\ProcImp{cuba\_gg\_me\_ort}
-\begin{Verbatim}
- subroutine cuba_gg_me_ort(d_hyp,hyp,d_me,me,pt2s)
- integer,intent(in)::d_hyp,d_me
- real(kind=double),dimension(d_hyp),intent(in)::hyp
- real(kind=double),dimension(1),intent(out)::me
- real(kind=double),dimension(3)::cart
- real(kind=double),intent(in)::pt2s
- real(kind=double)::p,p2
- if(d_hyp==3)then
- p=hyp(3)
- p2=hyp(3)**2
- else
- if(d_hyp==2)then
- p=sqrt(pt2s)
- p2=pt2s
- end if
- end if
- cart=h_to_c_ort([hyp(1),cart(2),p2])
- if(p>pts_min.and.product(cart(1:2))>p2)then
- me(1)=&
- &const_pref&
- &*alphasPDF(p*gev_pt_max)**2&
- &*ps_io_pol(109,p2)&
- &*pdf_in_in_kind(109,11,cart(1),cart(2),p2)&
- &*denom_ort([hyp(1),hyp(2),p2])&
- &/product(cart(1:2))
- else
- me(1)=0D0
- end if
- end subroutine cuba_gg_me_ort
-\end{Verbatim}
-
-\ProcImp{cuba\_gg\_me\_cart}
-\begin{Verbatim}
- subroutine cuba_gg_me_cart(d_cart,cart,d_me,me,pt2s)
- integer,intent(in)::d_cart,d_me
- real(kind=double),dimension(d_cart),intent(in)::cart
- real(kind=double),dimension(1),intent(out)::me
- real(kind=double),intent(in)::pt2s
- real(kind=double)::a,p,p2
- if(d_cart==3)then
- p=cart(3)
- p2=cart(3)**2
- else
- if(d_cart==2)then
- p=sqrt(pt2s)
- p2=pt2s
- end if
- end if
- a=product(cart(1:2))
- if(p>pts_min.and.a>p2)then
- me(1)=&
- &const_pref&
- &*alphasPDF(p*gev_pt_max)**2&
- &*ps_io_pol(109,p2)&
- &*pdf_in_in_kind(109,11,cart(1),cart(2),p2)&
- &*denom_cart([cart(1),cart(2),p2])&
- &/a
- else
- me(1)=0D0
- end if
- end subroutine cuba_gg_me_cart
-\end{Verbatim}
-
-\ProcImp{interactions\_proton\_proton\_integrand\_generic\_17\_reg}
-\begin{Verbatim}
- subroutine interactions_proton_proton_integrand_generic_17_reg(hyp_2,trafo,f,pt)
- real(kind=double),dimension(2),intent(in)::hyp_2
- procedure(coord_hcd_in)::trafo
- real(kind=double),dimension(17),intent(out)::f
- class(transversal_momentum_type), intent(in) :: pt
- real(kind=double),dimension(3)::cart,hyp_3
- real(kind=double),dimension(5)::psin
- real(kind=double),dimension(-6:6)::c,d
- real(kind=double)::gev_pt,gev2_pt,pts,pt2s,pt2shat,a,&
- pdf_seaquark_seaquark,pdf_seaquark_gluon,pdf_gluon_gluon,&
- pdf_up_seaquark,pdf_up_gluon,pdf_down_seaquark,pdf_down_gluon,&
- v1u,v1d,v2u,v2d,denom
-
- pts=pt%get_unit_scale()
- pt2s=pt%get_unit2_scale()
- gev_pt=pt%get_gev_scale()
- gev2_pt=pt%get_gev2_scale()
-
- hyp_3(1:2)=hyp_2
- hyp_3(3)=pt2s
- call trafo(hyp_3,cart,denom)
- a=product(cart(1:2))
- if(cart(1)<=1D0.and.cart(2)<=1D0.and.a>pt2s)then
- pt2shat=pt2s/a
-
- ! phase space polynom
- psin=matmul([1D0,pt2shat,pt2shat**2,pt2shat**3],phase_space_coefficients_in)
- ! pdf
- call evolvepdf(cart(1),gev_pt,c)
- call evolvepdf(cart(2),gev_pt,d)
- !c=[1,1,1,1,1,1,1,1,1,1,1,1,1]*1D0
- !d=c
- v1d=c(1)-c(-1)
- v1u=c(2)-c(-2)
- v2d=d(1)-d(-1)
- v2u=d(2)-d(-2)
- c(1)=c(-1)
- c(2)=c(-2)
- d(1)=d(-1)
- d(2)=d(-2)
- f(1)=0D0
- !gluon_gluon
- f( 2)=(&
- !type5
- c(0)*d(0)&
- )*psin(5)
- !gluon_seaquark
- f( 3)=(&
- !type4
- c(0)*d(-4)+c(0)*d(-3)+c(0)*d(-2)+c(0)*d(-1)+c(0)*d(1)+c(0)*d(2)+c(0)*d(3)+c(0)*d(4)&
- )*psin(4)
- !gluon_down
- f( 4)=(&
- !type4
- c( 0)*v2d&
- )*psin(4)
- !gluon_up
- f( 5)=(&
- !type4
- c(0)*v2u&
- )*psin(4)
- !seaquark_gluon
- f( 6)=(&
- !type4
- c(-4)*d(0)+c(-3)*d(0)+c(-2)*d(0)+c(-1)*d(0)&
- +c(1)*d(0)+c( 2)*d(0)+c( 3)*d(0)+c( 4)*d(0)&
- )*psin(4)
- !seaquark_seaquark
- f( 7)=&
- !type1
- (c(-4)*d(-3)+c(-4)*d(-2)+c(-4)*d(-1)+c(-4)*d( 1)+c(-4)*d( 2)+c(-4)*d( 3)+&
- c(-3)*d(-4)+c(-3)*d(-2)+c(-3)*d(-1)+c(-3)*d( 1)+c(-3)*d( 2)+c(-3)*d( 4)+&
- c(-2)*d(-4)+c(-2)*d(-3)+c(-2)*d(-1)+c(-2)*d( 1)+c(-2)*d( 3)+c(-2)*d( 4)+&
- c(-1)*d(-4)+c(-1)*d(-3)+c(-1)*d(-2)+c(-1)*d( 2)+c(-1)*d( 3)+c(-1)*d( 4)+&
- c( 1)*d(-4)+c( 1)*d(-3)+c( 1)*d(-2)+c( 1)*d( 2)+c( 1)*d( 3)+c( 1)*d( 4)+&
- c( 2)*d(-4)+c( 2)*d(-3)+c( 2)*d(-1)+c( 2)*d( 1)+c( 2)*d( 3)+c( 2)*d( 4)+&
- c( 3)*d(-4)+c( 3)*d(-2)+c( 3)*d(-1)+c( 3)*d( 1)+c( 3)*d( 2)+c( 3)*d( 4)+&
- c( 4)*d(-3)+c( 4)*d(-2)+c( 4)*d(-1)+c( 4)*d( 1)+c( 4)*d( 2)+c( 4)*d( 3))&
- *psin(1)&
- !type2
- +( c(-4)*d(-4)+c(-3)*d(-3)+c(-2)*d(-2)+c(-1)*d(-1)&
- +c( 4)*d( 4)+c( 3)*d( 3)+c( 2)*d( 2)+c( 1)*d( 1))&
- *psin(2)&
- !type3
- +( c(-4)*d( 4)+c(-3)*d( 3)+c(-2)*d( 2)+c(-1)*d( 1)&
- +c( 4)*d(-4)+c( 3)*d(-3)+c( 2)*d(-2)+c( 1)*d(-1))&
- *psin(3)
- !seaquark_down
- f( 8)=&
- !type1
- (c(-4)*v2d+c(-3)*v2d+c(-2)*v2d+c( 2)*v2d+c( 3)*v2d+c( 4)*v2d)&
- *psin(1)&
- !type2
- +c( 1)*v2d&
- *psin(2)&
- !type3
- +c(-1)*v2d&
- *psin(3)
- !seaquark_up
- f( 9)=&
- !type1
- (c(-4)*v2u+c(-3)*v2u+c(-1)*v2u+c( 1)*v2u+c( 3)*v2u+c( 4)*v2u)&
- *psin(1)&
- !type2
- +c(2)*v2u&
- *psin(2)&
- !type3
- +c(-2)*v2u&
- *psin(3)
- !down_gluon
- f(10)=(&
- !type4
- v1d*d( 0)&
- )*psin(4)
- !down_seaquark
- f(11)=&
- !type1
- (v1d*d(-4)+v1d*d(-3)+v1d*d(-2)+v1d*d( 2)+v1d*d( 3)+v1d*d( 4))&
- *psin(1)&
- !type2
- +v1d*d( 1)&
- *psin(2)&
- !type3
- +v1d*d(-1)&
- *psin(3)
- !down_down
- f(12)=v1d*v2d*psin(2)
- !down_up
- f(13)=v1d*v2u*psin(1)
- !up_gluon
- f(14)=(&
- !type4
- &v1u*d(0)&
- &)*psin(4)
- !up_seaquark
- f(15)=&
- !type1
- (v1u*d(-4)+v1u*d(-3)+v1u*d(-1)+v1u*d( 1)+v1u*d( 3)+v1u*d( 4))&
- *psin(1)&
- !type2
- +v1u*d(2)&
- *psin(2)&
- !type3
- +v1u*d(-2)&
- *psin(3)
- !up_down
- f(16)=v1u*v2d*psin(1)
- !up_up
- f(17)=v1u*v2u*psin(2)
- f=f&
- *const_pref&
- *alphasPDF(sqrt(gev2_pt+gev2_p_t_0))**2&
- *denom&
- /a
- ! print *,const_pref,alphasPDF(gev_pt)**2,denom_smooth(hyp),a
- else
- f=[0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0]
- end if
-! print *,pt2shat,c(0)*d(0),psin(5),const_pref,alphasPDF(gev_pt)**2,denom,a
- end subroutine interactions_proton_proton_integrand_generic_17_reg
-\end{Verbatim}
-
-\ProcImp{interactions\_proton\_proton\_integrand\_param\_17\_reg}
-\begin{Verbatim}
- subroutine interactions_proton_proton_integrand_param_17_reg(d_hyp,hyp_2,d_f,f,pt)
- integer,intent(in)::d_hyp,d_f
- real(kind=double),dimension(2),intent(in)::hyp_2
- real(kind=double),dimension(17),intent(out)::f
- class(transversal_momentum_type), intent(in) :: pt
- call interactions_proton_proton_integrand_generic_17_reg&
- (hyp_2,coordinates_hcd_param_reg,f,pt)
- ! write (53,*)hyp_2,momentum_get_pts_scale(),f
- end subroutine interactions_proton_proton_integrand_param_17_reg
-\end{Verbatim}
-
-\ProcImp{interactions\_proton\_proton\_integrand\_smooth\_17\_reg}
-\begin{Verbatim}
- subroutine interactions_proton_proton_integrand_smooth_17_reg(d_hyp,hyp_2,d_f,f,pt)
- integer,intent(in)::d_hyp,d_f
- real(kind=double),dimension(2),intent(in)::hyp_2
- real(kind=double),dimension(17),intent(out)::f
- class(transversal_momentum_type), intent(in) :: pt
- call interactions_proton_proton_integrand_generic_17_reg&
- (hyp_2,coordinates_hcd_smooth_reg,f,pt)
- ! write (53,*)hyp_2,momentum_get_pts_scale(),f
- end subroutine interactions_proton_proton_integrand_smooth_17_reg
-\end{Verbatim}
Index: trunk/src/muli/doc/uml-module-tree.mp
===================================================================
--- trunk/src/muli/doc/uml-module-tree.mp (revision 8371)
+++ trunk/src/muli/doc/uml-module-tree.mp (revision 8372)
@@ -1,517 +0,0 @@
-input common;
-color extends_color, comp_color;
-extends_color=(1,0,0);
-comp_color=(0,0,1);
-path last_extends_path, mae_ser_path;
-pair last_extends_endpoint, last_extends_beginning;
-numeric last_extends_eangle, last_extends_bangle;
-
-def draw_label(expr px,py,lab,offset)=
- label(TEX(lab),((px*xu,py*yu)+offset));
-enddef;
-
-def draw_line(expr s,ds,e,de,c,offset)=
- draw ((xpart(s)*xu,ypart(s)*yu)+offset){dir ds} .. {dir de}((xpart(e)*xu,ypart(e)*yu)+offset) withcolor c;
-enddef;
-
-def draw_extends_endpoint(expr parent, a, offset)=
- save d;
- save v;
- pair d;
- pair v[];
- pair last_extends_endpoint;
- numeric last_extends_eangle;
- last_extends_eangle=a;
- d=dir(a);
- v1=(xpart(parent)*xu,ypart(parent)*yu)+offset;
- v2=v1+(d rotated 150)*unit;
- v3=v1+(d rotated 210)*unit;
- last_extends_endpoint=(v2+v3)/2;
- draw v2 -- v1 -- v3 -- cycle withcolor extends_color;
-enddef;
-
-def draw_extends_line(expr child, ca, ten, offset)=
- path last_extends_path;
- pair last_extends_beginning;
- numeric last_extends_bangle;
- last_extends_bangle=ca;
- last_extends_beginning=(xpart(child)*xu,ypart(child)*yu)+offset;
- last_extends_path=last_extends_beginning{dir ca} .. tension ten .. {dir last_extends_eangle}last_extends_endpoint;
- draw last_extends_path withcolor extends_color;
-enddef;
-
-def fork_extends_line(expr child, ca, ten, time, offset)=
- save b_v,p;
- pair b_v;
- path p;
- b_v=(xpart(child)*xu,ypart(child)*yu)+offset;
- p=b_v{dir ca} .. tension ten .. {dir (angle (direction time of last_extends_path))}point time of last_extends_path;
- draw p withcolor extends_color;
-enddef;
-
-def fork_push_extends_line(expr child, ca, ten, time, offset)=
- save b_v,p;
- pair b_v;
- path p;
- b_v=(xpart(child)*xu,ypart(child)*yu)+offset;
- p=b_v{dir ca} .. tension ten .. {dir (angle (direction time of last_extends_path))}point time of last_extends_path;
- draw p withcolor extends_color;
- path last_extends_path;
- last_extends_path=p;
- pair last_extends_beginning;
- last_extends_beginning=b_v;
- numeric last_extends_bangle;
- last_extends_bangle = ca;
-enddef;
-
-def push_extends_line(expr child, ca, ten, offset)=
- save b_v,p;
- pair b_v;
- path p[];
- b_v=(xpart(child)*xu,ypart(child)*yu)+offset;
- p2=b_v{dir ca} .. tension ten .. {dir last_extends_bangle}last_extends_beginning;
- draw p2 withcolor extends_color;
- p1=last_extends_path;
- path last_extends_path;
- last_extends_path=p2;
- pair last_extends_beginning;
- last_extends_beginning=b_v;
- numeric last_extends_bangle;
- last_extends_bangle = ca;
-enddef;
-
-def draw_extends(expr child,ca,parent,pa,ten,offset)=
- draw_extends_endpoint(parent,pa,offset);
- draw_extends_line(child,ca,ten,offset);
-enddef;
-
-def draw_comp_endpoint(expr type, a, offset)=
- save d;
- save v;
- pair v[];
- pair d;
- path last_comp_path;
- pair last_comp_endpoint;
- numeric last_comp_eangle;
- v2=(xpart(type)*xu,ypart(type)*yu)+offset;
- last_comp_endpoint = v2 - d*unit;
- last_comp_eangle = a;
- d=dir(a);
- last_comp_path=(v2 -- (v2 + (d rotated 135)*unit/diag) -- (v2 - d*unit) -- (v2+(d rotated 225)*unit/diag) -- cycle);
- draw last_comp_path withcolor comp_color;
- fill last_comp_path withcolor comp_color;
-enddef;
-
-def draw_comp_beginning(expr comp_v, comp_a, ten, comp_n, l_width, offset)=
- save beg_v;
- pair beg_v;
- beg_v=(xpart(comp_v)*xu,ypart(comp_v)*yu)+offset;
- draw beg_v{dir comp_a} .. tension ten .. {dir last_comp_eangle}last_comp_endpoint withcolor comp_color;
- label(TEX(comp_n),beg_v-(dir comp_a)*l_width*unit/2);
-enddef;
-
-def draw_comp_line(expr child, ca, ten, offset)=
- draw ((xpart(child)*xu,ypart(child)*yu)+offset){dir ca} .. tension ten .. {dir last_comp_eangle}last_comp_endpoint withcolor comp_color;
-enddef;
-
-def push_comp_line(expr child, ca, ten, offset)=
- save b_v,p;
- pair b_v;
- path p[];
- b_v=(xpart(child)*xu,ypart(child)*yu)+offset;
- p2=b_v{dir ca} .. tension ten .. {dir last_comp_eangle}last_comp_endpoint;
- draw p2 withcolor comp_color;
- p1=last_comp_path;
- path last_comp_path;
- last_comp_path=p2;
- pair last_comp_endpoint;
- last_comp_endpoint=b_v;
- numeric last_comp_eangle;
- last_comp_eangle = ca;
-enddef;
-
-def draw_comp(expr comp,ca,type,ta,ten,lab,lab_width,offset)=
- draw_comp_endpoint(type,ta,offset);
- draw_comp_beginning(comp,ca,ten,lab,lab_width,offset);
-enddef;
-
-def draw_module(expr lu,ro,lab,offset)=
- save v;
- save lx;
- pair v[];
- lx=8*xu;
- v1=(xpart(lu)*xu,ypart(lu)*yu)+offset;
- v2=(xpart(ro)*xu,ypart(ro)*yu)+offset;
- v3=(xpart(v1),ypart(v2));
- draw v1 -- (xpart(v2),ypart(v1)) -- v2 -- v3 -- cycle;
- draw v3 -- v3+(0,2*yu) -- v3+(lx,2*yu) -- v3+(lx,0);
- label(TEX(lab),v3+(lx/2,yu));
-enddef;
-
-def draw_box(expr lu,ro,lab,offset)=
- draw ((xpart(lu)*xu,ypart(lu)*yu)+offset)
- -- ((xpart(ro)*xu,ypart(lu)*yu)+offset)
- -- ((xpart(ro)*xu,ypart(ro)*yu)+offset)
- -- ((xpart(lu)*xu,ypart(ro)*yu)+offset)
- -- cycle;
- label(TEX(lab),
- ((xpart(lu)+xpart(ro))*xu/2,(ypart(lu)+ypart(ro))*yu/2)+offset);
-enddef;
-
-def basic_module(expr offset)=
- draw_module((-2,-2),(47,12),"muli\_basic",offset);
- draw_box((0,4),(10,6),"measurable\_type",offset);
- draw_box((6,9),(16,11),"serializable\_class",offset);
- draw_box((7,-1),(15,1),"unique\_type",offset);
- draw_box((12,4),(22,6),"identified\_type",offset);
- draw_box((24,0),(34,3),"",offset);
- draw_label(29,1,"next",offset);
- draw_label(29,2,"ref",offset);
- draw_box((24,3),(34,5),"serializable\_ref\_type",offset);
- draw_box((24,7),(34,9),"",offset);
- draw_label(29,8,"next",offset);
- draw_box((24,9),(34,11),"position\_stack\_type",offset);
- draw_box((36,0),(46,3),"",offset);
- draw_label(41,1,"references",offset);
- draw_label(41,2,"heap",offset);
- draw_box((36,3),(46,5),"marker\_type",offset);
- draw_box((36,7),(46,9),"position\_stack",offset);
- draw_box((36,9),(46,11),"page\_ring\_type",offset);
-
- draw_extends((5,6),90,(11,9),90,1.5,offset);
- path mae_ser_path;
- mae_ser_path=last_extends_path;
- draw_extends_line((17,6),90,1.5,offset);
- path id_ser_path;
- id_ser_path=last_extends_path;
-
- draw_extends((11,1),90,(17,4),90,1.5,offset);
- draw_extends((41,5),90,(41,7),90,1,offset);
-
- draw_comp((36,8),180,(34,10),180,1.5,"1",1,offset);
- draw_comp_beginning((34,8),0,1.5,"1",1,offset);
-
- draw_comp((34,1),0,(34,4),180,1.5,"1",1,offset);
- draw_comp_beginning((36,1),180,1.5,"1",1,offset);
- draw_comp_beginning((36,2),180,1.5,"1",1,offset);
-
- draw_comp_endpoint((16,10),180,offset);
- push_comp_line((23,3),90,1,offset);
- draw_comp_beginning((24,2),180,1,"1",1,offset);
-enddef;
-
-def momentum_module(expr offset)=
- draw_module((0,-1),(16,8),"muli\_momentum",offset);
- draw_box((1,1),(15,3),"qcd\_2\_2\_class",offset);
- draw_extends((8,3),90,(8,5),90,1,offset);
- draw_box((1,5),(15,7),"transversal\_momentum\_type",offset);
-enddef;
-
-def aq_module(expr offset)=
- draw_module((0,0),(14,8),"muli\_aq",offset);
- draw_box((1,2),(13,5),"",offset);
- draw_label(7,3,"int\_list",offset);
- draw_label(7,4,"err\_tree",offset);
- draw_box((1,5),(13,7),"aq\_class",offset);
-enddef;
-
-def dsigma_module(expr offset)=
- draw_module((0,0),(14,7),"dsigma",offset);
- draw_box((1,1),(13,4),"",offset);
- draw_label(6,2,"pt",offset);
- draw_label(6,3,"cuba\_int",offset);
- draw_box((1,4),(13,6),"muli\_dsigma\_type",offset);
-enddef;
-
-def cuba_module(expr offset)=
- draw_module((0,0),(32,9),"cuba",offset);
- draw_box((1,1),(7,3),"cuhre\_type",offset);
- draw_box((9,1),(15,3),"suave\_type",offset);
- draw_box((16.8,1),(23.2,3),"divonne\_type",offset);
- draw_box((25,1),(31,3),"vegas\_type",offset);
- draw_box((13,6),(19,8),"cuba\_type",offset);
- draw_extends((4,3),90,(16,6),90,5,offset);
- draw_extends_line((12,3),90,2,offset);
- draw_extends_line((20,3),90,2,offset);
- draw_extends_line((29,3),90,5,offset);
-enddef;
-
-def fibonacci_module(expr offset)=
- draw_module((0,0),(26,21),"fibonacci\_tree",offset);
- draw_box((1,4),(11,6),"fibonacci\_list\_type",offset);
- draw_box((15,1),(25,3),"fibonacci\_stub\_type",offset);
- draw_box((1,8),(11,10),"fibonacci\_leave\_type",offset);
- draw_box((15,8),(25,10),"fibonacci\_root\_type",offset);
- draw_box((8,18),(18,20),"fibonacci\_node\_type",offset);
-
- draw_box((8,13),(18,18),"",offset);
- draw_label(13,14,"down",offset);
- draw_label(13,15,"up",offset);
- draw_label(13,16,"right",offset);
- draw_label(13,17,"left",offset);
- draw_extends((6,10),90,(13,13),90,1.5,offset);
- draw_extends_line((20,10),90,1.5,offset);
- draw_extends((20,3),90,(20,5),90,1,offset);
-
- draw_box((15,5),(25,8),"",offset);
- draw_label(20,6,"rightmost",offset);
- draw_label(20,7,"leftmost",offset);
-
- draw_box((1,1),(11,4),"",offset);
- draw_label(6,2,"leave",offset);
- draw_label(6,3,"next",offset);
- draw_comp((11,3),0,(11,5),180,1.5,"1",1,offset);
-
- draw_comp((11,2),0,(11,9),180,2,"1",1,offset);
- draw_comp_beginning((15,6),180,1,"1",1,offset);
- draw_comp_beginning((15,7),180,1,"1",1,offset);
-
- draw_comp_endpoint((18,19),180,offset);
- draw_comp_beginning((18,17),0,1.5,"1",1,offset);
- draw_comp_beginning((18,16),0,1.5,"1",1,offset);
- draw_comp_beginning((18,15),0,1.5,"1",1,offset);
-enddef;
-
-def muli_module(expr offset)=
- draw_module((0,0),(14,13),"muli",offset);
- draw_box((5,1),(11,6),"",offset);
- draw_label(8,5,"node",offset);
- draw_label(8,4,"beam",offset);
- draw_label(8,3,"samples",offset);
- draw_label(8,2,"dsigma",offset);
- draw_box((5,6),(11,8),"muli\_type",offset);
- draw_box((4,10),(12,12),"qcd\_2\_2\_type",offset);
- draw_extends((8,8),90,(8,10),90,1,offset);
-enddef;
-
-def mcint_module(expr offset)=
- draw_module((0,0),(16,27),"muli\_mcint",offset);
- draw_box((3,1),(13,3),"",offset);
- draw_label(8,2,"int\_kinds",offset);
- draw_box((3,3),(13,5),"sample\_inclusive\_type",offset);
-
- draw_box((3,7),(13,9),"sample\_int\_kind\_type",offset);
-
- draw_box((3,11),(13,13),"",offset);
- draw_label(8,12,"slices",offset);
- draw_box((3,13),(13,15),"sample\_3d\_type",offset);
-
- draw_box((3,17),(13,19),"",offset);
- draw_label(8,18,"regions",offset);
- draw_box((3,19),(13,21),"sample\_2d\_type",offset);
-
- draw_box((3,23),(13,25),"sample\_region\_type",offset);
-
- draw_comp((13,2),0,(13,8),180,2,"1..n",2,offset);
- draw_comp((13,12),0,(13,20),180,2,"1..n",2,offset);
- draw_comp((3,18),180,(3,24),0,2,"1..n",2,offset);
-
- draw_extends((8,9),90,(8,11),90,1,offset);
-enddef;
-
-def trapezium_module(expr offset)=
- draw_module((0,0),(30,18),"muli\_trapezium",offset);
- draw_box((1,3),(13,5),"muli\_trapezium\_list\_type",offset);
- draw_box((15,1),(27,3),"",offset);
- draw_label(21,2,"down",offset);
- draw_box((15,3),(27,5),"muli\_trapezium\_tree\_type",offset);
- draw_box((8,8),(20,11),"",offset);
- draw_label(14,9,"right",offset);
- draw_label(14,10,"left",offset);
-
- draw_box((8,11),(20,13),"muli\_trapezium\_node\_class",offset);
- draw_box((8,15),(20,17),"muli\_trapezium\_type",offset);
-
- draw_extends_endpoint((14,15),90,offset);
- draw_extends_line((14,13),90,1,offset);
- draw_extends_endpoint((14,8),90,offset);
- draw_extends_line ((7,5),90,1.5,offset);
- draw_extends_line ((21,5),90,1.5,offset);
-
- draw_comp_endpoint((20,12),180,offset);
- draw_comp_beginning ((27,2),0,1.5,"1",1,offset);
- draw_comp_beginning ((20,9),0,1.5,"1",1,offset);
- draw_comp_beginning ((20,10),0,1.5,"1",1,offset);
-enddef;
-
-def remnant_module(expr offset)=
- draw_module((0,0),(22,28),"muli\_remnant",offset);
- draw_box((4,1),(16,4),"",offset);
- draw_label(10,2,"pdf\_norm",offset);
- draw_label(10,3,"proton",offset);
- draw_box((4,4),(16,6),"muli\_pp\_remnant\_type",offset);
- draw_box((4,8),(16,13),"",offset);
- draw_label(10,9,"pdf\_norm",offset);
- draw_label(10,10,"twin\_partons",offset);
- draw_label(10,11,"fs\_partons",offset);
- draw_label(10,12,"is\_partons",offset);
- draw_box((4,13),(16,15),"muli\_proton\_remnant\_type",offset);
- draw_box((4,17),(16,20),"",offset);
- draw_label(10,18,"twin",offset);
- draw_label(10,19,"next",offset);
- draw_box((4,20),(16,22),"muli\_parton\_type",offset);
- draw_box((4,24),(16,26),"pdfnorm\_type",offset);
-
- draw_comp((4,3),180,(4,14),0,2,"2",1,offset);
- draw_comp((16,2),0,(16,25),180,2.5,"1",1,offset);
- draw_comp_beginning((16,9),0,2,"1",1,offset);
-
- draw_comp((16,19),0,(16,21),180,1,"0,1",2,offset);
- draw_comp_beginning((16,18),0,1,"0,1",2,offset);
- draw_comp_beginning((16,10),0,2,"1",1,offset);
- draw_comp_beginning((16,11),0,2,"1",1,offset);
- draw_comp_beginning((16,12),0,2,"1",1,offset);
-enddef;
-
-def interactions_module(expr offset)=
- draw_box((0,0),(12,2),"",offset);
- draw_box((0,2),(10,4),"interactions\_module",offset);
-enddef;
-
-beginfig(1)
- pair basic_offset,%
- cuba_offset,%
- remnant_offset,%
- mcint_offset,%
- momentum_offset,%
- aq_offset,%
- dsigma_offset,%
- trapezium_offset,%
- fibonacci_offset,%
- interactions_offset,%
- muli_offset;
- basic_offset=(20*xu,48*yu);
- cuba_offset=(0,30*yu);
- remnant_offset=(72*xu,31*yu);
- mcint_offset=(78*xu,0);
- momentum_offset=(53*xu,27*yu);
- aq_offset=(36*xu,34*yu);
- dsigma_offset=(36*xu,23*yu);
- trapezium_offset=(29*xu,0*yu);
- fibonacci_offset=(0,0);
- interactions_offset=(0,58*yu);
- muli_offset=(61*xu,0);
-
- pickup pencircle scaled 1.5;
-
- basic_module(basic_offset);
-
- interactions_module(interactions_offset);
- cuba_module(cuba_offset);
- fibonacci_module(fibonacci_offset);
-
- aq_module(aq_offset);
- dsigma_module(dsigma_offset);
- trapezium_module(trapezium_offset);
-
- momentum_module(momentum_offset);
- muli_module(muli_offset);
-
- remnant_module(remnant_offset);
- mcint_module(mcint_offset);
-
- path last_extends_path;
- last_extends_path=id_ser_path;
- fork_push_extends_line((20,10),-150,1,0.67,basic_offset);
- push_extends_line((-2,29),90,1,remnant_offset);
- push_extends_line((-2,0),90,1,remnant_offset);
- fork_extends_line((10,26),90,2,1,remnant_offset);
- fork_extends_line((10,22),90,2,25/29,remnant_offset);
- fork_extends_line((10,15),90,2,18/29,remnant_offset);
- fork_extends_line((10,7),90,1,13.5/29,momentum_offset);
- fork_extends_line((10,6),90,2,9/29,remnant_offset);
- push_extends_line((-2,17),110,1,mcint_offset);
- fork_extends_line((8,21),90,4,0.45,mcint_offset);
- fork_extends_line((8,15),90,3,0,mcint_offset);
- push_extends_line((3,6),180,1,mcint_offset);
- fork_extends_line((8,5),90,2,0,mcint_offset);
-
- path last_extends_path;
- last_extends_path=mae_ser_path;
- fork_push_extends_line((-4,4),90,1,0.5,basic_offset);
- push_extends_line((16,8),90,1,cuba_offset);
-
- draw_extends_endpoint((8,1),90,momentum_offset);
- draw_extends_line((10,12),90,1,muli_offset);
-
- draw_extends_endpoint((17,4),90,basic_offset);
- draw_extends_line((7,7),90,1,aq_offset);
-
- draw_extends_endpoint((7,2),90,aq_offset);
- draw_extends_line((10,6),90,1,dsigma_offset);
-
- draw_extends_endpoint((5,4),90,basic_offset);
- draw_extends_line((13,-11),90,1,basic_offset);
- push_extends_line((13,-23),90,1,basic_offset);
- fork_extends_line((13,20),90,1,0.5,fibonacci_offset);
- fork_extends_line((14,17),90,1,0,trapezium_offset);
-
- draw_comp_endpoint((6,10),0,basic_offset);
- draw_comp_beginning((8,14),180,1.2,"1",1,fibonacci_offset);
-
- draw_comp_endpoint((1,6),0,momentum_offset);
- draw_comp_beginning((13,2),0,1,"1",1,dsigma_offset);
-
- draw_comp_endpoint((23.7,2.5),90,cuba_offset);
- draw_comp_beginning((1,3),180,1.2,"1",1,dsigma_offset);
-
- draw_comp_endpoint((27,4),180,trapezium_offset);
- draw_comp_beginning((5,2),180,1,"1",1,muli_offset);
-
- draw_comp_endpoint((3,4),0,mcint_offset);
- draw_comp_beginning((11,3),0,1,"1",1,muli_offset);
-
- draw_comp_endpoint((20,12),180,trapezium_offset);
- draw_comp_beginning((5,4),180,1,"1",1,muli_offset);
-
- draw_comp_endpoint((4,5),0,remnant_offset);
- draw_comp_beginning((11,5),0,1.5,"1",1,muli_offset);
-
- draw_comp_endpoint((25,9),180,fibonacci_offset);
- push_comp_line((27,10),-90,1,fibonacci_offset);
- push_comp_line((27,20),-90,1,fibonacci_offset);
- push_comp_line((-2,-5),-90,1,aq_offset);
- push_comp_line((-2,1),-90,1,aq_offset);
- draw_comp_beginning((1,4),180,1,"1",1,aq_offset);
-
- draw_comp_endpoint((1,4),0,trapezium_offset);
- push_comp_line((-1,5),-90,1,trapezium_offset);
- push_comp_line((-1,19),-90,1,trapezium_offset);
- push_comp_line((-1,-6),-90,1,aq_offset);
- push_comp_line((-1,1),-90,1,aq_offset);
- draw_comp_beginning((1,3),180,1,"1",1,aq_offset);
-endfig;
-beginfig(2)
- basic_module((0,0));
-endfig;
-beginfig(3)
- aq_module((0,0));
-endfig;
-beginfig(4)
- dsigma_module((0,0));
-endfig;
-beginfig(5)
- trapezium_module((0,0));
-endfig;
-beginfig(6)
- momentum_module((0,0));
-endfig;
-beginfig(7)
- muli_module((0,0));
-endfig;
-beginfig(8)
- remnant_module((0,0));
-endfig;
-beginfig(9)
- mcint_module((0,0));
-endfig;
-beginfig(10)
- cuba_module((0,0));
-endfig;
-beginfig(11)
- fibonacci_module((0,0));
-endfig;
-beginfig(12)
- interactions_module((0,0));
-endfig;
-end;
Index: trunk/src/muli/doc/Baustelle.pdf
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: trunk/src/muli/doc/muli_dsigma.tex
===================================================================
--- trunk/src/muli/doc/muli_dsigma.tex (revision 8371)
+++ trunk/src/muli/doc/muli_dsigma.tex (revision 8372)
@@ -1,187 +0,0 @@
-\Module{muli\_dsigma}
-%\begin{figure}
-% \centering{\includegraphics{uml-module-tree-4.mps}}
-% \caption{\label{fig:\ThisModule:types}Klassendiagramm des Moduls \ThisModule}
-%\end{figure}
-Hier wird eine Approximation der Stammstrati $\mathcal{S}(\pperp)$ aus \eqref{eq:all:strati_root_def} bereitgestellt. Die Integrationen in \eqref{eq:imp:double_strati_int} werden mit der externen Bibliothek libcuba ausgewertet, die verbleibende Integration in \eqref{eq:all:strati_root_def} wird mit dem muli-eigenen Modul \ModuleRef{muli\_aq} ausgewertet.
-
-Zu Beginn hatte ich mit verschiedenen Darstellungen der Wirkungsquerschnitte und mit verschiedenen Integrationsparametern und verschiedenen Einteilungen in Strati experimentiert. Um Codevervielfältigung zu vermeiden hatte ich dann den Code für die Integration von den Wirkungsquerschnitten getrennt. Da die Wirkungsquerschnitte auf Parameter zugreifen müssen, die nicht fur alle Darstellungen gleich sind, konnte ich die Integraden nicht als Funktion an \TypeRef{aq\_class} übergeben. Stattdessen habe ich mich entschieden, die verschiedenen Varianten durch Überladen der Methode evaluate zu erzeugen. So konnten die Erweiterung von \TypeRef{aq\_class} komplett verschiedene Methoden zur Auswertung von \eqref{eq:imp:double_strati_int}, und dennoch dieselbe Quadratur für \eqref{eq:all:strati_root_def} verwenden. Heute ist nur noch eine einzige Erweiterung übrig, nämlich \TypeRef{muli\_dsigma\_type} in diesem Modul. Deswegen ist der Sinn zwischen der Aufteilung der Module \ModuleRef{muli\_aq} und \ModuleRef{muli\_dsigma} nicht mehr offensichtlich.
-\section{Abhängigkeiten}
-\use{muli\_momentum}
-\use{muli\_interactions}
-\use{muli\_cuba}
-\use{muli\_aq}
-\section{Parameter}
-\begin{Verbatim}
- \IC{Die Anzahl der Strati plus 1, für die Summe aller Strati.}
- integer,parameter,private::\MC{dim\_f}=17
-\end{Verbatim}
-\section{Derived Types}
-\TypeDef{muli\_dsigma\_type}
-Der Zweck von muli\_dsigma\_type liegt darin, die abstrakte Methode evaluate von \TypeRef{aq\_class} zu implementieren und so einen Integradem für die nummerische Integration bereitzustellen. Weiterhin stellt aq\_class die Methode \TbpRef{muli\_dsigma\_type}{generate} zur Verfügung, um die Integration zu starten.
-
-Für das setzten der Faktorisierungsskala wird eine eigene Instanz \CompRef{muli\_dsigma\_type}{pt} des Datentyps \TypeRef{transversal\_momentum\_type} verwendet. Eigen bedeutet, dass \CompRef{muli\_dsigma\_type}{pt} nicht mit der muli-Skala synchronisiert ist, denn diese Integration findet vor der Eventgenerierung mit MULI statt.
-
-\begin{Verbatim}
- type,public,\Extends{aq\_class} :: muli_dsigma_type
- private
- type(\TypeRef{transversal\_momentum\_type})::pt\TC{pt}
- type(\TypeRef{cuba\_divonne\_type}) :: cuba_int\TC{cuba\_int}
- contains
- \OverridesDeclaration{serializable\_class}
- procedure::\TbpDec{write\_to\_marker}{muli\_dsigma\_write\_to\_marker}
- procedure::\TbpDec{read\_from\_marker}{muli\_dsigma\_read\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{muli\_dsigma\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{muli\_dsigma\_get\_type}
- \OriginalDeclaration
- procedure :: \TbpDec{generate}{muli\_dsigma\_generate}
- procedure :: \TbpDec{evaluate}{muli\_dsigma\_evaluate}
- procedure :: muli_dsigma_initialize
- generic :: \TbpDec{initialize}{muli\_dsigma\_initialize}
- end type muli_dsigma_type
-\end{Verbatim}
-\Methods
-\MethodsFor{muli\_dsigma\_type}
-\TbpImp{muli\_dsigma\_write\_to\_marker}
-\begin{Verbatim}
- subroutine muli_dsigma_write_to_marker(this,marker,status)
- class(muli_dsigma_type), intent(in) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik), intent(out) :: status
- ! local variables
- class(serializable_class),pointer::ser
- call marker%mark_begin("muli_dsigma_type")
- call aq_write_to_marker(this,marker,status)
- call this%cuba_int%serialize(marker,"cuba_int")
- call marker%mark_end("muli_dsigma_type")
- end subroutine muli_dsigma_write_to_marker
-\end{Verbatim}
-
-\TbpImp{muli\_dsigma\_read\_from\_marker}
-\begin{Verbatim}
- subroutine muli_dsigma_read_from_marker(this,marker,status)
- class(muli_dsigma_type), intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik), intent(out) :: status
- ! local variables
- call marker%pick_begin("muli_dsigma_type",status=status)
- call aq_read_from_marker(this,marker,status)
- call this%cuba_int%deserialize("cuba_int",marker)
- call marker%pick_end("muli_dsigma_type",status)
- end subroutine muli_dsigma_read_from_marker
-\end{Verbatim}
-
-\TbpImp{muli\_dsigma\_print\_to\_unit}
-\begin{Verbatim}
- subroutine muli_dsigma_print_to_unit(this,unit,parents,components,peers)
- class(muli_dsigma_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- integer::ite
- if(parents>0)call aq_print_to_unit(this,unit,parents-1,components,peers)
- write(unit,'("Components of muli_dsigma_type")')
- if(components>0)then
- write(unit,fmt=*)"Printing components of cuba_int:"
- call this%cuba_int%print_to_unit(unit,parents,components-1,peers)
- else
- write(unit,fmt=*)"Skipping components of cuba_int:"
- end if
- end subroutine muli_dsigma_print_to_unit
-\end{Verbatim}
-\TbpImp{muli\_dsigma\_get\_type}
-\begin{Verbatim}
- pure subroutine muli_dsigma_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="muli_dsigma_type")
- end subroutine muli_dsigma_get_type
-\end{Verbatim}
-\TbpImp{muli\_dsigma\_generate}
-Initialisierung und Generierung der Stammstrati $\mathcal{S}$.
-
-
-Man kann eine Start-Segmentierung des Integrationsbereichs angeben. Dadurch kann die Integration erheblich beschleunigt werden. Wir wählen eine Segmentierung in \emph{initial\_values} so, dass $\mu_j=\mu_0\exp(j)$, solange $\mu_j<\sqrt{s}/2$ und nehmen als letzten Wert $\sqrt{s}/2$ hinzu.
-\begin{Verbatim}
- subroutine muli_dsigma_generate(this,gev2_scale_cutoff,gev2_s,int_tree)
- class(muli_dsigma_type),intent(inout)::this
- real(kind=drk),intent(in)::gev2_scale_cutoff,gev2_s
- type(muli_trapezium_tree_type),intent(out)::int_tree
- real(kind=drk),dimension(ceiling(log(gev2_s/gev2_scale_cutoff)/2D0))::initial_values
- integer::n
- \IC{Debugging}
- print *,gev2_s/gev2_scale_cutoff,ceiling(log(gev2_s/gev2_scale_cutoff)/2D0)
- \IC{Setzen der Start-Segmentierung}
- initial_values(1)=sqrt(gev2_scale_cutoff/gev2_s)*2D0
- do n=2,size(initial_values)-1
- initial_values(n)=initial_values(n-1)*euler
- end do
- initial_values(n)=1D0
- \IC{Debugging}
- print *,initial_values
- \IC{Wir geben dieser Instanz einen Namen und die Nummer 1.}
- call identified_initialize(this,one,"dsigma")
- \IC{Die Skala wird initialisiert.}
- call this%pt%initialize(gev2_s)
- \IC{Die Genauigkeit der Stammfunktion \eqref{eq:all:strati_root_def}}
- this%abs_error_goal = 0D0
- this%rel_error_goal=scale(1D0,-12)!-12
- this%max_nodes=1000
- \IC{Dimension und Genauigkeit der Integration \eqref{eq:imp:double_strati_int}}
- call this%cuba_int%set_common(&
- &dim_f=dim_f,&
- &dim_x=2,&
- &eps_rel=scale(this%rel_error_goal,-8),&!-8
- &flags = 0)
- \IC{Die ungefähre Position der Maxima des Integranden}
- call this%cuba_int%set_deferred&
- (xgiven_flat=[1D-2,5D-1+epsilon(1D0),1D-2,5D-1-epsilon(1D0)])
- print *,"muli_dsigma_generate:"
- print *,"Overall Error Goal: ",this%rel_error_goal
- \IC{Wir initialisieren die Integration mit der Start-Segmentierung}
- call this%init_error_tree(dim_f,initial_values)
- \IC{Die eigentliche Integration}
- call this%run()
- \IC{Konvertierung der internen Darstellung mittels \TypeRef{fibonacci\_root\_type}}
- \IC{in ein bessere Darstellung mittels \TypeRef{muli\_trapezium\_tree\_type}.}
- call this%integrate(int_tree)
- \IC{Aufräumen}
- call this%err_tree%deallocate_all()
- deallocate(this%err_tree)
- nullify(this%int_list)
- end subroutine muli_dsigma_generate
-\end{Verbatim}
-\TbpImp{muli\_dsigma\_evaluate}
-Die Wahl der Integrationsroutine und der Darstellung der Wirkungsquerschnitte.
-\begin{Verbatim}
- subroutine muli_dsigma_evaluate(this,x,y)
- class(muli_dsigma_type),intent(inout) :: this
- real(kind=double), intent(in) :: x
- real(kind=double), intent(out),dimension(:):: y
- call this%pt%set_unit_scale(x)
- call this%cuba_int%integrate_userdata(&
- interactions_proton_proton_integrand_param_17_reg,this%pt)
- call this%cuba_int%get_integral_array(y)
- end subroutine muli_dsigma_evaluate
-\end{Verbatim}
-\TbpImp{muli\_dsigma\_initialize}
-\begin{Verbatim}
- subroutine muli_dsigma_initialize(this,id,name,goal,max_nodes,dim,cuba_goal)
- class(muli_dsigma_type),intent(inout) :: this
- integer(kind=dik),intent(in)::id,max_nodes
- integer,intent(in)::dim
- character(*),intent(in)::name
- real(kind=double),intent(in)::goal,cuba_goal
- call identified_initialize(this,id,name)
- this%rel_error_goal = goal!1d-4
- this%max_nodes=max_nodes
- call this%cuba_int%set_common(&
- &dim_f=dim,&
- &dim_x=2,&
- &eps_rel=cuba_goal,&!1d-6
- &flags = 0)
- call this%cuba_int%set_deferred&
- (xgiven_flat=[1D-2,5D-1+epsilon(1D0),1D-2,5D-1-epsilon(1D0)])
- call this%init_error_tree(dim,(/8D-1/7D3,2D-3,1D-2,1D-1,1D0/))
- this%is_deferred_initialised = .true.
- end subroutine muli_dsigma_initialize
-\end{Verbatim}
-
Index: trunk/src/muli/doc/definitions.sty
===================================================================
--- trunk/src/muli/doc/definitions.sty (revision 8371)
+++ trunk/src/muli/doc/definitions.sty (revision 8372)
@@ -1,95 +0,0 @@
-\definecolor{dred}{RGB}{100,1,0}
-\definecolor{dgreen}{RGB}{0,100,0}
-\definecolor{dblue}{RGB}{0,0,100}
-
-%\def\url@myurlstyle{%
-%\def\UrlFont{\sffamily}
-%\def\UrlColor{silver-blue}}
-%\urlstyle{myurl}
-\hypersetup{
- pdftitle={MulI Manual}, %%
- pdfauthor={Hans-Werner Boschmann}, %%
- pdfsubject={MulI Manual}, %%
- pdfcreator={LaTeX2e and pdfLaTeX with hyperref-package.},
- pdfproducer={}, %%
- pdfkeywords={},%%
- pdfhighlight=/O,
- colorlinks=true,
- urlcolor=yellow,
- linkcolor=dgreen,
- urlbordercolor=green,
- linkbordercolor=green,
- menubordercolor=green,
-}
-
-\DeclareMathOperator{\hard}{hard}
-\DeclareMathOperator{\cart}{cart}
-\DeclareMathOperator{\hyp}{hyp}
-\DeclareMathOperator{\der}{d}
-\DeclareMathOperator{\nd}{nd}
-%\DeclareMathOperator{\dim}{dim}
-\newcommand{\ThisModule}{none}
-\newcommand{\ThisType}{none}
-\newcommand{\mean}[1]{\ensuremath{\left<#1\right>}}
-\newcommand{\pperp}{p_{\!\perp}}
-
-\newcommand{\wip}[1]{\framebox[\textwidth]{\parbox{0.98\textwidth}{#1}}{\marginpar{\raisebox{-1em}{\includegraphics[scale=0.05]{Baustelle.pdf}}}\linebreak}
-}
-
-\newcommand{\mip}[1]{\framebox[\textwidth]{%
-\parbox{0.98\textwidth}{#1}%
-}\marginpar{\raisebox{-1em}{\includegraphics[scale=0.05]{Schleudergefahr.pdf}}}%
-\linebreak}
-
-
-\newcommand{\wa}[1]{\framebox{\parbox{0.98\textwidth}{#1}}\marginpar{\includegraphics[scale=0.05]{Spurwechsel.pdf}}\linebreak}
-
-\newcommand{\hack}[1]{\framebox{\parbox{0.98\textwidth}{#1}}\marginpar{\includegraphics[scale=0.5]{uneben.pdf}}\linebreak}
-\newcommand{\TbpDec}[2]{\hypertarget{TBP:#1:\ThisType}{#1}\hypertarget{TBP:#2}{}=>\hyperlink{PROC:#2}{#2}\index{Type bound procedures!#1!\ThisType}}
-\newcommand{\TbpDecS}[1]{\hypertarget{TBP:#1:\ThisType}{#1}\hypertarget{TBP:#1}{}\index{Type bound procedures!#1!\ThisType}}
-\newcommand{\TbpGen}[2]{\hypertarget{TBP:#1:\ThisType}{#1}=>#2
-\index{Type bound procedures!#1!\ThisType}}
-\newcommand{\TbpDef}[1]{#1}
-\newcommand{\TbpImp}[1]{\hypertarget{PROC:#1}{{\bfseries#1 }}\hyperlink{TBP:#1}{$\uparrow$}\index{Prozeduren!#1}
-
-}
-\newcommand{\ProcImp}[1]{\hypertarget{PROC:#1}{{\bfseries#1 }}\index{Prozeduren!#1}
-
-}
-\newcommand{\TbpRef}[2]{\hyperlink{TBP:#2:#1}{#1\%#2}}
-\newcommand{\ThisTbpRef}[1]{\hyperlink{TBP:#1:\ThisType}{#1}}
-\newcommand{\ProcRef}[1]{\hyperlink{PROC:#1}{#1}}
-\newcommand{\TypeDef}[1]{%
- \subsection{#1}\hypertarget{TYPE:#1}{}%
- \index{Derived Types!#1}%
- \renewcommand{\ThisType}{#1}}
-\newcommand{\TypeRef}[1]{\hyperlink{TYPE:#1}{#1}}
-\newcommand{\CompDef}[2]{\hypertarget{COMP:#2:#1}{}\index{Komponenten!#2!#1}}
-\newcommand{\CompRef}[2]{\hyperlink{COMP:#2:#1}{#1\%#2}}
-\newcommand{\OverridesDeclaration}[1]{\IC{Überschriebene \hyperlink{TYPE:#1}{#1} Methoden}}
-\newcommand{\OriginalDeclaration}{\IC{Originäre \hyperlink{TYPE:\ThisType}{\ThisType} Methoden}}
-\newcommand{\OverridesSection}[1]{\subsubsection[Überschriebene #1 Methoden]{Überschriebene \hyperlink{TYPE:#1}{#1} Methoden}}
-\newcommand{\OriginalSection}[1]{\subsubsection[Originäre #1 Methoden] {Originäre \TypeRef{#1} Methoden}}
-\newcommand{\Module}[1]{%
-\chapter{Modul #1}%
-\hypertarget{mod:#1}{}%
-\index{Module!#1}%
-\renewcommand{\ThisModule}{#1}%
-}
-\newcommand{\Methods}{\section{Implementierung der Prozeduren}}
-
-\newcommand{\MethodsFor}[1]{\subsection[Methoden für #1]{Methoden für \TypeRef{#1}}\renewcommand{\ThisType}{#1}}
-\newcommand{\MethodsNTB}{\subsection{Sonstige Prozeduren}}
-\newcommand{\ModuleRef}[1]{\hyperlink{mod:#1}{#1}}
-
-\newcommand{\use}[1]{\LocalVar{ use \ModuleRef{#1}}\newline}
-\newcommand{\usenodep}[1]{\LocalVar{ use #1 !NODEP!}\\}
-\newcommand{\useintrinsic}[1]{\LocalVar{ use,intrinsic::#1}\\}
-\newcommand{\LocalVar}[1]{\texttt{\color{verbcolor}{#1}}}
-\newcommand{\MC}[1]{\hypertarget{COMP:#1:\ThisModule}{#1}\index{Komponenten!#1!\ThisModule}}
-\newcommand{\TC}[1]{\hypertarget{COMP:#1:\ThisType}{#1}\index{Komponenten!#1!\ThisType}}
-\definecolor{verbcolor}{RGB}{0,0,100}
-\definecolor{commentcolor}{RGB}{100,0,0}
-\RecustomVerbatimEnvironment{Verbatim}{Verbatim}{formatcom=\color{verbcolor},commandchars=\\\{\}}
-\newcommand{\IC}[1]{\color{commentcolor}{!#1}}
-\newcommand{\Extends}[1]{extends(\hyperlink{TYPE:#1}{#1})}
Index: trunk/src/muli/doc/muli_remnant.tex
===================================================================
--- trunk/src/muli/doc/muli_remnant.tex (revision 8371)
+++ trunk/src/muli/doc/muli_remnant.tex (revision 8372)
@@ -1,1960 +0,0 @@
-\Module{muli\_remnant}
-\section{Allgemeines}
-\subsection{Zweck}
-\begin{figure}
- \centering{\includegraphics{uml-module-tree-8.mps}}
-% \caption{\label{fig:\ThisModule:Types}Klassendiagramm des Moduls}
-\end{figure}
-Das Modul muli\_remnant enthält die vollständige Beschreibung der Remnants. Bislang sind die ursprünglichen Hadronen fest auf Protonen implementiert, allerdings sind Verallgemeinerungen auf größere Klassen teilweise vorbereitet.
-\subsection{Voraussetzungen}
-Nicht in diesem Modul enthalten sind:
-\begin{itemize}
-\item Die ursprünglichen Strukturfunktionen der ungestörten Hadronen
-
-Diese werden für die Definition der Remnant-PDFs verwendet. Verschiedene PDF-Sets können daher auch zu verschiedene Remnant-PDFs führen. Im Moment werden die LHAPDF-Bibliotheken verwendet. muli\_remnant verlässt sich darauf, dass diese bereits initialisiert sind und initialisiert sie nicht selbst.
-
-In \TbpRef{pp\_remnant\_type}{initialize} werden zwar alle notwendigen LHAPDF Informationen, also Unix-Verzeichnis, Dateiname und Member, entgegengenommen. Diese werden aber nur verwendet, um die passenden integrierten PDFs \CompRef{pp\_remnant\_type}{pdf\_norm} zu deserialisieren.
-
-Es wird das Modul pdf\_builtin eingebunden, aber im aktuellen Status nicht verwendet.
-
-\item muli\_interactions
-\end{itemize}
-\subsection{Schnittstelle}
-Die meisten Typen und Prozeduren in diesem Modul sind nur für interne Zwecke vorgesehen. Der erweiterte Datentyp \TypeRef{muli\_pp\_remnant\_type} wurde eigens implementiert, um als Schnittstelle nach außen zu dienen. Er enthält zwei Instanzen vom Typ \TypeRef{muli\_proton\_remnant\_type} und abstrahiert auf diese Weise die einzelnen Hadron-Remnants. Deshalb sollte es auch ohne Änderung der Schnittstelle möglich sein, andere Hadron-Remnants zu realisieren. \TypeRef{muli\_pp\_remnant\_type} enthält Wrapper-Methoden für alle momentan benötigten Informationen. Von \TypeRef{muli\_type} werden verwendet:
-\begin{itemize}
-\item \TbpRef{pp\_remnant\_type}{initialize}
-\item \TbpRef{pp\_remnant\_type}{finalize}
-\item \TbpRef{pp\_remnant\_type}{reset}
-\item \TbpRef{pp\_remnant\_type}{replace\_parton}
-\item \TbpRef{pp\_remnant\_type}{apply\_interaction}
-\item \TbpRef{pp\_remnant\_type}{apply\_initial\_interaction}
-\item \TbpRef{pp\_remnant\_type}{momentum\_pdf}
-\item \TbpRef{pp\_remnant\_type}{parton\_pdf}
-\item \TbpRef{pp\_remnant\_type}{get\_pdf\_int\_weights}
-\end{itemize}
-Zusammen mit den überladenen Standardmethoden der Klasse \TypeRef{serializable\_class}
-\begin{itemize}
-\item \TbpRef{pp\_remnant\_type}{write\_to\_marker}
-\item \TbpRef{pp\_remnant\_type}{read\_from\_marker}
-\item \TbpRef{pp\_remnant\_type}{print\_to\_unit}
-\item \TbpRef{pp\_remnant\_type}{get\_type}
-\end{itemize}
-ergeben diese Methoden eine vollständige Schnittstelle für die Remnants. Konsequenterweise sollten alle Modul-Komponenten, alle Modul-Prozeduren und alle bis auf die erwähnten Type-Bound-Prozeduren als privat deklariert werden. Derzeit sind die Prozeduren nur deshalb public, um das Debugging zu erleichtern.
-\subsection{Datentypen}
-Alle Datentypen sind Erweiterungen von \TypeRef{serializable\_class}.
-\begin{itemize}
- \item \TypeRef{pdfnorm\_type}:
-
- Für die Berechnung der Wichtungsfaktoren $W_k$ für die einzelnen Beiträge $f_k(x,\mu_F)$ zur Remnant-Strukturfunktion ist nicht die volle Information $f_k(x,\mu_F)$ notwendig. Es reicht aus, den Impulsmittelwert $\mean{f_k(\mu_F)}=\int_{x=x_0}^{1}xf_k(x,\mu_F)$ zu kennen. \TypeRef{pdfnorm\_type} liefert eben diesen Impulsmittelwert. Außerdem enthält \TypeRef{pdfnorm\_type} die Summe über alle Impulsmittelwerte. Idealerweise sollte diese Summe geich Eins sein. Damit aber Abweichungen von Eins die Summenregel \eqref{eq:all:rem:sumrule} nicht beeinflussen, werden alle Impulserwartungswerte auf die Summe normiert, daher auch der Name pdfnorm\_type\footnote{hängt stark von den Integrationsparametern ab, bei exakterer Integration scheint der Fehler beliebig klein zu werden, dadurch wird die CPU-Last aber zu groß. Renormierung ist eine deutlich billigere Methode. In den aktuellen Einstellung mit einer gut angepassten Verteilung von $10^7$ Stützstellen ist die Abweichung mit $<10^{-4}$ eigentlich irrelevant, dafür dauert es einige Minuten, bis alle Integrationen fertig sind.}.
-
-\item \TypeRef{parton\_type}:
-
- Für die Berechnung der Wichtungsfaktoren ist es weiterhin notwendig zu wissen, welche Partonen bereits aus dem Remnant entnommen wurden. \TypeRef{parton\_type} ist eine Liste von eben diesen Partonen. Für Seequarks ist es außerdem wichtig, die Eigenschaften des Splittingpartners aus dem $g\rightarrow q_Sq_Q$ Gluonsplitting zu kennen. \TypeRef{parton\_type} enthält folglich einen Zeiger \CompRef{parton\_type}{twin} auf das jeweils andere Quark eines solchen Splittings
-
-\item \TypeRef{proton\_remnant\_type}:
-
- Container für alle Eigenschaften eines Proton-Remnants und für spezifische Methoden zur Bestimmung der Wichtungsfaktoren für Proton-Remnants.
-
-\item \TypeRef{pp\_remnant\_type}:
-
- Abstrahierung der beiden Remnants und Schnittstelle für das Modul.
-\end{itemize}
-
-
-
-\section{Abhängigkeiten}
- \useintrinsic{iso\_fortran\_env}
- \usenodep{pdf\_builtin}
- \usenodep{tao\_random\_numbers}
- \use{muli\_basic}
- \use{muli\_interactions}
- \use{muli\_momentum}
-
-\section{Parameter}
-\CompRef{muli\_remnant}{nx} und \CompRef{muli\_remnant}{nq} sind Parameter fur die Approximation von $\mean{f_k(\mu)}$. nx ist die Zahl der Stützstellen für $x$ und nq ist die Zahl der Stützstellen für $\mu_F=Q$, bei denen $f_k(x,\mu_F)$ dafür ausgewertet wird. Da über $x$ integriert wird, nehmen die Werte für $x$ keinen Speicher in Anspruch, sondern nur CPU-Zeit. Die Werte für $\mu_F$ werden hingegen gespeichert.
-
-\CompRef{muli\_remnant}{remnant\_weight\_model} und \CompRef{muli\_remnant}{gluon\_exp} sind Modellparameter für die Behandlung der Remnants. remnant\_weight\_model gibt an, wie die Wichtungsfaktoren durch die einzige Bedingung \eqref{eq:all:rem:sumrule} ausgedrückt werden. In Tabelle \ref{tab:all:rem:weight_models} ist eine Übersicht angegeben. In \TbpRef{proton\_remnant\_type}{calculate\_weight} werden die Wichtungsfaktoren bestimmt.
-
-gluon\_exp ist ein Parameter für die Approximation der Quasivalenzquarkbeiträge, siehe \ProcRef{remnant\_gluon\_pdf\_approx}
-\begin{Verbatim}
- implicit none
- integer,parameter::\MC{nx}=10000000
- integer,parameter::\MC{nq}=60
- integer,public::\MC{remnant\_weight\_model}=2
- integer::\MC{gluon\_exp}=4
-\end{Verbatim}
-
-\section{Derived Types}
-\TypeDef{pdfnorm\_type}
-pdfnorm\_type approximiert die Impulserwartungswerte $\mean{f_k(\mu)}=\int_{x=x_0}^{1}xf_k(x,\mu)$ aller Beiträge $k$ zur Strukturfunktion. pdfnorm\_type hat nur zwei neue Methoden, scan und get\_norm. scan Wertet $f_k(x,\mu)$ an allen $nx\otimes nq$ Stellen für alle 13 Einträge der LHAPDF-Sets aus und bestimmt daraus die Werte
-\begin{equation}
- \text{pdf\_norm}(\mu)=\left[\mean{f_\Sigma(\mu)},\frac{\mean{f_g(\mu)}}{\mean{f_\Sigma(\mu)}},\frac{\mean{f_{s}(\mu)}}{\mean{f_\Sigma(\mu)}},\frac{\mean{f_{d^v}(\mu)}}{\mean{f_\Sigma(\mu)}},\frac{\mean{f_{u^v}(\mu)}}{\mean{f_\Sigma(\mu)}}\right]
-\end{equation}
-für nq verschiedene Werte von $\mu_F$. $\mean{f_\Sigma(\mu)}$ bezeichnet die Summe über die Impulsmittelwerte aller 13 Einträge der LHAPDF-Sets. pdf\_int$(k,\mu_F)=\mean{f_k(\mu_F)}, k=$LHAPDF-Flavor, ist ein Zwischenschritt und wird eigentlich nicht benötigt, sobald pdf\_norm bestimmt ist. pdf\_int kann also gefahrlos von der Liste der Komponenten entfernt werden. Es wird nur zu Debugging-Zwecken mitgeführt.
-
-\mip{\CompRef{pdfnorm\_type}{qmin}, \CompRef{pdfnorm\_type}{qmax} und \CompRef{pdfnorm\_type}{dq} legen die Abbildung $j=1..nq\rightarrow \mu_j$ fest, wobei $j$ der zweite Index von pdf\_int bzw. pdf\_norm ist. Allerdings tragen sie die etwas unübliche Einheit $\sqrt{GeV}$. Es gilt:
- \begin{equation}
- \mu_j=\big(qmin + j\ dq\big)^2
- \end{equation}}
-
-\begin{Verbatim}
- type,\Extends{serializable\_class}::pdfnorm_type
- real(kind=double)::\TC{qmin},\TC{qmax},\TC{dq}
- real(kind=double),dimension(-6:6,0:nq)::\TC{pdf\_int}
- real(kind=double),dimension(0:4,0:nq)::\TC{pdf\_norm}
- contains
- \OverridesDeclaration{serializable\_class}
- procedure::\TbpDec{write\_to\_marker}{pdfnorm\_write\_to\_marker}
- procedure::\TbpDec{read\_from\_marker}{pdfnorm\_read\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{pdfnorm\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{pdfnorm\_get\_type}
- procedure,nopass::\TbpDec{verify\_type}{pdfnorm\_verify\_type}
- \OriginalDeclaration
- procedure::\TbpDec{scan}{pdfnorm\_scan}
- procedure::\TbpDec{get\_norm}{pdfnorm\_get\_norm}
- end type pdfnorm_type
-\end{Verbatim}
-\TypeDef{parton\_type}
-parton\_type ist eine Liste von Partonen. Jedes Parton bekommt eine eindeutige \CompRef{parton\_type}{id}, die mit der id des ISR-Algorithmus übereinstimmt. So können sich ISR und MPI miteinander verständigen, mit welchem Parton etwas geschieht.
-
-\CompRef{parton\_type}{lha\_flavor} ist das Flavor des Partons im LHA-Schema
-
-\mip{Handelt es sich nicht um ein Quasivalenzquark, dann ist \CompRef{parton\_type}{momentum} der Impulsanteil $\xi$, bezogen auf den aktuellen Remnantimpuls, des Partons. Bei einem Quasivalenzquark hingegen ist \CompRef{parton\_type}{momentum} der ungewichtete Impulserwartungswert des Quasivalenzquarks.}
-
-\CompRef{parton\_type}{twin} ist nur von Bedeutung, wenn das Parton ein Seequark oder ein Quasivalenzquark ist. Dann ist twin der Spittingpartner des vorangegangenen Gluonsplittings.
-
-\CompRef{parton\_type}{next} ist das nächste Parton in der Liste.
-\begin{Verbatim}
- type,Extends{serializable\_class}::parton_type
- private
- integer::\TC{id}=-1
- integer::\TC{lha\_flavor}
- real(kind=double)::\TC{momentum}=-1D0
- class(\TypeRef{parton\_type}),pointer::\TC{twin}=>null()
- class(\TypeRef{parton\_type}),pointer::\TC{next}=>null()
- contains
- \OverridesDeclaration{serializable\_class}
- procedure::\TbpDec{write\_to\_marker}{parton\_write\_to\_marker}
- procedure::\TbpDec{read\_from\_marker}{parton\_read\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{parton\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{parton\_get\_type}
- \OriginalDeclaration
- procedure::\TbpDec{unweighted\_pdf}{twin\_unweighted\_pdf}
- procedure::\TbpDec{deallocate}{twin\_deallocate}
- procedure::\TbpDec{push}{parton\_push}
- procedure::\TbpDec{pop\_by\_id}{parton\_pop\_by\_id}
- procedure::\TbpDec{pop\_by\_association}{parton\_pop\_by\_association}
- generic::\TbpGen{pop}{pop\_by\_id,pop\_by\_association}
- end type parton_type
-\end{Verbatim}
-\TypeDef{proton\_remnant\_type}
-proton\_remnant\_type enthält den aktuellen Status eines Proton-Remnants. Das sind
-
-die Anzahl der jeweiligen Valenzquarks \CompRef{proton\_remnant\_type}{valence\_content},
-
-die Anzahl aller Quasivalenzquarks \CompRef{proton\_remnant\_type}{n\_twins},
-
-die aktuellen Wichtungsfaktoren \CompRef{proton\_remnant\_type}{pdf\_int\_weight} (siehe \eqref{eq:all:rem:sumrule}),
-
-den Remnantimpuls dividiert durch den ursprünglichen Protonimpuls \CompRef{proton\_remnant\_type}{momentum\_fraction},
-
-die Summe der ungewichteten Impulsmittelwerte der Quasivalenzquarks \CompRef{proton\_remnant\_type}{twin\_norm},
-
-die Liste der Quasivalenzquarks im Remnant \CompRef{proton\_remnant\_type}{twin\_partons},
-
-die Liste der aktiven Initial State Partonen \CompRef{proton\_remnant\_type}{is\_partons},
-
-die Liste der aktiven Final State Partonen \CompRef{proton\_remnant\_type}{fs\_partons}
-
-sowie eine redundante Referenz auf die integrierten LHAPDFs \CompRef{proton\_remnant\_type}{pdf\_norm}.
-Redundant bedeutet, dass mehrere Instanzen einen Zeiger auf dasselbe Ziel haben. Die Allokierung der pdf\_norm wird einer Instanz des Datentyps \TypeRef{pp\_remnant\_type} durchgeführt. Nur diese Instanz sollte auch die Deallokierung durchführen.
-\begin{Verbatim}
- type,\Extends{serializable\_class}::proton_remnant_type
- integer,dimension(2)::\TC{valence\_content}=[1,2]
- integer::\TC{n\_twins}=0
- ![gluon,sea quark,valence down,valence up,twin]
- real(kind=drk),dimension(5)::\TC{pdf\_int\_weight}=[1D0,1D0,1D0,1D0,0D0]
- real(kind=drk)::\TC{momentum\_fraction}=1D0
- real(kind=double)::\TC{twin\_norm}=0D0
- type(\TypeRef{parton\_type})::\TC{twin\_partons}
- type(\TypeRef{parton\_type})::\TC{is\_partons}
- type(\TypeRef{parton\_type})::\TC{fs\_partons}
- ! these pointers shall not be allocated, deallocated, serialized or
- ! deserialized explicitly.
- class(\TypeRef{pdfnorm\_type}),pointer::\TC{pdf\_norm}=>null()
- contains
- \OverridesDeclaration{serializable\_class}
- procedure::\TbpDec{write\_to\_marker}{proton\_remnant\_write\_to\_marker}
- procedure::\TbpDec{read\_from\_marker}{proton\_remnant\_read\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{proton\_remnant\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{proton\_remnant\_get\_type}
- \OriginalDeclaration
- ! manipulating parton content
- procedure::\TbpDec{remove\_valence\_quark}{proton\_remnant\_remove\_valence\_quark}
- procedure::\TbpDec{remove\_sea\_quark}{proton\_remnant\_remove\_sea\_quark}
- procedure::\TbpDec{remove\_gluon}{proton\_remnant\_remove\_gluon}
- procedure::\TbpDec{remove\_valence\_up\_quark}{proton\_remnant\_remove\_valence\_up\_quark}
- procedure::\TbpDec{remove\_valence\_down\_quark}{proton\_remnant\_remove\_valence\_down\_quark}
- procedure::\TbpDec{remove\_twin}{proton\_remnant\_remove\_twin}
- ! getting pdf
- procedure::\TbpDec{momentum\_twin\_pdf}{proton\_remnant\_momentum\_twin\_pdf}
- procedure::\TbpDec{momentum\_twin\_pdf\_array}{proton\_remnant\_momentum\_twin\_pdf\_array}
- procedure::\TbpDec{momentum\_kind\_pdf}{proton\_remnant\_momentum\_kind\_pdf}
- procedure::\TbpDec{momentum\_flavor\_pdf}{proton\_remnant\_momentum\_flavor\_pdf}
- procedure::\TbpDec{momentum\_kind\_pdf\_array}{proton\_remnant\_momentum\_kind\_pdf\_array}
- procedure::\TbpDec{momentum\_flavor\_pdf\_array}{proton\_remnant\_momentum\_flavor\_pdf\_array}
- procedure::\TbpDec{parton\_twin\_pdf}{proton\_remnant\_parton\_twin\_pdf}
- procedure::\TbpDec{parton\_twin\_pdf\_array}{proton\_remnant\_parton\_twin\_pdf\_array}
- procedure::\TbpDec{parton\_kind\_pdf}{proton\_remnant\_parton\_kind\_pdf}
- procedure::\TbpDec{parton\_flavor\_pdf}{proton\_remnant\_parton\_flavor\_pdf}
- procedure::\TbpDec{parton\_kind\_pdf\_array}{proton\_remnant\_parton\_kind\_pdf\_array}
- procedure::\TbpDec{parton\_flavor\_pdf\_array}{proton\_remnant\_parton\_flavor\_pdf\_array}
- ! getting components
- procedure::\TbpDec{get\_pdf\_int\_weight}{proton\_remnant\_get\_pdf\_int\_weight}
- procedure::\TbpDec{get\_valence\_down\_weight}{proton\_remnant\_get\_valence\_down\_weight}
- procedure::\TbpDec{get\_valence\_up\_weight}{proton\_remnant\_get\_valence\_up\_weight}
- procedure::\TbpDec{get\_valence\_weight}{proton\_remnant\_get\_valence\_weight}
- procedure::\TbpDec{get\_gluon\_weight}{proton\_remnant\_get\_gluon\_weight}
- procedure::\TbpDec{get\_sea\_weight}{proton\_remnant\_get\_sea\_weight}
- procedure::\TbpDec{get\_twin\_weight}{proton\_remnant\_get\_twin\_weight}
- procedure::\TbpDec{get\_valence\_content}{proton\_remnant\_get\_valence\_content}
- procedure::\TbpDec{get\_momentum\_fraction}{proton\_remnant\_get\_momentum\_fraction}
- ! misc
- procedure::\TbpDec{deallocate}{proton\_remnant\_deallocate}
- procedure::\TbpDec{initialize}{proton\_remnant\_initialize}
- procedure::\TbpDec{finalize}{proton\_remnant\_finalize}
- procedure::\TbpDec{apply\_initial\_splitting}{proton\_remnant\_apply\_initial\_splitting}
- procedure::\TbpDec{reset}{proton\_remnant\_reset}
- ! private
- procedure,private::\TbpDec{calculate\_weight}{proton\_remnant\_calculate\_weight}
- procedure,private::\TbpDec{push\_is\_parton}{proton\_remnant\_push\_is\_parton}
- procedure,private::\TbpDec{push\_twin}{proton\_remnant\_push\_twin}
- procedure,private::\TbpDec{calculate\_twin\_norm}{proton\_remnant\_calculate\_twin\_norm}
- procedure,private::\TbpDec{replace\_is\_parton}{proton\_remnant\_replace\_is\_parton}
- ! plots
- procedure::\TbpDec{gnuplot\_momentum\_kind\_pdf\_array}{proton\_remnant\_gnuplot\_momentum\_kind\_pdf\_array}
- end type proton_remnant_type
-\end{Verbatim}
-\TypeDef{pp\_remnant\_type}
-pp\_remnant\_type abstrahiert die einzelnen Hadron-Remnants und dient als Schnittstelle für das komplette Modul. Aus anderen Modulen heraus sollen keine anderen Methoden, als die hier definierten, aufgerufen werden. Deswegen hat pp\_remnant\_type als einziger Datentyp in diesem Modul eine Komponente "`initialized"', so dass eine Warnung ausgegeben werden kann, wenn ein Zugriff auf nichtinitialisierte Komponenten versucht wird.
-
-\wip{\CompRef{pp\_remnant\_type}{gev\_cme\_tot} soll die aktuelle invariante Masse des hadronischen Systems zurückgeben. Dynamische invariante Massen sind aber noch nicht implementiert. \CompRef{pp\_remnant\_type}{X} ist die aktuelle invariante Masse dividiert durch die ursprüngliche invariante Masse des Proton-Proton-Systems, allerdings wird diese Variable (noch) nirgends verwendet.}
-
-\CompRef{pp\_remnant\_type}{proton} sind die beiden Proton-Remnants.
-
-\CompRef{pp\_remnant\_type}{pdfnorm\_type} sind die Impulsmittelwerte der PDFs.
-\begin{Verbatim}
- type,Extends{serializable\_class}::pp_remnant_type
- logical::\TC{initialized}=.false.
- real(kind=double),private::\TC{gev\_initial\_cme} = gev_cme_tot
- real(kind=double),private::\TC{X}=1D0
- type(\TypeRef{proton\_remnant\_type}),dimension(2)::\TC{proton}
- class(\TypeRef{pdfnorm\_type}),pointer,private::\TC{pdf\_norm}
- contains
- \OverridesDeclaration{serializable\_class}
- procedure::\TbpDec{write\_to\_marker}{pp\_remnant\_write\_to\_marker}
- procedure::\TbpDec{read\_from\_marker}{pp\_remnant\_read\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{pp\_remnant\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{pp\_remnant\_get\_type}
- \OriginalDeclaration
- ! init /final
- procedure::\TbpDec{initialize}{pp\_remnant\_initialize}
- procedure::\TbpDec{finalize}{pp\_remnant\_finalize}
- procedure::\TbpDec{reset}{pp\_remnant\_reset}
- ! manipulating parton content
- procedure::\TbpDec{apply\_initial\_interaction}{pp\_remnant\_apply\_initial\_interaction}
- procedure::\TbpDec{replace\_parton}{pp\_remnant\_replace\_parton}
- procedure::\TbpDec{apply\_interaction}{pp\_remnant\_apply\_interaction}
- ! getting pdfs
- procedure::\TbpDec{momentum\_pdf}{pp\_remnant\_momentum\_pdf}
- procedure::\TbpDec{parton\_pdf}{pp\_remnant\_parton\_pdf}
- procedure::\TbpDec{get\_proton\_remnant\_momentum\_fractions}{pp\_remnant\_get\_proton\_remnant\_momentum\_fractions}
- procedure::\TbpDec{get\_remnant\_parton\_flavor\_pdf\_arrays}{pp\_remnant\_get\_remnant\_parton\_flavor\_pdf\_arrays}
- ! getting components
- procedure::\TbpDec{get\_pdf\_int\_weights}{pp\_remnant\_get\_pdf\_int\_weights}
- procedure::\TbpDec{get\_pdf\_int\_weight}{pp\_remnant\_get\_pdf\_int\_weight}
- procedure::\TbpDec{set\_pdf\_weight}{pp\_remnant\_set\_pdf\_weight}
- procedure::\TbpDec{get\_gev\_initial\_cme}{pp\_remnant\_get\_gev\_initial\_cme}
- procedure::\TbpDec{get\_gev\_actual\_cme}{pp\_remnant\_get\_gev\_actual\_cme}
- procedure::\TbpDec{get\_cme\_fraction}{pp\_remnant\_get\_cme\_fraction}
- procedure::\TbpDec{get\_proton\_remnants}{pp\_remnant\_get\_proton\_remnants}
- end type pp_remnant_type
-\end{Verbatim}
-\section{Implementierung der Methoden}
-\MethodsFor{pdfnorm\_type}
-\TbpImp{pdfnorm\_write\_to\_marker}
-\begin{Verbatim}
- subroutine pdfnorm_write_to_marker(this,marker,status)
- class(pdfnorm_type),intent(in)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("pdfnorm_type")
- call marker%mark("qmin",this%qmin)
- call marker%mark("qmax",this%qmax)
- call marker%mark("dq",this%dq)
- call marker%mark("pdf_int",this%pdf_int)
- call marker%mark("pdf_norm",this%pdf_norm)
- call marker%mark_end("pdfnorm_type")
- end subroutine pdfnorm_write_to_marker
-\end{Verbatim}
-
-\TbpImp{pdfnorm\_read\_from\_marker}
-\begin{Verbatim}
- subroutine pdfnorm_read_from_marker(this,marker,status)
- class(pdfnorm_type),intent(out)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- character(:),allocatable::name
- call marker%pick_begin("pdfnorm_type",status=status)
- call marker%pick("qmin",this%qmin,status)
- call marker%pick("qmax",this%qmax,status)
- call marker%pick("dq",this%dq,status)
- call marker%pick("pdf_int",this%pdf_int,status)
- call marker%pick("pdf_norm",this%pdf_norm,status)
- call marker%pick_end("pdfnorm_type",status=status)
- end subroutine pdfnorm_read_from_marker
-\end{Verbatim}
-\TbpImp{pdfnorm\_print\_to\_unit}
-\begin{Verbatim}
- recursive subroutine pdfnorm_print_to_unit(this,unit,parents,components,peers)
- class(pdfnorm_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- write(unit,'("Components of pdfnorm_type:")')
- write(unit,'("qmin: ",F7.6)')this%qmin
- write(unit,'("qmax: ",F7.6)')this%qmax
- write(unit,'("dq: ",F7.6)')this%dq
- if(components>0)then
- write(unit,'("pdf_int: ",13(F8.6," "))')this%pdf_int
- write(unit,'("pdf_norm: ",5(F8.6," "))')this%pdf_norm
- else
- write(unit,'("Skipping pdf_int")')
- write(unit,'("Skipping pdf_norm")')
- end if
- end subroutine pdfnorm_print_to_unit
-\end{Verbatim}
-\TbpImp{pdfnorm\_get\_type}
-\begin{Verbatim}
- pure subroutine pdfnorm_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="pdfnorm_type")
- end subroutine pdfnorm_get_type
-\end{Verbatim}
-\TbpImp{pdfnorm\_verify\_type}
-\begin{Verbatim}
- elemental logical function pdfnorm_verify_type(type) result(match)
- character(*),intent(in)::type
- match=type=="pdfnorm_type"
- end function pdfnorm_verify_type
-\end{Verbatim}
-\TbpImp{pdfnorm\_scan}
-Für verschiedene Werte $\mu_j$ von $\mu_F$ integrieren wir über $x$ und bekommen so eine Approximation von $\mean{f_k(\mu)}=\int_{x=x_0}^{1}xf_k(x,\mu)$. In der Komponente this\%pdf\_int[k,j] werden die die Werte $\mean{f_k(\mu_j)}$ gespeichert, mit $k\in [-6:6]=[\overline{t}^S,\overline{b}^S,\overline{c}^S,\overline{s}^S,\overline{u}^S,\overline{d}^S,g,d^V,u^V,s^S,c^S,b^S,t^S]$. In der Komponente this\%pdf\_norm[m,j] werden normierte Summen dieser Integrale gspeichert.
-\begin{equation}
- this\%pdf\_norm[m,j]=\frac{\sum_{k\in I_m}\mean{f_k(\mu_j)}}{N}
-\end{equation}
-mit
-\begin{equation}
- N=\sum_{\text{alle } I_m}\mean{f_k(\mu_j)}
-\end{equation}
-und mit $I=$ [gluon,see,valenz-down,valenz-up], genauer:
-\begin{align}
- I_1&=g\\
- I_2&={\overline{t}^S,\overline{b}^S,\overline{c}^S,\overline{s}^S,\overline{u}^S,\overline{d}^S,d^S,u^S,s^S,c^S,b^S,t^S}\\
- I_3&=d^V\\
- I_4&=u^V
-\end{align}
-Schließlich wird $N$ in this\%pdf\_norm[0,j] gespeichert. Idealerweise sollte $N=1$ sein, das wird auch bei der Berechnung der Wichtungsfaktoren der Remnant-PDFs in \TbpRef{proton\_remnant\_type}{calculate\_weight} explizit angenommen. Da diese Summenregel durch nummerische Fehler aber nicht exakt erfüllt ist, normieren wir die Beiträge auf deren Summe. Dadurch bekommen wir in \TbpRef{proton\_remnant\_type}{calculate\_weight} Wichtungsfaktorn, die kaum von dem nummerischen Fehler der Gleichung $N=1$ abhängen.
-
-Die Integration über $x$ wird mit der Trapezregel durchgeführt. LHAPDF liefert bereits die momentum-pdfs $xf$, deswegen tritt der Faktor $x$ hier nicht mehr auf. Die $x$-Werte sind wie auch die $\mu$-Werte nicht äquidistant, sondern deren Abstand ist $\sim\sqrt{x}$ bzw. $\sim\sqrt{\mu}$. Da $x>0$ und $\mu>0$ treten keine Koordinaten-divergenzen auf.
-\begin{Verbatim}
- subroutine pdfnorm_scan(this)
- class(pdfnorm_type),intent(out)::this
- integer::ix,iq
- real(kind=double)::xmin,xmax,dx
- real(kind=double)::q,q2min,q2max
- real(kind=double),dimension(-6:6)::f
- real(kind=double),dimension(0:2)::x
- call getxmin(0,xmin)
- call getxmax(0,xmax)
- call getq2min(0,q2min)
- call getq2max(0,q2max)
- this%qmin=sqrt(sqrt(q2min))
- this%qmax=sqrt(sqrt(q2max))
- this%dq=(this%qmax-this%qmin)/nq
- xmin=sqrt(xmin)
- xmax=sqrt(xmax)
- dx=(xmax-xmin)/nx
- do iq=0,nq
- print *,"iq=",iq,"/",nq
- q=(this%qmin+iq*this%dq)**2
- x(0)=xmin**2
- x(1)=(xmin+dx)**2
- call evolvePDF(x(0),q,f)
- \IC{Valenzbeiträge}
- f(1)=f(1)-f(-1)
- f(2)=f(2)-f(-2)
- \IC{Trapezregel: linker Rand}
- this%pdf_int(:,iq)=(x(1)-x(0))*f
- do ix=2,nx
- x(2)=(xmin+ix*dx)**2
- call evolvePDF(x(1),q,f)
- f(1)=f(1)-f(-1)
- f(2)=f(2)-f(-2)
- \IC{Trapezregel: Die bekannte Form ergibt sich aus einer Umsummierung dieser Beiträge.}
- this%pdf_int(:,iq)=this%pdf_int(:,iq)+f*(x(2)-x(0))
- \IC{Die x-Werte werden nach links geschoben}
- x(0)=x(1)
- x(1)=x(2)
- end do
- \IC{Trapezregel: rechter Rand}
- call evolvePDF(x(1),q,f)
- f(1)=f(1)-f(-1)
- f(2)=f(2)-f(-2)
- \IC{Hier wird endlich durch 2 dividiert.}
- this%pdf_int(:,iq)=(this%pdf_int(:,iq)+f*(x(1)-x(0)))/2D0
- \IC{\mean{f_{u^v}}}
- this%pdf_norm(4,iq)=this%pdf_int(2,iq)
- \IC{\mean{f_{d^v}}}
- this%pdf_norm(3,iq)=this%pdf_int(1,iq)
- \IC{\mean{f_{u}}}
- this%pdf_int(2,iq)=this%pdf_int(2,iq)+this%pdf_int(-2,iq)
- \IC{\mean{f_{d}}}
- this%pdf_int(1,iq)=this%pdf_int(1,iq)+this%pdf_int(-1,iq)
- \IC{\mean{f_{g}}}
- this%pdf_norm(1,iq)=this%pdf_int(0,iq)
- \IC{\(\sum\mean{f_{q^s}}\)}
- this%pdf_norm(2,iq)=sum(this%pdf_int(-6:-1,iq))+sum(this%pdf_int(-2:-1,iq))+sum(this%pdf_int(3:6,iq))
- \IC{\(\sum_\{alle Partonen\}\mean{f_{k}}\)}
- this%pdf_norm(0,iq)=sum(this%pdf_int(:,iq))
- \IC{Normierung auf pdf_norm(0,iq)}
- this%pdf_norm(1,iq)=this%pdf_norm(1,iq)/this%pdf_norm(0,iq)
- this%pdf_norm(2,iq)=this%pdf_norm(2,iq)/this%pdf_norm(0,iq)
- this%pdf_norm(3,iq)=this%pdf_norm(3,iq)/this%pdf_norm(0,iq)
- this%pdf_norm(4,iq)=this%pdf_norm(4,iq)/this%pdf_norm(0,iq)
- end do
- end subroutine pdfnorm_scan
-\end{Verbatim}
-
-\TbpImp{pdfnorm\_get\_norm}
-Hier habe ich verschiedene Polynome zur Approximation der $\mu_F$-Abhängigkeit probiert. Dim ist die Ordnung des Polynoms. Wie auch bei der $x$-Integration hat die Trapezregel, also dim=1, die besten Resultate gebracht.
-\begin{Verbatim}
- subroutine pdfnorm_get_norm(this,gev_q,dim,kind,norm)
- class(pdfnorm_type),intent(in)::this
- real(kind=double),intent(in)::gev_q
- integer,intent(in)::dim,kind
- real(kind=double),intent(out)::norm
- integer::iq
- real(kind=double)::x,q,z0,z1,z2,z3,z4
- norm=-1D0
- q=sqrt(gev_q)-this%qmin
- iq=floor(q/this%dq)
- x=q/this%dq-iq
- if(iq<0)then
- print *,"pdfnorm_getnorm: q < q_min ",gev_q,this%qmin**2
- norm=this%pdf_norm(kind,0)
- else
- if(iq>=nq)then
- print *,"pdfnorm_getnorm: q >= q_max ",gev_q,this%qmax**2
- norm=this%pdf_norm(kind,nq)
- else
- select case(dim)
- case(0)
- norm=this%pdf_norm(kind,iq)
- case(1)
- norm=this%pdf_norm(kind,iq)*(1D0-x)+this%pdf_norm(kind,iq+1)*x
- case(2)
- x=x+mod(iq,2)
- iq=iq-mod(iq,2)
- z0=this%pdf_norm(kind,iq)
- z1=this%pdf_norm(kind,iq+1)
- z2=this%pdf_norm(kind,iq+2)
- norm=((z0-2D0*z1+z2)*x-(3D0*z0-4D0*z1+z2))*x/2D0+z0
- case(3)
- x=x+mod(iq,3)
- iq=iq-mod(iq,3)
- z0=this%pdf_norm(kind,iq)
- z1=this%pdf_norm(kind,iq+1)
- z2=this%pdf_norm(kind,iq+2)
- z3=this%pdf_norm(kind,iq+3)
- norm=((-(z0-3*z1+3*z2-z3)*x+3*(2*z0-5*z1+4*z2-z3))*x-(11*z0-18*z1+9*z2-2*z3))*x/6D0+z0
- case(4)
- x=x+mod(iq,4)
- iq=iq-mod(iq,4)
- z0=this%pdf_norm(kind,iq)
- z1=this%pdf_norm(kind,iq+1)
- z2=this%pdf_norm(kind,iq+2)
- z3=this%pdf_norm(kind,iq+3)
- z4=this%pdf_norm(kind,iq+4)
- norm=(((((z0-4*z1+6*z2-4*z3+z4)*x&
- -2*(5*z0-18*z1+24*z2-14*z3+3*z4))*x&
- +(35*z0-104*z1+114*z2-56*z3+11*z4))*x&
- -2*(25*z0-48*z1+36*z2-16*z3+3*z4))*x)/24D0&
- +z0
- case default
- norm=this%pdf_norm(kind,iq)*(1D0-x)+this%pdf_norm(kind,iq+1)*x
- end select
- ! print *,iq,x,norm
- end if
- end if
- end subroutine pdfnorm_get_norm
-\end{Verbatim}
-\MethodsFor{parton\_type}
-\TbpImp{parton\_write\_to\_marker}
-\begin{Verbatim}
- subroutine parton_write_to_marker(this,marker,status)
- class(parton_type),intent(in)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("parton_type")
- call marker%mark("id",this%id)
- call marker%mark("lha",this%lha_flavor)
- call marker%mark("momentum",this%momentum)
- call marker%mark_end("parton_type")
- end subroutine parton_write_to_marker
-\end{Verbatim}
-\TbpImp{parton\_read\_from\_marker}
-\begin{Verbatim}
- subroutine parton_read_from_marker(this,marker,status)
- class(parton_type),intent(out)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- character(:),allocatable::name
- call marker%pick_begin("parton_type",status=status)
- call marker%pick("id",this%id,status)
- call marker%pick("lha",this%lha_flavor,status)
- call marker%pick("momentum",this%momentum,status)
- call marker%pick_end("parton_type",status=status)
- end subroutine parton_read_from_marker
-\end{Verbatim}
-\TbpImp{parton\_print\_to\_unit}
-\begin{Verbatim}
- recursive subroutine parton_print_to_unit(this,unit,parents,components,peers)
- class(parton_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- class(serializable_class),pointer::ser
- write(unit,'("Components of parton_type:")')
- write(unit,'("id: ",I7)')this%id
- write(unit,'("lha flavor: ",I7)')this%lha_flavor
- write(unit,'("momentum: ",F7.6)')this%momentum
- ser=>this%next
- call serialize_print_peer_pointer(ser,unit,parents,components,peers-one,"next")
- ser=>this%twin
- call serialize_print_comp_pointer(ser,unit,parents,components,peers-one,"twin")
- end subroutine parton_print_to_unit
-\end{Verbatim}
-\TbpImp{parton\_get\_type}
-\begin{Verbatim}
- pure subroutine parton_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="parton_type")
- end subroutine parton_get_type
-\end{Verbatim}
-\TbpImp{twin\_unweighted\_pdf}
-\begin{Verbatim}
- pure function twin_unweighted_pdf(this,momentum_fraction) result(pdf)
- !parton pdf
- class(parton_type),intent(in)::this
- real(kind=double),intent(in)::momentum_fraction
- real(kind=double)::pdf
- if(momentum_fraction+this%twin%momentum<1D0)then
- pdf=remnant_twin_pdf_p(momentum_fraction,this%twin%momentum,gluon_exp)
- else
- pdf=0D0
- end if
- end function twin_unweighted_pdf
-\end{Verbatim}
-\TbpImp{twin\_deallocate}
-\begin{Verbatim}
- recursive subroutine twin_deallocate(this)
- class(parton_type)::this
- if(associated(this%next))then
- call this%next%deallocate
- deallocate(this%next)
- end if
- end subroutine twin_deallocate
-\end{Verbatim}
-\TbpImp{parton\_push}
-\begin{Verbatim}
- subroutine parton_push(this,parton)
- class(parton_type),intent(inout)::this
- class(parton_type),intent(inout),pointer::parton
- parton%next=>this%next
- this%next=>parton
- end subroutine parton_push
-\end{Verbatim}
-\TbpImp{parton\_pop\_by\_id}
-\begin{Verbatim}
- subroutine parton_pop_by_id(this,id,parton)
- class(parton_type),target,intent(inout)::this
- integer,intent(in)::id
- class(parton_type),intent(out),pointer::parton
- class(parton_type),pointer::tmp_parton
- tmp_parton=>this
- do while(associated(tmp_parton%next))
- if(tmp_parton%next%id==id)exit
- tmp_parton=>tmp_parton%next
- end do
- \IC{Noch wissen wir nicht, ob die Schleife erfolglos durchgelaufen ist.}
- if(associated(tmp_parton%next))then
- \IC{Erfolg: Das Parton wird aus der Liste entfernt.}
- parton=>tmp_parton%next
- tmp_parton%next=>parton%next
- nullify(parton%next)
- else
- \IC{Kein Erfolg: Das Dummyargument wird deassociiert.}
- nullify(parton)
- print *,"parton_pop ",id,"NULL"
- end if
- end subroutine parton_pop_by_id
-\end{Verbatim}
-\TbpImp{parton\_pop\_by\_association}
-\begin{Verbatim}
- subroutine parton_pop_by_association(this,parton)
- class(parton_type),target,intent(inout)::this
- class(parton_type),intent(inout),target::parton
- class(parton_type),pointer::tmp_parton
- tmp_parton=>this
- do while(associated(tmp_parton%next))
- if(associated(tmp_parton%next,parton))exit
- tmp_parton=>tmp_parton%next
- end do
- \IC{Noch wissen wir nicht, ob die Schleife erfolglos durchgelaufen ist.}
- if(associated(tmp_parton%next))then
- \IC{Erfolg: Das Parton wird aus der Liste entfernt.}
- tmp_parton%next=>parton%next
- nullify(parton%next)
- else
- \IC{Kein Erfolg}
- print *,"parton_pop NULL"
- end if
- end subroutine parton_pop_by_association
-\end{Verbatim}
-\MethodsFor{proton\_remnant\_type}
-! manipulating parton content
-
-\TbpImp{proton\_remnant\_remove\_valence\_quark}
-\begin{Verbatim}
- subroutine proton_remnant_remove_valence_quark(this,id,GeV_scale,momentum_fraction,lha_flavor)
- class(proton_remnant_type),intent(inout)::this
- integer,intent(in)::id
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- integer,intent(in)::lha_flavor !d=1 u=2
- if(lha_flavor==1.or.lha_flavor==2)then
- \IC{q ist die Anzahl der entsprechenden Valenzquarks.}
- associate(q=>this%valence_content(lha_flavor))
- if(q>0)then
- q=q-1
- \IC{Das Quark ist ab jetzt ein aktiven Shower-Teilchen.}
- call this%push_is_parton(id,lha_flavor,momentum_fraction)
- \IC{Der Remnant-Impuls wird um den Partonimpuls reduziert.}
- this%momentum_fraction=this%momentum_fraction*(1D0-momentum_fraction)
- \IC{Die Wichtugsfaktoren werden neu ausgewertet}
- call this%calculate_weight(GeV_scale)
- else
- print('("proton_remnant_remove_valence_quark: Cannot remove parton ",I2,": &
- &There are no such partons left.")'),lha_flavor
- call this%print_all()
- end if
- end associate
- else
- print('("proton_remnant_remove_valence_quark: Cannot remove parton ",I2,": &
- &There are no such valence partons.")'),lha_flavor
- end if
- end subroutine proton_remnant_remove_valence_quark
-\end{Verbatim}
-\TbpImp{proton\_remnant\_remove\_valence\_up\_quark}
-q ist die Zahl der Valenz-up-Quarks im Remnant. Wenn keine mehr da sind, dann ist etwas schief gelaufen, sonst wird die Zahl um eins reduziert. Das Parton, das aus dem Remnant entfernt wird, verschwindet natürlich nicht, sondern wird mit \TbpRef{proton\_remnant\_type}{push\_is\_parton} in die perturbative Beschreibung aufgenommen. is\_parton bedeutet Initial-State Parton, genauer gesagt aktives Initial-State Parton.
-
-Selbstverständlich wird der Impuls des Remants aktualisiert und schließlich werden mit\linebreak \TbpRef{proton\_remnant\_type}{calculate\_weight} die neuen Wichtungsfaktoren $W_{\alpha}$ bestimmt.
-\begin{Verbatim}
- subroutine proton_remnant_remove_valence_up_quark(this,id,GeV_scale,momentum_fraction)
- class(proton_remnant_type),intent(inout)::this
- integer,intent(in)::id
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- associate(q=>this%valence_content(lha_flavor_u))
- if(q>0)then
- q=q-1
- call this%push_is_parton(id,lha_flavor_u,momentum_fraction)
- this%momentum_fraction=this%momentum_fraction*(1D0-momentum_fraction)
- call this%calculate_weight(GeV_scale)
- else
- print('("proton_remnant_remove_valence_up_quark: Cannot remove parton ",I2,": &
- &There are no such partons left.")'),lha_flavor_u
- call this%print_all
- end if
- end associate
- end subroutine proton_remnant_remove_valence_up_quark
-\end{Verbatim}
-\TbpImp{proton\_remnant\_remove\_valence\_down\_quark}
-Siehe \TbpRef{proton\_remnant\_type}{remove\_valence\_up\_quark}
-\begin{Verbatim}
- subroutine proton_remnant_remove_valence_down_quark(this,id,GeV_scale,momentum_fraction)
- class(proton_remnant_type),intent(inout)::this
- integer,intent(in)::id
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- associate(q=>this%valence_content(lha_flavor_d))
- if(q>0)then
- q=q-1
- call this%push_is_parton(id,lha_flavor_d,momentum_fraction)
- this%momentum_fraction=this%momentum_fraction*(1D0-momentum_fraction)
- call this%calculate_weight(GeV_scale)
- else
- print('("proton_remnant_remove_valence_down_quark: Cannot remove&
- & parton ",I2,": There are no such partons left.")')&
- &,lha_flavor_d
- call this%print_all
- end if
- end associate
- end subroutine proton_remnant_remove_valence_down_quark
-\end{Verbatim}
-\TbpImp{proton\_remnant\_remove\_sea\_quark}
-Es wird ein Seequark aus dem Remnant genommen und ein Quasivalenzquark hinzugefügt. Wir merken uns, welches Quasivalenzquark zu welchem Seequark gehört und nennen das jeweils andere twin. Mit \TbpRef{proton\_remnant\_type}{push\_twin} erzeugen wir sowohl das neue aktive ISR Seequark als auch das neue Quasivalenzquark.
-\begin{Verbatim}
- subroutine proton_remnant_remove_sea_quark(this,id,GeV_scale,momentum_fraction&
- &,lha_flavor)
- integer,intent(in)::id
- class(proton_remnant_type),intent(inout)::this
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- integer,intent(in)::lha_flavor
- if(lha_flavor>-6.and.lha_flavor<6.and.(lha_flavor.ne.0))then
- this%momentum_fraction=this%momentum_fraction*(1D0-momentum_fraction)
- call this%push_twin(id,lha_flavor,momentum_fraction,GeV_scale)
- end if
- end subroutine proton_remnant_remove_sea_quark
-\end{Verbatim}
-\TbpImp{proton\_remnant\_remove\_gluon}
-Hier ist am wenigsten zu tun. Es wird nur der Remnant-Impuls aktualisiert und mit\linebreak \TbpRef{proton\_remnant\_type}{push\_is\_parton} ein neues aktives ISR-Gluon erzeugt.
-\begin{Verbatim}
- subroutine proton_remnant_remove_gluon(this,id,GeV_scale,momentum_fraction)
- class(proton_remnant_type),intent(inout)::this
- integer,intent(in)::id
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- this%momentum_fraction=this%momentum_fraction*(1D0-momentum_fraction)
- call this%push_is_parton(id,lha_flavor_g,momentum_fraction)
- end subroutine proton_remnant_remove_gluon
-\end{Verbatim}
-\TbpImp{proton\_remnant\_remove\_twin}
-Ein Quasivalenzquark wird aus dem Remnant genommen und in die Liste der aktiven Showerteilchen aufgenommen.
-\begin{Verbatim}
- subroutine proton_remnant_remove_twin(this,id,GeV_scale)
- class(proton_remnant_type),intent(inout)::this
- integer,intent(in)::id
- real(kind=double),intent(in)::GeV_scale
- class(parton_type),pointer::twin
- call this%twin_partons%pop(id,twin)
- call this%fs_partons%push(twin)
- this%twin_norm=this%twin_norm-twin%momentum
- this%n_twins=this%n_twins-1
- call this%calculate_weight(GeV_scale)
- end subroutine proton_remnant_remove_twin
-\end{Verbatim}
-! getting pdf
-
-\TbpImp{proton\_remnant\_parton\_twin\_pdf}
-Die Parton-PDFs aller Quasivalenzbeiträge zu dem angegebenen Flavor werden aufaddiert.
-\begin{Verbatim}
- subroutine proton_remnant_parton_twin_pdf(this,lha_flavor,momentum_fraction,pdf)
- class(proton_remnant_type),intent(in)::this
- integer,intent(in)::lha_flavor
- real(kind=double),intent(in)::momentum_fraction
- real(kind=double)::pdf
- class(parton_type),pointer::tmp_twin
- pdf=0D0
- tmp_twin=>this%twin_partons%next
- do while(associated(tmp_twin))
- if(tmp_twin%lha_flavor==lha_flavor)pdf=pdf+tmp_twin%unweighted_pdf(momentum_fraction)
- tmp_twin=>tmp_twin%next
- end do
- pdf=pdf*this%get_twin_weight()
- end subroutine proton_remnant_parton_twin_pdf
-\end{Verbatim}
-\TbpImp{proton\_remnant\_parton\_twin\_pdf\_array}
-Aus der Liste \CompRef{proton\_remnant\_type}{twin\_partons} wird in ein array von Parton-PDFs erzeugt. Jeder Eintrag in dem Dummy-Argument pdf entspricht einem Quasivalenzquark.
-\begin{Verbatim}
- subroutine proton_remnant_parton_twin_pdf_array(this,momentum_fraction,pdf)
- class(proton_remnant_type),intent(in)::this
- real(kind=double),intent(in)::momentum_fraction
- real(kind=double),dimension(this%n_twins),intent(out)::pdf
- class(parton_type),pointer::tmp_twin
- integer::l
- tmp_twin=>this%twin_partons%next
- l=0
- do while(associated(tmp_twin))
- l=l+1
- pdf(l)=tmp_twin%unweighted_pdf(momentum_fraction)*this%twin_norm
- tmp_twin=>tmp_twin%next
- end do
- end subroutine proton_remnant_parton_twin_pdf_array
-\end{Verbatim}
-\TbpImp{proton\_remnant\_momentum\_twin\_pdf}
-Die Momentum-PDFs aller Quasivalenzbeiträge zu dem angegebenen Flavor werden aufaddiert.
-\begin{Verbatim}
- subroutine proton_remnant_momentum_twin_pdf(this,lha_flavor,momentum_fraction,pdf)
- class(proton_remnant_type),intent(in)::this
- integer,intent(in)::lha_flavor
- real(kind=double),intent(in)::momentum_fraction
- real(kind=double),intent(out)::pdf
- call this%parton_twin_pdf(lha_flavor,momentum_fraction,pdf)
- pdf=pdf*momentum_fraction
- end subroutine proton_remnant_momentum_twin_pdf
-\end{Verbatim}
-\TbpImp{proton\_remnant\_momentum\_twin\_pdf\_array}
-Aus der Liste \CompRef{proton\_remnant\_type}{twin\_partons} wird in ein array von Momentum-PDFs erzeugt. Jeder Eintrag in dem Dummy-Argument pdf entspricht einem Quasivalenzquark.
-\begin{Verbatim}
- subroutine proton_remnant_momentum_twin_pdf_array(this,momentum_fraction,pdf)
- class(proton_remnant_type),intent(in)::this
- real(kind=double),intent(in)::momentum_fraction
- real(kind=double),dimension(this%n_twins),intent(out)::pdf
- call this%parton_twin_pdf_array(momentum_fraction,pdf)
- pdf=pdf*momentum_fraction
- end subroutine proton_remnant_momentum_twin_pdf_array
-\end{Verbatim}
-\TbpImp{proton\_remnant\_momentum\_kind\_pdf}
-Zu dem angegebenen Flavor wird die Momentum-Strukturfunktion nach See- (einschließlich Gluon-), Valenz- und Quasivalenzbeitrag aufgeschlüsselt.
-\begin{Verbatim}
- subroutine proton_remnant_momentum_kind_pdf(this,GeV_scale,momentum_fraction&
- &,lha_flavor,valence_pdf,sea_pdf,twin_pdf)
- class(proton_remnant_type),intent(in)::this
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- integer,intent(in)::lha_flavor !g,u,d,etc.
- real(kind=double),intent(out)::valence_pdf,sea_pdf,twin_pdf
- real(kind=double),dimension(-6:6)::pdf_array
- call evolvePDF(momentum_fraction,GeV_scale,pdf_array)
- select case (lha_flavor)
- case(0) !gluon
- valence_pdf=0D0
- sea_pdf=pdf_array(0)
- case(1) !down
- valence_pdf=this%get_valence_down_weight()*(pdf_array(1)-pdf_array(-1))
- sea_pdf=pdf_array(-1)
- case(2) !up
- valence_pdf=this%get_valence_up_weight()*(pdf_array(2)-pdf_array(-2))
- sea_pdf=pdf_array(-2)
- case default
- valence_pdf=0D0
- sea_pdf=pdf_array(lha_flavor)
- end select
- sea_pdf=sea_pdf*this%get_sea_weight()
- call this%momentum_twin_pdf(lha_flavor,momentum_fraction,twin_pdf)
- end subroutine proton_remnant_momentum_kind_pdf
-\end{Verbatim}
-\TbpImp{proton\_remnant\_momentum\_flavor\_pdf}
-Zu dem angegebenen Flavor wird die Momentum-Strukturfunktion zurückgegeben. (Summe über alle Beiträge mit diesem Flavor.)
-\begin{Verbatim}
- subroutine proton_remnant_momentum_flavor_pdf(this,GeV_scale,momentum_fraction&
- &,lha_flavor,pdf)
- class(proton_remnant_type),intent(in)::this
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- integer,intent(in)::lha_flavor !g,u,d,etc.
- real(kind=double),intent(out)::pdf
- real(kind=double)::valence_pdf,sea_pdf,twin_pdf
- call proton_remnant_momentum_kind_pdf(this,GeV_scale,momentum_fraction,lha_flavor&
- &,valence_pdf,sea_pdf,twin_pdf)
- pdf=valence_pdf+sea_pdf+twin_pdf
- end subroutine proton_remnant_momentum_flavor_pdf
-\end{Verbatim}
-\TbpImp{proton\_remnant\_momentum\_flavor\_pdf\_array}
-Es wird ein array von Momentum-PDFs (Summe über alle Beiträge für jedes Flavor), aufgeschlüsselt nach Partonflavor zurückgegeben.
-
-\wip{Es sind (noch) keine Quasivalenzquarks enthalten. Das ist aber nur eine Fleißübung, es gibt keinen technischen Hinderungsgrund.}
-\begin{Verbatim}
- subroutine proton_remnant_momentum_flavor_pdf_array(this,GeV_scale,momentum_fraction&
- &,pdf)
- class(proton_remnant_type),intent(in)::this
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- real(kind=double),dimension(-6:6),intent(out)::pdf
- real(kind=double),dimension(2)::valence_pdf
- call this%momentum_kind_pdf_array(GeV_scale,momentum_fraction,valence_pdf,pdf)
- pdf(1:2)=pdf(1:2)+valence_pdf
- ! no twin yet
- end subroutine proton_remnant_momentum_flavor_pdf_array
-\end{Verbatim}
-\TbpImp{proton\_remnant\_momentum\_kind\_pdf\_array}
-Es werden See- (einschließlich Gluon-) und Valenzbeiträge zur Momentum-PDF als separate arrays ausgegeben.
-\begin{Verbatim}
- subroutine proton_remnant_momentum_kind_pdf_array(this,GeV_scale,momentum_fraction&
- &,valence_pdf,sea_pdf)
- class(proton_remnant_type),intent(in)::this
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- real(kind=double),dimension(2),intent(out)::valence_pdf
- real(kind=double),dimension(-6:6),intent(out)::sea_pdf
- call evolvePDF(momentum_fraction,GeV_scale,sea_pdf)
- valence_pdf(1)=(sea_pdf(1)-sea_pdf(-1))*this%pdf_int_weight(pdf_int_kind_val_down)
- valence_pdf(2)=(sea_pdf(2)-sea_pdf(-2))*this%pdf_int_weight(pdf_int_kind_val_up)
- sea_pdf(1)=sea_pdf(-1)
- sea_pdf(2)=sea_pdf(-2)
- sea_pdf=sea_pdf*this%get_sea_weight()
- ! no twin yet
- end subroutine proton_remnant_momentum_kind_pdf_array
-\end{Verbatim}
-\TbpImp{proton\_remnant\_parton\_kind\_pdf}
-Zu dem angegebenen Flavor wird die Parton-Strukturfunktion nach See- (einschließlich Gluon-), Valenz- und Quasivalenzbeitrag aufgeschlüsselt.
-\begin{Verbatim}
- subroutine proton_remnant_parton_kind_pdf(this,GeV_scale,momentum_fraction&
- &,lha_flavor,valence_pdf,sea_pdf,twin_pdf)
- class(proton_remnant_type),intent(in)::this
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- integer,intent(in)::lha_flavor !g,u,d,etc.
- real(kind=double),intent(out)::valence_pdf,sea_pdf,twin_pdf
- call this%momentum_kind_pdf(GeV_scale,momentum_fraction,lha_flavor,valence_pdf&
- &,sea_pdf,twin_pdf)
- valence_pdf=valence_pdf/momentum_fraction
- sea_pdf=sea_pdf/momentum_fraction
- twin_pdf=twin_pdf/momentum_fraction
- end subroutine proton_remnant_parton_kind_pdf
-\end{Verbatim}
-\TbpImp{proton\_remnant\_parton\_flavor\_pdf}
-Zu dem angegebenen Flavor wird die Parton-Strukturfunktion zurückgegeben (Summe über alle Beiträge mit diesem Flavor).
-\begin{Verbatim}
- subroutine proton_remnant_parton_flavor_pdf(this,GeV_scale,momentum_fraction&
- &,lha_flavor,pdf)
- class(proton_remnant_type),intent(in)::this
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- integer,intent(in)::lha_flavor !g,u,d,etc.
- real(kind=double),intent(out)::pdf
- call this%momentum_flavor_pdf(GeV_scale,momentum_fraction,lha_flavor,pdf)
- pdf=pdf/momentum_fraction
- end subroutine proton_remnant_parton_flavor_pdf
-\end{Verbatim}
-\TbpImp{proton\_remnant\_parton\_kind\_pdf\_array}
-Es wird ein array von Parton-PDFs (Summe über alle Beiträge für jedes Flavor), aufgeschlüsselt nach Partonflavor zurückgegeben.
-
-\wip{Es sind (noch) keine Quasivalenzquarks enthalten. Das ist aber nur eine Fleißübung, es gibt keinen technischen Hinderungsgrund.}
-\begin{Verbatim}
- subroutine proton_remnant_parton_kind_pdf_array(this,GeV_scale,momentum_fraction&
- &,valence_pdf,sea_pdf)
- class(proton_remnant_type),intent(in)::this
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- real(kind=double),dimension(2),intent(out)::valence_pdf
- real(kind=double),dimension(-6:6),intent(out)::sea_pdf
- call evolvePDF(momentum_fraction,GeV_scale,sea_pdf)
- sea_pdf=sea_pdf/momentum_fraction
- valence_pdf(1)=(sea_pdf(1)-sea_pdf(-1))*this%valence_content(1)
- valence_pdf(2)=(sea_pdf(2)-sea_pdf(-2))*(this%valence_content(2)/2D0)
- sea_pdf(1)=sea_pdf(-1)
- sea_pdf(2)=sea_pdf(-2)
- valence_pdf=valence_pdf*this%get_valence_weight()
- sea_pdf=sea_pdf*this%get_sea_weight()
- ! no twin yet
- end subroutine proton_remnant_parton_kind_pdf_array
-\end{Verbatim}
-\TbpImp{proton\_remnant\_parton\_flavor\_pdf\_array}
-Es werden See- (einschließlich Gluon-) und Valenzbeiträge zur Parton-PDF als separate arrays ausgegeben.
-\begin{Verbatim}
- subroutine proton_remnant_parton_flavor_pdf_array(this,GeV_scale,momentum_fraction&
- &,pdf)
- class(proton_remnant_type),intent(in)::this
- real(kind=double),intent(in)::GeV_scale,momentum_fraction
- real(kind=double),dimension(-6:6),intent(out)::pdf
- real(kind=double),dimension(2)::valence_pdf
- real(kind=double),dimension(-6:6)::twin_pdf
- print('("proton_remnant_flavor_pdf_array: Not yet implemented.")')
- end subroutine proton_remnant_parton_flavor_pdf_array
-\end{Verbatim}
-
- ! getting components
-
-\TbpImp{proton\_remnant\_get\_pdf\_int\_weight}
-\begin{Verbatim}
- pure function proton_remnant_get_pdf_int_weight(this) result(weight)
- class(proton_remnant_type),intent(in)::this
- real(kind=double),dimension(5)::weight
- weight=this%pdf_int_weight
- end function proton_remnant_get_pdf_int_weight
-\end{Verbatim}
-
-\TbpImp{proton\_remnant\_get\_valence\_weight}
-\begin{Verbatim}
- pure function proton_remnant_get_valence_weight(this) result(weight)
- class(proton_remnant_type),intent(in)::this
- real(kind=double),dimension(2)::weight
- weight=this%pdf_int_weight(3:4)
- end function proton_remnant_get_valence_weight
-\end{Verbatim}
-
-\TbpImp{proton\_remnant\_get\_valence\_down\_weight}
-\begin{Verbatim}
- elemental function proton_remnant_get_valence_down_weight(this) result(weight)
- class(proton_remnant_type),intent(in)::this
- real(kind=double)::weight
- weight=this%pdf_int_weight(pdf_int_kind_val_down)
- end function proton_remnant_get_valence_down_weight
-\end{Verbatim}
-
-\TbpImp{proton\_remnant\_get\_valence\_up\_weight}
-\begin{Verbatim}
- elemental function proton_remnant_get_valence_up_weight(this) result(weight)
- class(proton_remnant_type),intent(in)::this
- real(kind=double)::weight
- weight=this%pdf_int_weight(pdf_int_kind_val_up)
- end function proton_remnant_get_valence_up_weight
-\end{Verbatim}
-
-\TbpImp{proton\_remnant\_get\_sea\_weight}
-\begin{Verbatim}
- elemental function proton_remnant_get_sea_weight(this) result(weight)
- class(proton_remnant_type),intent(in)::this
- real(kind=double)::weight
- weight=this%pdf_int_weight(pdf_int_kind_sea)
- end function proton_remnant_get_sea_weight
-\end{Verbatim}
-
-\TbpImp{proton\_remnant\_get\_gluon\_weight}
-\begin{Verbatim}
- elemental function proton_remnant_get_gluon_weight(this) result(weight)
- class(proton_remnant_type),intent(in)::this
- real(kind=double)::weight
- weight=this%pdf_int_weight(pdf_int_kind_gluon)
- end function proton_remnant_get_gluon_weight
-\end{Verbatim}
-
-\TbpImp{proton\_remnant\_get\_twin\_weight}
-\begin{Verbatim}
- elemental function proton_remnant_get_twin_weight(this) result(weight)
- class(proton_remnant_type),intent(in)::this
- real(kind=double)::weight
- weight=this%pdf_int_weight(pdf_int_kind_twin)
- end function proton_remnant_get_twin_weight
-\end{Verbatim}
-
-\TbpImp{proton\_remnant\_get\_valence\_content}
-\begin{Verbatim}
- pure function proton_remnant_get_valence_content(this) result(valence)
- class(proton_remnant_type),intent(in)::this
- integer,dimension(2)::valence
- valence=this%valence_content
- end function proton_remnant_get_valence_content
-\end{Verbatim}
-
-\TbpImp{proton\_remnant\_get\_momentum\_fraction}
-\begin{Verbatim}
- elemental function proton_remnant_get_momentum_fraction(this) result(momentum)
- class(proton_remnant_type),intent(in)::this
- real(kind=double)::momentum
- momentum=this%momentum_fraction
- end function proton_remnant_get_momentum_fraction
-\end{Verbatim}
-
- ! misc
-
-\TbpImp{proton\_remnant\_deallocate}
-\begin{Verbatim}
- subroutine proton_remnant_deallocate(this)
- class(proton_remnant_type),intent(inout)::this
- call this%is_partons%deallocate
- call this%fs_partons%deallocate
- call this%twin_partons%deallocate
- this%twin_norm=0D0
- this%n_twins=0
- end subroutine proton_remnant_deallocate
-\end{Verbatim}
-
-\TbpImp{proton\_remnant\_initialize}
-\begin{Verbatim}
- subroutine proton_remnant_initialize(this,pdf_norm)
- class(proton_remnant_type),intent(out)::this
- class(pdfnorm_type),target,intent(in)::pdf_norm
- this%pdf_norm=>pdf_norm
- end subroutine proton_remnant_initialize
-\end{Verbatim}
-
-\TbpImp{proton\_remnant\_finalize}
-\begin{Verbatim}
- subroutine proton_remnant_finalize(this)
- class(proton_remnant_type),intent(inout)::this
- call this%deallocate()
- nullify(this%pdf_norm)
- end subroutine proton_remnant_finalize
-\end{Verbatim}
-\TbpImp{proton\_remnant\_apply\_initial\_splitting}
-Es wird eine WHIZARD-Interaktion auf den Remnant übertragen. Im Falle eines Gluons im Eingangszustand wird einfach die Methode \TbpRef{proton\_remnant\_type}{remove\_gluon} aufgerufen. Im Falle eines Quarks muss noch entschieden werden, ob es sich um ein See- oder ein Valenzquark handelt.
-
-Mit \TbpRef{proton\_remnant\_type}{parton\_kind\_pdf} bekommen wir die Strukturfunktion nach See-, Valenz- und Quasivalenzanteil ($f_{q^S},f_{q^V},f_{q^Q}$) aufgeschlüsselt. Durch Vergleich des Verhältnisses $\frac{f_{q^V}}{f_{q^V}+f_{q^S}}$ mit der Zufallszahl \emph{rnd} entscheiden wir, ob \TbpRef{proton\_remnant\_type}{remove\_valence\_up\_quark} bzw. \TbpRef{proton\_remnant\_type}{remove\_valence\_down\_quark} oder \TbpRef{proton\_remnant\_type}{remove\_sea\_quark} aufgerufen wird.
-\begin{Verbatim}
- subroutine proton_remnant_apply_initial_splitting(this,id,pdg_flavor,x,gev_scale,rnd)
- class(proton_remnant_type),intent(inout)::this
- integer,intent(in)::id,pdg_flavor
- real(kind=double),intent(in)::x,gev_scale,rnd
- real(kind=double)::valence_pdf,sea_pdf,twin_pdf
- select case(pdg_flavor)
- case(pdg_flavor_g)
- call this%remove_gluon(id,gev_scale,x)
- case(pdg_flavor_u)
- call this%parton_kind_pdf(gev_scale,x&
- &,pdg_flavor,valence_pdf,sea_pdf,twin_pdf)
- if(valence_pdf/(valence_pdf+sea_pdf)<rnd)then
- call this%remove_sea_quark(id,gev_scale,x,pdg_flavor)
- else
- call this%remove_valence_up_quark(id,gev_scale,x)
- end if
- case(pdg_flavor_d)
- call this%parton_kind_pdf(gev_scale,x&
- &,pdg_flavor,valence_pdf,sea_pdf,twin_pdf)
- if(valence_pdf/(valence_pdf+sea_pdf)<rnd)then
- call this%remove_sea_quark(id,gev_scale,x,pdg_flavor)
- else
- call this%remove_valence_down_quark(id,gev_scale,x)
- end if
- case default
- call this%remove_sea_quark(id,gev_scale,x,pdg_flavor)
- end select
- this%momentum_fraction=(1D0-x)
- end subroutine proton_remnant_apply_initial_splitting
-\end{Verbatim}
-\TbpImp{proton\_remnant\_reset}
-\begin{Verbatim}
- subroutine proton_remnant_reset(this)
- class(proton_remnant_type),intent(inout)::this
- call this%deallocate()
- this%valence_content=[1,2]
- this%pdf_int_weight=[1D0,1D0,1D0,1D0,1D0]
- this%momentum_fraction=1D0
- end subroutine proton_remnant_reset
-\end{Verbatim}
- ! private
-
-\TbpImp{proton\_remnant\_push\_is\_parton}
-Es wird eine neue Instanz vom Typ \TypeRef{parton\_type} allokiert und mit \TbpRef{parton\_type}{push} auf den Stapel \CompRef{proton\_remnant\_type}{is\_partons} der aktiven ISR-Partonen gelegt.
-\begin{Verbatim}
- subroutine proton_remnant_push_is_parton(this,id,lha_flavor,momentum_fraction)
- class(proton_remnant_type),intent(inout)::this
- integer,intent(in)::id,lha_flavor
- real(kind=double),intent(in)::momentum_fraction
- class(parton_type),pointer::tmp_parton
- allocate(tmp_parton)
- tmp_parton%id=id
- tmp_parton%lha_flavor=lha_flavor
- tmp_parton%momentum=momentum_fraction
- call this%is_partons%push(tmp_parton)
- end subroutine proton_remnant_push_is_parton
-\end{Verbatim}
-\TbpImp{proton\_remnant\_push\_twin}
-Ein Seequark wird aus dem Remnant entfernt, indem ein neues quark auf den Stapel\linebreak \CompRef{proton\_remnant\_type}{is\_partons} der aktiven ISR-Partonen gelegt und ein Quasivalenzquark(twin) in den Remnant aufgenommen wird. Die Quasivalenzquarks im Remnant werden durch den Stapel \CompRef{proton\_remnant\_type}{twin\_partons} dargestelt. Das Quasivalenzquark bekommt eine negative ID, wodurch es als Quasivalenzquark ausgezeichnet wird. Beide bekommen einen Zeiger \emph{twin}, der auf das jeweils andere zeigt.
-
-\mip{Die Modulfunktion remnant\_twin\_momentum\_4 liefert das Integral über die ungewichtete momentum-PDF des Quasivalenzquarks zurück. new\_twin\%momentum ist also der ungewichtete Impulserwartungswert des Quasivalenzquarks, während new\_is\%momentum der Impulsanteil $\xi$ des Partons ist.}
-
-Mit \TbpRef{parton\_type}{push} werden die neuen Teichen auf die jeweiligen Stapel gelegt und mit\linebreak \TbpRef{proton\_remnant\_type}{calculate\_weight} werden die neuen Wichtungsfaktoren ausgewertet.
-\begin{Verbatim}
- subroutine proton_remnant_push_twin(this,id,lha_flavor,momentum_fraction,gev_scale)
- class(proton_remnant_type),intent(inout)::this
- integer,intent(in)::id,lha_flavor !of IS parton
- real(kind=double),intent(in)::momentum_fraction !of IS parton
- real(kind=double),intent(in)::GeV_scale
- class(parton_type),pointer::new_is,new_twin
- real(kind=double)::norm
- !print *,"proton_remnant_push_twin",momentum_fraction
- allocate(new_is)
- allocate(new_twin)
- !IS initialization
- new_is%id=id
- new_is%lha_flavor=lha_flavor
- new_is%momentum=momentum_fraction
- new_is%twin=>new_twin
- !twin initialization
- new_twin%id=-id
- new_twin%lha_flavor=-lha_flavor
- new_twin%momentum=remnant_twin_momentum_4(momentum_fraction)
- new_twin%twin=>new_is
- !remnant update
- this%n_twins=this%n_twins+1
- this%twin_norm=this%twin_norm+new_twin%momentum
- call this%is_partons%push(new_is)
- call this%twin_partons%push(new_twin)
- call this%calculate_weight(GeV_scale)
- end subroutine proton_remnant_push_twin
-\end{Verbatim}
-\TbpImp{proton\_remnant\_calculate\_twin\_norm}
-Wenn \CompRef{proton\_remnant\_type}{twin\_partons} Partonen enthält, dann wird die Summe der Impulsmittelwerte aller Partonen aus \CompRef{proton\_remnant\_type}{twin\_partons} in der Komponente \linebreak \CompRef{proton\_remnant\_type}{twin\_norm} abgelegt. Sonst wird \CompRef{proton\_remnant\_type}{twin\_norm} auf Null gesetzt.
-\begin{Verbatim}
- subroutine proton_remnant_calculate_twin_norm(this)
- class(proton_remnant_type),intent(inout)::this
- class(parton_type),pointer::twin
- integer::n
- if(associated(this%twin_partons%next))then
- this%twin_norm=0D0
- twin=>this%twin_partons%next
- do while(associated(twin))
- this%twin_norm=this%twin_norm+twin%momentum
- twin=>twin%next
- end do
- else
- this%twin_norm=0D0
- end if
- end subroutine proton_remnant_calculate_twin_norm
-\end{Verbatim}
-\TbpImp{proton\_remnant\_replace\_is\_parton}
-Der ISR-Algorithmus hat ein Splitting eines Teilchens mit der id \emph{old\_id} generiert, das zuvor aus dem Remnant entfert wurde. Jetzt wird das alte Remnant-Teilchen wieder in den Remnant zurückgelegt und das neue Teilchen mit der id \emph{new\_id} aus dem Remnant entfernt (siehe Abbildung \ref{fig:all:flow:isr}). In Abschnitt 5.4.3 meiner Dissertation wird noch einiges zu dieser Prozedur erläutert.
-\begin{Verbatim}
- subroutine proton_remnant_replace_is_parton&
- (this,&
- old_id,&
- new_id,&
- pdg_f,&
- x_proton,&
- gev_scale)
- class(proton_remnant_type),intent(inout)::this
- integer,intent(in)::old_id,new_id,pdg_f
- real(kind=double),intent(in)::x_proton,gev_scale
- class(parton_type),pointer::old_is_parton
- integer::lha_flavor
- real(kind=double)::momentum_fraction
- momentum_fraction=x_proton/this%momentum_fraction()
- \IC{convert pdg flavor numbers to lha flavor numbers}
- if(pdg_f==pdg_flavor_g)then
- lha_flavor=lha_flavor_g
- else
- lha_flavor=pdg_f
- end if
- \IC{we remove the old initial state parton from initial state stack.}
- call this%is_partons%pop(old_id,old_is_parton)
- \IC{this check has no physical meaning, it's just a check for consistency.}
- if(associated(old_is_parton))then
- \IC{do we emit a gluon?}
- if(lha_flavor==old_is_parton%lha_flavor)then
- \IC{has the old initial state parton been a sea quark?}
- if(associated(old_is_parton%twin))then
- \IC{the connection of the old is parton with it's twin was provisional.}
- \IC{We remove it now}
- call this%twin_partons%pop(old_is_parton%twin)
- call this%fs_partons%push(old_is_parton%twin)
- this%n_twins=this%n_twins-1
- \IC{and generate a new initial state parton - twin pair.}
- call this%push_twin(new_id,lha_flavor,momentum_fraction,gev_scale)
- else
- \IC{there is no twin, so we just insert the new initial state parton.}
- call this%push_is_parton(new_id,lha_flavor,momentum_fraction)
- end if
- else
- \IC{we emit a quark. is this a g->qqbar splitting?}
- if(lha_flavor==lha_flavor_g)then
- \IC{we insert the new initial state gloun.}
- call this%push_is_parton(new_id,lha_flavor,momentum_fraction)
- \IC{has the old initial state quark got a twin?}
- if(associated(old_is_parton%twin))then
- \IC{we assume that this twin is the second splitting particle. so the}
- \IC{twin becomes a final state particle now and must be removed from}
- \IC{the is stack.}
- call this%remove_twin(-old_id,GeV_scale)
- else
- \IC{the old initial state quark has been a valence quark.}
- \IC{what should we do now? is this splitting sensible at all?}
- \IC{we don't know but allow these splittings.}
- \IC{The most trivial treatment is to restore the former valence quark.}
- this%valence_content(old_is_parton%lha_flavor)=&
- this%valence_content(old_is_parton%lha_flavor)+1
- end if
- else
- \IC{this is a q->qg splitting. the new initial state quark emits the }
- \IC{preceding initial state gluon. yeah, backward evolution is confusing!}
- \IC{the new initial state quark is not part of the proton remnant any longer.}
- \IC{how do we remove a quark from the remnant? we add a conjugated twin}
- \IC{parton and assume, that this twin is created in a not yet resolved}
- \IC{g->qqbar splitting.}
- call this%push_twin(new_id,lha_flavor,momentum_fraction,gev_scale)
- end if
- end if
- \IC{everything is done. what shall we do with the old initial state parton?}
- \IC{we don't need it any more but we store it anyway for future FSR extension.}
- call this%fs_partons%push(old_is_parton)
- \IC{the new initial state parton has taken away momentum, so we update the remnant}
- \IC{momentum fraction.}
- this%momentum_fraction=&
- this%momentum_fraction*(1-momentum_fraction)/(1-old_is_parton%momentum)
- else
- \IC{this indicates a bug.}
- print *,"proton_remnant_replace_is_parton: parton #",old_id,&
- " not found on ISR stack."
- if(associated(this%is_partons%next))then
- print *,"actual content of isr stack:"
- call this%is_partons%next%print_peers()
- else
- print *,"isr stack is not associated."
- end if
- STOP
- end if
- end subroutine proton_remnant_replace_is_parton
-\end{Verbatim}
-\TbpImp{proton\_remnant\_calculate\_weight}
-Die Wichtungsfaktoren $[W_G,W_S,W_{d^V},W_{u^V},W_Q]$ aus \eqref{eq:all:rem:sumrule} werden bestimmt.
-\begin{Verbatim}
- subroutine proton_remnant_calculate_weight(this,GeV_scale)
- class(proton_remnant_type),intent(inout)::this
- real(kind=double),intent(in)::GeV_scale
- real(kind=double)::all,gluon,sea,vu,vd,valence,twin,weight
- \IC{Die 1 aus \eqref{eq:all:rem:sumrule}}
- call this%pdf_norm%get_norm(GeV_scale,1,0,all)
- \IC{Die Impulsmittelwerte}
- call this%pdf_norm%get_norm(GeV_scale,1,pdf_int_kind_gluon,gluon)
- call this%pdf_norm%get_norm(GeV_scale,1,pdf_int_kind_sea,sea)
- call this%pdf_norm%get_norm(GeV_scale,1,pdf_int_kind_val_down,vd)
- call this%pdf_norm%get_norm(GeV_scale,1,pdf_int_kind_val_up,vu)
- \IC{Wir multiplizieren die Valenzbeiträge mit dem Valenz-Inhalt-Faktor.}
- valence=&
- vd*this%valence_content(lha_flavor_d)+&
- vu*this%valence_content(lha_flavor_u)/2D0
- \IC{Die Quasivalenzquark-Beiträge werden auf die Summe aller LHAPDF-Mittelwerte normiert.}
- \IC{(siehe \TypeRef{pdfnorm\_type})}
- twin=this%twin_norm/all
- \IC{(siehe Tabelle \ref{tab:all:rem:weight_models} mit w\(\rightarrow\)weight)}
- select case(remnant_weight_model)
- case(0) ! no reweighting
- this%pdf_int_weight=[1D0,1D0,1D0,1D0,1D0]
- case(2) !pythia-like, only sea
- weight=(1D0-valence-twin)&
- &/(sea+gluon)
- this%pdf_int_weight=[weight,weight,1D0,1D0,1D0]
- case(3) !only valence and twin
- weight=(1D0-sea-gluon)&
- &/(valence+twin)
- this%pdf_int_weight=[1D0,1D0,weight,weight,weight]
- case(4) !only sea and twin
- weight=(1D0-valence)&
- &/(sea+gluon+twin)
- this%pdf_int_weight=[1D0,weight,1D0,1D0,weight]
- case default !equal weight
- weight=1D0/(valence+sea+gluon+twin)
- this%pdf_int_weight=[weight,weight,weight,weight,weight]
- end select
- this%pdf_int_weight(pdf_int_kind_val_down)=&
- this%pdf_int_weight(pdf_int_kind_val_down)*this%valence_content(1)
- this%pdf_int_weight(pdf_int_kind_val_up)=&
- this%pdf_int_weight(pdf_int_kind_val_up)*this%valence_content(2)*5D-1
- end subroutine proton_remnant_calculate_weight
-\end{Verbatim}
-\OverridesSection{serializable\_class}
-
-\TbpImp{proton\_remnant\_write\_to\_marker}
-\begin{Verbatim}
- subroutine proton_remnant_write_to_marker(this,marker,status)
- class(proton_remnant_type),intent(in)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("proton_remnant_type")
- call marker%mark("valence_content",this%valence_content)
- call marker%mark("momentum_fraction",this%momentum_fraction)
- call marker%mark("pdf_int_weight",this%pdf_int_weight)
- call marker%mark_end("proton_remnant_type")
- end subroutine proton_remnant_write_to_marker
-\end{Verbatim}
-
-\TbpImp{proton\_remnant\_read\_from\_marker}
-\begin{Verbatim}
- subroutine proton_remnant_read_from_marker(this,marker,status)
- class(proton_remnant_type),intent(out)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- character(:),allocatable::name
- call marker%pick_begin("proton_remnant_type",status=status)
- call marker%pick("valence_content",this%valence_content,status)
- call marker%pick("momentum_fraction",this%momentum_fraction,status)
- call marker%pick("pdf_int_weight",this%pdf_int_weight,status)
- call marker%pick_end("proton_remnant_type",status=status)
- end subroutine proton_remnant_read_from_marker
-\end{Verbatim}
-
-\TbpImp{proton\_remnant\_print\_to\_unit}
-\begin{Verbatim}
- subroutine proton_remnant_print_to_unit(this,unit,parents,components,peers)
- class(proton_remnant_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- write(unit,'("Components of proton_remnant_type:")')
- write(unit,'("Valence Content: ",I1,":",I1)')this&
- &%valence_content
- write(unit,'("N Twins: ",I1)')this%n_twins
- write(unit,'("INT weights [g,s,d,u,t] ",5(F7.3))')this%pdf_int_weight
- write(unit,'("Total Momentum Fraction: ",F7.3)')this%momentum_fraction
- write(unit,'("Twin Norm: ",F7.3)')this%twin_norm
- end subroutine proton_remnant_print_to_unit
-\end{Verbatim}
- \TbpImp{proton\_remnant\_get\_type}
-\begin{Verbatim}
- pure subroutine proton_remnant_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="proton_remnant_type")
- end subroutine proton_remnant_get_type
-\end{Verbatim}
-\TbpImp{proton\_remnant\_gnuplot\_momentum\_kind\_pdf\_array}
-Außerhalb dieser Prozedur müssen zwei Dateien mit formatiertem, sequentiellen Schreibzugriff geöffnet werden und die assoziierten units an momentum\_unit und parton\_unit übergeben werden. Dann wird $[x_j,\sum_k f_k(x_j,\mu),\{f_k(x_j,\mu)\}],j=1..100$ nach parton\_unit und $[x_j,\sum_k x_j f_k(x_j,\mu),x_j \{f_k(x_j,\mu)\}],j=1..100$ nach momentum\_unit geschrieben. $k$ sind alle einzelnen Beiträge zur Strukturfunktion mit $k=[v^d,v^u,\overline{\{q\}},g,\{q\},\{Q\}]$, $\{q\}$ sind alle Flavor und $\{Q\}$ alle Quasivalenzquarks.
-\begin{Verbatim}
- subroutine proton_remnant_gnuplot_momentum_kind_pdf_array&
- (this,momentum_unit,parton_unit,GeV_scale)
- class(proton_remnant_type),intent(in)::this
- integer,intent(in)::momentum_unit,parton_unit
- real(kind=double),intent(in)::GeV_scale
- real(kind=double),dimension(2)::valence_pdf
- real(kind=double),dimension(-6:6)::sea_pdf
- real(kind=double),dimension(this%n_twins)::twin_pdf
- integer::x
- real(kind=double)::momentum_fraction
- do x=1,100
- momentum_fraction=x*1D-2
- call this%momentum_kind_pdf_array(GeV_scale,momentum_fraction&
- &,valence_pdf,sea_pdf)
- call this%momentum_twin_pdf_array(momentum_fraction,twin_pdf)
- write(momentum_unit,fmt=*)momentum_fraction,&
- sum(valence_pdf)+sum(sea_pdf)+sum(twin_pdf),&
- valence_pdf,&
- sea_pdf,&
- twin_pdf
- call this%parton_kind_pdf_array(GeV_scale,momentum_fraction&
- &,valence_pdf,sea_pdf)
- call this%parton_twin_pdf_array(momentum_fraction,twin_pdf)
- write(parton_unit,fmt=*)momentum_fraction,&
- sum(valence_pdf)+sum(sea_pdf)+sum(twin_pdf),&
- valence_pdf,&
- sea_pdf,&
- twin_pdf
- end do
- end subroutine proton_remnant_gnuplot_momentum_kind_pdf_array
-\end{Verbatim}
-\MethodsFor{pp\_remnant\_type}
-\TbpImp{pp\_remnant\_initialize}
-Der Hauptzweck dieser Prozedur ist es, die Impulsmittelwerte $\mean{f}(\mu)=\int\!\der\!x\ x f(x,\mu)$
- bereitzustellen. Im Verzeichnis muli\_dir wird nach integrierten PDFs, passend zu dem verwendeten LHAPDF-Set, gesucht. Wenn sie existierten, werden sie deserialisiert, sonst werden sie neu generiert und serialisiert.
-\begin{Verbatim}
- subroutine pp_remnant_initialize(&
- this,&
- muli_dir,&
- lhapdf_dir,&
- lhapdf_file,&
- lhapdf_member)
- class(pp_remnant_type),intent(out)::this
- character(*),intent(in)::muli_dir,lhapdf_dir,lhapdf_file
- integer,intent(in)::lhapdf_member
- logical::exist
- allocate(this%pdf_norm)
- print *,"looking for previously generated pdf integrals..."
- inquire(file=muli_dir//"/pdf_norm_"//lhapdf_file//".xml",exist=exist)
- if(exist)then
- print *,"found. Starting deserialization..."
- call this%pdf_norm%deserialize(&
- name="pdf_norm_"//lhapdf_file,&
- file=muli_dir//"/pdf_norm_"//lhapdf_file//".xml")
- print *,"done."
- else
- print *,"No integrals found. Starting generation..."
- call this%pdf_norm%scan()
- print *,"done."
- call this%pdf_norm%serialize(&
- name="pdf_norm_"//lhapdf_file,&
- file=muli_dir//"/pdf_norm_"//lhapdf_file//".xml")
- end if
- call this%proton(1)%initialize(this%pdf_norm)
- call this%proton(2)%initialize(this%pdf_norm)
- this%initialized=.true.
- end subroutine pp_remnant_initialize
-\end{Verbatim}
-\TbpImp{pp\_remnant\_finalize}
-Die Impulsmittelwerte in \CompRef{pp\_remnant\_type}{pdf\_norm} werden deallokiert und Zeiger darauf deassoziiert.
-\begin{Verbatim}
- subroutine pp_remnant_finalize(this)
- class(pp_remnant_type),intent(inout)::this
- call this%proton(1)%finalize()
- call this%proton(2)%finalize()
- deallocate(this%pdf_norm)
- end subroutine pp_remnant_finalize
-\end{Verbatim}
-\TbpImp{pp\_remnant\_apply\_initial\_interaction}
-Wrapper für \TbpRef{proton\_remnant\_type}{apply\_initial\_splitting}
-\begin{Verbatim}
- subroutine pp_remnant_apply_initial_interaction&
- (this,gev_cme,x1,x2,pdg_f1,pdg_f2,n1,n2,gev_scale,rnd1,rnd2)
- class(pp_remnant_type),intent(inout)::this
- real(kind=double),intent(in)::gev_cme,x1,x2,gev_scale,rnd1,rnd2
- integer,intent(in)::pdg_f1,pdg_f2,n1,n2
- if(this%initialized)then
- call this%proton(1)%apply_initial_splitting(n1,pdg_f1,x1,gev_scale,rnd1)
- call this%proton(2)%apply_initial_splitting(n2,pdg_f2,x2,gev_scale,rnd2)
- this%X=(1D0-x1)*(1D0-x2)
- this%gev_initial_cme=gev_cme
- else
- print *,"pp_remnant_apply_initial_interaction:"
- print *,"Not yet initialized, call pp_remnant_initialize first!"
- stop
- end if
- end subroutine pp_remnant_apply_initial_interaction
-\end{Verbatim}
-\TbpImp{pp\_remnant\_replace\_parton}
-Wrapper für \TbpRef{proton\_remnant\_type}{replace\_is\_parton}
-\begin{Verbatim}
- subroutine pp_remnant_replace_parton(this,proton_id,old_id,new_id,pdg_f,x_proton,gev_scale)
- class(pp_remnant_type),intent(inout)::this
- integer,intent(in)::proton_id,old_id,new_id,pdg_f
- real(kind=double),intent(in)::x_proton,gev_scale
- call this%proton(proton_id)%replace_is_parton(old_id,new_id,pdg_f,x_proton,gev_scale)
- end subroutine pp_remnant_replace_parton
-\end{Verbatim}
-\TbpImp{pp\_remnant\_momentum\_pdf}
-\begin{Verbatim}
- subroutine pp_remnant_momentum_pdf(this,x_proton,gev2_scale,n,pdg_f,pdf)
- class(pp_remnant_type),intent(in)::this
- real(kind=double),intent(in)::x_proton,gev2_scale
- integer,intent(in)::n,pdg_f
- real(kind=double),intent(out)::pdf
- \IC{Von welchem Remnant wollen wir die Momentum PDF haben?}
- \IC{Es muss das erste oder das zweite sein.}
- if(n==1.or.n==2)then
- \IC{Der Impulsanteil $x$ ist auf den Impuls des ungestörten Protons bezogen,}
- \IC{deswegen darf es nicht zwischen 0 und 1 sein, sondern nur zwischen 0 und $X$.}
- if(x_proton<=this%proton(n)%momentum_fraction)then
- \IC{momentum\_flavor\_pdf erwartet Flavor im PDG-Schema.}
- \IC{Das Gluon muss entsprechend konvertiert werden.}
- if(pdg_f==pdg_flavor_g)then
- call this%proton(n)%momentum_flavor_pdf(&
- sqrt(GeV2_scale),&
- \IC{momentum\_flavor\_pdf erwartet Impulsanteile, die auf die Remnantimpulse}
- \IC{bezogen sind.}
- x_proton/this%proton(n)%momentum_fraction,&
- lha_flavor_g,&
- pdf&
- )
- else
- call this%proton(n)%momentum_flavor_pdf(&
- sqrt(GeV2_scale),x_proton/this%proton(n)%momentum_fraction,pdg_f,pdf&
- )
- end if
- \IC{Durch die Transformation des Arguments müssen auch die Funktionswerte}
- \IC{angepasst werden.}
- pdf=pdf*this%proton(n)%momentum_fraction
- else
- pdf=0D0
- end if
- else
- print *,"pp_remnant_momentum_pdf: n must be either 1 or 2, but it is ",n
- stop
- end if
- end subroutine pp_remnant_momentum_pdf
-\end{Verbatim}
-\TbpImp{pp\_remnant\_parton\_pdf}
-
-\begin{Verbatim}
- subroutine pp_remnant_parton_pdf(this,x_proton,gev2_scale,n,pdg_f,pdf)
- class(pp_remnant_type),intent(in)::this
- real(kind=double),intent(in)::x_proton,gev2_scale
- integer,intent(in)::n,pdg_f
- real(kind=double),intent(out)::pdf
- if(n==1.or.n==2)then
- if(x_proton<=this%proton(n)%momentum_fraction)then
- if(pdg_f==pdg_flavor_g)then
- call this%proton(n)%parton_flavor_pdf(&
- sqrt(GeV2_scale),&
- x_proton*(1D0-this%proton(n)%momentum_fraction),&
- lha_flavor_g,&
- pdf&
- )
- else
- call this%proton(n)%parton_flavor_pdf(&
- sqrt(GeV2_scale),&
- x_proton*(1D0-this%proton(n)%momentum_fraction),&
- pdg_f,&
- pdf&
- )
- end if
- pdf=pdf/(1D0-this%proton(n)%momentum_fraction)
- else
- pdf=0D0
- end if
- else
- print *,"pp_remnant_parton_pdf: n must be either 1 or 2, but it is ",n
- stop
- end if
- end subroutine pp_remnant_parton_pdf
-\end{Verbatim}
-\TbpImp{pp\_remnant\_apply\_interaction}
-Den Remnants wird mitgeteilt, dass eine Wechselwirkung stattgefunden hat. Alle Informationen über diese Wechselwirkung liegen in einer Instanz vom Typ \TypeRef{muli\_type}. Um sie zu erreichen, wird ein Dummyargument der Klasse \TypeRef{qcd\_2\_2\_type}, die von \TypeRef{muli\_type} erweitert wird, deklariert.
-
-Hier geschieht nichts, außer dass das Stratum $\{\alpha,\beta\}$ explizit als Ganzzahlen-Doublet in \emph{int\_k} abgelegt wird und für beide Remnants this\%proton(1) und this\%proton(2) die entsprechende Methoden aus der Menge $\{$\TbpRef{proton\_remnant\_type}{remove\_valence\_down\_quark}, \TbpRef{proton\_remnant\_type}{remove\_valence\_up\_quark}, \TbpRef{proton\_remnant\_type}{remove\_sea\_quark}, \TbpRef{proton\_remnant\_type}{remove\_gluon}$\}$ aufgerufen wird.
-\begin{Verbatim}
- subroutine pp_remnant_apply_interaction(this,qcd_2_2)
- class(pp_remnant_type),intent(inout)::this
- class(qcd_2_2_class),intent(in)::qcd_2_2
- integer,dimension(4)::lha_f
- integer,dimension(2)::int_k
- real(kind=double)::gev_pt
- real(kind=double),dimension(2)::mom_f
- integer::n
- mom_f=qcd_2_2%get_remnant_momentum_fractions()
- lha_f=qcd_2_2%get_lha_flavors()
- int_k=qcd_2_2%get_pdf_int_kinds()
- gev_pt=qcd_2_2%get_gev_scale()
- do n=1,2
- select case (int_k(n))
- case(pdf_int_kind_val_down)
- call this%proton(n)%remove_valence_down_quark(&
- qcd_2_2%get_parton_id(n),&
- gev_pt,&
- mom_f(n))
- case(pdf_int_kind_val_up)
- call this%proton(n)%remove_valence_up_quark(&
- qcd_2_2%get_parton_id(n),&
- gev_pt,&
- mom_f(n))
- case(pdf_int_kind_sea)
- call this%proton(n)%remove_sea_quark(&
- qcd_2_2%get_parton_id(n),&
- gev_pt,&
- mom_f(n),&
- lha_f(n))
- case(pdf_int_kind_gluon)
- call this%proton(n)%remove_gluon(&
- qcd_2_2%get_parton_id(n),&
- gev_pt,&
- mom_f(n))
- end select
- end do
- this%X=this%proton(1)%momentum_fraction*this%proton(2)%momentum_fraction
- end subroutine pp_remnant_apply_interaction
-\end{Verbatim}
-
-\TbpImp{pp\_remnant\_reset}
-\begin{Verbatim}
- subroutine pp_remnant_reset(this)
- class(pp_remnant_type),intent(inout)::this
- call this%proton(1)%reset()
- call this%proton(2)%reset()
- this%X=1D0
- end subroutine pp_remnant_reset
-\end{Verbatim}
-
-\TbpImp{pp\_remnant\_get\_pdf\_int\_weights}
-\begin{Verbatim}
- pure function pp_remnant_get_pdf_int_weights(this,pdf_int_kinds) result(weight)
- class(pp_remnant_type),intent(in)::this
- real(kind=double)::weight
- integer,dimension(2),intent(in)::pdf_int_kinds ! pdf_int_kind
- weight=this%proton(1)%pdf_int_weight(pdf_int_kinds(1))&
- *this%proton(2)%pdf_int_weight(pdf_int_kinds(2))
- end function pp_remnant_get_pdf_int_weights
-\end{Verbatim}
-
-\TbpImp{pp\_remnant\_get\_pdf\_int\_weight}
-\begin{Verbatim}
- elemental function pp_remnant_get_pdf_int_weight(this,kind1,kind2) result(weight)
- class(pp_remnant_type),intent(in)::this
- real(kind=double)::weight
- integer,intent(in)::kind1,kind2 ! pdf_int_kind
- weight=this%proton(1)%pdf_int_weight(kind1)&
- *this%proton(2)%pdf_int_weight(kind2)
- end function pp_remnant_get_pdf_int_weight
-\end{Verbatim}
-
-\TbpImp{pp\_remnant\_set\_pdf\_weight}
-\begin{Verbatim}
- subroutine pp_remnant_set_pdf_weight(this,weights)
- class(pp_remnant_type),intent(inout)::this
- real(kind=double),dimension(10),intent(in)::weights
- this%proton(1)%pdf_int_weight=weights(1:5)
- this%proton(2)%pdf_int_weight=weights(6:10)
- end subroutine pp_remnant_set_pdf_weight
-\end{Verbatim}
-
-\TbpImp{pp\_remnant\_get\_gev\_initial\_cme}
-\begin{Verbatim}
- elemental function pp_remnant_get_gev_initial_cme(this) result(cme)
- class(pp_remnant_type),intent(in)::this
- real(kind=double)::cme
- cme=this%gev_initial_cme
- end function pp_remnant_get_gev_initial_cme
-\end{Verbatim}
-
-\TbpImp{pp\_remnant\_get\_gev\_actual\_cme}
-\begin{Verbatim}
- elemental function pp_remnant_get_gev_actual_cme(this) result(cme)
- class(pp_remnant_type),intent(in)::this
- real(kind=double)::cme
- cme=this%gev_initial_cme*this%X
- end function pp_remnant_get_gev_actual_cme
-\end{Verbatim}
-
-\TbpImp{pp\_remnant\_get\_cme\_fraction}
-\begin{Verbatim}
- elemental function pp_remnant_get_cme_fraction(this) result(cme)
- class(pp_remnant_type),intent(in)::this
- real(kind=double)::cme
- cme=this%X
- end function pp_remnant_get_cme_fraction
-\end{Verbatim}
-
-\TbpImp{pp\_remnant\_get\_proton\_remnant\_momentum\_fractions}
-\begin{Verbatim}
- pure function pp_remnant_get_proton_remnant_momentum_fractions(this) result(fractions)
- class(pp_remnant_type),intent(in)::this
- real(kind=double),dimension(2)::fractions
- fractions=[&
- this%proton(1)%get_momentum_fraction(),&
- this%proton(2)%get_momentum_fraction()]
- end function pp_remnant_get_proton_remnant_momentum_fractions
-\end{Verbatim}
-
-\TbpImp{pp\_remnant\_get\_proton\_remnants}
-\begin{Verbatim}
- subroutine pp_remnant_get_proton_remnants(this,proton1,proton2)
- class(pp_remnant_type),target,intent(in)::this
- class(proton_remnant_type),intent(out),pointer::proton1,proton2
- proton1=>this%proton(1)
- proton2=>this%proton(2)
- end subroutine pp_remnant_get_proton_remnants
-\end{Verbatim}
-
-\TbpImp{pp\_remnant\_get\_remnant\_parton\_flavor\_pdf\_arrays}
-\begin{Verbatim}
- subroutine pp_remnant_get_remnant_parton_flavor_pdf_arrays&
- (this,GeV_scale,momentum1,momentum2,pdf1,pdf2)
- class(pp_remnant_type),intent(in)::this
- real(kind=double),intent(in)::GeV_scale,momentum1,momentum2
- real(kind=double),dimension(-6:6),intent(out)::pdf1,pdf2
- call this%proton(1)%parton_flavor_pdf_array(GeV_scale,momentum1,pdf1)
- call this%proton(2)%parton_flavor_pdf_array(GeV_scale,momentum2,pdf2)
- end subroutine pp_remnant_get_remnant_parton_flavor_pdf_arrays
-\end{Verbatim}
-
- !overridden procedures
-
-\TbpImp{pp\_remnant\_write\_to\_marker}
-\begin{Verbatim}
- subroutine pp_remnant_write_to_marker(this,marker,status)
- class(pp_remnant_type),intent(in)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("pp_remnant_type")
- call marker%mark("gev_initial_cme",this%gev_initial_cme)
- call marker%mark("X",this%X)
- call this%proton(1)%write_to_marker(marker,status)
- call this%proton(2)%write_to_marker(marker,status)
- call marker%mark_end("pp_remnant_type")
- end subroutine pp_remnant_write_to_marker
-\end{Verbatim}
-
-\TbpImp{pp\_remnant\_read\_from\_marker}
-\begin{Verbatim}
- subroutine pp_remnant_read_from_marker(this,marker,status)
- class(pp_remnant_type),intent(out)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- character(:),allocatable::name
- call marker%pick_begin("pp_remnant_type",status=status)
- call marker%pick("gev_initial_cme",this%gev_initial_cme,status)
- call marker%pick("X",this%X,status)
- call this%proton(1)%read_from_marker(marker,status)
- call this%proton(2)%read_from_marker(marker,status)
- call marker%pick_end("pp_remnant_type",status=status)
- end subroutine pp_remnant_read_from_marker
-\end{Verbatim}
-
-\TbpImp{pp\_remnant\_print\_to\_unit}
-\begin{Verbatim}
- subroutine pp_remnant_print_to_unit(this,unit,parents,components,peers)
- class(pp_remnant_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- write(unit,'("Components of pp_remnant_type:")')
- write(unit,'("Initial center of mass energy: ",F10.3)')this%gev_initial_cme
- write(unit,'("Actual center of mass energy: ",F10.3)')this%get_gev_actual_cme()
- write(unit,'("Total Momentum Fraction is: ",F10.3)')this%X
- if(components>0)then
- write(unit,'("Proton 1:")')
- call this%proton(1)%print_to_unit(unit,parents,components-1,peers)
- write(unit,'("Proton 2:")')
- call this%proton(2)%print_to_unit(unit,parents,components-1,peers)
- end if
- end subroutine pp_remnant_print_to_unit
-\end{Verbatim}
-\TbpImp{pp\_remnant\_get\_type}
-\begin{Verbatim}
- pure subroutine pp_remnant_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="pp_remnant_type")
- end subroutine pp_remnant_get_type
-\end{Verbatim}
-\MethodsNTB
-\ProcImp{remnant\_dglap\_splitting\_gqq}
-Der DGLAP-Splitting Kernel für ein $g\rightarrow q \overline{q}$ Splitting.
-\begin{Verbatim}
- pure function remnant_dglap_splitting_gqq(z) result(p)
- real(kind=double)::p
- real(kind=double),intent(in)::z
- p=(z**2+(1-z)**2)/2D0
- end function remnant_dglap_splitting_gqq
-\end{Verbatim}
-\ProcImp{remnant\_gluon\_pdf\_approx}
-Die Approximation der Gluon-Momentum-PDF. p ist Parameter der Approximation, üblicherweise wird er auf 4 gesetzt. Die Wahl von p wird in \CompRef{muli\_remnant}{gluon\_exp} festgelegt.
-\begin{Verbatim}
- pure function remnant_gluon_pdf_approx(x,p) result(g)
- real(kind=double)::g
- integer,intent(in)::p
- real(kind=double),intent(in)::x
- g=((1-x)**p)/x
- end function remnant_gluon_pdf_approx
-\end{Verbatim}
-
-\ProcImp{remnant\_norm\_0}
-Der reziproke Normierungsfaktor der Quasivalenzverteilung für p=0. xs ist der Impulsanteil des Seequarks.
-\begin{Verbatim}
- pure function remnant_norm_0(xs) result(c0)
- real(kind=double)::c0
- real(kind=double),intent(in)::xs
- c0=6*xs/(2-xs*(3-3*xs+2*xs**2))
- end function remnant_norm_0
-\end{Verbatim}
-
-\ProcImp{remnant\_norm\_1}
-Der reziproke Normierungsfaktor der Quasivalenzverteilung für p=1. xs ist der Impulsanteil des Seequarks.
-\begin{Verbatim}
- pure function remnant_norm_1(xs) result(c1)
- real(kind=double)::c1
- real(kind=double),intent(in)::xs
- c1=3*xs/(2-xs**2*(3-xs)+3*xs*log(xs))
- end function remnant_norm_1
-\end{Verbatim}
-
-\ProcImp{remnant\_norm\_4}
-Der reziproke Normierungsfaktor der Quasivalenzverteilung für p=4. xs ist der Impulsanteil des Seequarks.
-\begin{Verbatim}
- pure function remnant_norm_4(xs) result(c4)
- real(kind=double)::c4
- real(kind=double),intent(in)::xs
- real(kind=double)::y
- if((1D0-xs)>1D-3)then
- c4=3*xs/&
- (1 + 11*xs + 6*xs*log(xs) + 12*xs**3*log(xs) + 18*xs**2*log(xs)&
- + 9*xs**2 - 19*xs**3 - 2*xs**4)
- else
- y=1D0/(1D0-xs)
- c4=&
- &1130D0/11907D0&
- & -10D0 *y**5&
- & -40D0 *y**4/3D0&
- & -160D0*y**3/63D0&
- & +50D0 *y**2/189D0&
- & -565D0*y /3969D0&
- & -186170D0*(1D0-xs)/2750517D0
- end if
- end function remnant_norm_4
-\end{Verbatim}
-
-\ProcImp{remnant\_norm}
-Der reziproke Normierungsfaktor der Quasivalenzverteilung für p. xs ist der Impulsanteil des Seequarks.
-\begin{Verbatim}
- pure function remnant_norm(xs,p) result(c)
- real(kind=double)::c
- real(kind=double),intent(in)::xs
- integer,intent(in)::p
- select case (p)
- case(0)
- c=remnant_norm_0(xs)
- case(1)
- c=remnant_norm_1(xs)
- case default
- c=remnant_norm_4(xs)
- end select
- end function remnant_norm
-\end{Verbatim}
-
-\ProcImp{remnant\_twin\_pdf\_p}
-Der normierte, aber ungewichtete Quasivalenzbeitrag $f_{q^Q}(x,\overline{x})$ mit $xs\ =\overline{x}$.
-\begin{Verbatim}
- pure function remnant_twin_pdf_p(x,xs,p) result(qc)
- real(kind=double)::qc
- real(kind=double),intent(in)::x,xs
- integer,intent(in)::p
- qc=remnant_norm(xs,p)*&
- remnant_gluon_pdf_approx(xs+x,p)*&
- remnant_dglap_splitting_gqq(xs/(xs+x))/(xs+x)
- end function remnant_twin_pdf_p
-\end{Verbatim}
-
-\ProcImp{remnant\_twin\_momentum\_4}
-Der Impulsmittelwert des normierten, aber ungewichteten Quasivalenzbeitrags $\mean{f_{q^Q}}(\overline{x})=\int\!\der\!x\ x f_{q^Q}(x,\overline{x})$ mit $xs\ =\overline{x}$.
-\begin{Verbatim}
- elemental function remnant_twin_momentum_4(xs) result(p)
- real(kind=double)::p
- real(kind=double),intent(in)::xs
- if(xs<0.99D0)then
- p=(-9*(-1+xs)*xs*(1+xs)*(5+xs*(24+xs))+12*xs*(1+2*xs)*(1+2*xs*(5+2*xs))*Log(xs))/&
- (8*(1+2*xs)*((-1+xs)*(1+xs*(10+xs))-6*xs*(1+xs)*Log(xs)))
- else
- p=(1-xs)/6-(5*(-1+xs)**2)/63+(5*(-1+xs)**3)/216
- end if
- end function remnant_twin_momentum_4
-\end{Verbatim}
-
-\ProcImp{gnuplot\_integrated\_pdf}
-Zu Debuggingzwecken können die integrierten PDFs geplottet werden.
-\begin{Verbatim}
- subroutine gnuplot_integrated_pdf(this,momentum_unit,parton_unit)
- class(proton_remnant_type),intent(in)::this
- integer,intent(in)::momentum_unit,parton_unit
- integer,parameter::x_grid=1000000
- integer,parameter::q_grid=100
- integer::n,m,mem
- real(kind=double)::x,q,dx,dq,overall_sum,xmin,xmax,q2min,q2max,qmin,qmax
- real(kind=double),dimension(-6:6)::sea_pdf,sea_momentum_pdf_sum,sea_parton_pdf_sum
- real(kind=double),dimension(2)::valence_pdf,valence_momentum_pdf_sum,valence_parton_pdf_sum
- real(kind=double),allocatable,dimension(:)::twin_momentum_pdf_sum
- class(parton_type),pointer::tmp_twin
- mem=1
- call GetXmin(mem,xmin)
- call GetXmax(mem,xmax)
- call GetQ2max(mem,q2max)
- call GetQ2min(mem,q2min)
- qmin=sqrt(q2min)
- qmax=sqrt(q2max)
- print *,"qmin=",qmin,"GeV"
- print *,"qmax=",qmax,"GeV"
- dx=(xmax-xmin)/x_grid
- dq=(qmax-qmin)/q_grid
- q=qmin+dq/2D0
- tmp_twin=>this%twin_partons%next
- n=0
- if(this%n_twins>0)then
- allocate(twin_momentum_pdf_sum(this%n_twins))
- do while(associated(tmp_twin))
- n=n+1
- twin_momentum_pdf_sum(n)=tmp_twin%momentum
- tmp_twin=>tmp_twin%next
- end do
- end if
- do m=1,q_grid
- valence_momentum_pdf_sum=[0D0,0D0]
- valence_parton_pdf_sum=[0D0,0D0]
- sea_momentum_pdf_sum=[0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0]
- sea_parton_pdf_sum=[0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0]
- x=xmin+dx/2D0
- do n=1,x_grid
- call this%parton_kind_pdf_array(Q,x,valence_pdf,sea_pdf)
- valence_parton_pdf_sum=valence_parton_pdf_sum+valence_pdf
- sea_parton_pdf_sum=sea_parton_pdf_sum+sea_pdf
- call this%momentum_kind_pdf_array(Q,x,valence_pdf,sea_pdf)
- valence_momentum_pdf_sum=valence_momentum_pdf_sum+valence_pdf
- sea_momentum_pdf_sum=sea_momentum_pdf_sum+sea_pdf
- x=x+dx
- end do
- valence_parton_pdf_sum=valence_parton_pdf_sum*dx
- sea_parton_pdf_sum=sea_parton_pdf_sum*dx
- valence_momentum_pdf_sum=valence_momentum_pdf_sum*dx
- sea_momentum_pdf_sum=sea_momentum_pdf_sum*dx
- if(this%n_twins>0)then
- write(momentum_unit,fmt=*)q,&
- sum(valence_momentum_pdf_sum)&
- +sum(sea_momentum_pdf_sum)&
- +sum(twin_momentum_pdf_sum),&
- valence_momentum_pdf_sum,&
- sea_momentum_pdf_sum,&
- twin_momentum_pdf_sum
- else
- write(momentum_unit,fmt=*)q,&
- sum(valence_momentum_pdf_sum)+sum(sea_momentum_pdf_sum),&
- valence_momentum_pdf_sum,&
- sea_momentum_pdf_sum
- end if
- write(parton_unit,fmt=*)q,&
- sum(valence_parton_pdf_sum)+sum(sea_parton_pdf_sum),&
- valence_parton_pdf_sum,&
- sea_parton_pdf_sum
- q=q+dq
- end do
- end subroutine gnuplot_integrated_pdf
-\end{Verbatim}
-
Index: trunk/src/muli/doc/muli_cuba.tex
===================================================================
--- trunk/src/muli/doc/muli_cuba.tex (revision 8371)
+++ trunk/src/muli/doc/muli_cuba.tex (revision 8372)
@@ -1,1126 +0,0 @@
-\Module{muli\_cuba}
-%\begin{figure}
-% \centering{\includegraphics{uml-module-tree-10.mps}}
-% \caption{\label{fig:\ThisModule:Types}Klassendiagramm des Moduls \ThisModule}
-%\end{figure}
-\section{Abhängigkeiten}
-\use{muli\_momentum}
-\section{Parameter}
-\begin{Verbatim}
- integer, parameter :: max_maxeval = huge(1)
-\end{Verbatim}
-\section{Derived Types}
-\TypeDef{cuba\_class}
-\begin{Verbatim}
- type,\Extends{serializable\_class}, abstract :: cuba_class
- ! private
- real(kind=drk) :: \TC{start\_time}=0D0
- real(kind=drk) :: \TC{stop\_time}=0D0
- real(kind=drk) :: \TC{run\_time}=0D0
- ! common input
- integer :: \TC{dim\_x} = 2
- integer :: \TC{dim\_f} = 1
- type(\TypeRef{transversal\_momentum\_type}) :: \TC{userdata}
- real(kind=drk) :: \TC{eps\_rel} = 1D-3
- real(kind=drk) :: \TC{eps\_abs} = 0D0
- integer :: \TC{flags} = 0
- integer :: \TC{seed} = 1
- integer :: \TC{min\_eval} = 0
- integer :: \TC{max\_eval} = max_maxeval
- ! common output
- integer :: \TC{neval} = 0
- integer,public :: \TC{fail} = -1
- integer :: \TC{nregions} = 0
- real(kind=drk), dimension(:), allocatable :: \TC{integral}
- real(kind=drk), dimension(:), allocatable :: \TC{error}
- real(kind=drk), dimension(:), allocatable :: \TC{prob}
-
- procedure(integrand_interface),nopass,pointer::\TC{integrand}
- contains
- \OverridesDeclaration{serializable\_class}
- procedure::\TbpDec{write\_to\_marker}{cuba\_write\_to\_marker}
- procedure::\TbpDec{read\_from\_marker}{cuba\_read\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{cuba\_print\_to\_unit}
- \OriginalDeclaration
- procedure ::\TbpDec{get\_integral\_array}{cuba\_get\_integral\_array}
- procedure ::\TbpDec{get\_integral\_1}{cuba\_get\_integral\_1}
- generic ::\TbpGen{get\_integral}{get\_integral\_array,get\_integral\_1}
- procedure ::\TbpDec{copy\_common}{cuba\_copy\_common}
- procedure ::\TbpDec{set\_common}{cuba\_set\_common}
- procedure ::\TbpDec{set\_dim\_f}{cuba\_set\_dim\_f}
- procedure ::\TbpDec{set\_dim\_x}{cuba\_set\_dim\_x}
- procedure ::\TbpDec{reset\_timer}{cuba\_reset\_timer}
- procedure ::\TbpDec{integrate\_with\_timer}{cuba\_integrate\_with\_timer}
- procedure ::\TbpDec{integrate\_associated}{cuba\_integrate\_associated}
- procedure(integrate_interface), deferred :: integrate_nd
- procedure(integrate_userdata_interface), deferred :: integrate_userdata
- procedure(cuba_copy_interface), deferred :: copy
-
- procedure ::\TbpDec{dealloc\_dim\_f}{cuba\_dealloc\_dim\_f}
- procedure ::\TbpDec{alloc\_dim\_f}{cuba\_alloc\_dim\_f}
- procedure ::\TbpDec{dealloc}{cuba\_dealloc}
- procedure ::\TbpDec{alloc}{cuba\_alloc}
- generic ::\TbpGen{integrate}{integrate\_nd,integrate\_userdata}
- end type cuba_class
-\end{Verbatim}
-\TypeDef{cuba\_cuhre\_type}
-\begin{Verbatim}
- type,\Extends{cuba\_class} :: cuba_cuhre_type
- private
- integer :: \TC{key} = 13
- contains
- \OverridesDeclaration{serializable\_class}
- procedure::\TbpDec{write\_to\_marker}{cuba\_cuhre\_write\_to\_marker}
- procedure::\TbpDec{read\_from\_marker}{cuba\_cuhre\_read\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{cuba\_cuhre\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{cuba\_cuhre\_get\_type}
- \OverridesDeclaration{cuba\_class}
- procedure ::\TbpDec{integrate\_nd}{integrate\_cuhre}
- procedure ::\TbpDec{integrate\_userdata}{integrate\_cuhre\_userdata}
- procedure ::\TbpDec{copy}{cuba\_cuhre\_copy}
- procedure ::\TbpDec{set\_deferred}{cuba\_cuhre\_set\_deferred}
- end type cuba_cuhre_type
-\end{Verbatim}
-\TypeDef{cuba\_suave\_type}
-\begin{Verbatim}
- type,\Extends{cuba\_class} :: cuba_suave_type
- private
- integer :: \TC{nnew} = 10000 !1000
- integer :: \TC{flatness} = 5 !50
- contains
- \OverridesDeclaration{serializable\_class}
- procedure::\TbpDec{write\_to\_marker}{cuba\_suave\_write\_to\_marker}
- procedure::\TbpDec{read\_from\_marker}{cuba\_suave\_read\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{cuba\_suave\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{cuba\_suave\_get\_type}
- \OverridesDeclaration{cuba\_class}
- procedure ::\TbpDec{integrate\_nd}{integrate\_suave}
- procedure ::\TbpDec{integrate\_userdata}{integrate\_suave\_userdata}
- procedure ::\TbpDec{copy}{cuba\_suave\_copy}
- end type cuba_suave_type
-\end{Verbatim}
-\TypeDef{cuba\_divonne\_type}
-\begin{Verbatim}
- type,\Extends{cuba\_class} :: cuba_divonne_type
- private
- integer :: \TC{key1} = 13
- integer :: \TC{key2} = 13
- integer :: \TC{key3} = 13
- integer :: \TC{maxpass} = 2
- real(kind=drk) :: \TC{border} = 0D0
- real(kind=drk) :: \TC{maxchisq} = 10D0
- real(kind=drk) :: \TC{mindeviation} = .25D0
- integer :: \TC{ngiven} = 0
- integer :: \TC{ldxgiven} = 0
- real(kind=drk),dimension(:,:),allocatable :: \TC{xgiven}
- integer :: \TC{nextra} = 0
- contains
- \OverridesDeclaration{serializable\_class}
- procedure::\TbpDec{write\_to\_marker}{cuba\_divonne\_write\_to\_marker}
- procedure::\TbpDec{read\_from\_marker}{cuba\_divonne\_read\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{cuba\_divonne\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{cuba\_divonne\_get\_type}
- \OverridesDeclaration{cuba\_class}
- procedure ::\TbpDec{integrate\_nd}{integrate\_divonne}
- procedure ::\TbpDec{integrate\_userdata}{integrate\_divonne\_userdata}
- procedure ::\TbpDec{copy}{cuba\_divonne\_copy}
- procedure ::\TbpDec{set\_deferred}{cuba\_divonne\_set\_deferred}
- end type cuba_divonne_type
-\end{Verbatim}
-\TypeDef{cuba\_vegas\_type}
-\begin{Verbatim}
- type,\Extends{cuba\_class} :: cuba_vegas_type
- private
- integer :: \TC{nstart} = 500
- integer :: \TC{nincrease} = 1000
- integer :: \TC{nbatch} = 1000
- integer :: \TC{gridno} = 0
- character(len=8),pointer :: \TC{statefile} => null()
- contains
- \OverridesDeclaration{serializable\_class}
- procedure::\TbpDec{write\_to\_marker}{cuba\_vegas\_write\_to\_marker}
- procedure::\TbpDec{read\_from\_marker}{cuba\_vegas\_read\_from\_marker}
- procedure::\TbpDec{print\_to\_unit}{cuba\_vegas\_print\_to\_unit}
- procedure,nopass::\TbpDec{get\_type}{cuba\_vegas\_get\_type}
- \OverridesDeclaration{cuba\_class}
- procedure ::\TbpDec{integrate\_nd}{integrate\_vegas}
- procedure ::\TbpDec{integrate\_userdata}{integrate\_vegas\_userdata}
- procedure ::\TbpDec{copy}{cuba\_vegas\_copy}
- procedure ::\TbpDec{set\_deferred}{cuba\_vegas\_set\_deferred}
- end type cuba_vegas_type
-\end{Verbatim}
-\section{Interfaces}
-\begin{Verbatim}
- interface
- subroutine integrand_interface(dim_x, x, dim_f, f,userdata)
- use kinds !NODEP!
- use muli_momentum
- integer, intent(in) :: dim_x, dim_f
- real(kind=drk), dimension(dim_x), intent(in) :: x
- real(kind=drk), dimension(dim_f), intent(out) :: f
- class(transversal_momentum_type), intent(in) :: userdata
- end subroutine integrand_interface
- end interface
- interface
- subroutine cuba_copy_interface(this,source)
- import :: cuba_class
- class(cuba_class),intent(out)::this
- class(cuba_class),intent(in)::source
- end subroutine cuba_copy_interface
- subroutine ca_plain(this)
- import :: cuba_class
- class(cuba_class) :: this
- end subroutine ca_plain
- subroutine integrate_interface(this, integrand)
- import :: cuba_class
- class(cuba_class),intent(inout) :: this
- interface
- subroutine integrand(dim_x, x, dim_f, f,userdata)
- use kinds !NODEP!
- use muli_momentum
- integer, intent(in) :: dim_x, dim_f
- real(kind=drk), dimension(dim_x), intent(in) :: x
- real(kind=drk), dimension(dim_f), intent(out) :: f
- class(transversal_momentum_type), intent(in) :: userdata
- end subroutine integrand
- end interface
- end subroutine integrate_interface
- end interface
- interface
- subroutine integrate_userdata_interface(this, integrand,userdata)
- use muli_momentum
- import :: cuba_class
- class(cuba_class),intent(inout) :: this
- interface
- subroutine integrand(dim_x, x, dim_f, f,userdata)
- use kinds !NODEP!
- use muli_momentum
- integer, intent(in) :: dim_x, dim_f
- real(kind=drk), dimension(dim_x), intent(in) :: x
- real(kind=drk), dimension(dim_f), intent(out) :: f
- class(transversal_momentum_type), intent(in) :: userdata
- end subroutine integrand
- end interface
- class(transversal_momentum_type),intent(in)::userdata
- end subroutine integrate_userdata_interface
- end interface
-\end{Verbatim}
-\Methods
-\MethodsFor{cuba\_class}
-\OverridesSection{serializable\_class}
-
-\TbpImp{cuba\_write\_to\_marker}
-\begin{Verbatim}
- subroutine cuba_write_to_marker(this,marker,status)
- class(cuba_class),intent(in)::this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("cuba_class")
- call marker%mark("dim_x",this%dim_x)
- call marker%mark("dim_f",this%dim_f)
- call marker%mark("eps_rel",this%eps_rel)
- call marker%mark("eps_abs",this%eps_abs)
- call marker%mark("flags",this%flags)
- call marker%mark("min_eval",this%min_eval)
- call marker%mark("max_eval",this%max_eval)
- call marker%mark("neval",this%neval)
- call marker%mark("fail",this%fail)
- call marker%mark("nregions",this%nregions)
- if(allocated(this%integral))then
- call marker%mark("integral",this%integral)
- else
- call marker%mark_null("integral")
- end if
- if(allocated(this%error))then
- call marker%mark("error",this%error)
- else
- call marker%mark_null("error")
-
- end if
- if(allocated(this%prob))then
- call marker%mark("prob",this%prob)
- else
- call marker%mark_null("prob")
- end if
- call marker%mark_null("cuba_class")
- end subroutine cuba_write_to_marker
-\end{Verbatim}
-
-\TbpImp{cuba\_read\_from\_marker}
-\begin{Verbatim}
- subroutine cuba_read_from_marker(this,marker,status)
- class(cuba_class),intent(out) :: this
- class(marker_type), intent(inout) :: marker
- integer(kind=dik),intent(out)::status
- call marker%pick_begin("CUBA_CLASS",status=status)
- call marker%pick("dim_x",this%dim_x,status)
- call marker%pick("dim_f",this%dim_f,status)
- call marker%pick("eps_rel",this%eps_rel,status)
- call marker%pick("eps_abs",this%eps_abs,status)
- call marker%pick("flags",this%flags,status)
- call marker%pick("min_eval",this%min_eval,status)
- call marker%pick("max_eval",this%max_eval,status)
- call marker%pick("neval",this%neval,status)
- call marker%pick("fail",this%fail,status)
- call marker%pick("nregions",this%nregions,status)
- call marker%verify_nothing("integral",status)
- if(allocated(this%integral))deallocate(this%integral)
- if(status==serialize_ok)then
- allocate(this%integral(this%dim_f))
- call marker%pick("integral",this%integral,status)
- end if
- call marker%verify_nothing("error",status)
- if(allocated(this%error))deallocate(this%error)
- if(status==serialize_ok)then
- allocate(this%error(this%dim_f))
- call marker%pick("error",this%error,status)
- end if
- call marker%verify_nothing("prob",status)
- if(allocated(this%prob))deallocate(this%prob)
- if(status==serialize_ok)then
- allocate(this%prob(this%dim_f))
- call marker%pick("prob",this%prob,status)
- end if
- call marker%pick_end("cuba_class",status)
- END SUBROUTINE cuba_read_from_marker
-\end{Verbatim}
-
-\TbpImp{cuba\_print\_to\_unit}
-\begin{Verbatim}
- subroutine cuba_print_to_unit(this,unit,parents,components,peers)
- class(cuba_class),intent(in) :: this
- INTEGER, INTENT(IN) :: unit
- integer(kind=dik),intent(in)::parents,components,peers
- character(11)::n
- write(n,'("(",I2,"(E12.4))")')this%dim_f
- write(unit,'("Components of cuba_class:")')
- write(unit,'("Parameters:")')
- write(unit,'("dim_f: ",I10)') this%dim_f
- write(unit,'("dim_x: ",I10)') this%dim_x
- call this%userdata%print_to_unit(unit,parents,components-1,peers)
- write(unit,'("eps_rel: ",E10.4)') this%eps_rel
- write(unit,'("eps_abs: ",E10.4)') this%eps_abs
- write(unit,'("flags: ",I10)') this%flags
- write(unit,'("seed: ",I10)') this%seed
- write(unit,'("min_eval: ",I10)') this%min_eval
- write(unit,'("max_eval: ",I10)') this%max_eval
- write(unit,'("Results:")')
- write(unit,'("neval: ",I10)') this%neval
- write(unit,'("fail: ",I10)') this%fail
- write(unit,'("integral: ")',advance="no")
- write(unit,fmt=n)this%integral
- write(unit,'("error: ")',advance="no")
- write(unit,fmt=n)this%error
- write(unit,'("prob: ")',advance="no")
- write(unit,fmt=n)this%prob
- write(unit,'("time: ",E10.4)') this%stop_time-this%start_time
- ! write(unit,'("time: ",E10.4)') this%run_time
- end subroutine cuba_print_to_unit
-\end{Verbatim}
-\OriginalSection{cuba\_class}
-\TbpImp{cuba\_integrate\_associated}
-\begin{Verbatim}
- subroutine cuba_integrate_associated(this)
- class(cuba_class),intent(inout)::this
- call cuba_integrate_with_timer(this,this%integrand)
- end subroutine cuba_integrate_associated
-\end{Verbatim}
-
-\TbpImp{cuba\_integrate\_with\_timer}
-\begin{Verbatim}
- subroutine cuba_integrate_with_timer(this,integrand)
- class(cuba_class),intent(inout)::this
- procedure(integrand_interface)::integrand
- call cpu_time(this%start_time)
- call this%integrate(integrand)
- call cpu_time(this%stop_time)
- this%run_time=this%run_time+this%stop_time-this%start_time
- end subroutine cuba_integrate_with_timer
-\end{Verbatim}
-
-\TbpImp{cuba\_reset\_timer}
-\begin{Verbatim}
- subroutine cuba_reset_timer(this)
- class(cuba_class),intent(inout)::this
- this%start_time=0D0
- this%stop_time=0D0
- this%run_time=0D0
- end subroutine cuba_reset_timer
-\end{Verbatim}
-
-\TbpImp{cuba\_get\_integral\_array}
-\begin{Verbatim}
- subroutine cuba_get_integral_array(this,integral)
- class(cuba_class) :: this
- real(kind=drk),intent(out),dimension(:) :: integral
- integral=this%integral
- end subroutine cuba_get_integral_array
-\end{Verbatim}
-
-\TbpImp{cuba\_get\_integral\_1}
-\begin{Verbatim}
- subroutine cuba_get_integral_1(this,integral)
- class(cuba_class) :: this
- real(kind=drk),intent(out) :: integral
- integral=this%integral(1)
- end subroutine cuba_get_integral_1
-\end{Verbatim}
-
-\TbpImp{cuba\_dealloc\_dim\_f}
-\begin{Verbatim}
- subroutine cuba_dealloc_dim_f(this)
- class(cuba_class) :: this
- ! print '("cuba_dealloc_dim_f...")'
- if (allocated(this%integral)) then
- deallocate(this%integral)
- end if
- if (allocated(this%error)) then
- deallocate(this%error)
- end if
- if (allocated(this%prob)) then
- deallocate(this%prob)
- end if
- ! print '("done")'
- end subroutine cuba_dealloc_dim_f
-\end{Verbatim}
-
-\TbpImp{cuba\_dealloc}
-\begin{Verbatim}
- subroutine cuba_dealloc(this)
- class(cuba_class) :: this
- call this%dealloc_dim_f
- end subroutine cuba_dealloc
-\end{Verbatim}
-
-\TbpImp{cuba\_alloc\_dim\_f}
-\begin{Verbatim}
- subroutine cuba_alloc_dim_f(this)
- class(cuba_class) :: this
- call this%dealloc_dim_f()
- allocate(this%integral(this%dim_f))
- allocate(this%error(this%dim_f))
- allocate(this%prob(this%dim_f))
- end subroutine cuba_alloc_dim_f
-\end{Verbatim}
-
-\TbpImp{cuba\_alloc}
-\begin{Verbatim}
- subroutine cuba_alloc(this)
- class(cuba_class) :: this
- call this%alloc_dim_f
- end subroutine cuba_alloc
-\end{Verbatim}
-
-\TbpImp{cuba\_set\_common}
-\begin{Verbatim}
- subroutine cuba_set_common&
- (this,dim_x,dim_f,eps_rel,eps_abs,flags,seed,min_eval,max_eval,integrand,userdata)
- class(cuba_class),intent(inout) :: this
- integer,intent(in),optional :: dim_x,dim_f,flags,min_eval,max_eval,seed
- real(kind=drk),intent(in),optional :: eps_rel,eps_abs
- type(transversal_momentum_type),intent(in),optional :: userdata
- procedure(integrand_interface),optional::integrand
- if(present(dim_x))then
- call this%set_dim_x(dim_x)
- end if
- if(present(dim_f))then
- call this%set_dim_f(dim_f)
- end if
- if(present(flags))then
- this%flags=flags
- end if
- if(present(seed))then
- this%seed=seed
- end if
- if(present(min_eval))then
- this%min_eval=min_eval
- end if
- if(present(max_eval))then
- if(max_eval<max_maxeval)then
- this%max_eval=max_eval
- else
- print '("cuba_set_common: Value of max_eval is too large.")'
- this%max_eval=max_maxeval
- end if
- end if
- if(present(eps_rel))then
- this%eps_rel=eps_rel
- end if
- if(present(eps_abs))then
- this%eps_abs=eps_abs
- end if
- if(present(integrand))this%integrand=>integrand
- if(present(userdata))this%userdata=userdata
- end subroutine cuba_set_common
-\end{Verbatim}
-
-\TbpImp{cuba\_set\_dim\_f}
-\begin{Verbatim}
- subroutine cuba_set_dim_f(this,new_dim_f)
- class(cuba_class) :: this
- integer,intent(in) :: new_dim_f
- if (new_dim_f>0) then
- this%dim_f = new_dim_f
- call this%alloc_dim_f
- else
- write (*,'("cuba_set_dim_f: New value for dim_f is negative. dim_f is not set.")')
- end if
- end subroutine cuba_set_dim_f
-\end{Verbatim}
-
-\TbpImp{cuba\_set\_dim\_x}
-\begin{Verbatim}
- subroutine cuba_set_dim_x(this,new_dim_x)
- class(cuba_class) :: this
- integer,intent(in) :: new_dim_x
- if (new_dim_x>0) then
- this%dim_x = new_dim_x
- else
- write (*,'("cuba_set_dim_x: New value for dim_x is negative. dim_x is not set.")')
- end if
- end subroutine cuba_set_dim_x
-\end{Verbatim}
-
-\TbpImp{cuba\_copy\_common}
-\begin{Verbatim}
- subroutine cuba_copy_common(this,source)
- class(cuba_class),intent(out) :: this
- class(cuba_class),intent(in) :: source
- this%dim_x = source%dim_x
- this%dim_f = source%dim_f
- this%eps_rel = source%eps_rel
- this%eps_abs = source%eps_abs
- this%flags = source%flags
- this%min_eval = source%min_eval
- this%max_eval = source%max_eval
- call this%alloc()
- end subroutine cuba_copy_common
-\end{Verbatim}
-\MethodsFor{cuba\_vegas\_type}
-\OverridesSection{serializable\_class}
-\TbpImp{cuba\_vegas\_write\_to\_marker}
-\begin{Verbatim}
- subroutine cuba_vegas_write_to_marker(this,marker,status)
- class(cuba_vegas_type),intent(in) :: this
- class(marker_type), intent(inout) :: marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("cuba_vegas_type")
- call cuba_write_to_marker(this,marker,status)
- call marker%mark("nstart",this%nstart)
- call marker%mark("nincrease",this%nincrease)
- call marker%mark_null("cuba_vegas_type")
- end subroutine cuba_vegas_write_to_marker
-\end{Verbatim}
-
-\TbpImp{cuba\_vegas\_read\_from\_marker}
-\begin{Verbatim}
- subroutine cuba_vegas_read_from_marker(this,marker,status)
- class(cuba_vegas_type),intent(out) :: this
- class(marker_type), intent(inout) :: marker
- integer(kind=dik),intent(out)::status
- call marker%pick_begin("cuba_vegas_type",status=status)
- call cuba_read_from_marker(this,marker,status)
- call marker%pick("nstart",this%nstart,status)
- call marker%pick("nincrease",this%nincrease,status)
- call marker%pick_end("cuba_vegas_type",status)
- end subroutine cuba_vegas_read_from_marker
-\end{Verbatim}
-
-\TbpImp{cuba\_vegas\_print\_to\_unit}
-\begin{Verbatim}
- subroutine cuba_vegas_print_to_unit(this,unit,parents,components,peers)
- class(cuba_vegas_type),intent(in) :: this
- INTEGER, INTENT(IN) :: unit
- integer(kind=dik),intent(in)::parents,components,peers
- if(parents>0)call cuba_print_to_unit(this,unit,parents-1,components,peers)
- write(unit,'("Components of cuba_vegas_type:")')
- write(unit,'("nstart: ",I10)') this%nstart
- write(unit,'("nincrease: ",I10)') this%nincrease
- write(unit,'("nbatch: ",I10)') this%nbatch
- write(unit,'("gridno: ",I10)') this%gridno
- if(associated(this%statefile))then
- write(unit,'("statefile:",a)') this%statefile
- else
- write(unit,'("statefile:",a)') "not associated"
- end if
- end subroutine cuba_vegas_print_to_unit
-\end{Verbatim}
-\TbpImp{cuba\_vegas\_get\_type}
-\begin{Verbatim}
- pure subroutine cuba_vegas_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="cuba_vegas_type")
- end subroutine cuba_vegas_get_type
-\end{Verbatim}
-
-\OverridesSection{cuba\_class}
-\TbpImp{cuba\_vegas\_set\_deferred}
-\begin{Verbatim}
- subroutine cuba_vegas_set_deferred(this,n_start,n_increase,nbatch,gridno,statefile)
- class(cuba_vegas_type),intent(inout) :: this
- integer,intent(in),optional :: n_start,n_increase,nbatch,gridno
- character(len=*),intent(in),target,optional::statefile
- if(present(n_start))this%nstart=n_start
- if(present(n_increase))this%nincrease=n_increase
- if(present(nbatch))this%nbatch=nbatch
- if(present(gridno))this%gridno=gridno
- if(present(statefile))this%statefile=>statefile
- end subroutine cuba_vegas_set_deferred
-\end{Verbatim}
-
-\TbpImp{cuba\_vegas\_copy}
-\begin{Verbatim}
- subroutine cuba_vegas_copy(this,source)
- class(cuba_vegas_type),intent(out) :: this
- class(cuba_class),intent(in) :: source
- select type(source)
- class is (cuba_vegas_type)
- call this%copy_common(source)
- this%nstart=source%nstart
- this%nincrease=source%nincrease
- class default
- print *,"cuba_vegas_copy: type of source is not type compatible with &
- &cuba_vegas_type."
- end select
- end subroutine cuba_vegas_copy
-\end{Verbatim}
-
-\TbpImp{integrate\_vegas}
-\begin{Verbatim}
- subroutine integrate_vegas(this,integrand)
- class(cuba_vegas_type),intent(inout) :: this
- procedure(integrand_interface)::integrand
- ! print '("vegas")'
- call vegas(&
- this%dim_x, &
- this%dim_f, &
- integrand, &
- this%userdata, &
- this%eps_rel, &
- this%eps_abs, &
- this%flags, &
- this%seed, &
- this%min_eval, &
- this%max_eval, &
- this%nstart, &
- this%nincrease, &
- this%nbatch, &
- this%gridno, &
- this%statefile, &
- this%neval, &
- this%fail, &
- this%integral, &
- this%error, &
- this%prob)
- end subroutine integrate_vegas
-\end{Verbatim}
-
-\TbpImp{integrate\_vegas\_userdata}
-\begin{Verbatim}
- subroutine integrate_vegas_userdata(this,integrand,userdata)
- class(cuba_vegas_type),intent(inout) :: this
- procedure(integrand_interface)::integrand
- class(transversal_momentum_type),intent(in)::userdata
- ! print '("vegas")'
- call vegas(&
- this%dim_x, &
- this%dim_f, &
- integrand, &
- userdata, &
- this%eps_rel, &
- this%eps_abs, &
- this%flags, &
- this%seed, &
- this%min_eval, &
- this%max_eval, &
- this%nstart, &
- this%nincrease, &
- this%nbatch, &
- this%gridno, &
- this%statefile, &
- this%neval, &
- this%fail, &
- this%integral, &
- this%error, &
- this%prob)
- end subroutine integrate_vegas_userdata
-\end{Verbatim}
-\MethodsFor{cuba\_suave\_type}
-\OverridesSection{serializable\_class}
-\TbpImp{cuba\_suave\_write\_to\_marker}
-\begin{Verbatim}
- subroutine cuba_suave_write_to_marker(this,marker,status)
- class(cuba_suave_type),intent(in) :: this
- class(marker_type), intent(inout) :: marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("cuba_suave_type")
- call cuba_write_to_marker(this,marker,status)
- call marker%mark("nnew",this%nnew)
- call marker%mark("flatness",this%flatness)
- call marker%mark_null("cuba_suave_type")
- end subroutine cuba_suave_write_to_marker
-\end{Verbatim}
-
-\TbpImp{cuba\_suave\_read\_from\_marker}
-\begin{Verbatim}
- subroutine cuba_suave_read_from_marker(this,marker,status)
- class(cuba_suave_type),intent(out) :: this
- class(marker_type), intent(inout) :: marker
- integer(kind=dik),intent(out)::status
- call marker%pick_begin("cuba_suave_type",status=status)
- call cuba_read_from_marker(this,marker,status)
- call marker%pick("nnew",this%nnew,status)
- call marker%pick("flatnes",this%flatness,status)
- call marker%pick_end("cuba_suave_type",status)
- end subroutine cuba_suave_read_from_marker
-\end{Verbatim}
-
-\TbpImp{cuba\_suave\_print\_to\_unit}
-\begin{Verbatim}
- subroutine cuba_suave_print_to_unit(this,unit,parents,components,peers)
- class(cuba_suave_type),intent(in) :: this
- INTEGER, INTENT(IN) :: unit
- integer(kind=dik),intent(in)::parents,components,peers
- if(parents>0)call cuba_print_to_unit(this,unit,parents-1,components,peers)
- write(unit,'("Components of cuba_suave_type:")')
- write(unit,'("nnew: ",I10)') this%nnew
- write(unit,'("flatness: ",I10)') this%flatness
- end subroutine cuba_suave_print_to_unit
-\end{Verbatim}
-
-\TbpImp{cuba\_suave\_get\_type}
-\begin{Verbatim}
- pure subroutine cuba_suave_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="cuba_suave_type")
- end subroutine cuba_suave_get_type
-\end{Verbatim}
-\OverridesSection{cuba\_class}
-\TbpImp{integrate\_suave}
-\begin{Verbatim}
- subroutine integrate_suave(this,integrand)
- class(cuba_suave_type),intent(inout) :: this
- procedure(integrand_interface)::integrand
- ! print '("suave")'
- call suave(&
- this%dim_x, &
- this%dim_f, &
- integrand, &
- this%userdata, &
- this%eps_rel, &
- this%eps_abs, &
- this%flags, &
- this%seed, &
- this%min_eval, &
- this%max_eval, &
- this%nnew, &
- this%flatness, &
- this%nregions, &
- this%neval, &
- this%fail, &
- this%integral, &
- this%error, &
- this%prob)
- end subroutine integrate_suave
-\end{Verbatim}
-
-\TbpImp{integrate\_suave\_userdata}
-\begin{Verbatim}
- subroutine integrate_suave_userdata(this,integrand,userdata)
- class(cuba_suave_type),intent(inout) :: this
- procedure(integrand_interface)::integrand
- class(transversal_momentum_type),intent(in)::userdata
- ! print '("suave")'
- call suave(&
- this%dim_x, &
- this%dim_f, &
- integrand, &
- userdata, &
- this%eps_rel, &
- this%eps_abs, &
- this%flags, &
- this%seed, &
- this%min_eval, &
- this%max_eval, &
- this%nnew, &
- this%flatness, &
- this%nregions, &
- this%neval, &
- this%fail, &
- this%integral, &
- this%error, &
- this%prob)
- end subroutine integrate_suave_userdata
-\end{Verbatim}
-
-\TbpImp{cuba\_suave\_copy}
-\begin{Verbatim}
- subroutine cuba_suave_copy(this,source)
- class(cuba_suave_type),intent(out) :: this
- class(cuba_class),intent(in) :: source
- select type(source)
- class is (cuba_suave_type)
- call this%copy_common(source)
- this%nnew = source%nnew
- this%flatness = source%flatness
- class default
- print *,"cuba_suave_copy: type of source is not type compatible with cuba_suave_type."
- end select
- end subroutine cuba_suave_copy
-\end{Verbatim}
-\MethodsFor{cuba\_divonne\_type}
-\OverridesSection{serializable\_class}
-
-\TbpImp{cuba\_divonne\_write\_to\_marker}
-\begin{Verbatim}
- subroutine cuba_divonne_write_to_marker(this,marker,status)
- class(cuba_divonne_type),intent(in) :: this
- class(marker_type), intent(inout) :: marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("cuba_divonne_type")
- call cuba_write_to_marker(this,marker,status)
- call marker%mark("key1",this%key1)
- call marker%mark("key2",this%key2)
- call marker%mark("key3",this%key3)
- call marker%mark("maxpass",this%maxpass)
- call marker%mark("border",this%border)
- call marker%mark("maxchisq",this%maxchisq)
- call marker%mark("mindeviation",this%mindeviation)
- call marker%mark("ngiven",this%ngiven)
- call marker%mark("ldxgiven",this%ldxgiven)
- call marker%mark("nextra",this%nextra)
- call marker%mark("xgiven",this%xgiven)
- call marker%mark_null("cuba_divonne_type")
- end subroutine cuba_divonne_write_to_marker
-\end{Verbatim}
-
-\TbpImp{cuba\_divonne\_read\_from\_marker}
-\begin{Verbatim}
- subroutine cuba_divonne_read_from_marker(this,marker,status)
- class(cuba_divonne_type),intent(out) :: this
- class(marker_type), intent(inout) :: marker
- integer(kind=dik),intent(out)::status
- call marker%pick_begin("cuba_divonne_type",status=status)
- call cuba_read_from_marker(this,marker,status)
- call marker%pick("key1",this%key1,status)
- call marker%pick("key2",this%key2,status)
- call marker%pick("key3",this%key3,status)
- call marker%pick("maxpass",this%maxpass,status)
- call marker%pick("border",this%border,status)
- call marker%pick("maxchisq",this%maxchisq,status)
- call marker%pick("mindeviation",this%mindeviation,status)
- call marker%pick("ngiven",this%ngiven,status)
- call marker%pick("ldxgiven",this%ldxgiven,status)
- call marker%pick("nextra",this%nextra,status)
- if(allocated(this%xgiven))deallocate(this%xgiven)
- allocate(this%xgiven(this%ldxgiven,this%ngiven))
- call marker%pick("xgiven",this%xgiven,status)
- call marker%pick_end("cuba_divonne_type",status)
- end subroutine cuba_divonne_read_from_marker
-\end{Verbatim}
-
-\TbpImp{cuba\_divonne\_print\_to\_unit}
-\begin{Verbatim}
- subroutine cuba_divonne_print_to_unit(this,unit,parents,components,peers)
- class(cuba_divonne_type),intent(in) :: this
- INTEGER, INTENT(IN) :: unit
- integer(kind=dik),intent(in)::parents,components,peers
- if(parents>0)call cuba_print_to_unit(this,unit,parents-1,components,peers)
- write(unit,'("Components of cuba_divonne_type:")')
- write(unit,'("key1: ",I10)') this%key1
- write(unit,'("key2: ",I10)') this%key2
- write(unit,'("key3: ",I10)') this%key3
- write(unit,'("maxpass: ",I10)') this%maxpass
- write(unit,'("ngiven: ",I10)') this%ngiven
- write(unit,'("ldxgiven: ",I10)') this%ldxgiven
- write(unit,'("nextra: ",I10)') this%nextra
- write(unit,'("border: ",E10.4)') this%border
- write(unit,'("maxchisq: ",E10.4)') this%maxchisq
- write(unit,'("mindeviation:",E10.4)') this%mindeviation
- write(unit,'("xgiven: ",2(E10.4))') this%xgiven
- end subroutine cuba_divonne_print_to_unit
-\end{Verbatim}
-\TbpImp{cuba\_divonne\_get\_type}
-\begin{Verbatim}
- pure subroutine cuba_divonne_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="cuba_divonne_type")
- end subroutine cuba_divonne_get_type
-\end{Verbatim}
-\OverridesSection{cuba\_class}
-\TbpImp{integrate\_divonne}
-\begin{Verbatim}
- subroutine integrate_divonne(this,integrand)
- class(cuba_divonne_type),intent(inout) :: this
- procedure(integrand_interface)::integrand
- ! call this%reset_output()
- ! print '("divonne")'
- call divonne(&
- & this%dim_x, &
- & this%dim_f, &
- & integrand, &
- & this%userdata,&
- & this%eps_rel, &
- & this%eps_abs, &
- & this%flags, &
- & this%seed, &
- & this%min_eval, &
- & this%max_eval, &
- & this%key1, &
- & this%key2, &
- & this%key3, &
- & this%maxpass, &
- & this%border, &
- & this%maxchisq, &
- & this%mindeviation, &
- & this%ngiven, &
- & this%ldxgiven, &
- & this%xgiven, &
- & this%nextra, &
- ! & this%peakfinder, &
- & 0,&
- & this%nregions, &
- & this%neval, &
- & this%fail, &
- & this%integral, &
- & this%error, &
- & this%prob)
- end subroutine integrate_divonne
-\end{Verbatim}
-
-\TbpImp{integrate\_divonne\_userdata}
-\begin{Verbatim}
-subroutine integrate_divonne_userdata(this,integrand,userdata)
- class(cuba_divonne_type),intent(inout) :: this
- procedure(integrand_interface)::integrand
- class(transversal_momentum_type),intent(in)::userdata
- ! call this%reset_output()
- ! print '("divonne")'
- call divonne(&
- & this%dim_x, &
- & this%dim_f, &
- & integrand, &
- & userdata,&
- & this%eps_rel, &
- & this%eps_abs, &
- & this%flags, &
- & this%seed, &
- & this%min_eval, &
- & this%max_eval, &
- & this%key1, &
- & this%key2, &
- & this%key3, &
- & this%maxpass, &
- & this%border, &
- & this%maxchisq, &
- & this%mindeviation, &
- & this%ngiven, &
- & this%ldxgiven, &
- & this%xgiven, &
- & this%nextra, &
- ! & this%peakfinder, &
- & 0,&
- & this%nregions, &
- & this%neval, &
- & this%fail, &
- & this%integral, &
- & this%error, &
- & this%prob)
- end subroutine integrate_divonne_userdata
-\end{Verbatim}
-
-\TbpImp{cuba\_divonne\_copy}
-\begin{Verbatim}
- subroutine cuba_divonne_copy(this,source)
- class(cuba_divonne_type),intent(out) :: this
- class(cuba_class),intent(in) :: source
- select type(source)
- class is (cuba_divonne_type)
- call this%copy_common(source)
- call this%set_deferred(&
- &source%key1,&
- &source%key2,&
- &source%key3,&
- &source%maxpass,&
- &source%border,&
- &source%maxchisq,&
- &source%mindeviation,&
- &source%xgiven&
- &)
- class default
- print *,"cuba_divonne_copy: type of source is not type compatible with cuba_divonne_type."
- end select
- end subroutine cuba_divonne_copy
-\end{Verbatim}
-
-\TbpImp{cuba\_divonne\_set\_deferred}
-\begin{Verbatim}
- subroutine cuba_divonne_set_deferred&
- (this,key1,key2,key3,maxpass,border,maxchisq,mindeviation,xgiven,xgiven_flat)
- class(cuba_divonne_type) :: this
- integer,optional,intent(in)::key1,key2,key3,maxpass
- real(kind=drk),optional,intent(in)::border,maxchisq,mindeviation
- real(kind=drk),dimension(:,:),optional,intent(in)::xgiven
- real(kind=drk),dimension(:),optional,intent(in)::xgiven_flat
- integer,dimension(2)::s
- if(present(key1))this%key1=key1
- if(present(key2))this%key2=key2
- if(present(key3))this%key3=key3
- if(present(maxpass))this%maxpass=maxpass
- if(present(border))this%border=border
- if(present(maxchisq))this%maxchisq=maxchisq
- if(present(mindeviation))this%mindeviation=mindeviation
- if(present(xgiven))then
- if(allocated(this%xgiven))deallocate(this%xgiven)
- s=shape(xgiven)
- if(s(1)==this%dim_x)then
- allocate(this%xgiven(s(1),s(2)),source=xgiven)
- this%ldxgiven=s(1)
- this%ngiven=s(2)
- else
- print *,"cuba_divonne_set_deferred: shape of xgiven is not [dim_x,:]."
- this%ngiven=0
- end if
- end if
- if(present(xgiven_flat))then
- if(allocated(this%xgiven))deallocate(this%xgiven)
- if(mod(size(xgiven_flat),this%dim_x)==0)then
- this%ngiven=size(xgiven_flat)/this%dim_x
- this%ldxgiven=this%dim_x
- allocate(this%xgiven(this%ldxgiven,this%ngiven),&
- source=reshape(xgiven_flat,[this%ldxgiven,this%ngiven]))
- else
- print *,"cuba_divonne_set_deferred: size of xgiven_flat is no multiple of dim_x."
- this%ngiven=0
- end if
- end if
- end subroutine cuba_divonne_set_deferred
-\end{Verbatim}
-\MethodsFor{cuba\_vegas\_type}
-\OverridesSection{serializable\_class}
-
-\TbpImp{cuba\_cuhre\_write\_to\_marker}
-\begin{Verbatim}
- subroutine cuba_cuhre_write_to_marker(this,marker,status)
- class(cuba_cuhre_type),intent(in) :: this
- class(marker_type), intent(inout) :: marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("cuba_cuhre_type")
- call cuba_write_to_marker(this,marker,status)
- call marker%mark("key",this%key)
- call marker%pick_end("cuba_cuhre_type",status)
- end subroutine cuba_cuhre_write_to_marker
-\end{Verbatim}
-
-\TbpImp{cuba\_cuhre\_read\_from\_marker}
-\begin{Verbatim}
- subroutine cuba_cuhre_read_from_marker(this,marker,status)
- class(cuba_cuhre_type),intent(out) :: this
- class(marker_type), intent(inout) :: marker
- integer(kind=dik),intent(out)::status
- call marker%pick_begin("cuba_cuhre_type",status=status)
- call cuba_read_from_marker(this,marker,status)
- call marker%pick("key",this%key,status)
- call marker%pick_end("cuba_cuhre_type",status)
- end subroutine cuba_cuhre_read_from_marker
-\end{Verbatim}
-
-\TbpImp{cuba\_cuhre\_print\_to\_unit}
-\begin{Verbatim}
- subroutine cuba_cuhre_print_to_unit(this,unit,parents,components,peers)
- class(cuba_cuhre_type),intent(in) :: this
- integer, intent(in) :: unit
- integer(kind=dik),intent(in)::parents,components,peers
- if(parents>0)call cuba_print_to_unit(this,unit,parents-1,components,peers)
- write(unit,'("Components of cuba_cuhre_type:")')
- write(unit,'("key: ",I10)') this%key
- end subroutine cuba_cuhre_print_to_unit
-\end{Verbatim}
-\TbpImp{cuba\_cuhre\_get\_type}
-\begin{Verbatim}
- pure subroutine cuba_cuhre_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="cuba_cuhre_type")
- end subroutine cuba_cuhre_get_type
-\end{Verbatim}
-\OverridesSection{cuba\_class}
-\TbpImp{integrate\_cuhre}
-\begin{Verbatim}
- subroutine integrate_cuhre(this,integrand)
- class(cuba_cuhre_type),intent(inout) :: this
- procedure(integrand_interface)::integrand
- !c print '("cuhre")'
- call cuhre(&
- this%dim_x, &
- this%dim_f, &
- integrand, &
- this%userdata, &
- this%eps_rel, &
- this%eps_abs, &
- this%flags, &
-! this%seed, &
- this%min_eval, &
- this%max_eval, &
- this%key, &
- this%nregions, &
- this%neval, &
- this%fail, &
- this%integral, &
- this%error, &
- this%prob)
- end subroutine integrate_cuhre
-\end{Verbatim}
-
-\TbpImp{integrate\_cuhre\_userdata}
-\begin{Verbatim}
- subroutine integrate_cuhre_userdata(this,integrand,userdata)
- class(cuba_cuhre_type),intent(inout) :: this
- procedure(integrand_interface)::integrand
- class(transversal_momentum_type),intent(in)::userdata
- !c print '("cuhre")'
- call cuhre(&
- this%dim_x, &
- this%dim_f, &
- integrand, &
- userdata, &
- this%eps_rel, &
- this%eps_abs, &
- this%flags, &
-! this%seed, &
- this%min_eval, &
- this%max_eval, &
- this%key, &
- this%nregions, &
- this%neval, &
- this%fail, &
- this%integral, &
- this%error, &
- this%prob)
- end subroutine integrate_cuhre_userdata
-\end{Verbatim}
-
-\TbpImp{cuba\_cuhre\_copy}
-\begin{Verbatim}
- subroutine cuba_cuhre_copy(this,source)
- class(cuba_cuhre_type),intent(out) :: this
- class(cuba_class),intent(in) :: source
- select type(source)
- class is (cuba_cuhre_type)
- call this%copy_common(source)
- this%key=source%key
- class default
- print *,"cuba_cuhre_copy: type of source is not type compatible with &
- &cuba_cuhre_type."
- end select
- end subroutine cuba_cuhre_copy
-\end{Verbatim}
-
-\TbpImp{cuba\_cuhre\_set\_deferred}
-\begin{Verbatim}
- subroutine cuba_cuhre_set_deferred(this,key)
- class(cuba_cuhre_type),intent(inout) :: this
- integer, intent(in) :: key
- this%key = key
- end subroutine cuba_cuhre_set_deferred
-\end{Verbatim}
-
Index: trunk/src/muli/doc/muli_mcint.tex
===================================================================
--- trunk/src/muli/doc/muli_mcint.tex (revision 8371)
+++ trunk/src/muli/doc/muli_mcint.tex (revision 8372)
@@ -1,1534 +0,0 @@
-\Module{muli\_mcint}
-%\begin{figure}
-% \centering{\includegraphics{uml-module-tree-9.mps}}
-% \caption{\label{fig:\ThisModule:Types}Klassendiagramm des Moduls \ThisModule}
-%\end{figure}
-\section{Abhängigkeiten}
-\use{muli\_basic}
-\usenodep{tao\_random\_numbers}
-\use{muli\_interactions}
-\section{Parameter}
-\begin{Verbatim}
- integer,private,parameter::\MC{max\_n}=2**30
- real(kind=double),private,parameter::\MC{max\_d}=1D0*max_n
- real(kind=double),private,parameter,dimension(2,2)::\MC{unit\_square}=reshape([0D0,0D0,1D0,1D0],[2,2])
-\end{Verbatim}
-\section{Derived Types}
-\TypeDef{sample\_region\_type}
-\begin{Verbatim}
- type,\Extends{serializable\_class}::sample_region_type
- integer::\TC{n\_hits}=0
- integer::\TC{n\_alloc}=0
- real(kind=double),dimension(2,2)::\TC{corners}=unit\_square
- real(kind=double),dimension(:,:),allocatable::\TC{hyp\_hits}
- contains
- \OverridesDeclaration{serializable\_class}
- procedure ::\TbpDec{write\_to\_marker}{sample\_region\_write\_to\_marker}
- procedure ::\TbpDec{read\_from\_marker}{sample\_region\_read\_from\_marker}
- procedure ::\TbpDec{print\_to\_unit}{sample\_region\_print\_to\_unit}
- procedure,nopass ::\TbpDec{get\_type}{sample\_region\_get\_type}
- \OriginalDeclaration
- procedure ::\TbpDec{initialize}{sample\_region\_initialize}
- procedure ::\TbpDec{generate\_hit}{sample\_region\_generate\_hit}
- procedure ::\TbpDec{confirm\_hit}{sample\_region\_confirm\_hit}
- procedure ::\TbpDec{split}{sample\_region\_split}
- procedure ::\TbpDec{write\_hits}{sample\_region\_write\_hits}
- procedure ::\TbpDec{is\_full}{sample\_region\_is\_full}
- procedure ::\TbpDec{move\_components}{sample\_region\_move\_components}
- procedure ::\TbpDec{mean}{sample\_region\_mean}
- procedure ::\TbpDec{area}{sample\_region\_area}
- procedure ::\TbpDec{density}{sample\_region\_density}
- procedure ::\TbpDec{contains}{sample\_region\_contains}
- procedure ::\TbpDec{to\_generator}{sample\_region\_to\_generator}
- end type sample_region_type
-\end{Verbatim}
-\TypeDef{sample\_2d\_type}
-\begin{Verbatim}
- type,\Extends{serializable\_class}::sample_2d_type
- integer::\TC{n\_regions}=0
- integer::\TC{n\_alloc}=0
- integer::\TC{n\_hits}=0
- real(kind=double),dimension(2)::\TC{range}=[0,1]
- type(\TypeRef{sample\_region\_type}),dimension(:),allocatable::\TC{regions}
- contains
- \OverridesDeclaration{serializable\_class}
- procedure ::\TbpDec{write\_to\_marker}{sample\_2d\_write\_to\_marker}
- procedure ::\TbpDec{read\_from\_marker}{sample\_2d\_read\_from\_marker}
- procedure ::\TbpDec{print\_to\_unit}{sample\_2d\_print\_to\_unit}
- procedure,nopass ::\TbpDec{get\_type}{sample\_2d\_get\_type}
- \OriginalDeclaration
- procedure ::\TbpDec{initialize}{sample\_2d\_initialize}
- procedure ::\TbpDec{contains}{sample\_2d\_contains}
- procedure ::\TbpDec{generate\_hit}{sample\_2d\_generate\_hit}
- procedure ::\TbpDec{confirm\_hit}{sample\_2d\_confirm\_hit}
- procedure ::\TbpDec{split}{sample\_2d\_split}
- procedure ::\TbpDec{push}{sample\_2d\_push}
- procedure ::\TbpDec{write\_hits}{sample\_2d\_write\_hits}
- procedure ::\TbpDec{is\_full}{sample\_2d\_is\_full}
- procedure ::\TbpDec{move\_components}{sample\_2d\_move\_components}
- procedure ::\TbpDec{thickness}{sample\_2d\_thickness}
- procedure ::\TbpDec{analyse}{sample\_2d\_analyse}
- procedure ::\TbpDec{to\_generator}{sample\_2d\_to\_generator}
- procedure ::\TbpDec{mean}{sample\_2d\_mean}
- end type sample_2d_type
-\end{Verbatim}
-\TypeDef{sample\_3d\_type}
-\begin{Verbatim}
- type,\Extends{serializable\_class}::sample_3d_type
- integer::\TC{n\_slices}=0
- integer::\TC{n\_alloc}=0
- type(\TypeRef{sample\_2d\_type}),dimension(:),allocatable::\TC{slices}
- contains
- \OverridesDeclaration{serializable\_class}
- procedure ::\TbpDec{write\_to\_marker}{sample\_3d\_write\_to\_marker}
- procedure ::\TbpDec{read\_from\_marker}{sample\_3d\_read\_from\_marker}
- procedure ::\TbpDec{print\_to\_unit}{sample\_3d\_print\_to\_unit}
- procedure,nopass ::\TbpDec{get\_type}{sample\_3d\_get\_type}
- ! overridden measurable_class procedures
- procedure ::\TbpDec{measure}{sample\_3d\_measure}
- \OriginalDeclaration
- procedure ::\TbpDec{to\_generator}{sample\_3d\_to\_generator}
- procedure :: sample_3d_initialize
- procedure :: sample_3d_generate_hit
- procedure :: sample_3d_confirm_hit
- procedure ::\TbpDec{enlarge}{sample\_3d\_enlarge}
- generic::\TbpDec{initialize}{sample\_3d\_initialize}
- generic::\TbpDec{generate\_hit}{sample\_3d\_generate\_hit}
- generic::\TbpDec{confirm\_hit}{sample\_3d\_confirm\_hit}
- end type sample_3d_type
-\end{Verbatim}
-\TypeDef{sample\_int\_kind\_type}
-\begin{Verbatim}
- type,\Extends{sample\_3d\_type}::sample_int_kind_type
- integer::\TC{n\_proc}=0
- integer(kind=i64)::\TC{n\_tries}=0
- integer::\TC{n\_hits}=0
- integer::\TC{n\_over}=0
- integer,dimension(:),allocatable::\TC{hits},\TC{weights},\TC{processes}
- real(kind=double)::\TC{overall\_boost}=1D-1
- contains
- \OverridesDeclaration{serializable\_class}
- procedure ::\TbpDec{write\_to\_marker}{sample\_int\_kind\_write\_to\_marker}
- procedure ::\TbpDec{read\_from\_marker}{sample\_int\_kind\_read\_from\_marker}
- procedure ::\TbpDec{print\_to\_unit}{sample\_int\_kind\_print\_to\_unit}
- procedure,nopass ::\TbpDec{get\_type}{sample\_int\_kind\_get\_type}
- ! overridden sample_3d_type procedures
- procedure ::\TbpDec{to\_generator}{sample\_int\_kind\_to\_generator}
- \OriginalDeclaration
- procedure ::\TbpDec{process\_id}{sample\_int\_kind\_process\_id}
- procedure :: sample_int_kind_initialize
- procedure :: sample_int_kind_generate_hit
- procedure ::\TbpDec{mcgenerate\_hit}{sample\_int\_kind\_mcgenerate\_hit}
- procedure :: sample_int_kind_confirm_hit
- procedure ::\TbpDec{analyse}{sample\_int\_kind\_analyse}
- generic::\TbpDec{initialize}{sample\_int\_kind\_initialize}
- generic::\TbpDec{generate\_hit}{sample\_int\_kind\_generate\_hit}
- generic::\TbpDec{confirm\_hit}{sample\_int\_kind\_confirm\_hit}
- end type sample_int_kind_type
-\end{Verbatim}
-\TypeDef{sample\_inclusive\_type}
-\begin{Verbatim}
- type,\Extends{serializable\_class}::sample_inclusive_type
- integer::\TC{n\_alloc}=0
- integer(kind=i64)::\TC{n\_tries\_sum}=zero
- integer(kind=i64)::\TC{n\_over\_sum}=zero
- integer(kind=i64)::\TC{n\_hits\_sum}=zero
- type(\TypeRef{sample\_int\_kind\_type}),dimension(:),allocatable::\TC{int\_kinds}
- contains
- \OverridesDeclaration{serializable\_class}
- procedure ::\TbpDec{write\_to\_marker}{sample\_inclusive\_write\_to\_marker}
- procedure ::\TbpDec{read\_from\_marker}{sample\_inclusive\_read\_from\_marker}
- procedure ::\TbpDec{print\_to\_unit}{sample\_inclusive\_print\_to\_unit}
- procedure,nopass ::\TbpDec{get\_type}{sample\_inclusive\_get\_type}
- \OriginalDeclaration
- procedure ::\TbpDec{process\_id}{sample\_inclusive\_process\_id}
- procedure ::\TbpDec{initialize}{sample\_inclusive\_initialize}
- procedure ::\TbpDec{finalize}{sample\_inclusive\_finalize}
- procedure ::\TbpDec{generate\_hit}{sample\_inclusive\_generate\_hit}
- procedure ::\TbpDec{mcgenerate\_hit}{sample\_inclusive\_mcgenerate\_hit}
- procedure ::\TbpDec{confirm\_hit}{sample\_inclusive\_confirm\_hit}
- procedure ::\TbpDec{sum\_up}{sample\_inclusive\_sum\_up}
- procedure ::\TbpDec{analyse}{sample\_inclusive\_analyse}
- procedure ::\TbpDec{to\_generator}{sample\_inclusive\_to\_generator}
- procedure ::\TbpDec{allocate}{sample\_inclusive\_allocate}
- end type sample_inclusive_type
-\end{Verbatim}
-\Methods
-\MethodsFor{sample\_region\_type}
-\TbpImp{sample\_region\_write\_to\_marker}
-\begin{Verbatim}
- subroutine sample_region_write_to_marker(this,marker,status)
- class(sample_region_type),intent(in) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- integer::n
- call marker%mark_begin("sample_region_type")
- call marker%mark("n_hits",this%n_hits)
- call marker%mark("n_alloc",this%n_alloc)
- call marker%mark("lower_corner",this%corners(1:2,1))
- call marker%mark("upper_corner",this%corners(1:2,2))
- if(allocated(this%hyp_hits))then
- call marker%mark("hyp_hits",this%hyp_hits(1:3,:this%n_hits))
- else
- call marker%mark_nothing("hyp_hits")
- end if
- call marker%mark_end("sample_region_type")
- end subroutine sample_region_write_to_marker
-\end{Verbatim}
-
-\TbpImp{sample\_region\_read\_from\_marker}
-\begin{Verbatim}
- subroutine sample_region_read_from_marker(this,marker,status)
- class(sample_region_type),intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- integer::n
- call marker%pick_begin("sample_region_type",status=status)
- call marker%pick("n_hits",this%n_hits,status)
- call marker%pick("n_alloc",this%n_alloc,status)
- call marker%pick("lower_corner",this%corners(1:2,1),status)
- call marker%pick("upper_corner",this%corners(1:2,2),status)
- if(allocated(this%hyp_hits))deallocate(this%hyp_hits)
- call marker%verify_nothing("hyp_hits",status)
- if(.not.status==serialize_nothing)then
- allocate(this%hyp_hits(3,this%n_alloc))
- call marker%pick("hyp_hits",this%hyp_hits(1:3,:this%n_hits),status)
- end if
- call marker%pick_end("sample_region_type",status)
- end subroutine sample_region_read_from_marker
-\end{Verbatim}
-
-\TbpImp{sample\_region\_print\_to\_unit}
-\begin{Verbatim}
- subroutine sample_region_print_to_unit(this,unit,parents,components,peers)
- class(sample_region_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- write(unit,fmt=*)"components of sample_region_type"
- write(unit,'("n_hits: ",i10)')this%n_hits
- write(unit,'("n_alloc: ",i10)')this%n_alloc
- write(unit,'("corners: ",4(e20.10))')this%corners
- if(allocated(this%hyp_hits).and.this%n_hits>0)then
- if(components>0)then
- write(unit,'("hits:")')
- print *,shape(this%hyp_hits)
- write(unit,fmt='(3(e20.10))')this%hyp_hits(1:3,this%n_hits)
- else
- write(unit,fmt=*)"skipping hits."
- end if
- else
- write(unit,fmt=*)"hits are not allocated."
- end if
- end subroutine sample_region_print_to_unit
-\end{Verbatim}
-
-\TbpImp{sample\_region\_get\_type}
-\begin{Verbatim}
- pure subroutine sample_region_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="sample_region_type")
- end subroutine sample_region_get_type
-\end{Verbatim}
-
-\TbpImp{sample\_region\_initialize}
-\begin{Verbatim}
- subroutine sample_region_initialize(this,n_alloc)
- class(sample_region_type),intent(out)::this
- integer,intent(in)::n_alloc
- if(allocated(this%hyp_hits))deallocate(this%hyp_hits)
- allocate(this%hyp_hits(3,n_alloc))
- this%n_alloc=n_alloc
- end subroutine sample_region_initialize
-\end{Verbatim}
-
-\TbpImp{sample\_region\_generate\_hit}
-\begin{Verbatim}
- pure subroutine sample_region_generate_hit(this,rnd,area,hit)
- class(sample_region_type),intent(in)::this
- integer,intent(in),dimension(2)::rnd
- real(kind=double),dimension(2),intent(out)::hit
- real(kind=double),intent(out)::area
- call muli_mcint_generate_hit(rnd,this%corners,hit)
- area=this%area()
- end subroutine sample_region_generate_hit
-\end{Verbatim}
-
-\TbpImp{sample\_region\_confirm\_hit}
-\begin{Verbatim}
- subroutine sample_region_confirm_hit(this,hit)
- class(sample_region_type),intent(inout)::this
- real(kind=double),dimension(3),intent(in)::hit
-! print *,"sample_region_confirm_hit: ",this%n_hits,this%n_alloc,hit
- this%n_hits=this%n_hits+1
- if(this%n_hits<=this%n_alloc)then
- this%hyp_hits(1:3,this%n_hits)=hit
- else
- print *,"sample_region_confirm_hit: Region is already full."
- end if
- end subroutine sample_region_confirm_hit
-\end{Verbatim}
-
-\TbpImp{sample\_region\_split}
-\begin{Verbatim}
- subroutine sample_region_split(this,pos,dimX,n_alloc,lower,upper)
- class(sample_region_type),intent(in)::this
- type(sample_region_type),intent(out)::lower,upper
- real(kind=double),dimension(3)::hit
- real(kind=double),intent(in)::pos
- integer,intent(in)::dimX,n_alloc
- integer::n_hit
- call lower%initialize(n_alloc)
- call upper%initialize(n_alloc)
- do n_hit=1,this%n_hits
- hit=this%hyp_hits(1:3,n_hit)
- if(hit(dimX)<pos)then
- call lower%confirm_hit(hit)
- else
- call upper%confirm_hit(hit)
- end if
- end do
- lower%corners=this%corners
- upper%corners=this%corners
- if(dimX<3)then
- lower%corners(dimX,2)=pos
- upper%corners(dimX,1)=pos
- end if
- end subroutine sample_region_split
-\end{Verbatim}
-
-\TbpImp{sample\_region\_write\_hits}
-\begin{Verbatim}
- subroutine sample_region_write_hits(this,unit)
- class(sample_region_type),intent(in)::this
- integer,intent(in)::unit
- integer::n
- do n=1,this%n_hits
- write(unit,fmt=*)this%hyp_hits(1:3,n)
- end do
- end subroutine sample_region_write_hits
-\end{Verbatim}
-
-\TbpImp{sample\_region\_is\_full}
-\begin{Verbatim}
- elemental logical function sample_region_is_full(this)
- class(sample_region_type),intent(in)::this
- sample_region_is_full=this%n_alloc==this%n_hits
- end function sample_region_is_full
-\end{Verbatim}
-
-\TbpImp{sample\_region\_move\_components}
-\begin{Verbatim}
- subroutine sample_region_move_components(this,that)
- class(sample_region_type),intent(inout)::this
- class(sample_region_type),intent(out)::that
- that%n_alloc=this%n_alloc
- that%n_hits=this%n_hits
- that%corners=this%corners
- call move_alloc(this%hyp_hits,that%hyp_hits)
- this%n_alloc=0
- this%n_hits=0
- end subroutine sample_region_move_components
-\end{Verbatim}
-
-\TbpImp{sample\_region\_mean}
-\begin{Verbatim}
- elemental function sample_region_mean(this,dim)
- real(kind=double)::sample_region_mean
- class(sample_region_type),intent(in)::this
- integer,intent(in)::dim
- sample_region_mean=sum(this%hyp_hits(dim,1:this%n_hits))/this%n_hits
- end function sample_region_mean
-\end{Verbatim}
-
-\TbpImp{sample\_region\_area}
-\begin{Verbatim}
- elemental function sample_region_area(this)
- real(kind=double)::sample_region_area
- class(sample_region_type),intent(in)::this
- sample_region_area=product(this%corners(1:2,2)-this%corners(1:2,1))
- end function sample_region_area
-\end{Verbatim}
-
-\TbpImp{sample\_region\_density}
-\begin{Verbatim}
- elemental function sample_region_density(this)
- real(kind=double)::sample_region_density
- class(sample_region_type),intent(in)::this
- sample_region_density=this%n_hits/this%area()
- end function sample_region_density
-\end{Verbatim}
-
-\TbpImp{sample\_region\_contains}
-\begin{Verbatim}
- pure logical function sample_region_contains(this,hit)
- class(sample_region_type),intent(in)::this
- real(kind=double),intent(in),dimension(3)::hit
- sample_region_contains=(this%corners(1,1)<=hit(1)&
- .and.hit(1)<=this%corners(1,2)&
- .and.this%corners(2,1)<=hit(2)&
- .and.hit(2)<=this%corners(2,2))
- end function sample_region_contains
-\end{Verbatim}
-
-\TbpImp{sample\_region\_to\_generator}
-\begin{Verbatim}
- subroutine sample_region_to_generator(this)
- class(sample_region_type),intent(inout)::this
- if(allocated(this%hyp_hits))deallocate(this%hyp_hits)
- this%n_alloc=0
- end subroutine sample_region_to_generator
-\end{Verbatim}
-\MethodsFor{sample\_2d\_type}
-
-\TbpImp{sample\_2d\_write\_to\_marker}
-\begin{Verbatim}
- subroutine sample_2d_write_to_marker(this,marker,status)
- class(sample_2d_type),intent(in) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- integer::n
- call marker%mark_begin("sample_2d_type")
- call marker%mark("n_regions",this%n_regions)
- call marker%mark("n_alloc",this%n_alloc)
- call marker%mark("n_hits",this%n_hits)
- call marker%mark("range",this%range)
- if(this%n_regions>0)then
- call marker%mark_instance_begin(this%regions(1),name="sample_2d_type",shape=shape(this%regions))
- do n=1,this%n_regions
- call sample_region_write_to_marker(this%regions(n),marker,status)
- end do
- call marker%mark_instance_end()
- end if
- call marker%mark_end("sample_2d_type")
- end subroutine sample_2d_write_to_marker
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_read\_from\_marker}
-\begin{Verbatim}
- subroutine sample_2d_read_from_marker(this,marker,status)
- class(sample_2d_type),intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- integer::n
- call marker%pick_begin("sample_2d_type",status=status)
- call marker%pick("n_regions",this%n_regions,status)
- call marker%pick("n_alloc",this%n_alloc,status)
- call marker%pick("n_hits",this%n_hits,status)
- call marker%pick("range",this%range,status)
- if(this%n_regions>0)then
- call marker%pick_begin("regions",status=status)
- allocate(this%regions(this%n_regions))
- do n=1,this%n_regions
- call sample_region_read_from_marker(this%regions(n),marker,status)
- end do
- call marker%pick_end("regions",status)
- end if
- call marker%pick_end("sample_2d_type",status)
- end subroutine sample_2d_read_from_marker
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_print\_to\_unit}
-\begin{Verbatim}
- subroutine sample_2d_print_to_unit(this,unit,parents,components,peers)
- class(sample_2d_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- integer::n
- write(unit,fmt=*)"components of sample_2d_type"
- write(unit,'("n_regions: ",i10)')this%n_regions
- write(unit,'("n_alloc: ",i10)')this%n_alloc
- write(unit,'("range: ",2(e20.10))')this%range
- if(allocated(this%regions))then
- if(components>0)then
- write(unit,'("regions:")')
- do n=1,this%n_regions
- call this%regions(n)%print_to_unit(unit,parents,components-1,peers)
- end do
- else
- write(unit,fmt=*)"skipping regions."
- end if
- else
- write(unit,fmt=*)"regions are not allocated."
- end if
- end subroutine sample_2d_print_to_unit
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_get\_type}
-\begin{Verbatim}
- pure subroutine sample_2d_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="sample_2d_type")
- end subroutine sample_2d_get_type
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_initialize}
-\begin{Verbatim}
- subroutine sample_2d_initialize(this,n_alloc)
- class(sample_2d_type),intent(out)::this
- integer,intent(in)::n_alloc
- integer::n
- if(allocated(this%regions))deallocate(this%regions)
- allocate(this%regions(n_alloc))
- this%n_alloc=n_alloc
- this%n_regions=1
- call this%regions(1)%initialize(n_alloc)
-! do n=1,n_alloc
-! call this%regions(n)%initialize(n_alloc)
-! end do
- end subroutine sample_2d_initialize
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_contains}
-\begin{Verbatim}
- pure logical function sample_2d_contains(this,pts2)
- class(sample_2d_type),intent(in)::this
- real(kind=double),intent(in)::pts2
- sample_2d_contains=this%range(1)<=pts2.and.pts2<=this%range(2)
- end function sample_2d_contains
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_generate\_hit}
-\begin{Verbatim}
- pure subroutine sample_2d_generate_hit(this,rnd,boost,hit,region)
- class(sample_2d_type),intent(in)::this
- integer,dimension(3),intent(in)::rnd
- integer,intent(out)::region
- integer::n,sum
- real(kind=double),dimension(2),intent(out)::hit
- real(kind=double),intent(out)::boost
- if(0<this%n_hits.and.this%n_hits<10)then
- sum=modulo(rnd(1),this%n_hits)+1!this should be improved
- region=0
- do while(sum>0)
- region=region+1
- sum=sum-this%regions(region)%n_hits
- end do
- call this%regions(region)%generate_hit(rnd(2:3),boost,hit)
- boost=boost*this%n_hits/this%regions(region)%n_hits
- else
- if(this%n_regions>1)then
- region=modulo(rnd(1),this%n_regions)+1!this should be improved
- call this%regions(region)%generate_hit(rnd(2:3),boost,hit)
- boost=boost*this%n_regions
- else
- region=1
- call this%regions(1)%generate_hit(rnd(2:3),boost,hit)
- end if
- end if
- end subroutine sample_2d_generate_hit
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_confirm\_hit}
-\begin{Verbatim}
- subroutine sample_2d_confirm_hit(this,hit,region,full)
- class(sample_2d_type),intent(inout)::this
- integer,intent(in)::region
- real(kind=double),dimension(3),intent(in)::hit
- type(sample_region_type),allocatable::old_region
- real(kind=double),dimension(2)::mean,var,diff,cm,cv,c
- integer::n,n_alloc,dim
- logical,intent(out)::full
- this%n_hits=this%n_hits+1
- if(region<=this%n_alloc)then
- full=.false.
- call this%regions(region)%confirm_hit(hit)
- n_alloc=this%regions(region)%n_alloc
- if(this%regions(region)%is_full())then
- if(this%is_full())then
- full=.true.
- else
- this%n_regions=this%n_regions+1
- allocate(old_region)
- call this%regions(region)%move_components(old_region)
- mean=sum(old_region%hyp_hits(1:2,:),dim=2)/n_alloc
- var=0D0
- do n=1,n_alloc
- var=var+abs(mean-old_region%hyp_hits(1:2,n))
- end do
- var=var/n_alloc
- diff=old_region%corners(1:2,2)-old_region%corners(1:2,1)
- cm=abs([0.5D0,0.5D0]-(old_region%corners(1:2,2)-mean)/diff)
- cv=abs(2*([0.25D0,0.25D0]-var/diff))
- c=max(cm,cv)
- if(c(1)<c(2))then
- dim=2
- else
- dim=1
- end if
- call old_region%split(&
- mean(dim),&
- dim,&
- this%n_alloc,&
- this%regions(region),&
- this%regions(this%n_regions))
- end if
- end if
- else
- print *,"sample_2d_confirm_hit: Region ",region," not allocated."
- end if
- end subroutine sample_2d_confirm_hit
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_is\_full}
-\begin{Verbatim}
- elemental logical function sample_2d_is_full(this)
- class(sample_2d_type),intent(in)::this
- sample_2d_is_full=this%n_alloc==this%n_regions
- end function sample_2d_is_full
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_split}
-\begin{Verbatim}
- recursive subroutine sample_2d_split(this,n_alloc,pos,lower,upper)
- class(sample_2d_type),intent(in)::this
- integer,intent(in)::n_alloc
- real(kind=double),intent(in)::pos
- type(sample_2d_type),intent(out)::lower,upper
- integer::n_r,n_h
- real(kind=double),dimension(3)::hit
- !print *,"sample_2d_split: ",pos,this%range
- call lower%initialize(4*n_alloc)
- call upper%initialize(4*n_alloc)
- do n_r=this%n_regions,1,-1
- do n_h=1,this%regions(n_r)%n_hits
- hit=this%regions(n_r)%hyp_hits(1:3,n_h)
- if(hit(3)>pos)then
- call upper%push(hit)
- else
- call lower%push(hit)
- end if
- end do
- end do
- lower%range=[this%range(1),pos]
- upper%range=[pos,this%range(2)]
- end subroutine sample_2d_split
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_push}
-\begin{Verbatim}
- subroutine sample_2d_push(this,hit)
- class(sample_2d_type),intent(inout)::this
- real(kind=double),dimension(3),intent(in)::hit
- integer::region
- logical::full
- do region=1,this%n_regions
- if(this%regions(region)%contains(hit))then
- call this%confirm_hit(hit,region,full)
-! call this%regions(region)%confirm_hit(hit)
- if(full)print *,"sample_2d_push: region is full now"
- exit
- end if
- end do
- if(region>this%n_regions)print *,"sample_2d_push: no region contains ",hit
- end subroutine sample_2d_push
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_write\_hits}
-\begin{Verbatim}
- subroutine sample_2d_write_hits(this,unit)
- class(sample_2d_type),intent(in)::this
- integer,intent(in)::unit
- integer::n
- do n=1,this%n_regions
- call this%regions(n)%write_hits(unit)
- end do
- end subroutine sample_2d_write_hits
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_move\_components}
-\begin{Verbatim}
- subroutine sample_2d_move_components(this,that)
- class(sample_2d_type),intent(inout)::this
- class(sample_2d_type),intent(out)::that
- that%n_alloc=this%n_alloc
- that%n_regions=this%n_regions
- that%n_hits=this%n_hits
- that%range=this%range
- call move_alloc(this%regions,that%regions)
- this%n_alloc=0
- this%n_regions=0
- this%n_hits=0
- this%range=[0D0,0D0]
- end subroutine sample_2d_move_components
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_thickness}
-\begin{Verbatim}
- elemental function sample_2d_thickness(this)
- class(sample_2d_type),intent(in)::this
- real(kind=double)::sample_2d_thickness
- sample_2d_thickness=this%range(2)-this%range(1)
- end function sample_2d_thickness
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_analyse}
-\begin{Verbatim}
- subroutine sample_2d_analyse(this,dir,file)
- class(sample_2d_type),intent(in)::this
- character(*),intent(in)::dir,file
- integer::u
- real(kind=double),dimension(1:2,0:100,0:100)::grid
- integer,dimension(0:100,0:100)::i_grid
- integer::r,x,y
- integer,dimension(2,2)::i
- call generate_unit(u)
- print *,"sample_2d_analyse: ",dir//"/"//file
- open(u,file=dir//"/"//file)
- do x=0,100
- do y=0,100
- grid(1:2,x,y)=[-1D0,-1D0]
- end do
- end do
- do r=1,this%n_regions
- i=int(this%regions(r)%corners*1D2)
- do x=i(1,1),i(1,2)
- do y=i(2,1),i(2,2)
- i_grid(x,y)=this%regions(r)%n_hits
- grid(1,x,y)=1D0/this%regions(r)%area()
- grid(2,x,y)=this%regions(r)%density()
- end do
- end do
- end do
- do x=0,100
- do y=0,100
- write(u,fmt=*)x,y,i_grid(x,y),grid(1:2,x,y)
- end do
- write(u,fmt=*)""
- end do
- close(u)
- end subroutine sample_2d_analyse
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_to\_generator}
-\begin{Verbatim}
- subroutine sample_2d_to_generator(this)
- class(sample_2d_type),intent(inout)::this
- integer::region
- do region=1,this%n_regions
- call this%regions(region)%to_generator()
- end do
- end subroutine sample_2d_to_generator
-\end{Verbatim}
-
-\TbpImp{sample\_2d\_mean}
-\begin{Verbatim}
- elemental function sample_2d_mean(this,dim) result(mean)
- class(sample_2d_type),intent(in)::this
- integer,intent(in)::dim
- real(kind=double)::mean
- integer::region,hit
- mean=0D0
- do region=1,this%n_regions
- do hit=1,this%regions(region)%n_hits
- mean=mean+this%regions(region)%hyp_hits(dim,hit)
- end do
- end do
- mean=mean/this%n_hits
- end function sample_2d_mean
-\end{Verbatim}
-\MethodsFor{sample\_3d\_type}
-
-\TbpImp{sample\_3d\_write\_to\_marker}
-\begin{Verbatim}
- subroutine sample_3d_write_to_marker(this,marker,status)
- class(sample_3d_type),intent(in) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- integer::n
- call marker%mark_begin("sample_3d_type")
- call marker%mark("n_slices",this%n_slices)
- call marker%mark("n_alloc",this%n_alloc)
- if(this%n_slices>0)then
- call marker%mark_instance_begin&
- (this%slices(1),"slices",shape=shape(this%slices))
- do n=1,this%n_slices
- call sample_2d_write_to_marker(this%slices(n),marker,status)
- end do
- call marker%mark_instance_end()
- end if
- call marker%mark_end("sample_3d_type")
- end subroutine sample_3d_write_to_marker
-\end{Verbatim}
-
-\TbpImp{sample\_3d\_read\_from\_marker}
-\begin{Verbatim}
- subroutine sample_3d_read_from_marker(this,marker,status)
- class(sample_3d_type),intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- integer::n
- call marker%pick_begin("sample_3d_type",status=status)
- call marker%pick("n_slices",this%n_slices,status)
- call marker%pick("n_alloc",this%n_alloc,status)
- if(this%n_slices>0)then
- call marker%pick_instance_begin("slices",status=status)
- allocate(this%slices(this%n_slices))
- do n=1,this%n_slices
- call sample_2d_read_from_marker(this%slices(n),marker,status)
- end do
- call marker%pick_instance_end(status)
- end if
- call marker%pick_end("sample_3d_type",status)
- end subroutine sample_3d_read_from_marker
-\end{Verbatim}
-
-\TbpImp{sample\_3d\_print\_to\_unit}
-\begin{Verbatim}
- subroutine sample_3d_print_to_unit(this,unit,parents,components,peers)
- class(sample_3d_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- integer::n
- write(unit,fmt=*)"components of sample_3d_type"
- write(unit,'("n_slices: ",i10)')this%n_slices
- write(unit,'("n_alloc: ",i10)')this%n_alloc
- if(allocated(this%slices))then
- if(components>0)then
- do n=1,this%n_slices
- call this%slices(n)%print_to_unit(unit,parents,components-1,peers)
- end do
- else
- write(unit,fmt=*)"skipping slices."
- end if
- else
- write(unit,fmt=*)"slices are not allocated."
- end if
- end subroutine sample_3d_print_to_unit
-\end{Verbatim}
-
-\TbpImp{sample\_3d\_get\_type}
-\begin{Verbatim}
- pure subroutine sample_3d_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="sample_3d_type")
- end subroutine sample_3d_get_type
-\end{Verbatim}
-
-\TbpImp{sample\_3d\_measure}
-\begin{Verbatim}
- elemental function sample_3d_measure(this)
- real(kind=double)::sample_3d_measure
- class(sample_3d_type),intent(in)::this
- sample_3d_measure=1D0
- end function sample_3d_measure
-\end{Verbatim}
-
-\TbpImp{sample\_3d\_to\_generator}
-\begin{Verbatim}
- subroutine sample_3d_to_generator(this)
- class(sample_3d_type),intent(inout)::this
- integer::slice
- do slice=1,this%n_slices
- call this%slices(slice)%to_generator()
- end do
- end subroutine sample_3d_to_generator
-\end{Verbatim}
-
-\TbpImp{sample\_3d\_initialize}
-\begin{Verbatim}
- subroutine sample_3d_initialize(this,n_alloc)
- class(sample_3d_type),intent(out)::this
- integer,intent(in)::n_alloc
- if(allocated(this%slices))deallocate(this%slices)
- if(n_alloc>0)then
- allocate(this%slices(n_alloc))
- this%n_alloc=n_alloc
- this%n_slices=1
- call this%slices(1)%initialize(n_alloc)
- else
- this%n_alloc=0
- end if
- end subroutine sample_3d_initialize
-\end{Verbatim}
-
-\TbpImp{sample\_3d\_generate\_hit}
-\begin{Verbatim}
- pure subroutine sample_3d_generate_hit(this,rnd,pts2,boost,hit,region,slice)
- class(sample_3d_type),intent(in)::this
- integer,intent(in),dimension(3)::rnd
- real(kind=double),intent(in)::pts2
- integer,intent(out)::slice,region
- real(kind=double),dimension(3),intent(out)::hit
- real(kind=double),intent(out)::boost
- if(this%n_slices==0)then
- call muli_mcint_generate_hit(rnd,unit_square,hit(1:2))
- boost=1D0
- slice=1
- region=1
- else
- do slice=1,this%n_slices
- if(this%slices(slice)%contains(pts2))exit
- end do
- call this%slices(slice)%generate_hit(rnd,boost,hit(1:2),region)
- end if
- hit(3)=pts2
- end subroutine sample_3d_generate_hit
-\end{Verbatim}
-
-\TbpImp{sample\_3d\_confirm\_hit}
-\begin{Verbatim}
- subroutine sample_3d_confirm_hit(this,hit,region,slice)
- class(sample_3d_type),intent(inout)::this
- integer,intent(in)::slice,region
- real(kind=double),intent(in),dimension(3)::hit
- type(sample_2d_type),allocatable::old_slice
- integer::n
- logical::full
- if(this%n_alloc<slice)then
- print *,"sample_3d_confirm_hit: Slice ",slice," not allocated."
- else
- !if(.not.allocated(this%slices))call this%initialize(2)
- call this%slices(slice)%confirm_hit(hit,region,full)
- if(full)then
- if(this%n_alloc==this%n_slices)call this%enlarge()
- this%n_slices=this%n_slices+1
- allocate(old_slice)
- call this%slices(slice)%move_components(old_slice)
- call sample_2d_split(&
- old_slice,&
- this%n_alloc,&
- old_slice%mean(3),&
- this%slices(slice),&
- this%slices(this%n_slices))
- end if
- end if
- end subroutine sample_3d_confirm_hit
-\end{Verbatim}
-
-\TbpImp{sample\_3d\_enlarge}
-\begin{Verbatim}
- subroutine sample_3d_enlarge(this)
- class(sample_3d_type),intent(inout)::this
- type(sample_2d_type),allocatable,dimension(:)::old_slices
- integer::n
- print *,"sample_3d_enlarge"
- call move_alloc(this%slices,old_slices)
- this%n_alloc=this%n_alloc*2
- allocate(this%slices(this%n_alloc))
- do n=1,size(old_slices)
- call old_slices(n)%move_components(this%slices(n))
- end do
- end subroutine sample_3d_enlarge
-\end{Verbatim}
-\MethodsFor{sample\_int\_kind\_type}
-
-\TbpImp{sample\_int\_kind\_write\_to\_marker}
-\begin{Verbatim}
- subroutine sample_int_kind_write_to_marker(this,marker,status)
- class(sample_int_kind_type),intent(in) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%mark_begin("sample_int_kind_type")
- call sample_3d_write_to_marker(this,marker,status)
- call marker%mark("n_hits",this%n_hits)
- call marker%mark("n_proc",this%n_proc)
- call marker%mark("boost",this%overall_boost)
- if(this%n_hits>0)then
- call marker%mark("hits",this%hits)
- end if
- if(this%n_proc>0)then
- call marker%mark("processes",this%processes)
- call marker%mark("weights",this%weights)
- end if
- call marker%mark_end("sample_int_kind_type")
- end subroutine sample_int_kind_write_to_marker
-\end{Verbatim}
-
-\TbpImp{sample\_int\_kind\_read\_from\_marker}
-\begin{Verbatim}
- subroutine sample_int_kind_read_from_marker(this,marker,status)
- class(sample_int_kind_type),intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- call marker%pick_begin("sample_int_kind_type",status=status)
- call sample_3d_read_from_marker(this,marker,status)
- call marker%pick("n_hits",this%n_hits,status)
- call marker%pick("n_proc",this%n_proc,status)
- call marker%pick("boost",this%overall_boost,status)
- if(this%n_hits>0)then
- allocate(this%hits(this%n_hits))
- call marker%pick("hits",this%hits,status)
- end if
- if(this%n_proc>0)then
- allocate(this%processes(this%n_proc))
- call marker%pick("processes",this%processes,status)
- allocate(this%weights(this%n_proc))
- call marker%pick("weights",this%weights,status)
- end if
- call marker%pick_end("sample_int_kind_type",status)
- end subroutine sample_int_kind_read_from_marker
-\end{Verbatim}
-
-\TbpImp{sample\_int\_kind\_print\_to\_unit}
-\begin{Verbatim}
- subroutine sample_int_kind_print_to_unit(this,unit,parents,components,peers)
- class(sample_int_kind_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- integer::n
- if(parents>0)call sample_3d_print_to_unit(this,unit,parents,components,peers)
- write(unit,fmt=*)"components of sample_int_kind_type"
- write(unit,'("n_hits: ",i10)')this%n_hits
- write(unit,'("n_proc: ",i10)')this%n_proc
- write(unit,'("overall_boost: ",e14.7)')this%overall_boost
- write(unit,'("hits:")')
- write(unit,'(10(i0," "))')this%hits(1:this%n_hits)
- write(unit,'("weights:")')
- write(unit,'(10(i0," "))')this%weights
- write(unit,'("processes:")')
- write(unit,'(2(i0," "))')this%processes
- end subroutine sample_int_kind_print_to_unit
-\end{Verbatim}
-
-\TbpImp{sample\_int\_kind\_get\_type}
-\begin{Verbatim}
- pure subroutine sample_int_kind_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="sample_int_kind_type")
- end subroutine sample_int_kind_get_type
-\end{Verbatim}
-
-\TbpImp{sample\_int\_kind\_to\_generator}
-\begin{Verbatim}
- subroutine sample_int_kind_to_generator(this)
- class(sample_int_kind_type),intent(inout)::this
- integer::int_kind
- if(allocated(this%hits))deallocate(this%hits)
- call sample_3d_to_generator(this)
- end subroutine sample_int_kind_to_generator
-\end{Verbatim}
-
-\TbpImp{sample\_int\_kind\_process\_id}
-\begin{Verbatim}
- elemental integer function sample_int_kind_process_id(this,subprocess)
- class(sample_int_kind_type),intent(in)::this
- integer,intent(in)::subprocess
- sample_int_kind_process_id=this%processes(subprocess)
- end function sample_int_kind_process_id
-\end{Verbatim}
-
-\TbpImp{sample\_int\_kind\_initialize}
-\begin{Verbatim}
- subroutine sample_int_kind_initialize(this,n_alloc,processes,overall_boost)
- class(sample_int_kind_type),intent(out)::this
- integer,intent(in)::n_alloc
- integer,intent(in),dimension(:)::processes
- real(kind=double),optional,intent(in)::overall_boost
- integer::s,n
- s=size(processes)
- call sample_3d_initialize(this,n_alloc)
- if(allocated(this%hits))deallocate(this%hits)
- allocate(this%hits(n_alloc))
- if(allocated(this%weights))deallocate(this%weights)
- allocate(this%weights(s))
- if(allocated(this%processes))deallocate(this%processes)
- allocate(this%processes(s),source=processes)
- do n=1,s
- this%weights(n)=0
- end do
- this%n_alloc=n_alloc
- this%n_hits=0
- this%n_proc=s
- if(present(overall_boost))this%overall_boost=overall_boost
- this%overall_boost=this%overall_boost*this%n_proc
-! print *,this%weights
- end subroutine sample_int_kind_initialize
-\end{Verbatim}
-
-\TbpImp{sample\_int\_kind\_generate\_hit}
-\begin{Verbatim}
- pure subroutine sample_int_kind_generate_hit&
- (this,rnd,pts2,boost,hit,region,slice,subprocess)
- class(sample_int_kind_type),intent(in)::this
- integer,dimension(4),intent(in)::rnd
- real(kind=double),intent(in)::pts2
- real(kind=double),dimension(3),intent(out)::hit
- integer,intent(out)::region,slice,subprocess
- real(kind=double),intent(out)::boost
- integer::n_n
-! print *,rnd,pts2,boost,hit,region,slice,subprocess
- call sample_3d_generate_hit(this,rnd(2:4),pts2,boost,hit,region,slice)
- n_n=modulo(rnd(1),this%n_hits+size(this%weights))+1
- if(n_n>this%n_hits)then
- subprocess=n_n-this%n_hits
- else
- subprocess=this%hits(n_n)
- end if
- boost=boost*this%overall_boost*(this%n_proc+this%n_hits)&
- /(this%n_proc*(this%weights(subprocess)+1))
- end subroutine sample_int_kind_generate_hit
-\end{Verbatim}
-
-\TbpImp{sample\_int\_kind\_mcgenerate\_hit}
-\begin{Verbatim}
- subroutine sample_int_kind_mcgenerate_hit&
- (this,pts2,mean,integrand_kind,tao_rnd,process_id,cart_hit)
- class(sample_int_kind_type),intent(inout)::this
- integer,intent(in)::integrand_kind
- real(kind=double),intent(in)::pts2,mean
- type(tao_random_state),intent(inout)::tao_rnd
- real(kind=double),dimension(3),intent(out)::cart_hit
- integer,intent(out)::process_id
- real(kind=double)::boost
- integer::region,slice,subprocess
- integer,dimension(4)::i_rnd
- real(kind=double)::dddsigma,d_rnd
- real(kind=double),dimension(3)::hyp_hit
- MC:do
- this%n_tries=this%n_tries+1
- call tao_random_number(tao_rnd,i_rnd)
- call tao_random_number(tao_rnd,d_rnd)
- !print *,pts2,mean,integrand_kind,process_id,cart_hit
- call this%generate_hit(i_rnd,pts2,boost,hyp_hit,region,slice,subprocess)
- process_id=this%process_id(subprocess)
- call interactions_dddsigma_reg(process_id,integrand_kind,hyp_hit,cart_hit,dddsigma)
- dddsigma=dddsigma*boost
- if(d_rnd*mean<dddsigma)then
- exit MC
- end if
- end do MC
- if(mean<dddsigma)then
- call this%confirm_hit(hyp_hit,region,slice,subprocess,.true.)
- else
- call this%confirm_hit(hyp_hit,region,slice,subprocess,.false.)
- end if
- end subroutine sample_int_kind_mcgenerate_hit
-\end{Verbatim}
-
-\TbpImp{sample\_int\_kind\_confirm\_hit}
-\begin{Verbatim}
- subroutine sample_int_kind_confirm_hit(this,hit,region,slice,subprocess,over)
- class(sample_int_kind_type),intent(inout)::this
- real(kind=double),dimension(3),intent(in)::hit
- integer,intent(in)::region,slice,subprocess
- integer,dimension(:),allocatable::tmp_hits
- logical,optional,intent(in)::over
- this%n_hits=this%n_hits+1
- if(present(over))then
- if(over)then
- this%n_over=this%n_over+1
- this%overall_boost=this%overall_boost/1.1D0
- else
- this%overall_boost=this%overall_boost*1.0001D0
- end if
- end if
- if(0<size(this%hits))then
- if(this%n_hits>size(this%hits))then
- call move_alloc(this%hits,tmp_hits)
- allocate(this%hits(2*size(tmp_hits)))
- this%hits(1:size(tmp_hits))=tmp_hits
- end if
- this%hits(this%n_hits)=subprocess
- end if
- this%weights(subprocess)=this%weights(subprocess)+1
- call sample_3d_confirm_hit(this,hit,region,slice)
- end subroutine sample_int_kind_confirm_hit
-\end{Verbatim}
-
-\TbpImp{sample\_int\_kind\_analyse}
-\begin{Verbatim}
- subroutine sample_int_kind_analyse(this,dir,prefix)
- class(sample_int_kind_type),intent(in)::this
- character(*),intent(in)::dir,prefix
- integer::slices_unit,subprocs_unit
- integer::n,slice
- character(3)::slice_name
- integer,dimension(:),allocatable::int_a
- real(kind=double),dimension(:),allocatable::real_a
- call generate_unit(slices_unit)
- print *,"sample_int_kind_analyse: ",dir//"/"//prefix//"slice_distribution.plot"
- open(slices_unit,file=dir//"/"//prefix//"slice_distribution.plot")
- call generate_unit(subprocs_unit)
- print *,"sample_int_kind_analyse: ",dir//"/"//prefix//"subproc_distribution.plot"
- open(subprocs_unit,file=dir//"/"//prefix//"subproc_distribution.plot")
- allocate(real_a(this%n_slices))
- allocate(int_a(this%n_slices))
- do n=1,this%n_slices
- real_a(n)=this%slices(n)%range(1)
- end do
- call misc_sort(real_a,int_a)
- do n=1,size(this%weights)
- if(this%n_hits>0)then
- write(subprocs_unit,fmt=*)&
- real(this%weights(n)),real(this%weights(n)+1)/this%n_hits
- else
- write(subprocs_unit,fmt=*)0,0
- end if
- end do
- do n=1,this%n_slices
- slice=int_a(n)
- call integer_with_leading_zeros(n,3,slice_name)
- call sample_2d_analyse(this%slices(slice),dir,prefix//slice_name//".plot")
- print *,this%n_hits,this%slices(slice)%range(2)-this%slices(slice)%range(1)
- if (this%n_hits>0)then
- write(slices_unit,fmt=*)&
- &this%slices(slice)%range(1),&
- &this%slices(slice)%range(2),&
- &this%slices(slice)%n_hits,&
- &real(this%slices(slice)%n_hits)/&
- (this%n_hits*(this%slices(slice)%range(2)-this%slices(slice)%range(1)))
- else
- write(slices_unit,fmt=*)&
- &this%slices(slice)%range(1),&
- &this%slices(slice)%range(2),&
- &this%slices(slice)%n_hits,&
- &0D0
- end if
- end do
- write(slices_unit,fmt=*)1D0,0D0,0D0,0D0
- close(slices_unit)
- close(subprocs_unit)
- end subroutine sample_int_kind_analyse
-\end{Verbatim}
-\MethodsFor{sample\_inclusive\_type}
-
-\TbpImp{sample\_inclusive\_write\_to\_marker}
-\begin{Verbatim}
- subroutine sample_inclusive_write_to_marker(this,marker,status)
- class(sample_inclusive_type),intent(in) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- integer::n
- call marker%mark_begin("sample_inclusive_type")
- call marker%mark("n_alloc",this%n_alloc)
- if(allocated(this%int_kinds))then
- call marker%mark_begin(tag="int_kinds",shape=shape(this%int_kinds))
- do n=1,size(this%int_kinds)
- call this%int_kinds(n)%write_to_marker(marker,status)
- end do
- call marker%mark_instance_end()
- else
- call marker%mark_empty(tag="int_kinds",shape=[0])
- end if
- call marker%mark_end("sample_inclusive_type")
- end subroutine sample_inclusive_write_to_marker
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_read\_from\_marker}
-\begin{Verbatim}
- subroutine sample_inclusive_read_from_marker(this,marker,status)
- class(sample_inclusive_type),intent(out) :: this
- class(marker_type),intent(inout)::marker
- integer(kind=dik),intent(out)::status
- integer::n
- integer,dimension(:),allocatable::s
- call marker%pick_begin("sample_inclusive_type",status=status)
- call marker%pick("n_alloc",this%n_alloc,status)
- call marker%pick_begin("int_kinds",shape=s,status=status)
- if(s(1)>0)then
- do n=1,size(this%int_kinds)
- call this%int_kinds(n)%read_from_marker(marker,status)
- end do
- call marker%pick_end("int_kinds",status)
- end if
- call marker%pick_end("sample_inclusive_type",status)
- end subroutine sample_inclusive_read_from_marker
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_print\_to\_unit}
-\begin{Verbatim}
- subroutine sample_inclusive_print_to_unit(this,unit,parents,components,peers)
- class(sample_inclusive_type),intent(in)::this
- integer,intent(in)::unit
- integer(kind=dik),intent(in)::parents,components,peers
- integer::n
- write(unit,fmt=*)"components of sample_inclusive_type"
- write(unit,'("n_alloc: ",i10)')this%n_alloc
- if(allocated(this%int_kinds))then
- if(components>0)then
- write(unit,'("int_kinds:")')
- do n=1,this%n_alloc
- call this%int_kinds(n)%print_to_unit(unit,parents,components-1,peers)
- end do
- else
- write(unit,fmt=*)"skipping int_kinds."
- end if
- else
- write(unit,fmt=*)"int_kinds are not allocated."
- end if
- end subroutine sample_inclusive_print_to_unit
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_get\_type}
-\begin{Verbatim}
- pure subroutine sample_inclusive_get_type(type)
- character(:),allocatable,intent(out)::type
- allocate(type,source="sample_inclusive_type")
- end subroutine sample_inclusive_get_type
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_process\_id}
-\begin{Verbatim}
- elemental integer function sample_inclusive_process_id(this,subprocess,int_kind)
- class(sample_inclusive_type),intent(in)::this
- integer,intent(in)::subprocess,int_kind
- sample_inclusive_process_id=this%int_kinds(int_kind)%processes(subprocess)
- end function sample_inclusive_process_id
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_initialize}
-\begin{Verbatim}
- subroutine sample_inclusive_initialize(this,n_alloc,sizes,processes,overall_boost)
- class(sample_inclusive_type),intent(out)::this
- integer,intent(in)::n_alloc
- integer,dimension(:),intent(in)::sizes,processes
- real(kind=double),optional,intent(in)::overall_boost
- integer::n,sum
- this%n_tries_sum=zero
- this%n_over_sum=0
- this%n_alloc=size(sizes)
- if(allocated(this%int_kinds))deallocate(this%int_kinds)
- allocate(this%int_kinds(this%n_alloc))
- sum=0
- do n=1,this%n_alloc
- call this%int_kinds(n)%initialize(n_alloc,processes(sum+1:sum+sizes(n)),overall_boost)
- sum=sum+sizes(n)
- end do
- end subroutine sample_inclusive_initialize
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_finalize}
-\begin{Verbatim}
- subroutine sample_inclusive_finalize(this)
- class(sample_inclusive_type),intent(inout)::this
- deallocate(this%int_kinds)
- this%n_alloc=0
- end subroutine sample_inclusive_finalize
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_generate\_hit}
-\begin{Verbatim}
- pure subroutine sample_inclusive_generate_hit&
- (this,rnd,pts2,int_kind,hit,region,boost,slice,process)
- class(sample_inclusive_type),intent(in)::this
- integer,dimension(4),intent(in)::rnd
- real(kind=double),intent(in)::pts2
- integer,intent(in)::int_kind
- real(kind=double),dimension(3),intent(out)::hit
- integer,intent(out)::region,slice,process
- real(kind=double),intent(out)::boost
- call this%int_kinds(int_kind)%generate_hit(rnd,pts2,boost,hit,region,slice,process)
- end subroutine sample_inclusive_generate_hit
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_mcgenerate\_hit}
-\begin{Verbatim}
- subroutine sample_inclusive_mcgenerate_hit&
- (this,pts2,mean,integrand_kind,tao_rnd,process_id,cart_hit)
- class(sample_inclusive_type),intent(inout)::this
- real(kind=double),intent(in)::pts2,mean
- integer,intent(in)::integrand_kind
- type(tao_random_state),intent(inout)::tao_rnd
- real(kind=double),dimension(3),intent(out)::cart_hit
- integer,intent(out)::process_id
- call sample_int_kind_mcgenerate_hit(&
- this%int_kinds(integrand_kind),pts2,mean,integrand_kind,tao_rnd,process_id,cart_hit)
- end subroutine sample_inclusive_mcgenerate_hit
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_confirm\_hit}
-\begin{Verbatim}
- subroutine sample_inclusive_confirm_hit(this,hit,int_kind,region,slice,process,over)
- class(sample_inclusive_type),intent(inout)::this
- real(kind=double),dimension(3),intent(in)::hit
- integer,intent(in)::int_kind,region,slice,process
- logical,optional,intent(in)::over
- call this%int_kinds(int_kind)%confirm_hit(hit,region,slice,process,over)
- end subroutine sample_inclusive_confirm_hit
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_sum\_up}
-\begin{Verbatim}
- subroutine sample_inclusive_sum_up(this)
- class(sample_inclusive_type),intent(inout)::this
- integer::n
- this%n_tries_sum=zero
- this%n_hits_sum=zero
- this%n_over_sum=zero
- do n=1,this%n_alloc
- this%n_tries_sum=this%n_tries_sum+this%int_kinds(n)%n_tries
- this%n_hits_sum=this%n_hits_sum+this%int_kinds(n)%n_hits
- this%n_over_sum=this%n_over_sum+this%int_kinds(n)%n_over
- end do
- end subroutine sample_inclusive_sum_up
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_analyse}
-\begin{Verbatim}
- subroutine sample_inclusive_analyse(this,dir,subdirs)
- class(sample_inclusive_type),intent(in)::this
- character(*),intent(in)::dir
- logical,intent(in)::subdirs
- integer::inclusive_unit
- integer::n,n_hits
- character(2)::sample_name
- call generate_unit(inclusive_unit)
- open(inclusive_unit,file=dir//"/int_kinds.plot")
- n_hits=0
- do n=1,size(this%int_kinds)
- n_hits=n_hits+this%int_kinds(n)%n_hits
- end do
- do n=1,size(this%int_kinds)
- write(inclusive_unit,fmt=*)n,real(this%int_kinds(n)%n_hits)/n_hits
- call integer_with_leading_zeros(n,2,sample_name)
- if(subdirs)then
- call sample_int_kind_analyse(&
- this%int_kinds(n),&
- dir//"/"//sample_name,&
- "")
- else
- call sample_int_kind_analyse(&
- this%int_kinds(n),&
- dir,&
- sample_name//"_")
- end if
- end do
- close(inclusive_unit)
- end subroutine sample_inclusive_analyse
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_to\_generator}
-\begin{Verbatim}
- subroutine sample_inclusive_to_generator(this)
- class(sample_inclusive_type),intent(inout)::this
- integer::int_kind
- do int_kind=1,size(this%int_kinds)
- call this%int_kinds(int_kind)%to_generator()
- end do
- end subroutine sample_inclusive_to_generator
-\end{Verbatim}
-
-\TbpImp{sample\_inclusive\_allocate}
-\begin{Verbatim}
- subroutine sample_inclusive_allocate(this,n_alloc)
- class(sample_inclusive_type),intent(out)::this
- integer,intent(in)::n_alloc
- allocate(this%int_kinds(n_alloc))
- this%n_alloc=n_alloc
- end subroutine sample_inclusive_allocate
-\end{Verbatim}
-\MethodsNTB
-
-\ProcImp{muli\_mcint\_generate\_hit}
-\begin{Verbatim}
- pure subroutine muli_mcint_generate_hit(rnd,corners,hit)
- real(kind=double),dimension(2),intent(out)::hit
- integer,intent(in),dimension(2)::rnd
- real(kind=double),dimension(2,2),intent(in)::corners
- !print *,hit
- !print *,corners
- !print *,(corners(1:2,2)-corners(1:2,1))
- hit=(rnd/max_d)*(corners(1:2,2)-corners(1:2,1))+corners(1:2,1)
- end subroutine muli_mcint_generate_hit
-\end{Verbatim}
-
-\ProcImp{plot\_pstvue3d}
-\begin{Verbatim}
- subroutine plot_pstvue3d(unit,corners,density)
- integer,intent(in)::unit
- real(kind=double),dimension(2,2),intent(in)::corners
- real(kind=double),intent(in)::density
- real(kind=double),dimension(2)::width,mean
- real(kind=double),dimension(3,3)::plot
- width=(corners(:,2)-corners(:,1))/2D0
- mean=(corners(:,1)+corners(:,2))/2D0
- plot(1,1)=width(1)
- plot(2,1)=width(2)
- plot(3,1)=density/2D0
- plot(1,2)=mean(1)
- plot(2,2)=mean(2)
- plot(3,2)=density/2D0
- call log_color_code(density,plot(1:3,3))
- if(density>1D0)then
- write(unit,fmt='("\\mybigcube{",F14.7,"}{",F14.7,"}{",F14.7,"}&
- &{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}")')plot
- return
- end if
- write(unit,fmt='("\\mycube{",F14.7,"}{",F14.7,"}{",F14.7,"}&
- &{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}")')plot
- end subroutine plot_pstvue3d
-\end{Verbatim}
-
-\ProcImp{log\_color\_code}
-\begin{Verbatim}
- subroutine log_color_code(number,rgb)
- real(kind=double),intent(in)::number
- real(kind=double),dimension(3),intent(out)::rgb
- if(number<exp(-5D0))then
- rgb=[0D0,0D0,exp(5D0)*number]
- else
- if(number<exp(-4D0))then
- rgb=[0D0,(number-exp(-5D0))/(exp(-4D0)-exp(-5D0)),1D0]
- else
- if(number<exp(-3D0))then
- rgb=[0D0,1D0,1D0-((number-exp(-4D0))/(exp(-3D0)-exp(-4D0)))]
- else
- if(number<exp(-2D0))then
- rgb=[(number-exp(-3D0))/(exp(-2D0)-exp(-3D0)),1D0,0D0]
- else
- if(number<exp(-1D0))then
- rgb=[1D0,1D0-(number-exp(-2D0))/(exp(-1D0)-exp(-2D0)),0D0]
- else
- if(number<1D0)then
- rgb=[1D0,0D0,(number-exp(-3D0))/(1D0-exp(-3D0))]
- else
- rgb=[exp(1D0),1D0,1D0]*exp(-number)
- return
- end if
- end if
- end if
- end if
- end if
- end if
- end subroutine log_color_code
-\end{Verbatim}
-
-\ProcImp{misc\_sort}
-\begin{Verbatim}
- recursive subroutine misc_sort(in,out)
- real(kind=double),dimension(:),intent(in)::in
- integer,dimension(:),intent(out)::out
- integer,dimension(:),allocatable::tmp
- integer::n,k,l,cut
- if(size(in)==1)then
- out=[1]
- else
- if(size(in)==2)then
- if(in(1)<=in(2))then
- out=[1,2]
- else
- out=[2,1]
- end if
- else
- cut=size(in)/2
- k=1
- l=cut+1
- allocate(tmp(size(in)))
- call misc_sort(in(1:cut),tmp(1:cut))
- call misc_sort(in(cut+1:),tmp(cut+1:))
- do n=cut+1,size(in)
- tmp(n)=tmp(n)+cut
- end do
- do n=1,size(in)
- if(k>cut)then
- out(n)=tmp(l)
- l=l+1
- else
- if(l>size(tmp))then
- out(n)=tmp(k)
- k=k+1
- else
- if(in(tmp(k))<in(tmp(l)))then
- out(n)=tmp(k)
- k=k+1
- else
- out(n)=tmp(l)
- l=l+1
- end if
- end if
- end if
- end do
- end if
- end if
- end subroutine misc_sort
-\end{Verbatim}
Index: trunk/src/muli/auxiliary/trainer.f90
===================================================================
--- trunk/src/muli/auxiliary/trainer.f90 (revision 8371)
+++ trunk/src/muli/auxiliary/trainer.f90 (revision 8372)
@@ -1,66 +0,0 @@
-program trainer
- use arguments
- use muli
- implicit none
- type(muli_type)::mi
- type(sample_inclusive_type)::sample
- type(sample_int_kind_type),dimension(:),allocatable::int_kinds
- call initialize()
-contains
- subroutine initialize()
- type(argument_list_type)::args
- type(integer_argument_type),target::int_kind,random_seed,pdf_set,n_total,n_print
- type(real_argument_type),target::gev_cme,gev_cutoff
- type(string_argument_type),target::pdf_file,muli_dir
- type(plain_argument_type),target::help_arg
- type(switch_argument_type),target::dynamic_remnant,collect,analyse
- character(2)::num
- integer::n
- call help_arg%initialize(args,"h","help","Print this Message and exit.")
- call random_seed%initialize(1_i64,1_i64,(2_i64)**30,args,long="random_seed",named_option="<NUMBER>", description="When given, tao random numbers are initialized with <NUMBER>.")
- call int_kind%initialize(1_i64,1_i64,16_i64,args,long="int_kind",named_option="<NUMBER>", description="The integrand kind stratus to train.")
- call n_total%initialize(1000000_i64,1_i64,huge(1_i64),args,long="n_total",named_option="<NUMBER>", description="Total number of pt chains.")
- call n_print%initialize(1000_i64,1_i64,huge(1_i64),args,long="n_print",named_option="<NUMBER>", description="Total number of output lines.")
- call pdf_set%initialize(1_i64,1_i64,huge(1_i64),args,long="pdf_set",named_option="<NUMBER>", description="The pdf set member.")
- call pdf_file%initialize("cteq5l.LHgrid",args,long="pdf_file",named_option="<FILE>")
- call muli_dir%initialize("/tmp",args,long="muli_dir",named_option="<DIR>",description="Place to read and write generator information.")
- call gev_cme%initialize(14D3,1D0,huge(1D0),long="cme",named_option="<NUMBER>",description="Initial center of mass energy in GeV")
- call gev_cutoff%initialize(1D0,0D0,huge(1D0),long="cutoff",named_option="<NUMBER>",description="Lower limit of pt in GeV")
- call collect%initialize(.false.,args,long="collect",description="Do not generate interactions but merge strati to one single file.")
- call analyse%initialize(.false.,args,long="analyse",description="Generate some Plots.")
- call dynamic_remnant%initialize(.false.,args,long="dynamic_remnant",description="When given, remnants will be altered after every interaction.")
- call pdf_file%push("cteq61.LHpdf")
- call pdf_file%push("GSG961.LHgrid")
- call args%process()
- if(help_arg%is_given())then
- call args%write_description(output_unit)
- stop
- end if
- if(collect%is_given())then
- allocate(int_kinds(16))
- do n=1,16
- call integer_with_leading_zeros(n,2,num)
- call int_kinds(n)%deserialize("sample_int_kind_"//num,muli_dir%get_actual_value()//"/sample_int_kind/"//num//".xml")
- end do
- else
- call mi%initialize(&
- gev_cutoff%get_actual_value()**2,&
- gev_cme%get_actual_value()**2,&
- muli_dir%get_actual_value(),&
-! pdf_file%get_actual_value(),&
-! int(pdf_set%get_actual_value(),kind=i32),&
- int(random_seed%get_actual_value(),kind=i32))
- if(dynamic_remnant%is_given())then
- call mi%enable_remnant_pdf()
- else
- call mi%disable_remnant_pdf()
- end if
- call mi%generate_samples(&
- n_total%get_actual_value(),&
- n_print%get_actual_value(),&
- int(int_kind%get_actual_value(),kind=i32),&
- muli_dir%get_actual_value(),&
- analyse%is_given())
- end if
- end subroutine initialize
-end program trainer
Index: trunk/src/muli/auxiliary/arguments.f90
===================================================================
--- trunk/src/muli/auxiliary/arguments.f90 (revision 8371)
+++ trunk/src/muli/auxiliary/arguments.f90 (revision 8372)
@@ -1,1067 +0,0 @@
-!!! module: arguments_module
-!!! This code is part of my Ph.D studies.
-!!!
-!!! Copyright (C) 2011 Hans-Werner Boschmann <boschmann@tp1.physik.uni-siegen.de>
-!!!
-!!! This program 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 3 of the License, or (at your option)
-!!! any later version.
-!!!
-!!! This program 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, see <http://www.gnu.org/licenses/>.
-!!!
-!!! Latest Change: 2011-06-29 16:11:41 CEST(+0200)
-!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-module arguments
- use,intrinsic::iso_fortran_env
- use kinds
- implicit none
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Intrinsic Type Module Component Declaration !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- integer,private,parameter::indent_len=30
- logical::arguments_stop_at_unrecognized_argument=.true.
- logical::arguments_stop_at_invalid_argument=.true.
- logical::arguments_stop_at_unrecognized_option=.true.
- logical::arguments_stop_at_invalid_option=.true.
- logical::arguments_revert_invalid_to_default=.true.
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Derived Type Definition !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- type::string_filo_stack_type
- character(:),allocatable::value
- class(string_filo_stack_type),pointer::next=>null()
- contains
- procedure::push_string=>string_filo_stack_push_string
- procedure::push_filo_stack=>string_filo_stack_push_filo_stack
- procedure::finalize=>string_filo_stack_finalize
- procedure::contains=>string_filo_stack_contains
- procedure::write_contents=>string_filo_stack_write_contents
- procedure::write_tail=>string_filo_stack_write_tail
- procedure::assign=>string_filo_stack_assign
- generic::push=>push_string,push_filo_stack
- end type string_filo_stack_type
-
- type,extends(string_filo_stack_type)::string_list_type
- class(string_filo_stack_type),pointer::last=>null()
- contains
- procedure::push_string=>string_list_push_string
- procedure::push_filo_stack=>string_list_push_filo_stack
- procedure::initialize=>string_list_initialize
- procedure::finalize=>string_list_finalize
- procedure::string_list_append_string
- procedure::string_list_append_filo_stack
- procedure::string_list_append_list
- procedure::get_rightmost=>string_list_get_rightmost
- generic::append=>string_list_append_string,string_list_append_filo_stack
- end type string_list_type
-
- type,abstract :: argument_class
- private
- character::short_form=""
- character(:),allocatable::long_form,named_option
- class(string_list_type),pointer::description=>null()
- integer::long_form_length=0
- integer::named_option_length=0
- logical::is_given_comp=.false.
- logical::is_default=.true.
- logical::is_valid=.true.
- logical::with_option=.false.
- logical::has_short_form=.false.
- logical::has_long_form=.false.
- contains
- procedure::is_given=>argument_is_given
- procedure::get_a_form=>argument_get_a_form
- procedure::compare_short=>argument_compare_short
- procedure::compare_long=>argument_compare_long
- procedure::argument_initialize
- procedure::argument_finalize
- procedure::write_description=>argument_write_description
- procedure(read_option_interface),deferred::read_option
- procedure::write_to_unit=>argument_write_to_unit
- end type argument_class
-
- type::argument_list_type
- class(argument_list_type),pointer::next=>null()
- class(argument_class),pointer::argument=>null()
- contains
- procedure::push=>argument_list_push
- procedure::finalize=>argument_list_finalize
- procedure::process=>argument_list_process
- procedure::process_long=>argument_list_process_long
- procedure::process_short=>argument_list_process_short
- procedure::write_description=>argument_list_write_description
- end type argument_list_type
-
- type,extends(argument_class) :: switch_argument_type
- logical::default_value=.true.
- logical::actual_value=.true.
- class(switch_argument_type),pointer::disable_arg=>null()
- contains
- procedure::read_option=>switch_argument_read_option
- procedure::switch_argument_initialize
- procedure::compare_short=>switch_argument_compare_short
- procedure::compare_long=>switch_argument_compare_long
- procedure::negates=>switch_argument_negates
- generic::initialize=>argument_initialize,switch_argument_initialize
- end type switch_argument_type
-
- type,extends(argument_class) :: real_argument_type
- real(kind=double)::default_value=0D0
- real(kind=double)::actual_value=0D0
- real(kind=double)::min_value=0D0
- real(kind=double)::max_value=1D0
- real(kind=double),dimension(:),allocatable::value_range
- contains
- procedure::get_actual_value=>real_argument_get_actual_value
- procedure::read_option=>real_argument_read_option
- procedure::write_description=>real_argument_write_description
- procedure::real_argument_initialize
- generic::initialize=>argument_initialize,real_argument_initialize
- end type real_argument_type
-
- type,extends(argument_class) :: integer_argument_type
- private
- integer(kind=i64)::default_value
- integer(kind=i64)::actual_value
- integer(kind=i64)::min_value
- integer(kind=i64)::max_value
- integer(kind=i64),dimension(:),allocatable::value_range
- contains
- procedure::get_actual_value=>integer_argument_get_actual_value
- procedure::read_option=>integer_argument_read_option
- procedure::write_description=>integer_argument_write_description
- procedure::integer_argument_initialize
- generic::initialize=>argument_initialize,integer_argument_initialize
- end type integer_argument_type
-
- type,extends(argument_class) :: string_argument_type
- private
- integer::actual_length=0
- integer::default_length=0
- character(:),allocatable::actual_value
- type(string_filo_stack_type)::value_range
- contains
- procedure::get_default_value=>string_argument_get_default_value
- procedure::get_actual_value=>string_argument_get_actual_value
- procedure::assign=>string_argument_assign
- procedure::push=>string_argument_push
- procedure::read_option=>string_argument_read_option
- procedure::string_argument_initialize
- procedure::finalize=>string_argument_finalize
- procedure::write_description=>string_argument_write_description
- generic::initialize=>string_argument_initialize
- end type string_argument_type
-
- type,extends(argument_class) :: plain_argument_type
- contains
- procedure::read_option=>plain_argument_read_option
- generic::initialize=>argument_initialize
- end type plain_argument_type
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Interface Definition !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- interface
- subroutine read_option_interface(this,index)
- import argument_class
- class(argument_class),intent(inout)::this
- integer,intent(inout)::index
- end subroutine read_option_interface
- end interface
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Module Procedure Definition !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-contains
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Type Bound Procedures for argument_list_type !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- subroutine argument_list_push(this,argument)
- class(argument_list_type),intent(inout)::this
- class(argument_class),intent(in),target::argument
- class(argument_list_type),pointer::new_list
-! print *,"argument_list_push(this,",argument%get_a_form()
- if(associated(this%argument))then
- allocate(new_list)
- new_list%argument=>argument
- new_list%next=>this%next
- this%next=>new_list
- else
- this%argument=>argument
- end if
- end subroutine argument_list_push
-
- recursive subroutine argument_list_finalize(this)
- class(argument_list_type),intent(out)::this
- if(associated(this%next))call this%next%finalize()
- deallocate(this%next)
- nullify(this%argument)
- end subroutine argument_list_finalize
-
- subroutine argument_list_process(this)
- class(argument_list_type),intent(inout)::this
- character(2)::arg_kind
- integer::arg_length,arg_index,short_index
- character(:),allocatable::long_arg
- character::short_arg
- arg_index=0
- arg_loop:do
- arg_index=arg_index+1
- call get_command_argument(arg_index,arg_kind,arg_length)
- if(arg_kind(1:1)=="-")then
- if(arg_kind(2:2)=="-")then
- if(arg_length>2)then
- allocate(character(arg_length)::long_arg)
- call get_command_argument(arg_index,long_arg,arg_length)
-! print *, "process_long ",long_arg
- call this%process_long(long_arg(3:arg_length),arg_index)
- deallocate(long_arg)
- else
- print *,arg_kind,"XD is no valid argument."
- if(arguments_stop_at_invalid_argument)stop
- end if
- else
- if(arg_length>1)then
- allocate(character(arg_length)::long_arg)
- call get_command_argument(arg_index,long_arg,arg_length)
- short:do short_index=2,arg_length
- short_arg=long_arg(short_index:short_index)
-! print *, "process_short ",short_arg
- call this%process_short(short_arg,arg_index)
- end do short
- else
- print *,arg_kind," is no valid argument."
- if(arguments_stop_at_invalid_argument)stop
- end if
- end if
- else
- exit
- end if
- end do arg_loop
- end subroutine argument_list_process
-
- recursive subroutine argument_list_process_short(this,short,index)
- class(argument_list_type),intent(inout)::this
- character,intent(in)::short
- integer,intent(inout)::index
- logical::match
- if(associated(this%argument))then
- call this%argument%compare_short(short,index,match)
- if(.not.match)then
- if(associated(this%next))then
- call this%next%process_short(short,index)
- else
- print *,"-",short," is no recognized argument."
- if(arguments_stop_at_unrecognized_argument)stop
- end if
- end if
- else
- print *,"argument_list_process_short: No Argument assigned."
- end if
- end subroutine argument_list_process_short
-
- recursive subroutine argument_list_process_long(this,long,index)
- class(argument_list_type),intent(inout)::this
- character(*),intent(in)::long
- integer,intent(inout)::index
- logical::match
- if(associated(this%argument))then
- call this%argument%compare_long(long,index,match)
- if(.not.match)then
- if(associated(this%next))then
- call this%next%process_long(long,index)
- else
- print *,"--",long," is no recognized argument."
- if(arguments_stop_at_unrecognized_argument)stop
- end if
- end if
- else
- print *,"argument_list_process_long: No Argument assigned."
- end if
- end subroutine argument_list_process_long
-
- recursive subroutine argument_list_write_description(this,unit)
- class(argument_list_type),intent(in)::this
- integer,intent(in)::unit
- if(associated(this%argument))call this%argument%write_description(unit)
- if(associated(this%next))call this%next%write_description(unit)
- end subroutine argument_list_write_description
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Type Bound Procedures for string_filo_stack_type !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- subroutine string_filo_stack_assign(this,string)
- class(string_filo_stack_type),intent(inout)::this
- character(*),intent(in)::string
- if(allocated(this%value))deallocate(this%value)
- allocate(character(len(string))::this%value)
- this%value=string
- end subroutine string_filo_stack_assign
-
- subroutine string_filo_stack_push_string(this,string)
- class(string_filo_stack_type),intent(inout)::this
- character(*),intent(in)::string
- class(string_filo_stack_type),pointer::new_entry
- allocate(new_entry)
- call new_entry%assign(string)
- new_entry%next=>this%next
- this%next=>new_entry
- end subroutine string_filo_stack_push_string
-
- subroutine string_filo_stack_push_filo_stack(this,stack)
- class(string_filo_stack_type),intent(inout)::this
- class(string_filo_stack_type),intent(inout),target::stack
- stack%next=>this%next
- this%next=>stack
- end subroutine string_filo_stack_push_filo_stack
-
- recursive subroutine string_filo_stack_finalize(this)
- class(string_filo_stack_type),intent(out)::this
- if(associated(this%next))then
- call this%next%finalize
- deallocate(this%next)
- end if
- if(allocated(this%value))deallocate(this%value)
- end subroutine string_filo_stack_finalize
-
- recursive subroutine string_filo_stack_contains(this,string,success)
- class(string_filo_stack_type),intent(in)::this
- character(*),intent(in)::string
- logical,intent(out)::success
- if(this%value==string)then
- success=.true.
- else
- if(associated(this%next))then
- call this%next%contains(string,success)
- else
- success=.false.
- end if
- end if
- end subroutine string_filo_stack_contains
-
- subroutine string_filo_stack_write_tail(this,unit,separator)
- class(string_filo_stack_type),intent(in)::this
- integer,intent(in)::unit
- character(*),intent(in),optional::separator
- if(associated(this%next))call string_filo_stack_write_contents(this%next,unit,separator)
- end subroutine string_filo_stack_write_tail
-
- recursive subroutine string_filo_stack_write_contents(this,unit,separator)
- class(string_filo_stack_type),intent(in)::this
- integer,intent(in)::unit
- character(*),intent(in),optional::separator
- if(allocated(this%value))write(unit,fmt=("(a)"),ADVANCE="NO")this%value
- if(associated(this%next))then
- if(present(separator))then
- write(unit,fmt=("(a)"),ADVANCE="NO")separator
- else
- write(unit,fmt=*)""
- end if
- call this%next%write_contents(unit,separator)
- end if
- end subroutine string_filo_stack_write_contents
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Type Bound Procedures for string_list_type !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- subroutine string_list_set_last(this)
- class(string_list_type),intent(inout),target::this
- if(.not.associated(this%next))then
- this%last=>this
- else
- if(.not.associated(this%last))this%last=>this
- do while(associated(this%last%next))
- this%last=>this%last%next
- end do
- end if
- end subroutine string_list_set_last
-
- subroutine string_list_push_string(this,string)
- class(string_list_type),intent(inout),target::this
- character(*),intent(in)::string
- call string_filo_stack_push_string(this,string)
- call string_list_set_last(this)
- end subroutine string_list_push_string
-
- subroutine string_list_push_filo_stack(this,stack)
- class(string_list_type),intent(inout),target::this
- class(string_filo_stack_type),intent(inout),target::stack
- class(string_filo_stack_type),pointer::thisp
- thisp=>this
- call string_filo_stack_push_filo_stack(this,stack)
- call string_list_set_last(this)
- end subroutine string_list_push_filo_stack
-
- subroutine string_list_initialize(this,string)
- class(string_list_type),intent(out),target::this
- character(*),intent(in),optional::string
-! print *,"string_list_initialize"
-! print *,associated(this%last)
- this%last=>this
- if(allocated(this%value))deallocate(this%value)
- if(present(string))call this%assign(string)
-! print *,associated(this%last)
- end subroutine string_list_initialize
-
- subroutine string_list_finalize(this)
- class(string_list_type),intent(out),target::this
- call string_filo_stack_finalize(this)
- nullify(this%last)
- end subroutine string_list_finalize
-
- subroutine string_list_append_string(this,string)
- class(string_list_type),target,intent(inout)::this
- character(*),intent(in)::string
-! print *,string
-! print *,associated(this%last)
- allocate(this%last%next)
- this%last=>this%last%next
- call this%last%assign(string)
- end subroutine string_list_append_string
-
- subroutine string_list_append_filo_stack(this,stack)
- class(string_list_type),intent(inout)::this
- class(string_filo_stack_type),intent(in),target::stack
- this%last%next=>stack
- do while(associated(this%last%next))
- this%last=>this%last%next
- end do
- end subroutine string_list_append_filo_stack
-
- subroutine string_list_append_list(this,list)
- class(string_list_type),intent(inout)::this,list
- if(allocated(list%value))call this%append(list%value)
- call this%append(list%next)
- end subroutine string_list_append_list
-
- subroutine string_list_get_rightmost(this,string)
- class(string_list_type),intent(inout)::this
- character(*),intent(out)::string
- if(allocated(this%last%value))string=this%last%value
- end subroutine string_list_get_rightmost
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Type Bound Procedures for argument_class !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- elemental function argument_is_given(this)
- logical::argument_is_given
- class(argument_class),intent(in)::this
- argument_is_given=this%is_given_comp
- end function argument_is_given
-
- function argument_get_a_form(this) result(form)
- class(argument_class),intent(in)::this
- character(max(1,this%long_form_length))::form
- if(allocated(this%long_form))then
- form=this%long_form
- else
- form=this%short_form
- end if
- end function argument_get_a_form
-
- subroutine argument_initialize(this,arg_list,short,long,description,description_list,named_option)
- class(argument_class),intent(inout),target::this
- character,intent(in),optional::short
- character(*),intent(in),optional::long,description,named_option
- type(string_list_type),intent(inout),optional,target::description_list
- class(argument_list_type),optional,intent(inout)::arg_list
- if(present(long).or.present(short))then
- if(present(short))then
- this%short_form=short
- this%has_short_form=.true.
- else
- this%short_form=" "
- this%has_short_form=.false.
- end if
- if(allocated(this%long_form))deallocate(this%long_form)
- if(present(long))then
- this%long_form_length=len(long)
- allocate(this%long_form,source=long)
- this%has_long_form=.true.
- else
- this%long_form_length=0
- this%has_long_form=.false.
- end if
- allocate(this%description)
- call this%description%initialize()
- if(present(arg_list))call arg_list%push(this)
- if(present(description_list))then
- call this%description%push(description_list)
- else
- if(present(description))then
- call this%description%append(description)
- end if
- end if
- if(allocated(this%named_option))deallocate(this%named_option)
- if(present(named_option))then
- allocate(this%named_option,source=named_option)
- this%named_option_length=len(named_option)
- else
- this%named_option_length=0
- end if
- else
- print *,"argument_initialize: Neither short form nor long form given for argument. Stop."
- stop
- end if
- end subroutine argument_initialize
-
- subroutine argument_finalize(this)
- class(argument_class),intent(out)::this
- call this%description%finalize()
- deallocate(this%description)
- end subroutine argument_finalize
-
- subroutine argument_compare_short(this,short,index,match)
- class(argument_class),intent(inout)::this
- character,intent(in)::short
- integer,intent(inout)::index
- logical,intent(out)::match
- if(this%short_form==short)then
- match=.true.
- this%is_given_comp=.true.
- call this%read_option(index)
- else
- match=.false.
- end if
- end subroutine argument_compare_short
-
- subroutine argument_compare_long(this,long,index,match)
- class(argument_class),intent(inout)::this
- character(*),intent(in)::long
- integer,intent(inout)::index
- logical,intent(out)::match
- if(allocated(this%long_form))then
- if(this%long_form==long)then
- match=.true.
- this%is_given_comp=.true.
- call this%read_option(index)
- else
- match=.false.
- end if
- end if
- end subroutine argument_compare_long
-
- subroutine argument_write_description(this,unit)
- class(argument_class),intent(in)::this
- integer,intent(in)::unit
- integer::length
- length=6
- write(unit,fmt=("(a2)"),ADVANCE="NO")" "
- if(this%has_short_form)then
- write(unit,fmt=("(a1,a1)"),ADVANCE="NO")"-",this%short_form
- if(this%has_long_form)then
- write(unit,fmt=("(a)"),ADVANCE="NO")", "
- else
- write(unit,fmt=("(a3)"),ADVANCE="NO")" "
- end if
- else
- write(unit,fmt=("(a)"),ADVANCE="NO")" "
- end if
- if(this%has_long_form)then
- write(unit,fmt=("(a,a,a)"),ADVANCE="NO")"--",this%long_form," "
- length=length+this%long_form_length+3
- end if
- if(allocated(this%named_option))then
- write(unit,fmt=("(a,a)"),ADVANCE="NO")this%named_option(1:this%named_option_length)," "
- length=length+this%named_option_length+1
- end if
- if(length>=indent_len)then
- write(unit,fmt=*)""
- write(unit,fmt=("(a)"),ADVANCE="NO")repeat(" ",indent_len)
- else
- write(unit,fmt=("(a)"),ADVANCE="NO")repeat(" ",indent_len-length)
- end if
- call this%description%write_tail(unit,new_line(" ")//repeat(" ",indent_len))
- write(unit,fmt=*)""
- end subroutine argument_write_description
-
- subroutine argument_write_to_unit(this,unit)
- class(argument_class),intent(in)::this
- integer,intent(in)::unit
- write(unit,fmt=*)"short form: ",this%short_form
- if(allocated(this%long_form))then
- write(unit,fmt=*)"long form: ",this%long_form
- else
- write(unit,fmt=*)"long form: ","not allocated."
- end if
- write(unit,fmt=*)"long form length: ",this%long_form_length
- write(unit,fmt=*)"named option length:",this%named_option_length
- write(unit,fmt=*)"is given: ",this%is_given_comp
- write(unit,fmt=*)"is default: ",this%is_default
- write(unit,fmt=*)"is valid: ",this%is_valid
- write(unit,fmt=*)"with option: ",this%with_option
- write(unit,fmt=*)"has short form: ",this%has_short_form
- write(unit,fmt=*)"has long form: ",this%has_long_form
- end subroutine argument_write_to_unit
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Type Bound Procedures for real_argument_type !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- pure function real_argument_get_actual_value(this)
- real(kind=double)::real_argument_get_actual_value
- class(real_argument_type),intent(in)::this
- real_argument_get_actual_value=this%actual_value
- end function real_argument_get_actual_value
-
- subroutine real_argument_read_option(this,index)
- class(real_argument_type),intent(inout)::this
- integer,intent(inout)::index
- integer::n,length,iostat
- character(:),allocatable::option
- index=index+1
- call get_command_argument(index,length=length)
- allocate(character(length)::option)
- call get_command_argument(index,option)
- read(option,fmt=*,iostat=iostat)this%actual_value
- if(.not.iostat==0)then
- print *,"real_argument_read_option: could not parse option ",option," of argument ",this%get_a_form()
- if(arguments_stop_at_unrecognized_option)stop
- if(arguments_revert_invalid_to_default)then
- this%actual_value=this%default_value
- else
- this%is_valid=.false.
- end if
- end if
- if((this%actual_value<this%min_value).or.(this%actual_value>this%max_value))then
- print *,"real_argument_read_option: Option ",option," of argument ",this%get_a_form()," is out of range"
- print *,"Range is: [",this%min_value,":",this%max_value,"]"
- if(arguments_stop_at_invalid_option)stop
- if(arguments_revert_invalid_to_default)then
- this%actual_value=this%default_value
- else
- this%is_valid=.false.
- end if
- end if
- if(allocated(this%value_range))then
- this%is_valid=.false.
- do n=1,size(this%value_range)
- if(this%actual_value==this%value_range(n))then
- this%is_valid=.true.
- exit
- end if
- end do
- if(.not.this%is_valid)then
- print *,"Value ",this%actual_value," for argument ",this%get_a_form()," is invalid."
- print *,"Valid values are:"
- print *,this%value_range
- print *,"Default value is:"
- print *,this%default_value
- if(arguments_revert_invalid_to_default)then
- this%actual_value=this%default_value
- else
- this%is_valid=.false.
- end if
- end if
- end if
- if(this%actual_value==this%default_value)then
- this%is_default=.true.
- else
- this%is_default=.false.
- end if
- this%is_given_comp=.true.
- end subroutine real_argument_read_option
-
- subroutine real_argument_write_description(this,unit)
- class(real_argument_type),intent(in)::this
- integer,intent(in)::unit
- integer::i
- call argument_write_description(this,unit)
- if(allocated(this%value_range))then
- write(unit,("(a,a,a)"),ADVANCE="NO")repeat(" ",indent_len),this%named_option(1:this%named_option_length)," is one of: "
- write(unit,fmt='("{",E22.16)',ADVANCE="NO")this%value_range(1)
- do i=2,size(this%value_range)
- write(unit,fmt='(",",E22.16)',ADVANCE="NO")this%value_range(i)
- end do
- write(unit,fmt='("}")')
- else
- write(unit,("(a,a,a)"),ADVANCE="NO")repeat(" ",indent_len),this%named_option(1:this%named_option_length)," is in: "
- write(unit,fmt="(a,E22.16,a,E22.16,a)")"[",this%min_value,",",this%max_value,"]"
- end if
- end subroutine real_argument_write_description
-
- subroutine real_argument_initialize(this,value,min,max,arg_list,short,long,description,description_list,named_option,range)
- class(real_argument_type),intent(inout),target::this
- real(kind=double),intent(in)::value
- real(kind=double),optional,intent(in)::min,max
- class(argument_list_type),optional,intent(inout)::arg_list
- real(kind=double),dimension(:),intent(in),optional::range
- character,intent(in),optional::short
- character(*),intent(in),optional::long,description,named_option
- type(string_list_type),intent(inout),optional::description_list
- character(24)::default_char
- call argument_initialize(this,arg_list,short,long,description,description_list,named_option)
- this%default_value=value
- if(present(min))then
- this%min_value=min
- else
- this%min_value=-huge(1)
- end if
- if(present(max))then
- this%max_value=max
- else
- this%max_value=huge(1)
- end if
- if(this%min_value>this%max_value)then
- print *,"real_argument_initialize: min value is greater then max value. Stop."
- stop
- end if
- if((this%default_value<this%min_value).or.(this%default_value>this%max_value))then
- print *,"real_argument_initialize: default value is not in range. Stop."
- stop
- end if
- if(allocated(this%value_range))deallocate(this%value_range)
- if(present(range))allocate(this%value_range(size(range)),source=range)
- this%actual_value=this%default_value
- this%is_default=.true.
- this%is_valid=.true.
- write(default_char,'(E22.16)')this%default_value
- call this%description%append("Default value is "//trim(default_char)//".")
- end subroutine real_argument_initialize
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Type Bound Procedures for integer_argument_type !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- pure function integer_argument_get_actual_value(this)
- integer(kind=i64)::integer_argument_get_actual_value
- class(integer_argument_type),intent(in)::this
- integer_argument_get_actual_value=this%actual_value
- end function integer_argument_get_actual_value
-
- subroutine integer_argument_read_option(this,index)
- class(integer_argument_type),intent(inout)::this
- integer,intent(inout)::index
- integer::n,length,iostat
- character(:),allocatable::option
- index=index+1
- call get_command_argument(index,length=length)
- allocate(character(length)::option)
- call get_command_argument(index,option)
- read(option,fmt=*,iostat=iostat)this%actual_value
- if(.not.iostat==0)then
- print *,"integer_argument_read_option: could not parse option ",option," of argument ",this%get_a_form()
- if(arguments_stop_at_unrecognized_option)stop
- if(arguments_revert_invalid_to_default)then
- this%actual_value=this%default_value
- else
- this%is_valid=.false.
- end if
- end if
- if((this%actual_value<this%min_value).or.(this%actual_value>this%max_value))then
- print *,"integer_argument_read_option: Option ",option," of argument ",this%get_a_form()," is out of range"
- print *,"Range is: [",this%min_value,":",this%max_value,"]"
- if(arguments_stop_at_invalid_option)stop
- if(arguments_revert_invalid_to_default)then
- this%actual_value=this%default_value
- else
- this%is_valid=.false.
- end if
- end if
- if(allocated(this%value_range))then
- this%is_valid=.false.
- do n=1,size(this%value_range)
- if(this%actual_value==this%value_range(n))then
- this%is_valid=.true.
- exit
- end if
- end do
- if(.not.this%is_valid)then
- print *,"Value ",this%actual_value," for argument ",this%get_a_form()," is invalid."
- print *,"Valid values are:"
- print *,this%value_range
- print *,"Default value is:"
- print *,this%default_value
- if(arguments_revert_invalid_to_default)then
- this%actual_value=this%default_value
- else
- this%is_valid=.false.
- end if
- end if
- end if
- if(this%actual_value==this%default_value)then
- this%is_default=.true.
- else
- this%is_default=.false.
- end if
- this%is_given_comp=.true.
- end subroutine integer_argument_read_option
-
- subroutine integer_argument_write_description(this,unit)
- class(integer_argument_type),intent(in)::this
- integer,intent(in)::unit
- integer::i
- call argument_write_description(this,unit)
- if(allocated(this%value_range))then
- write(unit,("(a,a,a)"),ADVANCE="NO")repeat(" ",indent_len),this%named_option(1:this%named_option_length)," is one of: "
- write(unit,fmt='("{",I0)',ADVANCE="NO")this%value_range(1)
- do i=2,size(this%value_range)
- write(unit,fmt='(",",I0)',ADVANCE="NO")this%value_range(i)
- end do
- write(unit,fmt='("}")')
- else
- write(unit,("(a,a,a)"),ADVANCE="NO")repeat(" ",indent_len),this%named_option(1:this%named_option_length)," is in: "
- write(unit,fmt="(a,I0,a,I0,a)")"[",this%min_value,",",this%max_value,"]"
- end if
- end subroutine integer_argument_write_description
-
- subroutine integer_argument_initialize(this,value,min,max,arg_list,short,long,description,description_list,named_option,range)
- class(integer_argument_type),intent(inout),target::this
- integer(kind=i64),intent(in)::value
- integer(kind=i64),optional,intent(in)::min,max
- class(argument_list_type),optional,intent(inout)::arg_list
- integer(kind=i64),dimension(:),intent(in),optional::range
- character,intent(in),optional::short
- character(*),intent(in),optional::long,description,named_option
- type(string_list_type),intent(inout),optional::description_list
- character(12)::default_char
- call argument_initialize(this,arg_list,short,long,description,description_list,named_option)
- this%default_value=value
- if(present(min))then
- this%min_value=min
- else
- this%min_value=-huge(1)
- end if
- if(present(max))then
- this%max_value=max
- else
- this%max_value=huge(1)
- end if
- if(this%min_value>this%max_value)then
- print *,"integer_argument_initialize: min value is greater then max value. Stop."
- stop
- end if
- if((this%default_value<this%min_value).or.(this%default_value>this%max_value))then
- print *,"integer_argument_initialize: default value is not in range. Stop."
- stop
- end if
- if(allocated(this%value_range))deallocate(this%value_range)
- if(present(range))allocate(this%value_range(size(range)),source=range)
- this%actual_value=this%default_value
- this%is_default=.true.
- this%is_valid=.true.
- write(default_char,fmt='(I0)')this%default_value
- call this%description%append("Default value is "//trim(default_char)//".")
- end subroutine integer_argument_initialize
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Type Bound Procedures for string_argument_type !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- pure function string_argument_get_actual_value(this) result(def)
- class(string_argument_type),intent(in)::this
- character(this%actual_length)::def
- if(allocated(this%actual_value))then
- def=this%actual_value
- else
- def=""
- end if
- end function string_argument_get_actual_value
-
- pure function string_argument_get_default_value(this) result(def)
- class(string_argument_type),intent(in)::this
- character(this%default_length)::def
- if(allocated(this%value_range%value))then
- def=this%value_range%value
- else
- def=""
- end if
- end function string_argument_get_default_value
-
- subroutine string_argument_assign(this,string)
- class(string_argument_type),intent(inout)::this
- character(*),intent(in)::string
- if(allocated(this%actual_value))deallocate(this%actual_value)
- allocate(this%actual_value,source=string)
- this%actual_length=len(string)
- end subroutine string_argument_assign
-
- subroutine string_argument_push(this,string)
- class(string_argument_type),intent(inout)::this
- character(*),intent(in)::string
- call this%value_range%push(string)
- end subroutine string_argument_push
-
- subroutine string_argument_finalize(this)
- class(string_argument_type),intent(inout)::this
- call this%value_range%finalize()
- end subroutine string_argument_finalize
-
- subroutine string_argument_write_description(this,unit)
- class(string_argument_type),intent(in)::this
- integer,intent(in)::unit
-! print *,"hallo"
- call argument_write_description(this,unit)
- if(associated(this%value_range%next))then
- write(unit,("(a,a,a)"),ADVANCE="NO")repeat(" ",indent_len),this%named_option(1:this%named_option_length)," is one of: "
- call this%value_range%write_contents(unit,", ")
- write(unit,fmt=*)""
- end if
- end subroutine string_argument_write_description
-
- subroutine string_argument_read_option(this,index)
- class(string_argument_type),intent(inout)::this
- integer,intent(inout)::index
- integer::n,length,iostat
- character(:),allocatable::option
- index=index+1
- call get_command_argument(index,length=length)
- allocate(character(length)::option)
- call get_command_argument(index,option)
- if(associated(this%value_range%next))then
- call this%value_range%contains(option,this%is_valid)
- else
- this%is_valid=.true.
- end if
- if(this%is_valid)then
- call this%assign(option)
- else
- print *,"Value ",option," for argument ",this%short_form," is invalid."
- print *,"Valid values are:"
- call this%value_range%write_contents(output_unit)
- if(arguments_stop_at_invalid_option)stop
- if(arguments_revert_invalid_to_default)call this%assign(this%get_default_value())
- end if
- if(this%actual_value==this%value_range%value)then
- this%is_default=.true.
- else
- this%is_default=.false.
- end if
- this%is_given_comp=.true.
- end subroutine string_argument_read_option
-
- subroutine string_argument_initialize(this,value,arg_list,short,long,description,description_list,named_option)
- class(string_argument_type),intent(inout),target::this
- character(*),intent(in)::value
- class(argument_list_type),optional,intent(inout)::arg_list
- character,intent(in),optional::short
- character(*),intent(in),optional::long,description,named_option
- type(string_list_type),intent(inout),optional::description_list
- if(present(named_option))then
- call argument_initialize(this,arg_list,short,long,description,description_list,named_option)
- else
- call argument_initialize(this,arg_list,short,long,description,description_list,"<string>")
- end if
- call this%value_range%assign(value)
- this%default_length=len(value)
- call this%assign(value)
- this%is_default=.true.
- this%is_valid=.true.
- call this%description%append("Default value is '"//value//"'.")
- end subroutine string_argument_initialize
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Type Bound Procedures for switch_argument_type !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- subroutine switch_argument_read_option(this,index)
- class(switch_argument_type),intent(inout)::this
- integer,intent(inout)::index
- end subroutine switch_argument_read_option
-
- subroutine switch_argument_negates(this,negative)
- class(switch_argument_type),intent(inout),target::this,negative
- if(this%default_value.eqv.negative%default_value)then
- print *,"switch_argument_negates: Cannot assign negation: Both arguments have got the same default value."
- else
- this%disable_arg=>negative
- negative%disable_arg=>this
- call this%description%append("Negates "//negative%get_a_form())
- call negative%description%append("Negates "//this%get_a_form())
- end if
- end subroutine switch_argument_negates
-
- subroutine switch_argument_initialize(this,value,arg_list,short,long,description,description_list)
- class(switch_argument_type),intent(inout),target::this
- logical,intent(in)::value
- class(argument_list_type),optional,intent(inout)::arg_list
- character,intent(in),optional::short
- character(*),intent(in),optional::long,description
- type(string_list_type),intent(inout),optional::description_list
- call argument_initialize(this,arg_list,short,long,description,description_list)
- this%default_value=value
- this%actual_value=value
- this%is_default=.true.
- this%is_valid=.true.
- if(this%default_value)then
- call this%description%append("Default value is TRUE.")
- else
- call this%description%append("Default value is FALSE.")
- end if
- end subroutine switch_argument_initialize
-
- subroutine switch_argument_compare_short(this,short,index,match)
- class(switch_argument_type),intent(inout)::this
- character,intent(in)::short
- integer,intent(inout)::index
- logical,intent(out)::match
- call argument_compare_short(this,short,index,match)
- if(match)then
- this%actual_value=this%default_value
- this%is_default=.true.
- if(associated(this%disable_arg))then
- this%disable_arg%actual_value=.not.this%default_value
- this%disable_arg%is_default=.false.
- end if
- end if
- end subroutine switch_argument_compare_short
-
- subroutine switch_argument_compare_long(this,long,index,match)
- class(switch_argument_type),intent(inout)::this
- character(*),intent(in)::long
- integer,intent(inout)::index
- logical,intent(out)::match
- call argument_compare_long(this,long,index,match)
- if(match)then
- this%actual_value=this%default_value
- this%is_default=.true.
- if(associated(this%disable_arg))then
- this%disable_arg%actual_value=.not.this%default_value
- this%disable_arg%is_default=.false.
- end if
- end if
- end subroutine switch_argument_compare_long
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Type Bound Procedures for plain_argument_type !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- subroutine plain_argument_read_option(this,index)
- class(plain_argument_type),intent(inout)::this
- integer,intent(inout)::index
- end subroutine plain_argument_read_option
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !!! Non Type Bound Procedures !!!
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- subroutine arguments_setup(un_arg,in_arg,un_opt,in_opt,revert)
- logical,intent(in),optional::un_arg,in_arg,un_opt,in_opt,revert
- if(present(un_arg))arguments_stop_at_unrecognized_argument=un_arg
- if(present(in_arg))arguments_stop_at_invalid_argument=in_arg
- if(present(un_opt))arguments_stop_at_unrecognized_option=un_opt
- if(present(in_opt))arguments_stop_at_invalid_option=in_opt
- if(present(revert))arguments_revert_invalid_to_default=revert
- end subroutine arguments_setup
-
-end module arguments
Index: trunk/src/muli/Makefile.am
===================================================================
--- trunk/src/muli/Makefile.am (revision 8371)
+++ trunk/src/muli/Makefile.am (revision 8372)
@@ -1,195 +1,185 @@
## Makefile.am -- Makefile for WHIZARD - Multiple Interactions
##
## Process this file with automake to produce Makefile.in
#
# Copyright (C) 1999-2019 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# 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 files in this directory end up in an auxiliary libtool library.
noinst_LTLIBRARIES = libmuli.la
libmuli_la_SOURCES = \
- muli_base.f90 \
- muli.f90 \
- muli_cuba.f90 \
- muli_momentum.f90 \
- muli_interactions.f90 \
- muli_trapezium.f90 \
- muli_fibonacci_tree.f90 \
- muli_aq.f90 \
- muli_dsigma.f90 \
- muli_remnant.f90 \
- muli_mcint.f90
+ muli.f90
## Omitting this would exclude it from the distribution
dist_noinst_DATA = muli.nw
# Dump module names into file Modules
libmuli_Modules = ${libmuli_la_SOURCES:.f90=}
Modules: Makefile
@for module in $(libmuli_Modules); do \
echo $$module >> $@.new; \
done
@if diff $@ $@.new -q >/dev/null; then \
rm $@.new; \
else \
mv $@.new $@; echo "Modules updated"; \
fi
BUILT_SOURCES = Modules
## Fortran module dependencies
# Get module lists from other directories
module_lists = \
../basics/Modules \
../system/Modules \
../utilities/Modules
$(module_lists):
$(MAKE) -C `dirname $@` Modules
Module_dependencies.sed: $(libmuli_la_SOURCES)
Module_dependencies.sed: $(module_lists)
@rm -f $@
echo 's/, *only:.*//' >> $@
echo 's/, *&//' >> $@
echo 's/, *.*=>.*//' >> $@
echo 's/$$/.lo/' >> $@
for list in $(module_lists); do \
dir="`dirname $$list`"; \
for mod in `cat $$list`; do \
echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
done \
done
DISTCLEANFILES = Module_dependencies.sed
## Dependencies across directories and packages, if not automatically generated
$(libmuli_la_OBJECTS): \
../pdf_builtin/pdf_builtin.$(FC_MODULE_EXT)
# The following line just says
# include Makefile.depend
# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
@am__include@ @am__quote@Makefile.depend@am__quote@
Makefile.depend: Module_dependencies.sed
Makefile.depend: $(libmuli_la_SOURCES)
@rm -f $@
for src in $^; do \
module="`basename $$src | sed 's/\.f[90][0358]//'`"; \
grep '^ *use ' $$src \
| grep -v '!NODEP!' \
| sed -e 's/^ *use */'$$module'.lo: /' \
-f Module_dependencies.sed; \
done > $@
DISTCLEANFILES += Makefile.depend
# Fortran90 module files are generated at the same time as object files
.lo.$(FC_MODULE_EXT):
@:
# touch $@
AM_FCFLAGS = -I../basics -I../system -I../../vamp/src/ -I../pdf_builtin -I../utilities
AM_FFLAGS =
########################################################################
## Default Fortran compiler options
## Profiling
if FC_USE_PROFILING
AM_FFLAGS += $(FCFLAGS_PROFILING)
AM_FCFLAGS += $(FCFLAGS_PROFILING)
endif
## OpenMP
if FC_USE_OPENMP
AM_FFLAGS += $(FCFLAGS_OPENMP)
AM_FCFLAGS += $(FCFLAGS_OPENMP)
endif
# MPI
if FC_USE_MPI
AM_FFLAGS += $(FCFLAGS_MPI)
AM_FCFLAGS += $(FCFLAGS_MPI)
endif
########################################################################
## (Re)create F90 sources from NOWEB source.
if NOWEB_AVAILABLE
PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw
muli.stamp: $(PRELUDE) $(srcdir)/muli.nw $(POSTLUDE)
@rm -f muli.tmp
@touch muli.tmp
for src in $(MULI_SRC); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \
done
@mv -f muli.tmp muli.stamp
MULI_SRC = $(libmuli_la_SOURCES)
$(MULI_SRC): muli.stamp
## Recover from the removal of $@
@if test -f $@; then :; else \
rm -f muli.stamp; \
$(MAKE) $(AM_MAKEFLAGS) muli.stamp; \
fi
endif
########################################################################
## Remove backup files
## Remove sources that can be recreated using NOWEB
if NOWEB_AVAILABLE
maintainer-clean-noweb:
-rm -f *.f90 *.f
endif
.PHONY: maintainer-clean-noweb
## Remove those sources also if builddir and srcdir are different
if NOWEB_AVAILABLE
clean-noweb:
test "$(srcdir)" != "." && rm -f *.f90 *.f || true
endif
.PHONY: clean-noweb
## Remove F90 module files
clean-local: clean-noweb
-rm -f muli.stamp muli.tmp
-rm -f *.$(FC_MODULE_EXT)
if FC_SUBMODULES
-rm -f *.smod
endif
## Remove backup files
maintainer-clean-backup:
-rm -f *~
.PHONY: maintainer-clean-backup
## Register additional clean targets
maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
Index: trunk/src/muli/muli.nw
===================================================================
--- trunk/src/muli/muli.nw (revision 8371)
+++ trunk/src/muli/muli.nw (revision 8372)
@@ -1,17596 +1,192 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD multiple interactions code as NOWEB source
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Multiple Interactions (MPI) Code}
\includemodulegraph{muli}
-This is the code for the \whizard\ module for multiple interactions (MPI)
-in hadron collisions. It also provides the interleaved shower with together
-with the shower module.
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Basic types}
-
-This file contains the module [[muli_basic]] which is included by all
-other modules of the MPI code. It's main purpose is serialization and
-deserialization, but it also contains some bitmodel parameters and
-some minor definitions common to all modules and types.
-
-Serialization is implemented in three layers:
-
-\begin{enumerate}
-\item {\bf I/O layer}: streamfile access and exact, retreivable and
- compiler independent representation of all intrinsic types
-\item {\bf Marking layer}: storing/restoring pointer association and
- better human readability
-\item {\bf Derived type layer}: abstract type as parent for all
- serializable derived types
-\end{enumerate}
-
-\paragraph{The I/O Layer}
-
-The I/O layer is implemented by [[page_ring_t]] and its type bound
-procedures. We chose not to use the standard formatted sequential I/O for
-several reasons:
-\begin{itemize}
-\item Sequential I/O is line orientated, but serialization is not.
-\item Formatted I/O of floating point numbers is inexact. There were problems
- in reading numbers like [[1+epsilon(1)]] or [[huge(1)]]
- including arithmetic exeptions and wrong results.
-\item Formatted reading is slow. This does matter, when you read files
- of $\mathcal{O}(100)$ MB.
-\end{itemize}
-
-[[page_ring_t]] is a ring buffer of default kind characters holding
-a region of the addressed file. All read and write procedures use the
-ring buffer, not the file. [[page_ring]] automatically reads more
-characters from the file when needed and writes and discards parts of
-the ring buffer when not any longer needed.
-
-\paragraph{Marking layer}
-
-Marking is done by [[marking_t]] and its type bound procedures. Files
-written by [[marking_t]] are regular XML files, so you can use your
-favorite XML editor to examine or edit serialized contents. The main
-purpose of this layer is to recover the type of polymorphic entities
-and to restore association of pointers, but it also assigns names to
-all contents, so it is much easier to read generated files.
-
-Type recovery is done by a reference list. You must push a representive
-object to this reference list for each type that might get resolved before
-starting deserialization. [[marker_t]] will care for comparing these
-representives to the contents of the files.
-
-Association restoration is done by a heap list. It is technically equal
-to the reference list, but holds all targets that have been processed so
-far. Generation of this list is handled by [[marking_t]], so you
-dont't have to care for this aspect at all. Up to the present it is
-not possible to restore association, when a non-pointer target is
-serialized after its associated pointer is serialized.
-There is no trivial solution and this case does not appear here,
-so we will not take care of this.
-
-\paragraph{Derived type layer}
-
-Each instance that shall become serialized must extend
-[[ser_class_t]]. Essential for type recovery is the virtual
-type bound procedure [[get_type]]. Each non-virtual type shall override
-[[get_type]] and return the actual name of its type in lower-case letters.
-Each type which adds new, non-redundant components shall override
-[[write_to_marker]] and [[read_from_marker]]. These type-bound
-procedures define, what contents get serialized. While the marker
-cares about tagging the type and association of the instance, every
-instance still has to define what to serialize. The rule is to mark
-the begin of its contents, then its parents procedure, then mark all
-non-redundant components, then mark the end of its contents.
-Finally, each serializable type shall override [[print_to_unit]]. This
-procedure is called for an arbitrary human-readable output. It is
-quite similar to [[write_to_ring]], but without strict format and
-ignoring machine-readability.
-
-[[ser_class_t]] has strictly speaking two layers. [[write_to_marker]] and
-[[read_from_marker]] are only for internal usage. Serialization and
-deserialization are triggered by the TBPs serialize and deserialize. These
-procedures take care of initialization and finalization of the marker. A
-serializable type should override these procedures to push a representive
-of itself and any other references to the reference list of it's marker
-before (de)serialization and to pop them from the list afterwards.
-
-<<[[muli_base.f90]]>>=
-<<File header>>
-
-module muli_base
- use, intrinsic :: iso_fortran_env
-<<Use kinds with double>>
- use kinds, only: i64
-<<Use strings>>
- use constants
- use io_units
- use diagnostics
-
-<<Standard module head>>
-
-<<Muli base: variables>>
-
-<<Muli base: public>>
-
-<<Muli base: types>>
-
-<<Muli base: interfaces>>
-
-contains
-
-<<Muli base: procedures>>
-
-end module muli_base
-
-@ %def muli_base
-These are the bitmodel parameters.
-<<Muli base: variables>>=
- integer, public, parameter :: dik = i64
- integer(dik), public, parameter :: i_one = int(1, kind=dik)
- integer(dik), public, parameter :: i_zero = int(0, kind=dik)
-@ %def dik one i_zero
-These are the serialization parameters.
-<<Muli base: variables>>=
- integer(dik), public, parameter :: serialize_page_size = 1024
- integer(dik), public, parameter :: serialize_ok = 0000
- integer(dik), public, parameter :: serialize_syntax_error = 1001
- integer(dik), public, parameter :: serialize_wrong_tag = 1002
- integer(dik), public, parameter :: serialize_wrong_id = 1003
- integer(dik), public, parameter :: serialize_wrong_type = 1004
- integer(dik), public, parameter :: serialize_wrong_name = 1005
- integer(dik), public, parameter :: serialize_no_target = 1006
- integer(dik), public, parameter :: serialize_no_pointer = 1007
- integer(dik), public, parameter :: serialize_wrong_action = 1008
- integer(dik), public, parameter :: serialize_unexpected_content = 1009
- integer(dik), public, parameter :: serialize_null = 1010
- integer(dik), public, parameter :: serialize_nothing = 1011
- logical, public, parameter :: serialize_default_indent = .true.
- logical, public, parameter :: serialize_default_line_break = .true.
- logical, public, parameter :: serialize_default_asynchronous = .false.
-@ %def serializable_page_size serializable_ok
-@ %def serializable_syntax_error serializable_wrong_tag
-@ %def serializable_wrong_id serializable_wrong_type
-@ %def serializable_wrong_name serializable_no_target
-@ %def serializable_no_pointer serializable_wrong_action
-@ %def serializable_unexpected_content serializable_null
-@ %def serializable_nothing serializable_default_indent
-@ %def serializable_default_line_break serializable_default_asynchronous
-@
-And some private variables:
-<<Muli base: variables>>=
- integer(dik) :: last_id = 0
- character(len=*), parameter :: serialize_integer_characters = &
- "-0123456789"
-
-@ %def last_id serialize_integer_characters
-<<Muli base: interfaces>>=
- abstract interface
- subroutine ser_write_if (this, marker, status)
- import ser_class_t
- import marker_t
- import dik
- class(ser_class_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- end subroutine ser_write_if
- end interface
-
- abstract interface
- subroutine ser_read_if (this, marker, status)
- import ser_class_t
- import marker_t
- import dik
- class(ser_class_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- end subroutine ser_read_if
- end interface
-
- abstract interface
- subroutine ser_unit (this, unit, parents, components, peers)
- import ser_class_t
- import dik
- class(ser_class_t), intent(in) :: this
- integer,intent(in) :: unit
- integer(dik), intent(in) :: parents,components,peers
- end subroutine ser_unit
- end interface
-
- abstract interface
- pure subroutine ser_type (type)
- character(:), allocatable, intent(out) :: type
- end subroutine ser_type
- end interface
-
-@ %def ser_write_if ser_read_if ser_unit ser_type
-@
-<<Muli base: interfaces>>=
- abstract interface
- elemental function measure_int (this)
- import
- class(measure_class_t), intent(in) :: this
- real(default) :: measure_int
- end function measure_int
- end interface
-
-@ %def measure_int
-@
-<<Muli base: public>>=
- public :: operator(<)
-<<Muli base: interfaces>>=
- interface operator(<)
- module procedure measurable_less_measurable
- module procedure measurable_less_default
- end interface operator(<)
-<<Muli base: public>>=
- public :: operator(<=)
-<<Muli base: interfaces>>=
- interface operator(<=)
- module procedure measurable_less_or_equal_measurable
- module procedure measurable_less_or_equal_default
- end interface operator(<=)
-<<Muli base: public>>=
- public :: operator(==)
-<<Muli base: interfaces>>=
- interface operator(==)
- module procedure measurable_equal_measurable
- module procedure measurable_equal_default
- end interface operator(==)
-<<Muli base: public>>=
- public :: operator(>=)
-<<Muli base: interfaces>>=
- interface operator(>=)
- module procedure measurable_equal_or_greater_measurable
- module procedure measurable_equal_or_greater_default
- end interface operator(>=)
-<<Muli base: public>>=
- public :: operator(>)
-<<Muli base: interfaces>>=
- interface operator(>)
- module procedure measurable_greater_measurable
- module procedure measurable_greater_default
- end interface operator(>)
-
-@ %def < <= == >= >
-@
-<<Muli base: interfaces>>=
- interface page_ring_position_is_before
- module procedure page_ring_position_is_before_int_pos
- module procedure page_ring_position_is_before_pos_pos
- module procedure page_ring_position_is_before_pos_int
- end interface
-
-@
-<<Muli base: public>>=
- public :: ser_class_t
-<<Muli base: types>>=
- type, abstract :: ser_class_t
- contains
- <<Muli base: serial class: TBP>>
- end type ser_class_t
-
-@ %def ser_class_t
-<<Muli base: serial class: TBP>>=
- procedure(ser_write_if), deferred :: write_to_marker
-@
-This is a dummy procedure. Usually, you do not need to deserialize
-targets, so by implementing this dummy we don't force all descendants
-to override this procedure. Then again this is the only way to read
-targets from markers.
-<<Muli base: serial class: TBP>>=
- procedure(ser_read_if), deferred :: read_from_marker
-<<Muli base: procedures>>=
- subroutine serializable_read_target_from_marker (this, marker, status)
- class(ser_class_t), target, intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- write (output_unit, "(A)") "serializable_read_target_from_marker:"
- write (output_unit, "(A)") "This is a dummy procedure. Usually, this " &
- // "message indicates a missing overridden " &
- // "read_target_from_marker TPB for "
- call this%write_type (output_unit)
- write (output_unit, "(A)") ""
- call this%read_from_marker (marker, status)
- end subroutine serializable_read_target_from_marker
-
-@ %def serializable_read_target_from_marker
-@
-<<Muli base: serial class: TBP>>=
- procedure(ser_unit), deferred :: print_to_unit
-<<Muli base: procedures>>=
- subroutine serializable_serialize_to_unit (this, unit, name)
- class(ser_class_t), intent(in) :: this
- integer, intent(in) :: unit
- character (len=*), intent(in) :: name
- logical :: opened
- character(32) :: file
- !!! gfortran bug
- !!! character::stream
- character::write
- type(marker_t)::marker
- ! inquire(unit=unit,opened=opened,stream=stream,write=write)
- inquire (unit=unit,opened=opened,write=write)
- if (opened) then
- !!! if(stream=="Y")then
- if(write=="Y")then
- print *,"dummy: serializable_serialize_to_unit"
- stop
- else
- print *,"serializable_serialize_to_unit: cannot write to read-only unit."
- end if
- !!! else
- !!! print *,"serializable_serialize_to_unit: access kind of unit is not 'stream'."
- !!! end if
- else
- call msg_error ("serializable_serialize_to_unit: file is not opened.")
- end if
- end subroutine serializable_serialize_to_unit
-
-@ %def serializable_serialize_to_unit
-@
-<<Muli base: serial class: TBP>>=
- procedure(ser_type), nopass, deferred :: get_type
-@
-<<Muli base: serial class: TBP>>=
- procedure, nopass :: verify_type => serializable_verify_type
-<<Muli base: procedures>>=
- elemental function serializable_verify_type (type) result (match)
- character(*), intent(in) :: type
- logical :: match
- match = type == "ser_class_t"
- end function serializable_verify_type
-
-@ %def serializable_verify_type
-@
-<<Muli base: serial class: TBP>>=
- procedure :: read_target_from_marker => &
- serializable_read_target_from_marker
-@
-<<Muli base: serial class: TBP>>=
- procedure :: write_type => serializable_write_type
-<<Muli base: procedures>>=
- subroutine serializable_write_type (this, unit)
- class(ser_class_t), intent(in) :: this
- integer,intent(in) :: unit
- character(:), allocatable :: this_type
- call this%get_type (this_type)
- write (unit, "(A)", advance="no") this_type
- end subroutine serializable_write_type
-
-@ %def serializable_write_type
-@
-<<Muli base: serial class: TBP>>=
- procedure :: print => serializable_print
-<<Muli base: procedures>>=
- recursive subroutine serializable_print &
- (this, parents, components, peers, unit)
- class(ser_class_t), intent(in) :: this
- integer(dik), intent(in) :: parents, components, peers
- integer, intent(in), optional :: unit
- integer :: u
- u = given_output_unit (unit)
- write (u, "(A)")
- write (u, "(A)", advance="no") "Instance of type: "
- call this%write_type (u)
- write (u, "(A)")
- call this%print_to_unit (u, parents, components, peers)
- end subroutine serializable_print
-
-@ %def serializable_print
-@
-<<Muli base: serial class: TBP>>=
- procedure :: print_error => serializable_print_error
-<<Muli base: procedures>>=
- recursive subroutine serializable_print_error (this)
- class(ser_class_t), intent(in) :: this
- call this%print_to_unit (error_unit, i_zero, i_zero, i_zero)
- end subroutine serializable_print_error
-
-@ %def serializable_print_error
-@
-<<Muli base: serial class: TBP>>=
- procedure :: print_all => serializable_print_all
-<<Muli base: procedures>>=
- recursive subroutine serializable_print_all (this, unit)
- class(ser_class_t), intent(in) :: this
- integer, intent(in), optional :: unit
- integer :: u
- u = given_output_unit (unit)
- write (u, "(A)")
- write (u, "(A)", advance="no") "Instance of type: "
- call this%write_type (u)
- write (u, "(A)")
- call this%print_to_unit (u, huge(i_one), huge(i_one), huge(i_one))
- end subroutine serializable_print_all
-
-@ %def serializable_print_all
-@
-<<Muli base: serial class: TBP>>=
- procedure :: print_little => serializable_print_little
-<<Muli base: procedures>>=
- recursive subroutine serializable_print_little (this, unit)
- class(ser_class_t), intent(in) :: this
- integer, intent(in), optional :: unit
- integer :: u
- u = given_output_unit (u)
- write(u, "(A)")
- write(u, "(A)", advance="no") "Instance of type: "
- call this%write_type (u)
- write(u, "(A)")
- call this%print_to_unit (u, i_zero, i_zero, i_zero)
- end subroutine serializable_print_little
-
-@ %def serializable_print_little
-@
-<<Muli base: serial class: TBP>>=
- procedure :: print_parents => serializable_print_parents
-<<Muli base: procedures>>=
- recursive subroutine serializable_print_parents (this)
- class(ser_class_t), intent(in) :: this
- write(output_unit, "(A)")
- write(output_unit, "(A)", advance="no") "Instance of type: "
- call this%write_type (output_unit)
- write (output_unit, "(A)")
- call this%print_to_unit (output_unit, huge(i_one), i_zero, i_zero)
- end subroutine serializable_print_parents
-
-@ %def serializable_print_parents
-@
-<<Muli base: serial class: TBP>>=
- procedure :: print_components => serializable_print_components
-<<Muli base: procedures>>=
- recursive subroutine serializable_print_components(this)
- class(ser_class_t), intent(in) :: this
- write (output_unit, "(A)")
- write (output_unit, "(A)", advance="no") "Instance of type: "
- call this%write_type (output_unit)
- write(output_unit, "(A)")
- call this%print_to_unit (output_unit, i_zero, huge(i_one), i_zero)
- end subroutine serializable_print_components
-
-@ %def serializable_print_components
-@
-<<Muli base: serial class: TBP>>=
- procedure :: print_peers => serializable_print_peers
-<<Muli base: procedures>>=
- recursive subroutine serializable_print_peers (this)
- class(ser_class_t), intent(in) :: this
- write (output_unit, "(A)")
- write (output_unit, "(A)", advance="no") "Instance of type: "
- call this%write_type (output_unit)
- write (output_unit, "(A)")
- call this%print_to_unit (output_unit, i_zero, i_zero, huge(i_one))
- end subroutine serializable_print_peers
-
-@ %def serializable_print_peers
-@
-<<Muli base: serial class: TBP>>=
- procedure :: serialize_to_file => serializable_serialize_to_file
-<<Muli base: procedures>>=
- subroutine serializable_serialize_to_file (this, name, file)
- class(ser_class_t), intent(in) :: this
- character(len=*), intent(in) :: file, name
- type(marker_t) :: marker
- call marker%open_for_write_access (file)
- write (output_unit, "(A,A)") &
- "Serializable_serialize_to_file: writing xml preamble to ", file
- call marker%activate_next_page ()
- call marker%push ('<?xml version="1.0"?>')
- call marker%mark_begin (tag="file", name = file)
- flush(marker%unit)
- call this%serialize_to_marker (marker, name)
- call marker%mark_end ("file")
- call marker%close ()
- call marker%finalize ()
- end subroutine serializable_serialize_to_file
-
-@ %def serializable_serialize_to_file
-@
-<<Muli base: serial class: TBP>>=
- procedure :: serialize_to_unit => serializable_serialize_to_unit
-@
-<<Muli base: serial class: TBP>>=
- procedure :: serialize_to_marker => serializable_serialize_to_marker
-<<Muli base: procedures>>=
- recursive subroutine serializable_serialize_to_marker (this, marker, name)
- class(ser_class_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- character(len=*), intent(in) :: name
- if (marker%action == 1) then
- call marker%mark_instance (this, name)
- else
- call msg_error ("serializable_serialize_to_marker: Marker is " &
- // "not ready for write access.")
- end if
- end subroutine serializable_serialize_to_marker
-
-@ %def serializable_serialize_to_marker
-@
-<<Muli base: serial class: TBP>>=
- procedure :: deserialize_from_file => serializable_deserialize_from_file
-<<Muli base: procedures>>=
- subroutine serializable_deserialize_from_file (this, name, file)
- class(ser_class_t), intent(out) :: this
- character(*), intent(in) :: name, file
- type(marker_t) :: marker
- integer(dik), dimension(2) :: p1, p2
- call marker%open_for_read_access (file, "</file>")
- marker%eof_int = huge(i_one)
- marker%eof_pos = page_ring_position (marker%eof_int)
- call marker%read_page ()
- call marker%find ('<?', skip=2, proceed=.true., pos=p1)
- call marker%find ('?>', skip=3, proceed=.false., pos=p2)
- if ((p1(2) <= 0) .or. (p2(2) <= 0)) then
- call msg_error ("serializable_deserialize_from_file: no " &
- // "version substring found.")
- end if
- call marker%set_position (p2)
- call marker%find ('<file ', skip=4, proceed=.true., pos=p1)
- call marker%find ('>', skip=1, proceed=.false., pos=p2)
- if((p1(2)>0) .and. (p2(2)>0))then
- call marker%push_position (p2)
- call marker%find ('name="', skip=4, proceed=.true., pos=p1)
- call marker%find ('"', skip=1, proceed=.false., pos=p2)
- call marker%pop_position ()
- else
- call msg_error ("serializable_deserialize_from_file: no file " &
- // "header found.")
- end if
- call this%deserialize_from_marker (name, marker)
- call marker%close ()
- call marker%finalize ()
- end subroutine serializable_deserialize_from_file
-
-@ %def serializable_deserialize_from_file
-@
-<<Muli base: serial class: TBP>>=
- procedure :: deserialize_from_unit => &
- serializable_deserialize_from_unit
-<<Muli base: procedures>>=
- subroutine serializable_deserialize_from_unit (this, unit, name)
- class(ser_class_t), intent(inout) :: this
- integer, intent(in) :: unit
- character(len=*), intent(in) :: name
- logical::opened
- !!! gfortran bug
- !!! character::stream
- character::read
- type(marker_t)::marker
- !!! inquire(unit=unit,opened=opened,stream=stream,read=read)
- inquire(unit=unit,opened=opened,read=read)
- if(opened)then
- !!! if(stream=="Y")then
- if(read=="Y")then
- print *,"dummy: serializable_serialize_from_unit"
- stop
- else
- print *,"serializable_serialize_from_unit: cannot write from read-only unit."
- end if
- !!! else
- !!! print *,"serializable_serialize_from_unit: access kind of unit is not 'stream'."
- !!! end if
- else
- print *,"serializable_serialize_from_unit: file is not opened."
- end if
- end subroutine serializable_deserialize_from_unit
-
-@ %def serializable_deserialize_from_unit
-@ This needs to be made public, and not only be present as a TBP.
-<<Muli base: public>>=
- public :: serializable_deserialize_from_marker
-<<Muli base: serial class: TBP>>=
- procedure :: deserialize_from_marker => &
- serializable_deserialize_from_marker
-<<Muli base: procedures>>=
- subroutine serializable_deserialize_from_marker (this, name, marker)
- class(ser_class_t), intent(out) :: this
- character(*), intent(in) :: name
- class(marker_t), intent(inout) :: marker
- integer(dik) :: status
- if (marker%action == 2) then
- call marker%pick_instance (name, this, status)
- else
- call msg_error ("serializable_deserialize_from_marker: Marker is " &
- // "not ready for read access.")
- end if
- end subroutine serializable_deserialize_from_marker
-
-@ %def serializable_deserialize_from_marker
-@
-<<Muli base: serial class: TBP>>=
- generic :: serialize => serialize_to_file, serialize_to_unit, &
- serialize_to_marker
-@
-<<Muli base: serial class: TBP>>=
- generic :: deserialize => deserialize_from_file, &
- deserialize_from_unit, deserialize_from_marker
-@
-<<Muli base: public>>=
- public :: serialize_print_peer_pointer
-<<Muli base: procedures>>=
- recursive subroutine serialize_print_peer_pointer &
- (ser, unit, parents, components, peers, name)
- class(ser_class_t), pointer, intent(in) :: ser
- integer, intent(in) :: unit
- integer(dik) :: parents, components, peers
- character(len=*), intent(in) :: name
- if (associated (ser)) then
- write (unit,*) name, " is associated."
- if (peers>0) then
- write (unit,*) "Printing components of ", name
- call ser%print_to_unit (unit, parents, components, peers - i_one)
- else
- write (unit,*) "Skipping components of ", name
- end if
- else
- write (unit,*) name, " is not associated."
- end if
- end subroutine serialize_print_peer_pointer
-
-@ %def serialize_print_peer_pointer
-@
-<<Muli base: public>>=
- public :: serialize_print_comp_pointer
-<<Muli base: procedures>>=
- recursive subroutine serialize_print_comp_pointer &
- (ser, unit, parents, components, peers, name)
- class(ser_class_t), pointer, intent(in) :: ser
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- character(len=*), intent(in) :: name
- if (associated (ser)) then
- write (unit,*) name," is associated."
- if (components > 0) then
- write (unit,*) "Printing components of ", name
- call ser%print_to_unit (unit, parents, components - i_one, peers)
- else
- write (unit,*) "Skipping components of ", name
- end if
- else
- write (unit,*) name," is not associated."
- end if
- end subroutine serialize_print_comp_pointer
-
-@ %def serialize_print_comp_pointer
-@
-<<Muli base: public>>=
- public :: serialize_print_allocatable
-<<Muli base: procedures>>=
- subroutine serialize_print_allocatable &
- (ser, unit, parents, components, peers, name)
- class(ser_class_t), allocatable, intent(in) :: ser
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- character(len=*), intent(in) :: name
- if (allocated (ser)) then
- write (unit,*) name, " is allocated."
- if (components > 0) then
- write (unit,*) "Printing components of ",name
- call ser%print_to_unit (unit, parents, components-1, peers)
- else
- write (unit,*) "Skipping components of ",name
- end if
- else
- write (unit,*) name," is not allocated."
- end if
- end subroutine serialize_print_allocatable
-
-@ %def serialize_print_allocatable
-@
-<<Muli base: public>>=
- public :: measure_class_t
-<<Muli base: types>>=
- type, abstract, extends (ser_class_t) :: measure_class_t
- contains
- procedure(measure_int), public, deferred :: measure
- end type measure_class_t
-
-@ %def measure_class_t
-@
-<<Muli base: public>>=
- public :: identified_t
-<<Muli base: types>>=
- type, extends (ser_class_t) :: identified_t
- private
- integer(dik) :: id
- type(string_t) :: name
- contains
- <<Muli base: identified type: TBP>>
- end type identified_t
-
-@ %def identified_t
-@
-<<Muli base: identified type: TBP>>=
- procedure :: base_write_to_marker => identified_write_to_marker
- procedure :: write_to_marker => identified_write_to_marker
-<<Muli base: procedures>>=
- subroutine identified_write_to_marker (this, marker, status)
- class(identified_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- integer(dik) :: id
- id = this%get_id ()
- call marker%mark_begin ("identified_t")
- call marker%mark ("name", this%get_name ())
- call marker%mark ("id", id)
- call marker%mark_end ("identified_t")
- end subroutine identified_write_to_marker
-
-@ %def identified_write_to_marker
-@
-<<Muli base: identified type: TBP>>=
- procedure :: base_read_from_marker => identified_read_from_marker
- procedure :: read_from_marker => identified_read_from_marker
-<<Muli base: procedures>>=
- subroutine identified_read_from_marker (this, marker, status)
- class(identified_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- character(:), allocatable :: name
- call marker%pick_begin ("identified_t", status=status)
- call marker%pick ("name", name, status)
- call marker%pick ("id", this%id, status)
- call marker%pick_end ("identified_t", status=status)
- this%name = name
- end subroutine identified_read_from_marker
-
-@ %def identified_read_from_marker
-@
-<<Muli base: identified type: TBP>>=
- procedure :: base_print_to_unit => identified_print_to_unit
- procedure :: print_to_unit => identified_print_to_unit
-<<Muli base: procedures>>=
- subroutine identified_print_to_unit (this, unit, parents, components, peers)
- class(identified_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- write (unit, "(A)") "Components of identified_t:"
- write (unit, "(A,A)") "Name: ", this%get_name ()
- write (unit, "(A,I10)") "ID: ", this%get_id ()
- end subroutine identified_print_to_unit
-
-@ %def identified_print_to_unit
-@
-<<Muli base: identified type: TBP>>=
- procedure, nopass :: get_type => identified_get_type
-<<Muli base: procedures>>=
- pure subroutine identified_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="identified_t")
- end subroutine identified_get_type
-
-@ %def identified_get_type
-@
-<<Muli base: identified type: TBP>>=
- procedure, nopass :: verify_type => identified_verify_type
-<<Muli base: procedures>>=
- elemental logical function identified_verify_type (type)
- character(len=*), intent(in) ::type
- identified_verify_type = (type == "identified_t")
- end function identified_verify_type
-
-@ %def identified_verify_type
-@
-<<Muli base: identified type: TBP>>=
- generic :: initialize => identified_initialize
- procedure, private :: identified_initialize
-<<Muli base: procedures>>=
- subroutine identified_initialize (this, id, name)
- class(identified_t), intent(out) :: this
- integer(dik), intent(in) :: id
- character(len=*), intent(in) :: name
- this%name = name
- this%id = id
- end subroutine identified_initialize
-
-@ %def identified_initialize
-@
-<<Muli base: identified type: TBP>>=
- procedure :: get_id => identified_get_id
-<<Muli base: procedures>>=
- elemental function identified_get_id (this) result(id)
- class(identified_t), intent(in) :: this
- integer(dik) :: id
- id = this%id
- end function identified_get_id
-
-@ %def identified_get_id
-@
-<<Muli base: identified type: TBP>>=
- procedure :: get_name => identified_get_name
-<<Muli base: procedures>>=
- pure function identified_get_name (this)
- class(identified_t), intent(in) :: this
- character(len (this%name)) :: identified_get_name
- identified_get_name = char (this%name)
- end function identified_get_name
-
-@ %def identified_get_name
-@
-<<Muli base: public>>=
- public :: unique_t
-<<Muli base: types>>=
- type, extends (identified_t) :: unique_t
- private
- integer(dik) :: unique_id
- contains
- <<Muli base: unique type: TBP>>
- end type unique_t
-
-@ %def unique_t
-@
-<<Muli base: unique type: TBP>>=
- procedure, nopass :: get_type => unique_get_type
-<<Muli base: procedures>>=
- pure subroutine unique_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="unique_t")
- end subroutine unique_get_type
-
-@ %def unique_get_type
-@
-<<Muli base: unique type: TBP>>=
- procedure, nopass :: verify_type => unique_verify_type
-<<Muli base: procedures>>=
- elemental logical function unique_verify_type (type)
- character(len=*), intent(in) :: type
- unique_verify_type = (type == "unique_t")
- end function unique_verify_type
-
-@ %def unique_verify_type
-@
-<<Muli base: unique type: TBP>>=
- procedure :: write_to_marker => unique_write_to_marker
-<<Muli base: procedures>>=
- subroutine unique_write_to_marker (this, marker, status)
- class(unique_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("unique_t")
- call identified_write_to_marker (this, marker, status)
- call marker%mark ("unique_id", this%get_unique_id ())
- call marker%mark_end ("unique_t")
- end subroutine unique_write_to_marker
-
-@ %def unique_write_to_marker
-@
-<<Muli base: unique marker: TBP>>=
- procedure :: read_from_marker => unique_read_from_marker
-<<Muli base: procedures>>=
- subroutine unique_read_from_marker (this, marker, status)
- class(unique_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%pick_begin ("unique_t", status=status)
- call identified_read_from_marker (this, marker, status)
- call marker%pick ("unique_id", this%unique_id, status)
- call marker%pick_end ("unique_t", status)
- end subroutine unique_read_from_marker
-
-@ %def unique_read_from_marker
-@
-<<Muli base: unique type: TBP>>=
- procedure :: print_to_unit => unique_print_to_unit
-<<Muli base: procedures>>=
- subroutine unique_print_to_unit (this, unit, parents, components, peers)
- class(unique_t), intent(in) :: this
- integer,intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- if (parents > 0) call identified_print_to_unit &
- (this, unit, parents-1, components, peers)
- write (unit, "(A,I10)") "Unique ID: ", this%get_unique_id ()
- end subroutine unique_print_to_unit
-
-@ %def unique_print_to_unit
-@
-<<Muli base: unique type: TBP>>=
- procedure :: identified_initialize => unique_initialize
-<<Muli base: procedures>>=
- subroutine unique_initialize(this,id,name)
- class(unique_t), intent(out) :: this
- integer(dik), intent(in) :: id
- character(len=*), intent(in) :: name
- call identified_initialize (this, id, name)
- last_id = last_id + 1
- this%unique_id = last_id
- end subroutine unique_initialize
-
-@ %def unique_initialize
-@
-<<Muli base: unique type: TBP>>=
- procedure :: get_unique_id => unique_get_unique_id
-<<Muli base: procedures>>=
- pure function unique_get_unique_id (this)
- class(unique_t), intent(in) :: this
- integer(dik) :: unique_get_unique_id
- unique_get_unique_id = this%unique_id
- end function unique_get_unique_id
-
-@ %def unique_get_unique_id
-@
-<<Muli base: types>>=
- type :: serializable_ref_type
- private
- integer(dik) :: id
- class(ser_class_t), pointer :: ref => null()
- class(serializable_ref_type), pointer :: next => null()
- contains
- <<Muli base: serial ref: TBP>>
- end type serializable_ref_type
-
-@ %def serializable_ref_type
-@
-<<Muli base: serial ref: TBP>>=
- procedure :: finalize => serializable_ref_finalize
-<<Muli base: procedures>>=
- subroutine serializable_ref_finalize (this)
- class(serializable_ref_type), intent(inout) :: this
- class(serializable_ref_type), pointer :: next
- do while (associated (this%next))
- next => this%next
- this%next => next%next
- nullify (next%ref)
- deallocate (next)
- end do
- if (associated (this%ref)) nullify (this%ref)
- end subroutine serializable_ref_finalize
-
-@ %def serializable_ref_finalize
-@
-<<Muli base: types>>=
- type :: position_stack_t
- private
- integer(dik), dimension(2) :: position
- class(position_stack_t), pointer :: next => null()
- contains
- <<Muli base: position stack: TBP>>
- end type position_stack_t
-
-@ %def position_stack_t
-@
-<<Muli base: position stack: TBP>>=
- generic :: push => push_head, push_given
- procedure :: push_head => position_stack_push_head
- procedure :: push_given => position_stack_push_given
-<<Muli base: procedures>>=
- subroutine position_stack_push_head (this)
- class(position_stack_t) :: this
- class(position_stack_t), pointer :: new
- allocate (new)
- new%next => this%next
- new%position = this%position
- this%next => new
- end subroutine position_stack_push_head
-
-@ %def position_stack_push_head
-@
-<<Muli base: procedures>>=
- subroutine position_stack_push_given (this, position)
- class(position_stack_t) :: this
- integer(dik), dimension(2), intent(in) :: position
- class(position_stack_t), pointer:: new
- allocate (new)
- new%next => this%next
- new%position = position
- this%next => new
- end subroutine position_stack_push_given
-
-@ %def position_stack_push_given
-@
-<<Muli base: position stack: TBP>>=
- generic :: pop => position_stack_pop, position_stack_drop
- procedure :: position_stack_pop
- procedure :: position_stack_drop
-<<Muli base: procedures>>=
- subroutine position_stack_pop (this)
- class(position_stack_t) :: this
- class(position_stack_t), pointer :: old
- if (associated (this%next)) then
- old => this%next
- this%next => old%next
- this%position = old%position
- deallocate (old)
- end if
- end subroutine position_stack_pop
-
-@ %def position_stack_pop
-@
-<<Muli base: procedures>>=
- subroutine position_stack_drop (this, position)
- class(position_stack_t) :: this
- integer(dik), dimension(2), intent(out) :: position
- class(position_stack_t), pointer :: old
- if (associated (this%next)) then
- old => this%next
- this%next => old%next
- position = old%position
- deallocate (old)
- else
- position= [0,0]
- end if
- end subroutine position_stack_drop
-
-@ %def position_stack_drop
-@
-<<Muli base: position stack: TBP>>=
- procedure :: nth_position => position_stack_nth_position
-<<Muli base: procedures>>=
- function position_stack_nth_position (this, n) result (position)
- class(position_stack_t), intent(in) :: this
- integer(dik), intent(in) :: n
- integer(dik), dimension(2) :: position
- class(position_stack_t), pointer :: tmp
- integer(dik) :: pos
- tmp => this%next
- pos = n
- do while (associated (tmp) .and. pos>0)
- tmp => tmp%next
- pos = pos - 1
- end do
- if (associated(tmp)) then
- position = tmp%position
- else
- position = [0,0]
- end if
- end function position_stack_nth_position
-
-@ %def position_stack_nth_position
-@
-<<Muli base: position stack: TBP>>=
- procedure :: first => position_stack_first
-<<Muli base: procedures>>=
- function position_stack_first(this) result(position)
- class(position_stack_t), intent(in) :: this
- integer(kind=dik), dimension(2) :: position, tmp_position
- class(position_stack_t), pointer :: tmp_stack
- tmp_position = this%position
- tmp_stack => this%next
- do while (associated (tmp_stack))
- if (page_ring_position_is_before (tmp_stack%position, tmp_position)) then
- tmp_position = tmp_stack%position
- end if
- tmp_stack => tmp_stack%next
- end do
- end function position_stack_first
-
-@ %def position_stack_first
-@
-<<Muli base: position stack: TBP>>=
- procedure :: last => position_stack_last
-<<Muli base: procedures>>=
- function position_stack_last (this) result (position)
- class(position_stack_t), intent(in) :: this
- integer(dik), dimension(2) :: position, tmp_position
- class(position_stack_t), pointer :: tmp_stack
- tmp_position = this%position
- tmp_stack => this%next
- do while (associated (tmp_stack))
- if (page_ring_position_is_before (tmp_position, tmp_stack%position)) then
- tmp_position = tmp_stack%position
- end if
- tmp_stack => tmp_stack%next
- end do
- end function position_stack_last
-
-@ %def position_stack_last
-@
-<<Muli base: position stack: TBP>>=
- procedure :: range => position_stack_range
-<<Muli base: procedures>>=
- pure function position_stack_range (this) result (position)
- class(position_stack_t), intent(in) :: this
- integer(dik), dimension(2) :: position
- class(position_stack_t), pointer :: tmp
- end function position_stack_range
-
-@ %def position_stack_range
-@
-<<Muli base: public>>=
- public :: page_ring_t
-<<Muli base: types>>=
- type :: page_ring_t
- private
- logical :: asynchronous = serialize_default_asynchronous
- logical :: eof_reached = .false.
- integer :: unit = -1
- integer(dik) :: ring_size = 2
- integer(dik) :: action = 0
- integer(dik) :: eof_int = -1
- integer(dik) :: out_unit = output_unit
- integer(dik) :: err_unit = error_unit
- integer(dik), dimension(2) :: active_pages = [0,-1]
- integer(dik), dimension(2) :: eof_pos = [-1,-1]
- type(string_t) :: eof_string
- type(position_stack_t) :: position_stack
- character(serialize_page_size), dimension(:), allocatable::ring
- contains
- <<Muli base: page ring: TBP>>
- end type page_ring_t
-
-@ %def page_ring_t
-@ These are the [[page_ring_t]] procedures, here for read access only:
-<<Muli base: page ring: TBP>>=
- procedure :: open_for_read_access => page_ring_open_for_read_access
-<<Muli base: procedures>>=
- subroutine page_ring_open_for_read_access &
- (this, file, eof_string, asynchronous)
- class(page_ring_t), intent(inout) :: this
- character(*), intent(in) :: file, eof_string
- logical, intent(in), optional :: asynchronous
- logical :: exist
- this%eof_string = eof_string
- inquire (file=file, exist=exist)
- if (exist) then
- this%action = 2
- else
- call msg_error ("page_ring_open: File " // file // " is opened " &
- // "for read access but does not exist.")
- end if
- if (present (asynchronous)) this%asynchronous = asynchronous
- if (this%unit < 0) call generate_unit (this%unit, 100, 1000)
- if (this%unit < 0) then
- call msg_error ("page_ring_open: No free unit found.")
- end if
- this%ring_size = 2
- call this%set_position ([i_zero,i_one])
- this%active_pages = [i_zero,-i_one]
- if (allocated (this%ring)) deallocate (this%ring)
- allocate (this%ring (i_zero:this%ring_size - i_one))
- if (this%asynchronous) then
- open (this%unit, file=file, access="stream", &
- action="read", asynchronous="yes", status="old")
- else
- open (this%unit, file=file, access="stream", action="read", &
- asynchronous="no", status="old")
- end if
- call this%read_page ()
- end subroutine page_ring_open_for_read_access
-
-@ %def page_ring_open_for_read_access
-@
-<<Muli base: page ring: TBP>>=
- procedure :: read_page => page_ring_read_page
-<<Muli base: procedures>>=
- subroutine page_ring_read_page (this)
- class(page_ring_t), intent(inout) :: this
- integer(dik) :: iostat
- character(8) :: iomsg
- if (.not. this%eof_reached) then
- call this%activate_next_page ()
- read (this%unit, iostat=iostat) this%ring (this%last_index ())
- if (iostat == iostat_end) then
- this%eof_reached = .true.
- this%eof_pos(1) = this%last_page ()
- this%eof_pos(2) = index(this%ring(this%last_index()), &
- char(this%eof_string))
- this%eof_pos(2) = this%eof_pos(2) + len(this%eof_string) - 1
- this%eof_int = page_ring_ordinal(this%eof_pos)
- end if
- end if
- end subroutine page_ring_read_page
-
-@ %def page_ring_read_page
-@ Those are the write access only type-bound procedures of
-[[page_ring_t]]:
-<<Muli base: page ring: TBP>>=
- procedure :: open_for_write_access => page_ring_open_for_write_access
-<<Muli base: procedures>>=
- subroutine page_ring_open_for_write_access (this, file, asynchronous)
- class(page_ring_t), intent(inout) :: this
- character(*), intent(in) :: file
- logical, intent(in), optional :: asynchronous
- this%action = 1
- if (present (asynchronous)) this%asynchronous = asynchronous
- if (this%unit < 0) call generate_unit (this%unit, 100, 1000)
- if (this%unit < 0) then
- call msg_error ("page_ring_open: No free unit found.")
- end if
- this%ring_size = 2
- call this%set_position ([i_zero,i_one])
- this%active_pages = [i_zero,-i_one]
- if (allocated (this%ring)) deallocate (this%ring)
- allocate (this%ring (i_zero:this%ring_size-i_one))
- if (this%asynchronous) then
- open (this%unit, file=file, access="stream", action="write", &
- asynchronous="yes", status="replace")
- else
- open (this%unit, file=file, access="stream", action="write", &
- asynchronous="no",status="replace")
- end if
- end subroutine page_ring_open_for_write_access
-
-@ %def page_ring_open_for_write_access
-@
-<<Muli base: page ring: TBP>>=
- procedure :: flush => page_ring_flush
-<<Muli base: procedures>>=
- subroutine page_ring_flush (this)
- class(page_ring_t), intent(inout) :: this
- integer(dik) :: page
- do while (this%active_pages(1) < this%actual_page ())
- if (this%asynchronous) then
- write (this%unit, asynchronous="yes") &
- this%ring(mod(this%active_pages(1), this%ring_size))
- else
- write (this%unit, asynchronous="no") &
- this%ring(mod(this%active_pages(1), this%ring_size))
- end if
- this%active_pages(1) = this%active_pages(1) + 1
- end do
- end subroutine page_ring_flush
-
-@ %def page_ring_flush
-@
-<<Muli base: page ring: TBP>>=
- procedure :: break => page_ring_break
-<<Muli base: procedures>>=
- subroutine page_ring_break(this)
- class(page_ring_t), intent(inout) :: this
- if (this%actual_page () >= this%active_pages(2)) &
- call this%activate_next_page ()
- call this%turn_page ()
- end subroutine page_ring_break
-
-@ %def page_ring_break
-@ For comparisons:
-<<Muli base: page ring: TBP>>=
- procedure :: str_equal => page_ring_str_equal
-<<Muli base: procedures>>=
- pure logical function page_ring_str_equal (this, string, pos)
- class(page_ring_t), intent(in) :: this
- character(*), intent(in) :: string
- integer(dik), dimension(2,2), intent(in) :: pos
- page_ring_str_equal = string == this%substring (pos)
- end function page_ring_str_equal
-
-@ %def page_ring_str_equal
-@ Routines for searching:
-<<Muli base: page ring: TBP>>=
- generic :: find => page_ring_find, page_ring_find_default
- procedure, private :: page_ring_find
- procedure, private :: page_ring_find_default
-<<Muli base: procedures>>=
- recursive subroutine page_ring_find &
- (this, exp, start, limit, skip, proceed, pos)
- class(page_ring_t), intent(inout) :: this
- integer(dik), dimension(2), intent(in) :: start
- integer(dik), dimension(2), intent(in) :: limit
- character(*), intent(in) :: exp
- integer, intent(in) :: skip
- logical, intent(in) :: proceed
- integer(dik), dimension(2), intent(out) :: pos
- integer(dik) :: page, page2, ind
- page = this%ring_index (start(1))
- if (limit(1) == start(1)) then
- ind = index(this%ring(page) (start(2):limit(2)), exp)
- if (ind > 0) then
- select case (skip)
- case (1)
- pos= [start(1), start(2)+ind-2]
- if (pos(2) == 0) then
- pos(1) = pos(1) - 1
- pos(2) = serialize_page_size
- end if
- case (2)
- pos = [start(1), start(2)+ind-1]
- case (3)
- pos = [start(1), start(2)+ind+len(exp)-2]
- case (4)
- pos = [start(1),start(2)+ind+len(exp)-1]
- if (pos(1) == this%last_page()) call this%read_page ()
- if (pos(2) > serialize_page_size) then
- pos(1) = pos(1) + 1
- pos(2) = pos(2) - serialize_page_size
- end if
- end select
- if (proceed) call this%set_position (pos)
- else
- Call msg_warning ("page_ring_find: limit reached.")
- pos = [-1, -1]
- end if
- else
- ind = index (this%ring(page) (start(2):), exp)
- if (ind > 0) then
- select case (skip)
- case (1)
- pos = [start(1), start(2)+ind-2]
- if (pos(2) == 0) then
- pos(1) = pos(1) - 1
- pos(2) = serialize_page_size
- end if
- case (2)
- pos = [start(1), start(2)+ind-1]
- case (3)
- pos = [start(1), start(2)+ind+len(exp)-2]
- case (4)
- pos = [start(1), start(2)+ind+len(exp)-1]
- if (pos(1) == this%last_page ()) call this%read_page ()
- if (pos(2) > serialize_page_size) then
- pos(1) = pos(1) + 1
- pos(2) = i_one
- end if
- end select
- if(proceed)call this%set_position(pos)
- else
- if (start(1) + 1 > this%active_pages (2)) then
- call this%read_page ()
- page = this%ring_index(start(1))
- end if
- page2 = this%ring_index(start(1)+1)
- ind = index(this%ring(page) (serialize_page_size - &
- len(exp)+1:)//this%ring(page2)(:len(exp)),exp)
- if (ind > 0) then
- select case (skip)
- case (1)
- pos = [start(1), serialize_page_size-len(exp)+ind-1]
- case (2)
- pos = [start(1), serialize_page_size-len(exp)+ind]
- case (3)
- pos = [start(1)+1, ind-1]
- case (4)
- pos = [start(1)+1, ind]
- end select
- if (pos(2) > serialize_page_size) then
- pos(1) = pos(1) + 1
- pos(2) = pos(2) - serialize_page_size
- else
- if (pos(2) < 0) then
- pos(1) = pos(1) - 1
- pos(2) = pos(2) + serialize_page_size
- end if
- end if
- if (proceed) call this%set_position (pos)
- else
- if (proceed) this%active_pages(1) = this%active_pages(2)
- call this%find (exp, [start(1) + i_one, i_one], &
- limit, skip, proceed, pos)
- end if
- end if
- end if
- end subroutine page_ring_find
-
-@ %def page_ring_find
-@
-<<Muli base: procedures>>=
- subroutine page_ring_find_default (this, exp, skip, proceed, pos)
- class(page_ring_t), intent(inout) :: this
- character(*), intent(in), optional :: exp
- integer, intent(in) :: skip
- logical, intent(in) :: proceed
- integer(dik), dimension(2), intent(out) :: pos
- call this%find (exp, this%position_stack%position, this%eof_pos, &
- skip, proceed, pos)
- end subroutine page_ring_find_default
-
-@ %def page_ring_find_default
-@
-<<Muli base: page ring: TBP>>=
- procedure :: find_pure => page_ring_find_pure
-<<Muli base: procedures>>=
- pure recursive function page_ring_find_pure &
- (this, exp, start, limit, skip) result (pos)
- class(page_ring_t),intent(in) :: this
- integer(dik), dimension(2), intent(in) :: start
- integer(dik), dimension(2), intent(in) :: limit
- character(*),intent(in) :: exp
- integer,optional,intent(in) :: skip
- integer(dik), dimension(2) :: pos
- integer(dik) :: page, page2, ind, actual_skip
- !!! Is the starting point before limit?
- if (start(1) <= limit(1)) then
- !!! Default skip is what you expect from the build-in index function
- if (present(skip)) then
- actual_skip = skip
- else
- actual_skip = 2
- end if
- page = mod(start(1), this%ring_size)
- !!! Does the scanning region end on the page?
- if (start(1) == limit(1)) then
- ind = index (this%ring (page) (start(2):limit(2)),exp)
- else
- ind = index (this%ring (page) (start(2):),exp)
- end if
- if (ind > 0) then
- !!! substring found on first page
- select case (actual_skip)
- case (1)
- pos = [start(1), start(2)+ind-2]
- if (pos(2) == 0) then
- pos(1) = pos(1) - 1
- pos(2) = serialize_page_size
- end if
- case (2)
- pos= [start(1), start(2)+ind-1]
- case (3)
- pos= [start(1), start(2)+ind+len(exp)-2]
- case (4)
- pos= [start(1), start(2)+ind+len(exp)-1]
- if (pos(2) > serialize_page_size) then
- pos(1) = pos(1) + 1
- pos(2) = pos(2) - serialize_page_size
- end if
- end select
- else
- !!! Substring not found on first page. Is the next page already read?
- if ((start(1) >= limit(1)) .or. &
- (start(1)+1 > this%active_pages(2))) then
- !!! Either the limit is reached or the next page is not ready.
- pos = [0, 0]
- else
- !!! The next page is available.
- page2 = mod(start(1)+1, this%ring_size)
- !!! We concatenate the edges. When l is the length of exp,
- !!! then we want to concatenate the l-1 last characters of
- !!! page one and the first l characters of page two.
- ! print *,"overlap: |",this%ring(page) &
- ! (serialize_page_size-len(exp)+2:)//this%ring(page2) &
- ! (:len(exp)),"|"
- ind = index (this%ring(page) (serialize_page_size - &
- len(exp)+2:)//this%ring(page2) (:len(exp)),exp)
- if (ind > 0) then
- select case (actual_skip)
- case (1)
- pos = [start(1), serialize_page_size-len(exp)+ind]
- case (2)
- pos = [start(1), serialize_page_size-len(exp)+ind+1]
- case (3)
- pos = [start(1)+1, ind]
- case (4)
- pos = [start(1)+1, ind+1]
- end select
- else
- !!! EXP is not found in the overlap region.
- !!! We recursively search the next pages.
- pos = this%find_pure (exp, [start(i_one) + i_one, i_one], &
- limit, skip)
- end if
- end if
- end if
- else
- !!! Limit is before start
- pos = [0, 0]
- end if
- end function page_ring_find_pure
-
-@ %def page_ring_find_pure
-@ [[page_ring_t]] routines for positioning:
-<<Muli base: page ring: TBP>>=
- generic :: get_position => page_ring_get_position1, page_ring_get_position2
- procedure, private :: page_ring_get_position1
- procedure, private :: page_ring_get_position2
-<<Muli base: procedures>>=
- pure subroutine page_ring_get_position1 (this, pos)
- class(page_ring_t), intent(in) :: this
- integer(dik), intent(out) :: pos
- pos = page_ring_ordinal (this%position_stack%position)
- end subroutine page_ring_get_position1
-
-@ %def page_ring_get_position1
-@
-<<Muli base: procedures>>=
- pure subroutine page_ring_get_position2 (this, pos)
- class(page_ring_t), intent(in) :: this
- integer(dik), dimension(2), intent(out) :: pos
- pos = this%position_stack%position
- end subroutine page_ring_get_position2
-
-@ %def page_ring_get_position2
-@
-<<Muli base: page ring: TBP>>=
- generic :: pop_position => pop_actual_position, pop_given_position
- procedure, private :: pop_actual_position => &
- page_ring_ring_pop_actual_position
- procedure, private :: pop_given_position => &
- page_ring_ring_pop_given_position
-<<Muli base: procedures>>=
- subroutine page_ring_ring_pop_actual_position (this)
- class(page_ring_t), intent(inout) :: this
- call this%position_stack%pop ()
- end subroutine page_ring_ring_pop_actual_position
-
-@ %def page_ring_ring_pop_actual_position
-@
-<<Muli base: procedures>>=
- subroutine page_ring_ring_pop_given_position (this, pos)
- class(page_ring_t), intent(inout) :: this
- integer(dik), dimension(2), intent(out) :: pos
- call this%position_stack%pop (pos)
- end subroutine page_ring_ring_pop_given_position
-
-@ %def page_ring_ring_pop_given_position
-@
-<<Muli base: page ring: TBP>>=
- generic :: push_position => push_actual_position, push_given_position
- procedure, private :: push_actual_position => &
- page_ring_ring_push_actual_position
- procedure, private :: push_given_position => &
- page_ring_ring_push_given_position
-<<Muli base: procedures>>=
- subroutine page_ring_ring_push_actual_position (this)
- class(page_ring_t), intent(inout) :: this
- call this%position_stack%push ()
- end subroutine page_ring_ring_push_actual_position
-
-@ %def page_ring_ring_push_actual_position
-@
-<<Muli base: procedures>>=
- subroutine page_ring_ring_push_given_position (this, pos)
- class(page_ring_t), intent(inout) :: this
- integer(dik), dimension(2), intent(in) :: pos
- call this%position_stack%push (pos)
- end subroutine page_ring_ring_push_given_position
-
-@ %def page_ring_ring_push_given_position
-@
-<<Muli base: page ring: TBP>>=
- procedure :: set_position => page_ring_set_position
-<<Muli base: procedures>>=
- subroutine page_ring_set_position (this, pos)
- class(page_ring_t), intent(inout) :: this
- integer(dik), dimension(2), intent(in) :: pos
- this%position_stack%position = pos
- end subroutine page_ring_set_position
-
-@ %def page_ring_set_position
-@
-<<Muli base: page ring: TBP>>=
- procedure :: turn_page => page_ring_turn_page
-<<Muli base: procedures>>=
- subroutine page_ring_turn_page (this)
- class(page_ring_t), intent(inout) :: this
- this%position_stack%position(1) = this%position_stack%position(1) + 1
- this%position_stack%position(2) = 1
- end subroutine page_ring_turn_page
-
-@ %def page_ring_turn_page
-@
-<<Muli base: page ring: TBP>>=
- procedure :: proceed => page_ring_proceed
-<<Muli base: procedures>>=
- subroutine page_ring_proceed (this, n, deactivate)
- class(page_ring_t), intent(inout) :: this
- integer(dik), intent(in) :: n
- logical, intent(in), optional :: deactivate
- integer(dik) :: offset
- offset = this%position_stack%position(2) + n
- do while (offset > serialize_page_size)
- if (this%position_stack%position(1) >= this%active_pages(2)) &
- call this%activate_next_page ()
- this%position_stack%position(1) = this%position_stack%position(1) + 1
- offset = offset - serialize_page_size
- end do
- this%position_stack%position(2) = offset
- if (present (deactivate)) then
- if (deactivate)this%active_pages(1) = this%actual_page ()
- end if
- end subroutine page_ring_proceed
-
-@ %def page_ring_proceed
-@ These are the [[page_ring_t]] routines for printing:
-<<Muli base: page ring: TBP>>=
- procedure :: print_to_unit => page_ring_print_to_unit
-<<Muli base: procedures>>=
- subroutine page_ring_print_to_unit (this, unit, parents, components, peers)
- class(page_ring_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- write (unit, "(1x,A)") "Components of page_ring_t: "
- write (unit, "(3x,A,A)") "asynchronous: ", this%asynchronous
- write (unit, "(3x,A,L1)") "eof reached: ", this%eof_reached
- write (unit, "(3x,A,I0)") "ring_size: ", this%ring_size
- write (unit, "(3x,A,I0)") "unit: ", this%unit
- write (unit, "(3x,A,I0)") "action: ", this%action
- write (unit, "(3x,A,I0,I0)") &
- "position: ", this%position_stack%position
- write (unit, "(3x,A,I0)") "active_pages: ", this%active_pages
- write (unit, "(3x,A,I0)") "file size: ", this%eof_int
- write (unit, "(3x,A,I0,I0)") "eof position: ", this%eof_pos
- write (unit, "(3x,A,A)") "eof string: ", char(this%eof_string)
- if (allocated (this%ring)) then
- write (unit, "(3x,A)") "Ring is allocated."
- if (components > 0) call this%print_ring (unit)
- else
- write (unit, "(3x,A)") "Ring is not allocated."
- end if
- end subroutine page_ring_print_to_unit
-
-@ %def page_ring_print_to_unit
-@
-<<Muli base: page ring: TBP>>=
- procedure :: print_ring => page_ring_print_ring
-<<Muli base: procedures>>=
- subroutine page_ring_print_ring (this, unit)
- class(page_ring_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik) :: n
- write (unit, "(1x,A)") "Begin of page ring"
- do n = this%active_pages(1), this%active_pages(2)
- write (unit, "(3x,A,I0,A,A)") &
- "(", n, ")", this%ring (mod(n, this%ring_size))
- end do
- write (unit, "(1x,A)") "End of page ring"
- end subroutine page_ring_print_ring
-
-@ %def page_ring_print_ring
-@
-<<Muli base: page ring: TBP>>=
- procedure :: print_position => page_ring_print_position
-<<Muli base: procedures>>=
- subroutine page_ring_print_position(this)
- class(page_ring_t), intent(inout) :: this
- print *, this%actual_position(), &
- this%ring(this%actual_index()) (:this%actual_offset() - 1), "|", &
- this%ring(this%actual_index()) (this%actual_offset():)
- end subroutine page_ring_print_position
-
-@ %def page_ring_print_position
-@ Here are the [[page_ring_t]] routines for writing:
-<<Muli base: page ring: TBP>>=
- procedure :: put => page_ring_put
-<<Muli base: procedures>>=
- subroutine page_ring_put (this)
- class(page_ring_t), intent(inout) :: this
- end subroutine page_ring_put
-
-@ %def page_ring_put
-@
-<<Muli base: page ring: TBP>>=
- generic :: push => push_string, push_integer, push_integer_dik, &
- push_real, push_integer_array, push_integer_array_dik, &
- push_real_array
-<<Muli base: page ring: TBP>>=
- procedure, private :: push_string => page_ring_push_string
-<<Muli base: procedures>>=
- recursive subroutine page_ring_push_string (this, string)
- class(page_ring_t), intent(inout) :: this
- character(*), intent(in) :: string
- integer(dik) :: cut, l
- l = len(string)
- if (l <= serialize_page_size-this%actual_offset()+1) then
- this%ring(this%actual_index()) &
- (this%actual_offset():this%actual_offset()+l-1)=string
- if (l == serialize_page_size-this%actual_offset()+1) then
- call this%break()
- call this%flush()
- else
- call this%proceed(l)
- end if
- else
- cut = serialize_page_size-this%actual_offset() + 1
- call this%push_string(string(:cut))
- call this%push_string(string(cut+1:))
- end if
- end subroutine page_ring_push_string
-
-@ %def page_ring_push_string
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: push_integer => page_ring_push_integer
-<<Muli base: procedures>>=
- subroutine page_ring_push_integer (this, in)
- class(page_ring_t), intent(inout) :: this
- integer, intent(in) :: in
- call this%push_integer_dik (int(in,kind=dik))
- end subroutine page_ring_push_integer
-
-@ %def page_ring_push_integer
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: push_integer_dik => page_ring_push_integer_dik
-<<Muli base: procedures>>=
- recursive subroutine page_ring_push_integer_dik (this, int)
- class(page_ring_t), intent(inout) :: this
- integer(dik), intent(in) :: int
- integer(dik) :: int1
- if (int < 0) then
- call this%push ("-")
- call this%push_integer_dik (-int)
- else
- if (int > 9) call this%push (int/10)
- int1 = mod(int, 10*i_one)
- select case (int1)
- case (0)
- call this%push ("0")
- case (1)
- call this%push ("1")
- case (2)
- call this%push ("2")
- case (3)
- call this%push ("3")
- case (4)
- call this%push ("4")
- case (5)
- call this%push ("5")
- case (6)
- call this%push ("6")
- case (7)
- call this%push ("7")
- case (8)
- call this%push ("8")
- case (9)
- call this%push ("9")
- end select
- end if
- end subroutine page_ring_push_integer_dik
-
-@ %def page_ring_push_integer_dik
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: push_integer_array => page_ring_push_integer_array
-<<Muli base: procedures>>=
- subroutine page_ring_push_integer_array(this,int)
- class(page_ring_t), intent(inout) :: this
- integer, dimension(:), intent(in) :: int
- integer :: n
- do n = 1, size(int)
- call this%push (int(n))
- call this%push (" ")
- end do
- end subroutine page_ring_push_integer_array
-
-@ %def page_ring_push_integer_array
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: push_integer_array_dik => &
- page_ring_push_integer_array_dik
-<<Muli base: procedures>>=
- subroutine page_ring_push_integer_array_dik(this,int)
- class(page_ring_t), intent(inout) :: this
- integer(dik), dimension(:), intent(in) :: int
- integer(dik) :: n
- do n = 1, size(int)
- call this%push (int(n))
- call this%push (" ")
- end do
- end subroutine page_ring_push_integer_array_dik
-
-@ %def page_ring_push_integer_array_dik
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: push_real => page_ring_push_real
-<<Muli base: procedures>>=
- subroutine page_ring_push_real (this, dou)
- class(page_ring_t), intent(inout) :: this
- real(default), intent(in) :: dou
- integer(dik) :: f
- ! print *,"page_ring_push_real: ",dou
- if (dou == 0D0) then
- call this%push ("0")
- else
- f = int (scale (fraction(dou), digits(dou)), kind=dik)
- call this%push (digits(dou))
- call this%push (":")
- call this%push (f)
- call this%push (":")
- call this%push (exponent(dou))
- end if
- call this%push (" ")
- end subroutine page_ring_push_real
-
-@ %def page_ring_push_real
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: push_real_array => page_ring_push_real_array
-<<Muli base: procedures>>=
- subroutine page_ring_push_real_array (this, dou)
- class(page_ring_t), intent(inout) :: this
- real(default), dimension(:), intent(in) :: dou
- integer(dik) :: n
- do n=1, size(dou)
- call this%push (dou(n))
- end do
- end subroutine page_ring_push_real_array
-
-@ %def page_ring_push_real_array
-@
-<<Muli base: page ring: TBP>>=
- procedure :: get_character => page_ring_get_character
-<<Muli base: procedures>>=
- elemental function page_ring_get_character (this)
- class(page_ring_t), intent(in) :: this
- character :: page_ring_get_character
- page_ring_get_character = this%ring (this%actual_index()) &
- (this%actual_offset():this%actual_offset())
- end function page_ring_get_character
-
-@ %def page_ring_get_character
-@
-<<Muli base: page ring: TBP>>=
- procedure :: allocate_substring => page_ring_allocate_substring
-<<Muli base: procedures>>=
- subroutine page_ring_allocate_substring (this, p1, p2, string)
- class(page_ring_t), intent(in) :: this
- integer(dik), dimension(2), intent(in) :: p1, p2
- character(:), allocatable, intent(out) :: string
- string = this%substring (p1, p2)
- end subroutine page_ring_allocate_substring
-
-@ %def page_ring_allocate_substring
-@
-<<Muli base: page ring: TBP>>=
- procedure :: pop_character => page_ring_pop_character
-<<Muli base: procedures>>=
- subroutine page_ring_pop_character (this, c)
- class(page_ring_t), intent(inout) :: this
- character, intent(out) :: c
- c = this%ring (this%actual_index()) &
- (this%actual_offset():this%actual_offset())
- if (this%actual_offset () == serialize_page_size) call this%read_page
- call this%proceed (i_one)
- end subroutine page_ring_pop_character
-
-@ %def page_ring_pop_character
-@
-<<Muli base: page ring: TBP>>=
- procedure :: pop_by_keys => page_ring_pop_by_keys
-<<Muli base: procedures>>=
- subroutine page_ring_pop_by_keys (this, start, stop, inclusive, res)
- class(page_ring_t), intent(inout) :: this
- character(*), intent(in), optional :: start
- character(*), intent(in) :: stop
- logical, optional, intent(in) :: inclusive
- character(len=*), intent(out) :: res
- integer(dik), dimension(2) :: i1, i2
- if (inclusive) then
- call this%find (start, 2, .true., i1)
- call this%find (stop, 3, .false., i2)
- else
- call this%find (start, 4, .true., i1)
- call this%find (stop, 1, .false., i2)
- end if
- res = this%substring (i1, i2)
- call this%set_position (i2)
- end subroutine page_ring_pop_by_keys
-
-@ %def page_ring_pop_by_keys
-@
-<<Muli base: page ring: TBP>>=
- generic :: substring => page_ring_substring1, page_ring_substring2
- procedure, private :: page_ring_substring1
- procedure, private :: page_ring_substring2
-@
-<<Muli base: procedures>>=
- pure function page_ring_substring1 (this, i) result (res)
- class(page_ring_t), intent(in) :: this
- integer(dik), dimension(2,2), intent(in) :: i
- character(ring_position_metric1(i)) :: res
- integer(dik) :: page, pos
- if (i(1,1) == i(1,2)) then
- res = this%ring (mod(i(1,1), this%ring_size)) (i(2,1):i(2,2))
- else
- pos = serialize_page_size - i(2,1)
- res(1:pos+1) = this%ring (mod(i(1,1),this%ring_size)) (i(2,1):)
- do page = i(1,1) + 1, i(1,1) - 1
- res (pos+2:pos+2+serialize_page_size) = &
- this%ring (mod(page,this%ring_size))
- pos = pos + serialize_page_size
- end do
- res(pos+2:pos+1+i(2,2)) = &
- this%ring (mod(page,this%ring_size)) (1:i(2,2))
- end if
- end function page_ring_substring1
-
-@ %def page_ring_substring1
-@
-<<Muli base: procedures>>=
- pure function page_ring_substring2 (this, i1, i2) result (res)
- class(page_ring_t), intent(in) :: this
- integer(dik), dimension(2), intent(in) :: i1,i2
- character(ring_position_metric2(i1,i2)) :: res
- integer(dik) :: page, pos
- if (i1(1) == i2(1)) then
- res = this%ring(mod(i1(1),this%ring_size)) (i1(2):i2(2))
- else
- pos = serialize_page_size - i1(2)
- res(1:pos+1) = this%ring(mod(i1(1),this%ring_size)) (i1(2):)
- do page = i1(1)+1, i2(1)-1
- res(pos+2:pos+2+serialize_page_size) = &
- this%ring(mod(page, this%ring_size))
- pos = pos + serialize_page_size
- end do
- res(pos+2:pos+1+i2(2)) = this%ring(mod(page, this%ring_size)) (1:i2(2))
- end if
- end function page_ring_substring2
-
-@ %def page_ring_substring2
-@
-<<Muli base: page ring: TBP>>=
- generic :: substring_by_keys => page_ring_character_by_keys, &
- page_ring_positions_by_keys
- procedure, private :: page_ring_character_by_keys
- procedure, private :: page_ring_positions_by_keys
-<<Muli base: procedures>>=
- pure recursive subroutine page_ring_character_by_keys (this, exp1, &
- exp2, start, limit, inclusive, length, string)
- class(page_ring_t), intent(in) :: this
- character(*), intent(in) :: exp1, exp2
- integer(dik), dimension(2), intent(in) :: start, limit
- logical, optional, intent(in) :: inclusive
- integer(dik), intent(out), optional :: length
- character(:), allocatable, intent(out) :: string
- integer(dik), dimension(2,2) :: pos
- call this%substring_by_keys (exp1, exp2, start, limit, &
- inclusive, length, pos)
- string = this%substring (pos(:,1),pos(:,2))
- end subroutine page_ring_character_by_keys
-
-@ %def page_ring_character_by_keys
-@
-<<Muli base: procedures>>=
- pure recursive subroutine page_ring_positions_by_keys (this, exp1, &
- exp2, start, limit, inclusive, length, pos)
- class(page_ring_t), intent(in) :: this
- character(*), intent(in) :: exp1, exp2
- integer(dik), dimension(2), intent(in) :: start, limit
- logical, optional, intent(in) :: inclusive
- integer(dik), intent(out), optional :: length
- integer(dik), dimension(2,2), intent(out) :: pos
- if (inclusive) then
- pos(1:2,1) = this%find_pure (exp1, start, limit, 2)
- else
- pos(1:2,1) = this%find_pure (exp1,start, limit, 4)
- end if
- ! print *,pos1
- if (present(length)) then
- length = 0
- end if
- if (pos(2,1) > 0) then
- if (inclusive) then
- pos(1:2,2) = this%find_pure (exp2, pos(1:2,1), limit, 3)
- else
- pos(1:2,2) = this%find_pure (exp2, pos(1:2,1), limit, 1)
- end if
- ! print *,pos2
- if (pos(2,2) > 0) then
- if (present (length)) then
- length = ring_position_metric1 (pos)
- end if
- end if
- end if
- end subroutine page_ring_positions_by_keys
-
-@ %def page_ring_positions_by_keys
-@
-<<Muli base: page ring: TBP>>=
- generic :: pop => pop_string, pop_integer, pop_integer_dik, &
- pop_real, pop_logical, pop_integer_array, &
- pop_integer_array_dik, pop_real_array
-<<Muli base: page ring: TBP>>=
- procedure, private :: pop_string => page_ring_pop_string
-<<Muli base: procedures>>=
- recursive subroutine page_ring_pop_string (this, res)
- class(page_ring_t), intent(inout) :: this
- character(len=*), intent(out) :: res
- integer(dik) :: n, cut
- n = len(res)
- cut = serialize_page_size-this%actual_offset() + 1
- if (n <= cut) then
- res = this%ring (this%actual_index()) &
- (this%actual_offset():this%actual_offset()+n)
- if (n == cut) then
- call this%read_page
- end if
- call this%proceed (n)
- else
- call this%pop (res(:cut))
- call this%pop (res(cut+1:))
- end if
- end subroutine page_ring_pop_string
-
-@ %def page_ring_pop_string
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: pop_integer => page_ring_pop_integer
-<<Muli base: procedures>>=
- subroutine page_ring_pop_integer (this,in)
- class(page_ring_t), intent(inout) :: this
- integer, intent(out) :: in
- integer(dik) :: in_dik
- call this%pop (in_dik)
- in = int(in_dik)
- end subroutine page_ring_pop_integer
-
-@ %def page_ring_pop_integer
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: pop_integer_dik => page_ring_pop_integer_dik
-<<Muli base: procedures>>=
- subroutine page_ring_pop_integer_dik (this, int)
- class(page_ring_t), intent(inout) :: this
- integer(dik), intent(out) :: int
- integer(dik) :: int1
- integer(dik) :: sign
- character :: c
- int = 0
- sign = 1
- c = " "
- do while (scan (c, serialize_integer_characters) == 0)
- call this%pop_character (c)
- end do
- if (c == "-") then
- sign = -1
- call this%pop_character (c)
- end if
- do while (scan (c, serialize_integer_characters) > 0)
- int = int * 10
- select case (c)
- case ("1")
- int = int + 1
- case ("2")
- int = int + 2
- case ("3")
- int = int + 3
- case ("4")
- int = int + 4
- case ("5")
- int = int + 5
- case ("6")
- int = int + 6
- case ("7")
- int = int + 7
- case ("8")
- int = int + 8
- case ("9")
- int = int + 9
- end select
- call this%pop_character (c)
- end do
- int = int * sign
- if (c == "<") call this%proceed (-i_one)
- end subroutine page_ring_pop_integer_dik
-
-@ %def page_ring_pop_integer_dik
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: pop_integer_array => page_ring_pop_integer_array
-@
-<<Muli base: procedures>>=
- subroutine page_ring_pop_integer_array (this, int)
- class(page_ring_t), intent(inout) :: this
- integer, dimension(:), intent(out) :: int
- integer :: n
- do n = 1, size(int)
- call this%pop (int(n))
- end do
- end subroutine page_ring_pop_integer_array
-
-@ %def page_ring_pop_integer_array
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: pop_integer_array_dik => &
- page_ring_pop_integer_array_dik
-@
-<<Muli base: procedures>>=
- subroutine page_ring_pop_integer_array_dik (this, int)
- class(page_ring_t), intent(inout) :: this
- integer(dik), dimension(:), intent(out) :: int
- integer(dik) :: n
- do n = 1, size(int)
- call this%pop (int(n))
- end do
- end subroutine page_ring_pop_integer_array_dik
-
-@ %def page_ring_pop_integer_array_dik
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: pop_logical => page_ring_pop_logical
-<<Muli base: procedures>>=
- subroutine page_ring_pop_logical (this, l)
- class(page_ring_t), intent(inout) :: this
- logical, intent(out) :: l
- character(1) :: lc
- call this%pop (lc)
- do while (scan (lc,"tTfF") == 0)
- call this%pop (lc)
- end do
- read (lc, "(L1)") l
- end subroutine page_ring_pop_logical
-
-@ %def page_ring_pop_logical
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: pop_real => page_ring_pop_real
-@
-<<Muli base: procedures>>=
- subroutine page_ring_pop_real (this, def, skip)
- class(page_ring_t), intent(inout) :: this
- real(default), intent(out) :: def
- logical, optional, intent(in) :: skip
- integer(dik) :: d, f, e
- call this%pop (d)
- if (d == i_zero) then
- def = zero
- else
- call this%pop (f)
- call this%pop (e)
- def = set_exponent (scale (real(f, kind=default), -d), e)
- end if
- if (present (skip)) then
- if (.not. skip) call this%proceed (-i_one)
- end if
- end subroutine page_ring_pop_real
-
-@ %def page_ring_pop_real
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: pop_real_array => page_ring_pop_real_array
-@
-<<Muli base: procedures>>=
- subroutine page_ring_pop_real_array (this, def, skip)
- class(page_ring_t), intent(inout) :: this
- real(default), dimension(:), intent(out) :: def
- logical, optional, intent(in) :: skip
- integer(dik) :: n
- call this%pop_real (def(1))
- do n = 2, size(def)
- call this%pop_real (def(n))
- end do
- if (present(skip)) then
- if (.not. skip) call this%proceed (-i_one)
- end if
- end subroutine page_ring_pop_real_array
-
-@ %def page_ring_pop_real_array
-@
-<<Muli base: page ring: TBP>>=
- procedure :: close => page_ring_close
-<<Muli base: procedures>>=
- subroutine page_ring_close (this)
- class(page_ring_t), intent(inout) :: this
- if (this%action == 1) then
- call this%flush ()
- ! call this%print_position()
- if (this%asynchronous) then
- write (this%unit, asynchronous="yes") &
- this%ring (this%actual_index()) (:this%actual_offset() - 1)
- else
- write (this%unit, asynchronous="no") &
- this%ring (this%actual_index()) (:this%actual_offset() - 1)
- end if
- end if
- close (this%unit)
- end subroutine page_ring_close
-
-@ %def page_ring_close
-@
-<<Muli base: page ring: TBP>>=
- procedure :: ring_index => page_ring_ring_index
-<<Muli base: procedures>>=
- elemental integer(dik) function page_ring_ring_index (this, n)
- class(page_ring_t), intent(in) :: this
- integer(dik), intent(in) :: n
- page_ring_ring_index = mod(n, this%ring_size)
- end function page_ring_ring_index
-
-@ %def page_ring_ring_index
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: activate_next_page => page_ring_activate_next_page
-<<Muli base: procedures>>=
- subroutine page_ring_activate_next_page (this)
- class(page_ring_t), intent(inout) :: this
- if (this%active_pages(2) - this%active_pages(1) + 1 >= &
- this%ring_size) call this%enlarge
- this%active_pages(2) = this%active_pages(2) + 1
- end subroutine page_ring_activate_next_page
-
-@ %def page_ring_activate_next_page
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: enlarge => page_ring_enlarge
-<<Muli base: procedures>>=
- subroutine page_ring_enlarge (this)
- class(page_ring_t), intent(inout) :: this
- character(serialize_page_size), dimension(:), allocatable :: tmp_ring
- integer(dik) :: n
- call move_alloc (this%ring, tmp_ring)
- allocate (this%ring(0:this%ring_size*2-1))
- do n = this%active_pages(1), this%active_pages(2)
- this%ring (mod(n,this%ring_size*2)) = tmp_ring (mod(n,this%ring_size))
- end do
- this%ring_size = this%ring_size * 2
- end subroutine page_ring_enlarge
-
-@ %def page_ring_enlarge
-@ These are specific implementations of generic procedures:
-<<Muli base: page ring: TBP>>=
- procedure, private :: actual_index => page_ring_actual_index
-<<Muli base: procedures>>=
- elemental integer(dik) function page_ring_actual_index (this)
- class(page_ring_t), intent(in) :: this
- page_ring_actual_index = &
- mod (this%position_stack%position(1), this%ring_size)
- end function page_ring_actual_index
-
-@ %def page_ring_actual_index
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: actual_page => page_ring_actual_page
-<<Muli base: procedures>>=
- elemental integer(dik) function page_ring_actual_page (this)
- class(page_ring_t), intent(in) :: this
- page_ring_actual_page = this%position_stack%position(1)
- end function page_ring_actual_page
-
-@ %def page_ring_actual_page
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: actual_offset => page_ring_actual_offset
-<<Muli base: procedures>>=
- elemental integer(kind=dik) function page_ring_actual_offset(this)
- class(page_ring_t),intent(in) :: this
- page_ring_actual_offset=this%position_stack%position(2)
- end function page_ring_actual_offset
-
-@ %def page_ring_actual_offset
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: actual_position => page_ring_actual_position
-<<Muli base: procedures>>=
- pure function page_ring_actual_position(this)
- class(page_ring_t), intent(in) :: this
- integer(dik), dimension(2) :: page_ring_actual_position
- page_ring_actual_position = this%position_stack%position
- end function page_ring_actual_position
-
-@ %def page_ring_actual_position
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: first_index => page_ring_first_index
-<<Muli base: procedures>>=
- elemental integer(dik) function page_ring_first_index (this)
- class(page_ring_t), intent(in) :: this
- page_ring_first_index = mod(this%active_pages(1), this%ring_size)
- end function page_ring_first_index
-
-@ %def page_ring_first_index
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: first_page => page_ring_first_page
-<<Muli base: procedures>>=
- elemental integer(dik) function page_ring_first_page (this)
- class(page_ring_t), intent(in) :: this
- page_ring_first_page = this%active_pages(1)
- end function page_ring_first_page
-
-@ %def page_ring_first_page
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: last_index => page_ring_last_index
-<<Muli base: procedures>>=
- elemental integer(dik) function page_ring_last_index (this)
- class(page_ring_t), intent(in) :: this
- page_ring_last_index = mod(this%active_pages(2), this%ring_size)
- end function page_ring_last_index
-
-@ %def page_ring_last_index
-@
-<<Muli base: page ring: TBP>>=
- procedure, private :: last_page => page_ring_last_page
-<<Muli base: procedures>>=
- elemental integer(dik) function page_ring_last_page (this)
- class(page_ring_t), intent(in) :: this
- page_ring_last_page = this%active_pages(2)
- end function page_ring_last_page
-
-@ %def page_ring_last_page
-@
-<<Muli base: public>>=
- public :: marker_t
-<<Muli base: types>>=
- type, extends (page_ring_t) :: marker_t
- private
- integer(dik) :: indentation=0
- integer(dik) :: n_instances=0
- logical :: do_break=.true.
- logical :: do_indent=.false.
- class(serializable_ref_type),pointer :: heap=>null()
- class(serializable_ref_type),pointer :: references=>null()
- contains
- <<Muli base: marker: TBP>>
- end type marker_t
-
-@ %def marker_t
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_begin => marker_mark_begin
-<<Muli base: procedures>>=
- subroutine marker_mark_begin (this, tag, type, name, target, pointer, shape)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: tag
- character(*), intent(in), optional :: type, name
- integer(kind=dik), intent(in), optional :: target, pointer
- integer,intent(in), dimension(:), optional :: shape
- call this%indent ()
- call this%push ("<")
- call this%push (tag)
- if (present (type)) call this%push (' type="'//type//'"')
- if (present (name)) call this%push (' name="'//name//'"')
- if (present (target)) then
- call this%push (' target="')
- call this%push (target)
- call this%push ('"')
- end if
- if (present (pointer))then
- call this%push (' pointer="')
- call this%push (pointer)
- call this%push ('"')
- end if
- if (present (shape))then
- call this%push (' shape="')
- call this%push (shape)
- call this%push ('"')
- end if
- call this%push (">")
- this%indentation = this%indentation + 1
- end subroutine marker_mark_begin
-
-@ %def marker_mark_begin
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_instance_begin => marker_mark_instance_begin
-<<Muli base: procedures>>=
- subroutine marker_mark_instance_begin &
- (this, ser, name, target, pointer, shape)
- class(marker_t), intent(inout) :: this
- class(ser_class_t), intent(in) :: ser
- character(*), intent(in) :: name
- integer(dik), intent(in), optional :: target, pointer
- integer, dimension(:), intent(in), optional :: shape
- character(:), allocatable :: this_type
- call ser%get_type (this_type)
- call this%mark_begin ("ser", this_type, name, target, pointer, shape)
- end subroutine marker_mark_instance_begin
-
-@ %def marker_mark_instance_begin
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_end => marker_mark_end
-<<Muli base: procedures>>=
- subroutine marker_mark_end (this, tag)
- class(marker_t), intent(inout) :: this
- character(*), intent(in), optional :: tag
- this%indentation = this%indentation - 1
- call this%indent ()
- if (present (tag)) then
- call this%push ("</"//tag//">")
- else
- call this%push ("</ser>")
- end if
- end subroutine marker_mark_end
-
-@ %def marker_mark_end
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_instance_end => marker_mark_instance_end
-<<Muli base: procedures>>=
- subroutine marker_mark_instance_end (this)
- class(marker_t), intent(inout) :: this
- call this%mark_end ("ser")
- end subroutine marker_mark_instance_end
-
-@ %def marker_mark_instance_end
-@
-<<Muli base: marker: TBP>>=
- generic :: mark => mark_logical, &
- mark_integer, mark_integer_array, mark_integer_matrix, &
- mark_integer_dik, mark_integer_array_dik, mark_integer_matrix_dik, &
- mark_default, mark_default_array, mark_default_matrix, mark_string
- procedure, private :: mark_logical => marker_mark_logical
-<<Muli base: procedures>>=
- subroutine marker_mark_logical (this, name, content)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- logical, intent(in) :: content
- call this%indent ()
- call this%push ("<"//name//">")
- if (content) then
- call this%push ("T")
- else
- call this%push ("F")
- end if
- call this%push ("</"//name//">")
- end subroutine marker_mark_logical
-
-@ %def marker_mark_logical
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_integer => marker_mark_integer
-<<Muli base: procedures>>=
- subroutine marker_mark_integer (this, name, content)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer, intent(in) :: content
- call this%indent ()
- call this%push ("<"//name//">")
- call this%push (content)
- call this%push ("</"//name//">")
- end subroutine marker_mark_integer
-
-@ %def marker_mark_integer
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_integer_array => marker_mark_integer_array
-<<Muli base: procedures>>=
- subroutine marker_mark_integer_array (this, name, content)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer, dimension(:), intent(in) :: content
- call this%indent ()
- call this%push ("<"//name//">")
- call this%push (content)
- call this%push ("</"//name//">")
- end subroutine marker_mark_integer_array
-
-@ %def marker_mark_integer_array
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_integer_matrix => marker_mark_integer_matrix
-<<Muli base: procedures>>=
-
- subroutine marker_mark_integer_matrix (this, name, content)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer, dimension(:,:), intent(in) :: content
- integer :: n
- integer, dimension(2) :: s
- s= shape(content)
- call this%indent ()
- call this%push ("<"//name//">")
- do n = 1, s(2)
- call this%push (content(:,n))
- call this%push (" ")
- end do
- call this%push ("</"//name//">")
- end subroutine marker_mark_integer_matrix
-
-@ %def marker_mark_integer_matrix
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_integer_dik => marker_mark_integer_dik
-<<Muli base: procedures>>=
- subroutine marker_mark_integer_dik (this, name, content)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer(dik), intent(in) :: content
- call this%indent ()
- call this%push ("<"//name//">")
- call this%push (content)
- call this%push ("</"//name//">")
- end subroutine marker_mark_integer_dik
-
-@ %def marker_marker_integer_dik
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_integer_array_dik => marker_mark_integer_array_dik
-<<Muli base: procedures>>=
- subroutine marker_mark_integer_array_dik (this, name, content)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer(dik), dimension(:), intent(in) :: content
- call this%indent ()
- call this%push ("<"//name//">")
- call this%push (content)
- call this%push ("</"//name//">")
- end subroutine marker_mark_integer_array_dik
-
-@ %def marker_mark_integer_array_dik
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_integer_matrix_dik => marker_mark_integer_matrix_dik
-<<Muli base: procedures>>=
- subroutine marker_mark_integer_matrix_dik (this, name, content)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer(dik), dimension(:,:), intent(in) :: content
- integer :: n
- integer, dimension(2) :: s
- call this%indent ()
- call this%push ("<"//name//">")
- do n = 1, s(2)
- call this%push (content(:,n))
- call this%push (" ")
- end do
- call this%push ("</"//name//">")
- end subroutine marker_mark_integer_matrix_dik
-
-@ %def marker_mark_integer_matrix_dik
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_default => marker_mark_default
-<<Muli base: procedures>>=
- subroutine marker_mark_default (this, name, content)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- real(default), intent(in) :: content
- call this%indent ()
- call this%push ("<"//name//">")
- call this%push (content)
- call this%push ("</"//name//">")
- end subroutine marker_mark_default
-
-@ %def marker_mark_default
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_default_array => marker_mark_default_array
-<<Muli base: procedures>>=
- subroutine marker_mark_default_array (this, name, content)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- real(default), dimension(:), intent(in) :: content
- call this%indent ()
- call this%push ("<"//name//">")
- call this%push (content)
- call this%push ("</"//name//">")
- end subroutine marker_mark_default_array
-
-@ %def marker_mark_default_array
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_default_matrix => marker_mark_default_matrix
-<<Muli base: procedures>>=
- subroutine marker_mark_default_matrix (this, name, content)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- real(default), dimension(:,:), intent(in) :: content
- integer :: n
- integer, dimension(2) :: s
- s = shape(content)
- call this%indent ()
- call this%push ("<"//name//">")
- do n = 1, s(2)
- call this%push (content(:,n))
- call this%push (" ")
- end do
- call this%push ("</"//name//">")
- end subroutine marker_mark_default_matrix
-
-@ %def marker_mark_default_matrix
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_string => marker_mark_string
-<<Muli base: procedures>>=
- subroutine marker_mark_string (this, name, content)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name, content
- call this%indent ()
- call this%push ("<"//name//">")
- call this%push (content)
- call this%push ("</"//name//">")
- end subroutine marker_mark_string
-
-@ %def marker_mark_string
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_instance => marker_mark_instance
-<<Muli base: procedures>>=
- recursive subroutine marker_mark_instance (this, ser, name, target, pointer)
- class(marker_t), intent(inout) :: this
- class(ser_class_t), intent(in) :: ser
- character(len=*), intent(in) :: name
- integer(dik), intent(in), optional :: target, pointer
- integer(dik) :: status
- call this%mark_instance_begin (ser, name, target, pointer)
- call ser%write_to_marker (this, status)
- call this%mark_end ("ser")
- end subroutine marker_mark_instance
-
-@ %def marker_mark_instance
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_target => marker_mark_target
-<<Muli base: procedures>>=
- recursive subroutine marker_mark_target (this, name, ser)
- class(marker_t), intent(inout) :: this
- class(ser_class_t), target, intent(in) :: ser
- character(len=*), intent(in) :: name
- this%n_instances = this%n_instances + 1
- call this%push_heap (ser, this%n_instances)
- call this%mark_instance (ser, name, target = this%n_instances)
- end subroutine marker_mark_target
-
-@ %def marker_mark_target
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_allocatable => marker_mark_allocatable
-<<Muli base: procedures>>=
- subroutine marker_mark_allocatable (this, name, ser)
- class(marker_t), intent(inout) :: this
- class(ser_class_t), allocatable, intent(in) :: ser
- character(len=*), intent(in) :: name
- if (allocated (ser)) then
- call this%mark_instance (ser, name)
- else
- call this%mark_null (name)
- end if
- end subroutine marker_mark_allocatable
-
-@ %def marker_mark_allocatable
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_pointer => marker_mark_pointer
-<<Muli base: procedures>>=
- recursive subroutine marker_mark_pointer (this, name, ser)
- class(marker_t), intent(inout) :: this
- class(ser_class_t), pointer, intent(in) :: ser
- character(len=*), intent(in) :: name
- character(:), allocatable :: type
- integer(dik) :: p
- if (associated (ser)) then
- call this%search_heap (ser, p)
- if (p > 0) then
- call ser%get_type (type)
- call this%push ('<ser type="')
- call this%push (type)
- call this%push ('" name="')
- call this%push (name)
- call this%push ('" pointer="')
- call this%push (p)
- call this%push ('"/>')
- else
- call this%mark_target (name, ser)
- end if
- else
- call this%mark_null (name)
- end if
- end subroutine marker_mark_pointer
-
-@ %def marker_mark_pointer
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_null => marker_mark_null
-<<Muli base: procedures>>=
- subroutine marker_mark_null (this, name)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- call this%indent ()
- call this%push ('<ser type="null" name="')
- call this%push (name)
- call this%push ('"/>')
- end subroutine marker_mark_null
-
-@ %def marker_mark_null
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_nothing => marker_mark_nothing
-<<Muli base: procedures>>=
- subroutine marker_mark_nothing (this, name)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- call this%indent ()
- call this%push ('<')
- call this%push (name)
- call this%push ('/>')
- end subroutine marker_mark_nothing
-
-@ %def marker_mark_nothing
-@
-<<Muli base: marker: TBP>>=
- procedure :: mark_empty => marker_mark_empty
-<<Muli base: procedures>>=
- subroutine marker_mark_empty (this, tag, type, name, target, pointer, shape)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: tag
- character(*), intent(in), optional :: type, name
- integer(dik), intent(in), optional :: target, pointer
- integer, dimension(:), intent(in), optional :: shape
- call this%push ("<")
- call this%push (tag)
- if (present (type)) call this%push (' type="'//type//'"')
- if (present (name)) call this%push (' name="'//name//'"')
- if (present (target)) then
- call this%push (' target="')
- call this%push (target)
- call this%push ('"')
- end if
- if (present (pointer)) then
- call this%push (' pointer="')
- call this%push (pointer)
- call this%push ('"')
- end if
- if (present (shape)) then
- call this%push (' shape="')
- call this%push (shape)
- call this%push ('"')
- end if
- call this%push ("/>")
- end subroutine marker_mark_empty
-
-@ %def marker_mark_empty
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_begin => marker_pick_begin
-<<Muli base: procedures>>=
- subroutine marker_pick_begin (this, tag, type, name, target, &
- pointer, shape, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: tag
- integer(dik), dimension(2,2),intent(out),optional :: type,name
- integer(dik), intent(out), optional :: target, pointer
- integer, dimension(:), allocatable, optional, intent(out) :: shape
- integer(dik), intent(out) :: status
- integer(dik), dimension(2) :: p1, p2, p3
- integer(dik) :: l
- call this%find ("<", skip=4, proceed=.true., pos=p1)
- call this%find (">", skip=1, proceed=.false., pos=p2)
- p3 = this%find_pure (" ",p1,p2,skip=1)
- if (p3(2) > 0) then
- if (this%substring(p1, p3) == tag) then
- status = serialize_ok
- if (present (type)) then
- call this%substring_by_keys &
- ('type="','"', p3, p2, .false., l, type)
- if (l <= 0) then
- call msg_error ("marker_pick_begin: No type found")
- status = serialize_wrong_type
- end if
- end if
- if (present (name)) then
- call this%substring_by_keys &
- ('name="','"', p3, p2, .false., l, name)
- if (l <= 0) then
- call msg_error ("marker_pick_begin: No name found")
- status = serialize_wrong_name
- call this%print_position ()
- stop
- end if
- end if
- if (present (target)) then
- p1 = this%find_pure ('target="', p3, p2, 4)
- if (p1(2) > 0) then
- call this%set_position (p1)
- call this%pop (target)
- else
- target = -1
- status = serialize_ok
- end if
- end if
- if (present (pointer)) then
- p1=this%find_pure ('pointer="', p3, p2, 4)
- if (p1(2) > 0)then
- call this%set_position (p1)
- call this%pop (pointer)
- else
- pointer = -1
- status = serialize_ok
- end if
- end if
- if (present (shape)) then
- p1 = this%find_pure ('shape="', p3, p2, 4)
- if (p1(2) > 0) then
- call this%set_position (p1)
- call this%pop (shape)
- else
- status = serialize_ok
- end if
- end if
- else
- call msg_error ("marker_pick_begin: Wrong tag. Expected: " // &
- tag // " Found: " // this%substring(p1, p3))
- status = serialize_wrong_tag
- call this%print_position ()
- end if
- else
- if (this%substring(p1, p2) == tag) then
- status = serialize_ok
- else
- call msg_error ("marker_pick_begin: Wrong tag. Expected: " // &
- tag // " Found: " // this%substring(p1, p2))
- status = serialize_wrong_tag
- end if
- end if
- call this%set_position (p2)
- call this%proceed (i_one*2, .true.)
- end subroutine marker_pick_begin
-
-@ %def marker_pick_begin
-@
-<<Muli base: marker: TBP>>=
- procedure :: query_instance_begin => marker_query_instance_begin
-<<Muli base: procedures>>=
- subroutine marker_query_instance_begin &
- (this, type, name, target, pointer, shape,status)
- class(marker_t), intent(inout) :: this
- integer(dik), dimension(2,2), intent(out), optional :: type, name
- integer(dik), intent(out), optional :: target, pointer
- integer, dimension(:), allocatable, intent(out), optional :: shape
- integer(dik), intent(out) :: status
- call this%pick_begin ("ser", type, name, target, pointer, shape, status)
- end subroutine marker_query_instance_begin
-
-@ %def marker_query_instance_begin
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_instance_begin => marker_pick_instance_begin
-<<Muli base: procedures>>=
- subroutine marker_pick_instance_begin &
- (this, name, type, target, pointer, shape, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer(dik), dimension(2,2), intent(out), optional :: type
- integer(dik), intent(out), optional :: target,pointer
- integer, dimension(:), allocatable,intent(out), optional :: shape
- integer(dik), intent(out) :: status
- integer(dik), dimension(2,2) :: read_name
- call this%query_instance_begin &
- (type, read_name, target, pointer, shape, status)
- if (status == serialize_ok) then
- if (.not. this%str_equal (name, read_name)) &
- status = serialize_wrong_name
- end if
- end subroutine marker_pick_instance_begin
-
-@ %def marker_pick_instance_begin
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_end => marker_pick_end
-<<Muli base: procedures>>=
- subroutine marker_pick_end (this, tag, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: tag
- integer(dik), intent(out) :: status
- integer(dik), dimension(2) :: p1, p2
- call this%find ("</", skip=4, proceed=.true., pos=p1)
- call this%find (">", skip=1, proceed=.false., pos=p2)
- if (tag == this%substring (p1, p2)) then
- status = serialize_ok
- else
- call msg_error ("marker_pick_end: Wrong tag. Expected: " // tag &
- // " Found: " // this%substring (p1, p2))
- ! print *,"p1=",p1,"p2=",p2
- call this%print_position ()
- end if
- call this%set_position (p2)
- call this%proceed (i_one*2, .true.)
- end subroutine marker_pick_end
-
-@ %def marker_pick_end
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_instance_end => marker_pick_instance_end
-<<Muli base: procedures>>=
- subroutine marker_pick_instance_end (this, status)
- class(marker_t), intent(inout) :: this
- integer(dik), intent(out) :: status
- call this%pick_end ("ser",status)
- end subroutine marker_pick_instance_end
-
-@ %def marker_pick_instance_end
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_instance => marker_pick_instance
-<<Muli base: procedures>>=
- subroutine marker_pick_instance (this, name, ser, status)
- class(marker_t), intent(inout) :: this
- class(ser_class_t), intent(out) :: ser
- character(*), intent(in) :: name
- integer(dik), intent(out) :: status
- integer(dik), dimension(2,2) :: type, r_name
- call this%pick_begin ("ser", type, r_name, status=status)
- if (status == serialize_ok) then
- if (ser%verify_type (this%substring(type))) then
- if (this%str_equal (name, r_name)) then
- call ser%read_from_marker (this, status)
- call this%pick_end ("ser", status)
- else
- call msg_error ("marker_pick_instance: Name mismatch")
- write (*,*) "Expected: ", name, " Found: ", r_name
- status = serialize_wrong_name
- call this%print_position
- end if
- else
- call msg_error ("marker_pick_instance: Type mismatch: ")
- write (*,*) type
- call ser%write_type (output_unit)
- write (*,*)
- status = serialize_wrong_type
- call this%print_position
- end if
- end if
- end subroutine marker_pick_instance
-
-@ %def marker_pick_instance
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_target => marker_pick_target
-<<Muli base: procedures>>=
- subroutine marker_pick_target (this, name, ser, status)
- class(marker_t), intent(inout) :: this
- class(ser_class_t), target, intent(out) :: ser
- character(*), intent(in) :: name
- integer(dik), intent(out) :: status
- integer(dik), dimension(2,2) :: type, r_name
- integer(dik) :: target
- call this%pick_begin ("ser", type, r_name, target, status=status)
- if (status == serialize_ok) then
- if (ser%verify_type (this%substring(type))) then
- if (this%str_equal (name, r_name)) then
- call ser%read_target_from_marker (this, status)
- if (target > 0) call this%push_heap (ser, target)
- else
- call msg_error ("marker_pick_instance: Name mismatch: ")
- write (*,*) "Expected: ", name, " Found: ", r_name
- status = serialize_wrong_name
- end if
- else
- call msg_error ("marker_pick_instance: Type mismatch: ")
- write (*,*) type
- status = serialize_wrong_type
- end if
- end if
- call this%pick_end ("ser", status)
- end subroutine marker_pick_target
-
-@ %def marker_pick_target
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_allocatable => marker_pick_allocatable
-<<Muli base: procedures>>=
- subroutine marker_pick_allocatable (this, name, ser)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- class(ser_class_t), allocatable, intent(out) :: ser
- class(ser_class_t), pointer :: ref
- integer(dik),dimension(2,2) :: type, r_name
- integer(dik) :: status
- call this%pick_begin ("ser", type, r_name, status=status)
- if (status == serialize_ok) then
- if (ser%verify_type (this%substring(type))) then
- if (this%str_equal (name, r_name)) then
- call this%search_reference (type, ref)
- if (associated (ref)) then
- allocate (ser, source=ref)
- call ser%read_from_marker (this, status)
- else
- call msg_error ("marker_pick_allocatable:")
- write (*,*) "Type ", type, " not found on reference stack."
- end if
- else
- call msg_error ("marker_pick_instance: Name mismatch: ")
- write (*,*) "Expected: ",name," Found: ",r_name
- status = serialize_wrong_name
- end if
- else
- call msg_error ("marker_pick_instance: Type mismatch: ")
- write (*,*) type
- status = serialize_wrong_type
- end if
- end if
- call this%pick_end ("ser", status)
- end subroutine marker_pick_allocatable
-
-@ %def marker_pick_allocatable
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_pointer => marker_pick_pointer
-<<Muli base: procedures>>=
- recursive subroutine marker_pick_pointer (this, name, ser)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- class(ser_class_t), pointer, intent(out) :: ser
- class(ser_class_t), pointer :: ref
- integer(dik), dimension(2,2) :: type, r_name
- integer(dik) :: status, t, p
- nullify (ser)
- call this%pick_begin &
- ("ser", type, r_name, target=t, pointer=p, status=status)
- if (status == serialize_ok) then
- if (.not. this%str_equal ("null",type)) then
- if (p > 0) then
- call this%search_heap (p, ser)
- else
- call this%search_reference (type, ref)
- if (associated (ref))then
- allocate (ser, source=ref)
- call ser%read_target_from_marker (this, status)
- call this%pick_end ("ser", status)
- if (t > 0) call this%push_heap (ser, t)
- else
- write (*,*) "marker_pick_pointer:&
- & Type ",type," not found on reference stack."
- end if
- end if
- end if
- end if
- end subroutine marker_pick_pointer
-
-@ %def marker_pick_pointer
-@
-<<Muli base: marker: TBP>>=
- generic :: pick => pick_logical, &
- pick_integer, pick_integer_array, pick_integer_matrix, &
- pick_integer_dik, pick_integer_array_dik, pick_integer_matrix_dik, &
- pick_default, pick_default_array, pick_default_matrix, pick_string
- procedure :: pick_logical => marker_pick_logical
-<<Muli base: procedures>>=
- subroutine marker_pick_logical (this, name, content, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- logical, intent(out) :: content
- integer(dik), intent(out) :: status
- call this%pick_begin (name, status=status)
- if (status == serialize_ok) then
- call this%pop (content)
- call this%pick_end (name, status)
- end if
- end subroutine marker_pick_logical
-
-@ %def marker_pick_logical
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_integer => marker_pick_integer
-<<Muli base: procedures>>=
- subroutine marker_pick_integer (this, name, content, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer, intent(out) :: content
- integer(dik), intent(out) :: status
- call this%pick_begin (name, status=status)
- if (status == serialize_ok) then
- call this%pop (content)
- call this%pick_end (name, status)
- end if
- end subroutine marker_pick_integer
-
-@ %def marker_pick_integer
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_integer_array => marker_pick_integer_array
-<<Muli base: procedures>>=
- subroutine marker_pick_integer_array (this, name, content, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer, dimension(:), intent(out) :: content
- integer(dik), intent(out) :: status
- call this%pick_begin (name, status=status)
- if (status == serialize_ok) then
- call this%pop (content)
- call this%pick_end (name, status)
- end if
- end subroutine marker_pick_integer_array
-
-@ %def marker_pick_integer_array
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_integer_matrix => marker_pick_integer_matrix
-<<Muli base: procedures>>=
- subroutine marker_pick_integer_matrix (this, name, content, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer, dimension(:,:), intent(out) :: content
- integer(dik), intent(out) :: status
- integer :: n
- integer, dimension(2) :: s
- s = shape(content)
- call this%pick_begin (name, status=status)
- if (status == serialize_ok) then
- do n = 1, s(2)
- call this%pop (content(:,n))
- end do
- call this%pick_end (name, status)
- end if
- end subroutine marker_pick_integer_matrix
-
-@ %def marker_pick_integer_matrix
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_integer_dik => marker_pick_integer_dik
-<<Muli base: procedures>>=
- subroutine marker_pick_integer_dik (this, name, content, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer(dik), intent(out) :: content
- integer(dik), intent(out) :: status
- call this%pick_begin (name, status=status)
- if (status == serialize_ok) then
- call this%pop (content)
- call this%pick_end (name,status)
- end if
- end subroutine marker_pick_integer_dik
-
-@ %def marker_pick_integer_dik
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_integer_array_dik => marker_pick_integer_array_dik
-<<Muli base: procedures>>=
- subroutine marker_pick_integer_array_dik (this, name, content, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer(dik), dimension(:), intent(out) :: content
- integer(dik), intent(out) :: status
- call this%pick_begin (name, status=status)
- if (status == serialize_ok) then
- call this%pop (content)
- call this%pick_end (name, status)
- end if
- end subroutine marker_pick_integer_array_dik
-
-@ %def marker_pick_integer_array_dik
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_integer_matrix_dik => marker_pick_integer_matrix_dik
-<<Muli base: procedures>>=
- subroutine marker_pick_integer_matrix_dik (this, name, content, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer(dik), dimension(:,:), intent(out) :: content
- integer(dik), intent(out) :: status
- integer :: n
- integer, dimension(2) :: s
- s = shape(content)
- call this%pick_begin (name, status=status)
- if (status == serialize_ok) then
- do n = 1, s(2)
- call this%pop (content(:,n))
- end do
- call this%pick_end (name,status)
- end if
- end subroutine marker_pick_integer_matrix_dik
-
-@ %def marker_pick_integer_matrix_dik
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_default => marker_pick_default
-<<Muli base: procedures>>=
- subroutine marker_pick_default (this, name, content, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- real(default), intent(out) :: content
- integer(dik), intent(out) :: status
- call this%pick_begin (name, status=status)
- if (status == serialize_ok) then
- call this%pop (content)
- call this%pick_end (name,status)
- end if
- end subroutine marker_pick_default
-
-@ %def marker_pick_default
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_default_array => marker_pick_default_array
-<<Muli base: procedures>>=
- subroutine marker_pick_default_array (this, name, content, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- real(default), dimension(:), intent(out) :: content
- integer(dik), intent(out) :: status
- call this%pick_begin (name, status=status)
- if (status == serialize_ok) then
- call this%pop (content)
- call this%pick_end (name, status)
- end if
- end subroutine marker_pick_default_array
-
-@ %def marker_pick_default_array
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_default_matrix => marker_pick_default_matrix
-<<Muli base: procedures>>=
- subroutine marker_pick_default_matrix (this, name, content, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- real(default), dimension(:,:), intent(out) :: content
- integer(dik), intent(out) :: status
- integer :: n
- integer, dimension(2) :: s
- s = shape(content)
- call this%pick_begin (name, status=status)
- if (status == serialize_ok) then
- do n = 1, s(2)
- call this%pop (content(:,n))
- end do
- call this%pick_end (name,status)
- end if
- end subroutine marker_pick_default_matrix
-
-@ %def marker_pick_default_matrix
-@
-<<Muli base: marker: TBP>>=
- procedure :: pick_string => marker_pick_string
-<<Muli base: procedures>>=
- subroutine marker_pick_string (this, name, content, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- character(:), allocatable, intent(out) :: content
- integer(dik), intent(out) :: status
- call this%pick_begin (name, status=status)
- if (status == serialize_ok) then
- call this%pop (content)
- call this%pick_end (name, status)
- end if
- end subroutine marker_pick_string
-
-@ %def marker_pick_string
-@
-<<Muli base: marker: TBP>>=
- procedure :: verify_nothing => marker_verify_nothing
-<<Muli base: procedures>>=
- subroutine marker_verify_nothing (this, name, status)
- class(marker_t), intent(inout) :: this
- character(*), intent(in) :: name
- integer(dik) ,intent(out) :: status
- integer(dik), dimension(2) :: p1, p2
- call this%find ("<", skip=4, proceed=.false., pos=p1)
- call this%find (">", 1, .false., p2)
- if (name//"/" == this%substring(p1, p2)) then
- status = serialize_nothing
- call this%set_position (p2)
- call this%proceed (i_one*3, .true.)
- else
- if (name == this%substring(p1, p2)) then
- status = serialize_ok
- else
- status = serialize_wrong_tag
- end if
- end if
- end subroutine marker_verify_nothing
-
-@ %def marker_verify_nothin
-@
-<<Muli base: marker: TBP>>=
- procedure :: indent => marker_indent
-<<Muli base: procedures>>=
- subroutine marker_indent (this, step)
- class(marker_t), intent(inout) :: this
- integer(dik), optional :: step
- if (this%do_break) call this%push (new_line(" "))
- if (this%do_indent) then
- if (present(step)) this%indentation = this%indentation + step
- call this%push (repeat(" ", this%indentation))
- end if
- this%active_pages(1) = this%actual_page()
- end subroutine marker_indent
-
-@ %def marker_indent
-@
-<<Muli base: marker: TBP>>=
- procedure :: push_heap => marker_push_heap
-<<Muli base: procedures>>=
- subroutine marker_push_heap (this, ser, id)
- class(marker_t), intent(inout) :: this
- class(ser_class_t), target, intent(in) :: ser
- integer(dik), intent(in) :: id
- class(serializable_ref_type), pointer :: new_ref
- allocate (new_ref)
- new_ref%next => this%heap
- new_ref%ref => ser
- new_ref%id = id
- this%heap => new_ref
- end subroutine marker_push_heap
-
-@ %def marker_push_heap
-@
-<<Muli base: marker: TBP>>=
- procedure :: pop_heap => marker_pop_heap
-<<Muli base: procedures>>=
- subroutine marker_pop_heap (this, ser)
- class(marker_t), intent(inout) :: this
- class(ser_class_t), pointer, intent(out) :: ser
- class(serializable_ref_type), pointer :: old_ref
- if (associated (this%heap)) then
- old_ref => this%heap
- ser => old_ref%ref
- this%heap => this%heap%next
- deallocate (old_ref)
- else
- call msg_error ("marker_pop_heap: heap_stack is not associated.")
- end if
- end subroutine marker_pop_heap
-
-@ %def marker_pop_heap
-@
-<<Muli base: marker: TBP>>=
- procedure :: push_reference => marker_push_reference
-<<Muli base: procedures>>=
- subroutine marker_push_reference (this, ser, id)
- class(marker_t), intent(inout) :: this
- class(ser_class_t), target, intent(in) :: ser
- integer(kind=dik), intent(in), optional :: id
- class(serializable_ref_type), pointer :: new_ref
- allocate (new_ref)
- new_ref%next => this%references
- new_ref%ref => ser
- if (present(id)) then
- new_ref%id = id
- else
- new_ref%id = -1
- end if
- this%references => new_ref
- end subroutine marker_push_reference
-
-@ %def marker_push_reference
-@
-<<Muli base: marker: TBP>>=
- procedure :: pop_reference => marker_pop_reference
-<<Muli base: procedures>>=
- subroutine marker_pop_reference (this, ser)
- class(marker_t), intent(inout) :: this
- class(ser_class_t), pointer, intent(out) :: ser
- class(serializable_ref_type), pointer :: old_ref
- if (associated (this%references)) then
- old_ref => this%references
- ser => old_ref%ref
- this%references => this%references%next
- deallocate (old_ref)
- else
- call msg_error &
- ("marker_pop_reference: reference_stack is not associated.")
- end if
- end subroutine marker_pop_reference
-
-@ %def marker_pop_reference
-@
-<<Muli base: marker: TBP>>=
- procedure :: reset_references => marker_reset_references
-<<Muli base: procedures>>=
- subroutine marker_reset_references (this)
- class(marker_t), intent(inout) :: this
- if (associated (this%references)) then
- call this%references%finalize ()
- deallocate (this%references)
- end if
- end subroutine marker_reset_references
-
-@ %def marker_reset_references
-@
-<<Muli base: marker: TBP>>=
- procedure :: search_reference => marker_search_reference
-<<Muli base: procedures>>=
- subroutine marker_search_reference (this, type, ser)
- class(marker_t), intent(in) :: this
- integer(dik), dimension(2,2), intent(in) :: type
- class(ser_class_t), pointer, intent(out) :: ser
- !!! !!! !!! NAG bug workaround
- class(ser_class_t), pointer :: tmp_ser
- class(serializable_ref_type), pointer :: ref
- ref => this%references
- nullify (ser)
- do while (associated (ref))
- tmp_ser => ref%ref
- if (tmp_ser%verify_type (this%substring(type))) then
- ser => tmp_ser
- exit
- end if
- ref => ref%next
- end do
- end subroutine marker_search_reference
-
-@ %ref marker_search_reference
-@
-<<Muli base: marker: TBP>>=
- procedure :: reset_heap => marker_reset_heap
-<<Muli base: procedures>>=
- subroutine marker_reset_heap (this)
- class(marker_t), intent(inout) :: this
- if (associated (this%heap)) then
- call this%heap%finalize ()
- deallocate (this%heap)
- end if
- end subroutine marker_reset_heap
-
-@ %def marker_reset_heap
-@
-<<Muli base: marker: TBP>>=
- procedure :: finalize => marker_finalize
-<<Muli base: procedures>>=
- subroutine marker_finalize (this)
- class(marker_t), intent(inout) :: this
- call this%reset_heap ()
- call this%reset_references ()
- end subroutine marker_finalize
-
-@ %def marker_finalize
-@
-<<Muli base: marker: TBP>>=
- generic :: search_heap => search_heap_by_id, search_heap_by_ref
- procedure :: search_heap_by_id => marker_search_heap_by_id
- procedure :: search_heap_by_ref => marker_search_heap_by_ref
-<<Muli base: procedures>>=
- subroutine marker_search_heap_by_ref (this, ref, id)
- class(marker_t), intent(in) :: this
- class(ser_class_t), pointer, intent(in) :: ref
- integer(dik), intent(out) :: id
- class(serializable_ref_type), pointer :: ref_p
- ref_p => this%heap
- id = 0
- do while (associated (ref_p))
- if (associated (ref, ref_p%ref)) then
- id = ref_p%id
- exit
- end if
- ref_p => ref_p%next
- end do
- end subroutine marker_search_heap_by_ref
-
-@ %def marker_search_heap_by_ref
-@
-<<Muli base: procedures>>=
- subroutine marker_search_heap_by_id (this, id, ser)
- class(marker_t), intent(in) :: this
- integer(dik), intent(in) :: id
- class(ser_class_t), pointer, intent(out) :: ser
- class(serializable_ref_type), pointer :: ref
- ref => this%heap
- do while (associated (ref))
- if (id == ref%id) then
- ser => ref%ref
- exit
- end if
- ref => ref%next
- end do
- end subroutine marker_search_heap_by_id
-
-@ %def marker_search_heap_by_id
-@
-<<Muli base: procedures>>=
- elemental function measurable_less_measurable (mea1, mea2)
- class(measure_class_t), intent(in) :: mea1, mea2
- logical :: measurable_less_measurable
- measurable_less_measurable = mea1%measure() < mea2%measure()
- end function measurable_less_measurable
-
-@ %def measurable_less_measurable
-@
-<<Muli base: procedures>>=
- elemental function measurable_less_default (mea1, def)
- class(measure_class_t), intent(in) :: mea1
- real(default), intent(in) :: def
- logical :: measurable_less_default
- measurable_less_default = mea1%measure() < def
- end function measurable_less_default
-
-@ %def measurable_less_default
-@
-<<Muli base: procedures>>=
- elemental function measurable_less_or_equal_measurable (mea1, mea2)
- class(measure_class_t), intent(in) :: mea1, mea2
- logical :: measurable_less_or_equal_measurable
- measurable_less_or_equal_measurable = mea1%measure() <= mea2%measure()
- end function measurable_less_or_equal_measurable
-
-@ %def measurable_less_or_equal_measurable
-@
-<<Muli base: procedures>>=
- elemental function measurable_less_or_equal_default (mea1, def)
- class(measure_class_t), intent(in) :: mea1
- real(default), intent(in) :: def
- logical :: measurable_less_or_equal_default
- measurable_less_or_equal_default = mea1%measure() <= def
- end function measurable_less_or_equal_default
-
-@ %def measurable_less_or_equal_default
-@
-<<Muli base: procedures>>=
- elemental function measurable_equal_measurable (mea1, mea2)
- class(measure_class_t), intent(in) :: mea1, mea2
- logical :: measurable_equal_measurable
- measurable_equal_measurable = mea1%measure() == mea2%measure()
- end function measurable_equal_measurable
-
-@ %def measurable_equal_measurable
-@
-<<Muli base: procedures>>=
- elemental function measurable_equal_default (mea1, def)
- class(measure_class_t), intent(in) :: mea1
- real(default), intent(in) :: def
- logical :: measurable_equal_default
- measurable_equal_default = mea1%measure() == def
- end function measurable_equal_default
-
-@ %def measurable_equal_default
-@
-<<Muli base: procedures>>=
- elemental function measurable_equal_or_greater_measurable (mea1, mea2)
- class(measure_class_t), intent(in) :: mea1, mea2
- logical :: measurable_equal_or_greater_measurable
- measurable_equal_or_greater_measurable = mea1%measure() >= mea2%measure()
- end function measurable_equal_or_greater_measurable
-
-@ %def measurable_equal_or_greater_measurable
-@
-<<Muli base: procedures>>=
- elemental function measurable_equal_or_greater_default (mea1, def)
- class(measure_class_t), intent(in) :: mea1
- real(default), intent(in) :: def
- logical :: measurable_equal_or_greater_default
- measurable_equal_or_greater_default = mea1%measure() >= def
- end function measurable_equal_or_greater_default
-
-@ %def measurable_equal_or_greater_default
-@
-<<Muli base: procedures>>=
- elemental function measurable_greater_measurable (mea1, mea2)
- class(measure_class_t), intent(in) :: mea1,mea2
- logical :: measurable_greater_measurable
- measurable_greater_measurable = mea1%measure() > mea2%measure()
- end function measurable_greater_measurable
-
-@ %def measurable_greater_measurable
-@
-<<Muli base: procedures>>=
- elemental function measurable_greater_default (mea1, def)
- class(measure_class_t), intent(in) :: mea1
- real(default), intent(in) :: def
- logical :: measurable_greater_default
- measurable_greater_default = mea1%measure() > def
- end function measurable_greater_default
-
-@ %def measurable_greater_default
-@
-<<Muli base: procedures>>=
- pure function page_ring_position (n)
- integer(dik), intent(in) :: n
- integer(dik), dimension(2) :: page_ring_position
- page_ring_position(2) = mod(n, serialize_page_size)
- page_ring_position(1) = (n-page_ring_position(2)) / serialize_page_size
- end function page_ring_position
-
-@ %def page_ring_position
-@
-<<Muli base: procedures>>=
- pure integer(dik) function page_ring_ordinal (pos)
- integer(dik), dimension(2), intent(in) :: pos
- page_ring_ordinal = pos(1) * serialize_page_size + pos(2)
- end function page_ring_ordinal
-
-@ %def page_ring_ordinal
-@
-<<Muli base: procedures>>=
- pure logical function page_ring_position_is_before_int_pos (m, n)
- integer(dik), intent(in) :: m
- integer(dik), dimension(2), intent(in) :: n
- if (m < page_ring_ordinal(n)) then
- page_ring_position_is_before_int_pos = .true.
- else
- page_ring_position_is_before_int_pos = .false.
- end if
- end function page_ring_position_is_before_int_pos
-
-@ %def page_ring_position_is_before_int_pos
-@
-<<Muli base: procedures>>=
- pure logical function page_ring_position_is_before_pos_int (m, n)
- integer(dik), dimension(2), intent(in) :: m
- integer(dik), intent(in) :: n
- if (page_ring_ordinal(m) < n) then
- page_ring_position_is_before_pos_int = .true.
- else
- page_ring_position_is_before_pos_int = .false.
- end if
- end function page_ring_position_is_before_pos_int
-
-@ %def page_ring_position_is_before_pos_int
-@
-<<Muli base: procedures>>=
- pure logical function page_ring_position_is_before_pos_pos (m, n)
- integer(dik), dimension(2), intent(in) :: m,n
- if (m(1) < n(1)) then
- page_ring_position_is_before_pos_pos = .true.
- else
- if (m(1) > n(1)) then
- page_ring_position_is_before_pos_pos = .false.
- else
- if (m(2) < n(2)) then
- page_ring_position_is_before_pos_pos = .true.
- else
- page_ring_position_is_before_pos_pos = .false.
- end if
- end if
- end if
- end function page_ring_position_is_before_pos_pos
-
-@ %def page_ring_position_is_before_pos_pos
-@
-<<Muli base: procedures>>=
- subroutine ring_position_increase (pos, n)
- integer(dik), dimension(2), intent(inout) :: pos
- integer(dik), intent(in) :: n
- pos = page_ring_position (page_ring_ordinal(pos) + n)
- end subroutine ring_position_increase
-
-@ %def ring_position_increase
-@
-<<Muli base: procedures>>=
- pure integer(dik) function ring_position_metric1 (p)
- integer(dik), dimension(2,2), intent(in) :: p
- ring_position_metric1 = (p(1,2) - p(1,1)) * serialize_page_size + &
- p(2,2) - p(2,1) + 1
- end function ring_position_metric1
-
- pure integer(dik) function ring_position_metric2 (p1, p2)
- integer(dik), dimension(2), intent(in) :: p1, p2
- ring_position_metric2 = (p2(1) - p1(1)) * &
- serialize_page_size + p2(2) - p1(2) + 1
- end function ring_position_metric2
-
-@ %def ring_position_metric1 ring_position_metric2
-@
-<<Muli base: public>>=
- public :: generate_unit
-<<Muli base: procedures>>=
- subroutine generate_unit (unit, min, max)
- integer, intent(out) :: unit
- integer, intent(in), optional :: min,max
- integer :: min_u, max_u
- logical :: is_open
- ! print *,"generate_unit"
- unit = -1
- if (present (min)) then
- min_u = min
- else
- min_u = 10
- end if
- if (present (max)) then
- max_u = max
- else
- max_u = huge (max_u)
- end if
- do unit = min_u, max_u
- !print *,"testing ",unit
- inquire (unit, opened = is_open)
- if (.not. is_open) then
- exit
- end if
- end do
- end subroutine generate_unit
-
-@ %def generate_unit
-@
-<<Muli base: public>>=
- public :: ilog2
-<<Muli base: procedures>>=
- subroutine ilog2 (int, exp, rem)
- integer,intent(in) :: int
- integer,intent(out) :: exp, rem
- integer :: count
- count = 2
- exp = 1
- do while (count < int)
- exp = exp + 1
- count = ishft(count, 1)
- end do
- if (count > int) then
- rem = (int - ishft(count, -1))
- else
- rem = 0
- end if
- end subroutine ilog2
-
-@ %def ilog2
-@
-<<Muli base: public>>=
- public :: integer_with_leading_zeros
-<<Muli base: procedures>>=
- subroutine integer_with_leading_zeros (number, length, string)
- integer, intent(in) :: number, length
- character(len=*), intent(out) :: string
- integer :: zeros
- character::sign
- if (number == 0) then
- string = repeat("0", length)
- else
- if (number > 0) then
- zeros = length -floor(log10 (real(number))) - 1
- if (zeros < 0) then
- string = repeat("*", length)
- else
- write (string, fmt="(A,I0)") repeat("0", zeros), number
- end if
- else
- zeros = length - floor (log10 (real (-number))) - 2
- if (zeros < 0) then
- string = repeat("*", length)
- else
- write (string, fmt="(A,A,I0)") "-", repeat("0", zeros), &
- abs(number)
- end if
- end if
- end if
- end subroutine integer_with_leading_zeros
-
-@ %def integer_with_leading_zeros
-@
-<<Muli base: procedures>>=
- pure logical function character_is_in (c, array)
- character, intent(in) :: c
- character, dimension(:), intent(in) :: array
- integer(dik) :: n
- character_is_in = .false.
- do n=1,size(array)
- if (c == array(n)) then
- character_is_in = .true.
- exit
- end if
- end do
- end function character_is_in
-
-@ %def character_is_in
-@
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Transverse momenta}
-
-This file contains the module [[muli_momentum]]. Its purpose is to
-store the actual value of the evolution parameter $p_t^2$ in a
-convenient way. We use the normalized value $p_t^2 /
-p_{t,\text{max}}^2$ for generating the next value of the scale, also
-need the square root of both $p_t^2$ and $p_t^2 / p_{t,\text{max}}^2$
-for other purposes. That's why I store all four combinations together
-with $p_{t, \text{max}}$ in an array.
-
-<<[[muli_momentum.f90]]>>=
-<<File header>>
-
-module muli_momentum
-
-<<Use kinds>>
- use constants
- use muli_base
-
-<<Standard module head>>
-
-<<Muli mom: public>>
-
-<<Muli mom: types>>
-
-<<Muli mom: interfaces>>
-
-contains
-
-<<Muli mom: procedures>>
-
-end module muli_momentum
-
-@ %def muli_momentum
-@
-<<Muli mom: public>>=
- public :: transverse_mom_t
-<<Muli mom: types>>=
- type, extends (ser_class_t) :: transverse_mom_t
- private
- real(default), dimension(0:4) :: momentum = [0, 0, 0, 0, 0]
- contains
- <<Muli mom: trans mom: TBP>>
- end type transverse_mom_t
-
-@ %def transverse_mom_t
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: mom_write_to_marker => transverse_mom_write_to_marker
- procedure :: write_to_marker => transverse_mom_write_to_marker
-<<Muli mom: procedures>>=
- subroutine transverse_mom_write_to_marker (this, marker, status)
- class(transverse_mom_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("transverse_mom_t")
- call marker%mark ("gev_momenta", this%momentum(0:1))
- call marker%mark_end ("transverse_mom_t")
- end subroutine transverse_mom_write_to_marker
-
-@ %def transverse_mom_write_to_marker
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: mom_read_from_marker => transverse_mom_read_from_marker
- procedure :: read_from_marker => transverse_mom_read_from_marker
-<<Muli mom: procedures>>=
- subroutine transverse_mom_read_from_marker (this, marker, status)
- class(transverse_mom_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%pick_begin ("transverse_mom_t", status=status)
- call marker%pick ("gev_momenta", this%momentum(0:1), status)
- this%momentum(2:4) = [ this%momentum(1)**2, &
- this%momentum(1) / this%momentum(0), &
- (this%momentum(1)/this%momentum(0))**2 ]
- call marker%pick_end ("transverse_mom_t", status=status)
- end subroutine transverse_mom_read_from_marker
-
-@ %def transverse_mom_read_from_marker
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: mom_print_to_unit => transverse_mom_print_to_unit
- procedure :: print_to_unit => transverse_mom_print_to_unit
-<<Muli mom: procedures>>=
- subroutine transverse_mom_print_to_unit &
- (this, unit, parents, components, peers)
- class(transverse_mom_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- write (unit, "(1x,A)") "Components of transverse_mom_t:"
- write (unit, "(3x,A)") "Actual energy scale:"
- write (unit, "(A,E20.10)") "Max scale (MeV) :", this%momentum(0)
- write (unit, "(A,E20.10)") "Scale (MeV) :", this%momentum(1)
- write (unit, "(A,E20.10)") "Scale^2 (MeV^2) :", this%momentum(2)
- write (unit, "(A,E20.10)") "Scale normalized :", this%momentum(3)
- write (unit, "(A,E20.10)") "Scale^2 normalized:", this%momentum(4)
- end subroutine transverse_mom_print_to_unit
-
-@ %def transverse_mom_print_to_unit
-@
-<<Muli mom: trans mom: TBP>>=
- procedure, nopass :: get_type => transverse_mom_get_type
-<<Muli mom: procedures>>=
- pure subroutine transverse_mom_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="transverse_mom_t")
- end subroutine transverse_mom_get_type
-
-@ %def transverse_mom_get_type
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: get_gev_initial_cme => transverse_mom_get_gev_initial_cme
-<<Muli mom: procedures>>=
- elemental function transverse_mom_get_gev_initial_cme (this) result(scale)
- class(transverse_mom_t), intent(in) :: this
- real(default) :: scale
- scale = this%momentum(0) * 2D0
- end function transverse_mom_get_gev_initial_cme
-
-@ %def transverse_mom_get_gev_initial_cme
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: get_gev_max_scale => transverse_mom_get_gev_max_scale
-<<Muli mom: procedures>>=
- elemental function transverse_mom_get_gev_max_scale (this) result (scale)
- class(transverse_mom_t), intent(in) :: this
- real(default) :: scale
- scale = this%momentum(0)
- end function transverse_mom_get_gev_max_scale
-
-@ %def transverse_mom_get_gev_max_scale
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: get_gev2_max_scale => transverse_mom_get_gev2_max_scale
-<<Muli mom: procedures>>=
- elemental function transverse_mom_get_gev2_max_scale (this) result (scale)
- class(transverse_mom_t), intent(in) :: this
- real(default) :: scale
- scale = this%momentum(0)**2
- end function transverse_mom_get_gev2_max_scale
-
-@ %def transverse_mom_get_gev2_max_scale
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: get_gev_scale => transverse_mom_get_gev_scale
-<<Muli mom: procedures>>=
- elemental function transverse_mom_get_gev_scale(this) result(scale)
- class(transverse_mom_t), intent(in) :: this
- real(default) :: scale
- scale = this%momentum(1)
- end function transverse_mom_get_gev_scale
-
-@ %def transverse_mom_get_gev_scale
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: get_gev2_scale => transverse_mom_get_gev2_scale
-<<Muli mom: procedures>>=
- elemental function transverse_mom_get_gev2_scale (this) result (scale)
- class(transverse_mom_t), intent(in) :: this
- real(default) :: scale
- scale = this%momentum(2)
- end function transverse_mom_get_gev2_scale
-
-@ %def transverse_mom_get_gev2_scale
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: get_unit_scale => transverse_mom_get_unit_scale
-<<Muli mom: procedures>>=
- pure function transverse_mom_get_unit_scale (this) result (scale)
- class(transverse_mom_t), intent(in) :: this
- real(default) :: scale
- scale = this%momentum(3)
- end function transverse_mom_get_unit_scale
-
-@ %def transverse_mom_get_unit_scale
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: get_unit2_scale => transverse_mom_get_unit2_scale
-<<Muli mom: procedures>>=
- pure function transverse_mom_get_unit2_scale (this) result (scale)
- class(transverse_mom_t), intent(in) :: this
- real(default) :: scale
- scale = this%momentum(4)
- end function transverse_mom_get_unit2_scale
-
-@ %def transverse_mom_get_unit2_scale
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: set_gev_initial_cme => transverse_mom_set_gev_initial_cme
-<<Muli mom: procedures>>=
- subroutine transverse_mom_set_gev_initial_cme (this, new_gev_initial_cme)
- class(transverse_mom_t), intent(inout) :: this
- real(default), intent(in) :: new_gev_initial_cme
- this%momentum(0) = new_gev_initial_cme / 2D0
- this%momentum(3) = this%momentum(1) / this%momentum(0)
- this%momentum(4) = this%momentum(3)**2
- end subroutine transverse_mom_set_gev_initial_cme
-
-@ %def transverse_mom_set_gev_initial_cme
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: set_gev_max_scale => transverse_mom_set_gev_max_scale
-<<Muli mom: procedures>>=
- subroutine transverse_mom_set_gev_max_scale (this, new_gev_max_scale)
- class(transverse_mom_t), intent(inout) :: this
- real(default), intent(in) :: new_gev_max_scale
- this%momentum(0) = new_gev_max_scale
- this%momentum(3) = this%momentum(1) / this%momentum(0)
- this%momentum(4) = this%momentum(3)**2
- end subroutine transverse_mom_set_gev_max_scale
-
-@ %def transverse_mom_set_gev_max_scale
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: set_gev2_max_scale => transverse_mom_set_gev2_max_scale
-<<Muli mom: procedures>>=
- subroutine transverse_mom_set_gev2_max_scale (this, new_gev2_max_scale)
- class(transverse_mom_t), intent(inout) :: this
- real(default), intent(in) :: new_gev2_max_scale
- this%momentum(0) = sqrt (new_gev2_max_scale)
- this%momentum(3) = this%momentum(1) / this%momentum(0)
- this%momentum(4) = this%momentum(3)**2
- end subroutine transverse_mom_set_gev2_max_scale
-
-@ %def transverse_mom_set_gev2_max_scale
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: set_gev_scale => transverse_mom_set_gev_scale
-<<Muli mom: procedures>>=
- subroutine transverse_mom_set_gev_scale (this, new_gev_scale)
- class(transverse_mom_t), intent(inout) :: this
- real(default), intent(in) :: new_gev_scale
- this%momentum(1) = new_gev_scale
- this%momentum(2) = new_gev_scale**2
- this%momentum(3) = new_gev_scale / this%momentum(0)
- this%momentum(4) = this%momentum(3)**2
- end subroutine transverse_mom_set_gev_scale
-
-@ %def transverse_mom_set_gev_scale
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: set_gev2_scale => transverse_mom_set_gev2_scale
-<<Muli mom: procedures>>=
- subroutine transverse_mom_set_gev2_scale (this, new_gev2_scale)
- class(transverse_mom_t), intent(inout) :: this
- real(default), intent(in) :: new_gev2_scale
- this%momentum(1) = sqrt (new_gev2_scale)
- this%momentum(2) = new_gev2_scale
- this%momentum(3) = this%momentum(1) / this%momentum(0)
- this%momentum(4) = this%momentum(3)**2
- end subroutine transverse_mom_set_gev2_scale
-
-@ %def transverse_mom_set_gev2_scale
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: set_unit_scale => transverse_mom_set_unit_scale
-<<Muli mom: procedures>>=
- subroutine transverse_mom_set_unit_scale (this, new_unit_scale)
- class(transverse_mom_t), intent(inout)::this
- real(default), intent(in) :: new_unit_scale
- this%momentum(1) = new_unit_scale * this%momentum(0)
- this%momentum(2) = this%momentum(1)**2
- this%momentum(3) = new_unit_scale
- this%momentum(4) = this%momentum(3)**2
- end subroutine transverse_mom_set_unit_scale
-
-@ %def transverse_mom_set_unit_scale
-@
-<<Muli mom: trans mom: TBP>>=
- procedure :: set_unit2_scale => transverse_mom_set_unit2_scale
-<<Muli mom: procedures>>=
- subroutine transverse_mom_set_unit2_scale (this, new_unit2_scale)
- class(transverse_mom_t), intent(inout)::this
- real(default), intent(in) :: new_unit2_scale
- this%momentum(3) = sqrt (new_unit2_scale)
- this%momentum(4) = new_unit2_scale
- this%momentum(1) = this%momentum(3) * this%momentum(0)
- this%momentum(2) = this%momentum(1)**2
- end subroutine transverse_mom_set_unit2_scale
-
-@ %def transverse_mom_set_unit2_scale
-@
-<<Muli mom: trans mom: TBP>>=
- generic :: initialize => transverse_mom_initialize
- procedure :: transverse_mom_initialize
-<<Muli mom: procedures>>=
- subroutine transverse_mom_initialize (this, gev2_s)
- class(transverse_mom_t), intent(out) :: this
- real(default), intent(in) :: gev2_s
- real(default) :: gev_s
- gev_s = sqrt (gev2_s)
- this%momentum = [gev_s/2, gev_s/2, gev2_s/4, one, one]
- end subroutine transverse_mom_initialize
-
-@ %def transverse_mom_initialize
-@
-<<Muli mom: public>>=
- public :: qcd_2_2_class
-<<Muli mom: types>>=
- type, extends (transverse_mom_t), abstract :: qcd_2_2_class
- contains
- <<Muli mom: QCD22: TBP>>
- end type qcd_2_2_class
-
-@ %def qcd_2_2_class
-@
-<<Muli mom: QCD22: TBP>>=
- procedure(qcd_get_int), deferred :: get_process_id
-<<Muli mom: QCD22: TBP>>=
- procedure(qcd_get_int), deferred :: get_integrand_id
-<<Muli mom: QCD22: TBP>>=
- procedure(qcd_get_int), deferred :: get_diagram_kind
-<<Muli mom: QCD22: TBP>>=
- procedure(qcd_get_int_4), deferred :: get_lha_flavors
-<<Muli mom: QCD22: TBP>>=
- procedure(qcd_get_int_4), deferred :: get_pdg_flavors
-<<Muli mom: QCD22: TBP>>=
- procedure(qcd_get_int_by_int), deferred :: get_parton_id
-<<Muli mom: QCD22: TBP>>=
- procedure(qcd_get_int_2), deferred :: get_parton_kinds
-<<Muli mom: QCD22: TBP>>=
- procedure(qcd_get_int_2), deferred :: get_pdf_int_kinds
-<<Muli mom: QCD22: TBP>>=
- procedure(qcd_get_real), deferred :: get_momentum_boost
-<<Muli mom: QCD22: TBP>>=
- ! procedure(qcd_get_real_3),deferred :: get_parton_in_momenta
-<<Muli mom: QCD22: TBP>>=
- procedure(qcd_get_real_2), deferred :: get_remnant_momentum_fractions
-<<Muli mom: QCD22: TBP>>=
- procedure(qcd_get_real_2), deferred :: get_total_momentum_fractions
-<<Muli mom: interfaces>>=
- abstract interface
- subroutine qcd_none (this)
- import qcd_2_2_class
- class(qcd_2_2_class), target, intent(in) :: this
- end subroutine qcd_none
- end interface
-@ %def qcd_none
-@
-<<Muli mom: interfaces>>=
- ! abstract interface
- ! subroutine qcd_get_beam (this, beam)
- ! import qcd_2_2_class
- ! import pp_remnant_class
- ! class(qcd_2_2_class),target, intent(in) :: this
- ! class(pp_remnant_class),pointer, intent(out) :: beam
- ! end subroutine qcd_get_beam
- ! end interface
-@ %def qcd_get_beam
-@
-<<Muli mom: interfaces>>=
- abstract interface
- elemental function qcd_get_real (this)
- import
- class(qcd_2_2_class), intent(in) :: this
- real(default) :: qcd_get_real
- end function qcd_get_real
- end interface
-@ %def qcd_get_real
-@
-<<Muli mom: interfaces>>=
- abstract interface
- pure function qcd_get_real_2 (this)
- import
- class(qcd_2_2_class), intent(in) :: this
- real(default), dimension(2) :: qcd_get_real_2
- end function qcd_get_real_2
- end interface
-@ %def qcd_get_real_2
-@
-<<Muli mom: interfaces>>=
- abstract interface
- pure function qcd_get_real_3 (this)
- import
- class(qcd_2_2_class), intent(in) :: this
- real(default), dimension(3) :: qcd_get_real_3
- end function qcd_get_real_3
- end interface
-@ %def qcd_get_real_3
-@
-<<Muli mom: interfaces>>=
- abstract interface
- elemental function qcd_get_int (this)
- import
- class(qcd_2_2_class), intent(in) :: this
- integer :: qcd_get_int
- end function qcd_get_int
- end interface
-@ %def qcd_get_int
-@
-<<Muli mom: interfaces>>=
- abstract interface
- pure function qcd_get_int_by_int (this, n)
- import
- class(qcd_2_2_class), intent(in) :: this
- integer, intent(in) :: n
- integer :: qcd_get_int_by_int
- end function qcd_get_int_by_int
- end interface
-@ %def qcd_get_int_by_int
-@
-<<Muli mom: interfaces>>=
- abstract interface
- pure function qcd_get_int_2 (this)
- import
- class(qcd_2_2_class), intent(in) :: this
- integer, dimension(2) :: qcd_get_int_2
- end function qcd_get_int_2
- end interface
-@ %def qcd_get_int_2
-@
-<<Muli mom: interfaces>>=
- abstract interface
- pure function qcd_get_int_4 (this)
- import
- class(qcd_2_2_class), intent(in) :: this
- integer, dimension(4) :: qcd_get_int_4
- end function qcd_get_int_4
- end interface
-
-@ %def qcd_get_int_t
-@
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Multi parton interactions}
-
-This file contains the module [[muli_interactions]]. The allowed
-interactions and their cross sections are defined here. Additionaly,
-some coordinate transformations which annihilate divergencies of the
-cross sections are defined. Since the phase space border is
-hyperbolic, this transformations are also hyperbolic. That's why all
-interactions are named [[x_cart]] for cartesian or [[x_hyp]] for
-hyperbolic to avoid confusion.
-
-<<[[muli_interactions.f90]]>>=
-<<File header>>
-
-module muli_interactions
-
-<<Use kinds with double>>
- use constants
- use muli_momentum
-
-<<Standard module head>>
-
-<<Muli interactions: public>>
-
-<<Muli interactions: variables>>
-
-<<Muli interactions: interfaces>>
-
-contains
-
-<<Muli interactions: procedures>>
-
-end module muli_interactions
-
-@ %def muli_interactions
-@
-<<Muli interactions: variables>>=
- character(len=2), dimension(-6:6), parameter :: integer_parton_names = &
- ["-6", "-5", "-4", "-3", "-2", "-1", "00", &
- "+1", "+2", "+3", "+4", "+5", "+6" ]
- character, dimension(-6:6),parameter :: traditional_parton_names = &
- ["T", "B", "C", "S", "U", "D", "g", "d", "u", "s", "c", "b", "t"]
-@ %def integer_parton_names traditional_parton_names
-@ These are the phase space coefficients of the polynomial mappings,
-the evolution variable is [[pt2s/(x1*x2)]].
-<<Muli interactions: variables>>=
- real(default), dimension(1:4,1:5), parameter :: &
- phase_space_coefficients_in = reshape (source = &
- [ 6144, -4608, +384, 0, &
- 6144, -5120, +384, 0, &
- 6144, -2048, +128, -576, &
- 13824, -9600, +1056, 0, &
- 31104,-19872, +2160, +486 ], shape=[4,5])
-@ %def phase_space_coefficients_in
-@
-<<Muli interactions: variables>>=
- integer, parameter :: hadron_A_kind = 2212
- integer, parameter :: hadron_B_kind = -2212
- integer, dimension(4), parameter, public :: &
- parton_kind_of_int_kind = [1, 1, 2, 2]
- real(default), parameter :: b_sigma_tot_all = 100 !mb PDG
- real(default), parameter :: &
- b_sigma_tot_nd = 0.5*b_sigma_tot_all !!! PRD 49 n5 1994
- real(default), parameter, public :: &
- gev_cme_tot = 14000 ! total center of mass energie
- real(default), parameter :: gev2_cme_tot = gev_cme_tot**2 !!! s
- real(default), parameter :: gev_pt_max = gev_cme_tot/2D0
- real(default), parameter :: gev2_pt_max = gev2_cme_tot/4D0
- !model parameters
- real(default), parameter :: gev_pt_min = 8E-1_default
- real(default), parameter :: gev2_pt_min = gev_pt_min**2
- real(default), parameter :: pts_min = gev_pt_min / gev_pt_max
- real(default), parameter :: pts2_min = gev2_pt_min / gev2_pt_max
- real(default), parameter :: gev_p_t_0 = 2.0
- real(default), parameter :: gev2_p_t_0 = gev_p_t_0**2
- real(default), parameter :: norm_p_t_0 = gev_p_t_0 / gev_pt_max
- real(default), parameter :: norm2_p_t_0 = gev2_p_t_0 / gev2_pt_max
- !mathematical constants
- real(default), parameter, public :: euler = exp(one)
- !physical constants
- real(default), parameter :: gev2_mbarn = 0.389379304_default
- real(default), parameter :: const_pref = pi * gev2_mbarn / &
- (gev2_cme_tot * b_sigma_tot_nd)
-
-@
-@
-<<Muli interactions: variables>>=
- integer, parameter, public :: LHA_FLAVOR_AT = -6
- integer, parameter, public :: LHA_FLAVOR_AB = -5
- integer, parameter, public :: LHA_FLAVOR_AC = -4
- integer, parameter, public :: LHA_FLAVOR_AS = -3
- integer, parameter, public :: LHA_FLAVOR_AU = -2
- integer, parameter, public :: LHA_FLAVOR_AD = -1
- integer, parameter, public :: LHA_FLAVOR_G = 0
- integer, parameter, public :: LHA_FLAVOR_D = 1
- integer, parameter, public :: LHA_FLAVOR_U = 2
- integer, parameter, public :: LHA_FLAVOR_S = 3
- integer, parameter, public :: LHA_FLAVOR_C = 4
- integer, parameter, public :: LHA_FLAVOR_B = 5
- integer, parameter, public :: LHA_FLAVOR_T = 6
-
-@ %def LHA_FLAVOR_AT, LHA_FLAVOR_T, LHA_FLAVOR_AB, LHA_FLAVOR_B
-@ %def LHA_FLAVOR_AC, LHA_FLAVOR_C, LHA_FLAVOR_AS, LHA_FLAVOR_S
-@ %def LHA_FLAVOR_AU, LHA_FLAVOR_U, LHA_FLAVOR_AD, LHA_FLAVOR_D
-@ %def LHA_FLAVOR_G
-@
-<<Muli interactions: variables>>=
- integer, parameter, public :: PDG_FLAVOR_AT = -6
- integer, parameter, public :: PDG_FLAVOR_AB = -5
- integer, parameter, public :: PDG_FLAVOR_AC = -4
- integer, parameter, public :: PDG_FLAVOR_AS = -3
- integer, parameter, public :: PDG_FLAVOR_AU = -2
- integer, parameter, public :: PDG_FLAVOR_AD = -1
- integer, parameter, public :: PDG_FLAVOR_G = 21
- integer, parameter, public :: PDG_FLAVOR_D = 1
- integer, parameter, public :: PDG_FLAVOR_U = 2
- integer, parameter, public :: PDG_FLAVOR_S = 3
- integer, parameter, public :: PDG_FLAVOR_C = 4
- integer, parameter, public :: PDG_FLAVOR_B = 5
- integer, parameter, public :: PDG_FLAVOR_T = 6
-
-@ %def PDG_FLAVOR_AT, PDG_FLAVOR_T, PDG_FLAVOR_AB, PDG_FLAVOR_B
-@ %def PDG_FLAVOR_AC, PDG_FLAVOR_C, PDG_FLAVOR_AS, PDG_FLAVOR_S
-@ %def PDG_FLAVOR_AU, PDG_FLAVOR_U, PDG_FLAVOR_AD, PDG_FLAVOR_D
-@ %def PDG_FLAVOR_G
-@
-<<Muli interactions: variables>>=
- integer, parameter, public :: PARTON_SEA = 1
- integer, parameter, public :: PARTON_VALENCE = 2
- integer, parameter, public :: PARTON_SEA_AND_VALENCE = 3
- integer, parameter, public :: PARTON_TWIN = 4
- integer, parameter, public :: PARTON_SEA_AND_TWIN = 5
- integer, parameter, public :: PARTON_VALENCE_AND_TWIN = 6
- integer, parameter, public :: PARTON_ALL = 7
-
-@ %def PARTON_SEA PARTON_VALENCE PARTON_SEA_AND_VALENCE
-@ %def PARTON_TWIN PARTON_SEA_AND_TWIN PARTON_VALENCE_AND_TWIN PARTON_ALL
-@
-<<Muli interactions: variables>>=
- integer, parameter, public :: PDF_UNDEFINED = 0
- integer, parameter, public :: PDF_GLUON = 1
- integer, parameter, public :: PDF_SEA = 2
- integer, parameter, public :: PDF_VALENCE_DOWN = 3
- integer, parameter, public :: PDF_VALENCE_UP = 4
- integer, parameter, public :: PDF_TWIN = 5
-
-@ %def PDF_UNDEFINED, PDF_GLUON, PDF_SEA
-@ %def PDF_VALENCE_DOWN, PDF_VALENCE_UP, PDF_TWIN
-@ Evolution variable is [[pt2s/(x1*x2)]].
-<<Muli interactions: variables>>=
- real(default), dimension(1:4,1:8),parameter :: &
- phase_space_coefficients_inout = reshape(source=[ &
- 3072, -2304, +192, 0, &
- 6144, -5120, +384, 0, &
- 0, 0, 192, -96, &
- 3072, -2048, +192, -96, &
- 0, 2048, -2176, +576, &
- 0, 288, -306, +81, &
- 6912, -4800, +528, 0, &
- 31104,-23328, +5832, -486], &
- shape=[4,8])
-
-@ %def phase_space_coefficients_inout
-@
-<<Muli interactions: variables>>=
- integer, dimension(1:4,0:8), parameter :: inout_signatures = &
- reshape (source = [ &
- 1, 1, 1, 1, & !1a
- -1, 1,-1, 1, & !1b
- 1, 1, 1, 1, & !2
- 1,-1, 1,-1, & !3
- 1,-1, 1,-1, & !4
- 1,-1, 0, 0, & !5
- 0, 0, 1,-1, & !6
- 1, 0, 1, 0, & !7
- 0, 0, 0, 0 ], &
- shape = [4,9])
-
-@ %def inout_signatures
-@
-<<Muli interactions: variables>>=
- integer, dimension(6,-234:234), save, public :: valid_processes
- data valid_processes (:,-234) / -6, -6, -6, -6, 2, 2 /
- data valid_processes (:,-233) / -6, -5, -6, -5, 1, 1 /
- data valid_processes (:,-232) / -6, -5, -5, -6, 1, 1 /
- data valid_processes (:,-231) / -6, -4, -6, -4, 1, 1 /
- data valid_processes (:,-230) / -6, -4, -4, -6, 1, 1 /
- data valid_processes (:,-229) / -6, -3, -6, -3, 1, 1 /
- data valid_processes (:,-228) / -6, -3, -3, -6, 1, 1 /
- data valid_processes (:,-227) / -6, -2, -6, -2, 1, 1 /
- data valid_processes (:,-226) / -6, -2, -2, -6, 1, 1 /
- data valid_processes (:,-225) / -6, -1, -6, -1, 1, 1 /
- data valid_processes (:,-224) / -6, -1, -1, -6, 1, 1 /
- data valid_processes (:,-223) / -6, 0, -6, 0, 4, 7 /
- data valid_processes (:,-222) / -6, 0, 0, -6, 4, 7 /
- data valid_processes (:,-221) / -6, 1, -6, 1, 1, 1 /
- data valid_processes (:,-220) / -6, 1, 1, -6, 1, 1 /
- data valid_processes (:,-219) / -6, 2, -6, 2, 1, 1 /
- data valid_processes (:,-218) / -6, 2, 2, -6, 1, 1 /
- data valid_processes (:,-217) / -6, 3, -6, 3, 1, 1 /
- data valid_processes (:,-216) / -6, 3, 3, -6, 1, 1 /
- data valid_processes (:,-215) / -6, 4, -6, 4, 1, 1 /
- data valid_processes (:,-214) / -6, 4, 4, -6, 1, 1 /
- data valid_processes (:,-213) / -6, 5, -6, 5, 1, 1 /
- data valid_processes (:,-212) / -6, 5, 5, -6, 1, 1 /
- data valid_processes (:,-211) / -6, 6, -6, 6, 3, 4 /
- data valid_processes (:,-210) / -6, 6, -5, 5, 3, 3 /
- data valid_processes (:,-209) / -6, 6, -4, 4, 3, 3 /
- data valid_processes (:,-208) / -6, 6, -3, 3, 3, 3 /
- data valid_processes (:,-207) / -6, 6, -2, 2, 3, 3 /
- data valid_processes (:,-206) / -6, 6, -1, 1, 3, 3 /
- data valid_processes (:,-205) / -6, 6, 0, 0, 3, 5 /
- data valid_processes (:,-204) / -6, 6, 1, -1, 3, 3 /
- data valid_processes (:,-203) / -6, 6, 2, -2, 3, 3 /
- data valid_processes (:,-202) / -6, 6, 3, -3, 3, 3 /
- data valid_processes (:,-201) / -6, 6, 4, -4, 3, 3 /
- data valid_processes (:,-200) / -6, 6, 5, -5, 3, 3 /
- data valid_processes (:,-199) / -6, 6, 6, -6, 3, 4 /
- data valid_processes (:,-198) / -5, -6, -6, -5, 1, 1 /
- data valid_processes (:,-197) / -5, -6, -5, -6, 1, 1 /
- data valid_processes (:,-196) / -5, -5, -5, -5, 2, 2 /
- data valid_processes (:,-195) / -5, -4, -5, -4, 1, 1 /
- data valid_processes (:,-194) / -5, -4, -4, -5, 1, 1 /
- data valid_processes (:,-193) / -5, -3, -5, -3, 1, 1 /
- data valid_processes (:,-192) / -5, -3, -3, -5, 1, 1 /
- data valid_processes (:,-191) / -5, -2, -5, -2, 1, 1 /
- data valid_processes (:,-190) / -5, -2, -2, -5, 1, 1 /
- data valid_processes (:,-189) / -5, -1, -5, -1, 1, 1 /
- data valid_processes (:,-188) / -5, -1, -1, -5, 1, 1 /
- data valid_processes (:,-187) / -5, 0, -5, 0, 4, 7 /
- data valid_processes (:,-186) / -5, 0, 0, -5, 4, 7 /
- data valid_processes (:,-185) / -5, 1, -5, 1, 1, 1 /
- data valid_processes (:,-184) / -5, 1, 1, -5, 1, 1 /
- data valid_processes (:,-183) / -5, 2, -5, 2, 1, 1 /
- data valid_processes (:,-182) / -5, 2, 2, -5, 1, 1 /
- data valid_processes (:,-181) / -5, 3, -5, 3, 1, 1 /
- data valid_processes (:,-180) / -5, 3, 3, -5, 1, 1 /
- data valid_processes (:,-179) / -5, 4, -5, 4, 1, 1 /
- data valid_processes (:,-178) / -5, 4, 4, -5, 1, 1 /
- data valid_processes (:,-177) / -5, 5, -6, 6, 3, 3 /
- data valid_processes (:,-176) / -5, 5, -5, 5, 3, 4 /
- data valid_processes (:,-175) / -5, 5, -4, 4, 3, 3 /
- data valid_processes (:,-174) / -5, 5, -3, 3, 3, 3 /
- data valid_processes (:,-173) / -5, 5, -2, 2, 3, 3 /
- data valid_processes (:,-172) / -5, 5, -1, 1, 3, 3 /
- data valid_processes (:,-171) / -5, 5, 0, 0, 3, 5 /
- data valid_processes (:,-170) / -5, 5, 1, -1, 3, 3 /
- data valid_processes (:,-169) / -5, 5, 2, -2, 3, 3 /
- data valid_processes (:,-168) / -5, 5, 3, -3, 3, 3 /
- data valid_processes (:,-167) / -5, 5, 4, -4, 3, 3 /
- data valid_processes (:,-166) / -5, 5, 5, -5, 3, 4 /
- data valid_processes (:,-165) / -5, 5, 6, -6, 3, 3 /
- data valid_processes (:,-164) / -5, 6, -5, 6, 1, 1 /
- data valid_processes (:,-163) / -5, 6, 6, -5, 1, 1 /
- data valid_processes (:,-162) / -4, -6, -6, -4, 1, 1 /
- data valid_processes (:,-161) / -4, -6, -4, -6, 1, 1 /
- data valid_processes (:,-160) / -4, -5, -5, -4, 1, 1 /
- data valid_processes (:,-159) / -4, -5, -4, -5, 1, 1 /
- data valid_processes (:,-158) / -4, -4, -4, -4, 2, 2 /
- data valid_processes (:,-157) / -4, -3, -4, -3, 1, 1 /
- data valid_processes (:,-156) / -4, -3, -3, -4, 1, 1 /
- data valid_processes (:,-155) / -4, -2, -4, -2, 1, 1 /
- data valid_processes (:,-154) / -4, -2, -2, -4, 1, 1 /
- data valid_processes (:,-153) / -4, -1, -4, -1, 1, 1 /
- data valid_processes (:,-152) / -4, -1, -1, -4, 1, 1 /
- data valid_processes (:,-151) / -4, 0, -4, 0, 4, 7 /
- data valid_processes (:,-150) / -4, 0, 0, -4, 4, 7 /
- data valid_processes (:,-149) / -4, 1, -4, 1, 1, 1 /
- data valid_processes (:,-148) / -4, 1, 1, -4, 1, 1 /
- data valid_processes (:,-147) / -4, 2, -4, 2, 1, 1 /
- data valid_processes (:,-146) / -4, 2, 2, -4, 1, 1 /
- data valid_processes (:,-145) / -4, 3, -4, 3, 1, 1 /
- data valid_processes (:,-144) / -4, 3, 3, -4, 1, 1 /
- data valid_processes (:,-143) / -4, 4, -6, 6, 3, 3 /
- data valid_processes (:,-142) / -4, 4, -5, 5, 3, 3 /
- data valid_processes (:,-141) / -4, 4, -4, 4, 3, 4 /
- data valid_processes (:,-140) / -4, 4, -3, 3, 3, 3 /
- data valid_processes (:,-139) / -4, 4, -2, 2, 3, 3 /
- data valid_processes (:,-138) / -4, 4, -1, 1, 3, 3 /
- data valid_processes (:,-137) / -4, 4, 0, 0, 3, 5 /
- data valid_processes (:,-136) / -4, 4, 1, -1, 3, 3 /
- data valid_processes (:,-135) / -4, 4, 2, -2, 3, 3 /
- data valid_processes (:,-134) / -4, 4, 3, -3, 3, 3 /
- data valid_processes (:,-133) / -4, 4, 4, -4, 3, 4 /
- data valid_processes (:,-132) / -4, 4, 5, -5, 3, 3 /
- data valid_processes (:,-131) / -4, 4, 6, -6, 3, 3 /
- data valid_processes (:,-130) / -4, 5, -4, 5, 1, 1 /
- data valid_processes (:,-129) / -4, 5, 5, -4, 1, 1 /
- data valid_processes (:,-128) / -4, 6, -4, 6, 1, 1 /
- data valid_processes (:,-127) / -4, 6, 6, -4, 1, 1 /
- data valid_processes (:,-126) / -3, -6, -6, -3, 1, 1 /
- data valid_processes (:,-125) / -3, -6, -3, -6, 1, 1 /
- data valid_processes (:,-124) / -3, -5, -5, -3, 1, 1 /
- data valid_processes (:,-123) / -3, -5, -3, -5, 1, 1 /
- data valid_processes (:,-122) / -3, -4, -4, -3, 1, 1 /
- data valid_processes (:,-121) / -3, -4, -3, -4, 1, 1 /
- data valid_processes (:,-120) / -3, -3, -3, -3, 2, 2 /
- data valid_processes (:,-119) / -3, -2, -3, -2, 1, 1 /
- data valid_processes (:,-118) / -3, -2, -2, -3, 1, 1 /
- data valid_processes (:,-117) / -3, -1, -3, -1, 1, 1 /
- data valid_processes (:,-116) / -3, -1, -1, -3, 1, 1 /
- data valid_processes (:,-115) / -3, 0, -3, 0, 4, 7 /
- data valid_processes (:,-114) / -3, 0, 0, -3, 4, 7 /
- data valid_processes (:,-113) / -3, 1, -3, 1, 1, 1 /
- data valid_processes (:,-112) / -3, 1, 1, -3, 1, 1 /
- data valid_processes (:,-111) / -3, 2, -3, 2, 1, 1 /
- data valid_processes (:,-110) / -3, 2, 2, -3, 1, 1 /
- data valid_processes (:,-109) / -3, 3, -6, 6, 3, 3 /
- data valid_processes (:,-108) / -3, 3, -5, 5, 3, 3 /
- data valid_processes (:,-107) / -3, 3, -4, 4, 3, 3 /
- data valid_processes (:,-106) / -3, 3, -3, 3, 3, 4 /
- data valid_processes (:,-105) / -3, 3, -2, 2, 3, 3 /
- data valid_processes (:,-104) / -3, 3, -1, 1, 3, 3 /
- data valid_processes (:,-103) / -3, 3, 0, 0, 3, 5 /
- data valid_processes (:,-102) / -3, 3, 1, -1, 3, 3 /
- data valid_processes (:,-101) / -3, 3, 2, -2, 3, 3 /
- data valid_processes (:,-100) / -3, 3, 3, -3, 3, 4 /
- data valid_processes (:, -99) / -3, 3, 4, -4, 3, 3 /
- data valid_processes (:, -98) / -3, 3, 5, -5, 3, 3 /
- data valid_processes (:, -97) / -3, 3, 6, -6, 3, 3 /
- data valid_processes (:, -96) / -3, 4, -3, 4, 1, 1 /
- data valid_processes (:, -95) / -3, 4, 4, -3, 1, 1 /
- data valid_processes (:, -94) / -3, 5, -3, 5, 1, 1 /
- data valid_processes (:, -93) / -3, 5, 5, -3, 1, 1 /
- data valid_processes (:, -92) / -3, 6, -3, 6, 1, 1 /
- data valid_processes (:, -91) / -3, 6, 6, -3, 1, 1 /
- data valid_processes (:, -90) / -2, -6, -6, -2, 1, 1 /
- data valid_processes (:, -89) / -2, -6, -2, -6, 1, 1 /
- data valid_processes (:, -88) / -2, -5, -5, -2, 1, 1 /
- data valid_processes (:, -87) / -2, -5, -2, -5, 1, 1 /
- data valid_processes (:, -86) / -2, -4, -4, -2, 1, 1 /
- data valid_processes (:, -85) / -2, -4, -2, -4, 1, 1 /
- data valid_processes (:, -84) / -2, -3, -3, -2, 1, 1 /
- data valid_processes (:, -83) / -2, -3, -2, -3, 1, 1 /
- data valid_processes (:, -82) / -2, -2, -2, -2, 2, 2 /
- data valid_processes (:, -81) / -2, -1, -2, -1, 1, 1 /
- data valid_processes (:, -80) / -2, -1, -1, -2, 1, 1 /
- data valid_processes (:, -79) / -2, 0, -2, 0, 4, 7 /
- data valid_processes (:, -78) / -2, 0, 0, -2, 4, 7 /
- data valid_processes (:, -77) / -2, 1, -2, 1, 1, 1 /
- data valid_processes (:, -76) / -2, 1, 1, -2, 1, 1 /
- data valid_processes (:, -75) / -2, 2, -6, 6, 3, 3 /
- data valid_processes (:, -74) / -2, 2, -5, 5, 3, 3 /
- data valid_processes (:, -73) / -2, 2, -4, 4, 3, 3 /
- data valid_processes (:, -72) / -2, 2, -3, 3, 3, 3 /
- data valid_processes (:, -71) / -2, 2, -2, 2, 3, 4 /
- data valid_processes (:, -70) / -2, 2, -1, 1, 3, 3 /
- data valid_processes (:, -69) / -2, 2, 0, 0, 3, 5 /
- data valid_processes (:, -68) / -2, 2, 1, -1, 3, 3 /
- data valid_processes (:, -67) / -2, 2, 2, -2, 3, 4 /
- data valid_processes (:, -66) / -2, 2, 3, -3, 3, 3 /
- data valid_processes (:, -65) / -2, 2, 4, -4, 3, 3 /
- data valid_processes (:, -64) / -2, 2, 5, -5, 3, 3 /
- data valid_processes (:, -63) / -2, 2, 6, -6, 3, 3 /
- data valid_processes (:, -62) / -2, 3, -2, 3, 1, 1 /
- data valid_processes (:, -61) / -2, 3, 3, -2, 1, 1 /
- data valid_processes (:, -60) / -2, 4, -2, 4, 1, 1 /
- data valid_processes (:, -59) / -2, 4, 4, -2, 1, 1 /
- data valid_processes (:, -58) / -2, 5, -2, 5, 1, 1 /
- data valid_processes (:, -57) / -2, 5, 5, -2, 1, 1 /
- data valid_processes (:, -56) / -2, 6, -2, 6, 1, 1 /
- data valid_processes (:, -55) / -2, 6, 6, -2, 1, 1 /
- data valid_processes (:, -54) / -1, -6, -6, -1, 1, 1 /
- data valid_processes (:, -53) / -1, -6, -1, -6, 1, 1 /
- data valid_processes (:, -52) / -1, -5, -5, -1, 1, 1 /
- data valid_processes (:, -51) / -1, -5, -1, -5, 1, 1 /
- data valid_processes (:, -50) / -1, -4, -4, -1, 1, 1 /
- data valid_processes (:, -49) / -1, -4, -1, -4, 1, 1 /
- data valid_processes (:, -48) / -1, -3, -3, -1, 1, 1 /
- data valid_processes (:, -47) / -1, -3, -1, -3, 1, 1 /
- data valid_processes (:, -46) / -1, -2, -2, -1, 1, 1 /
- data valid_processes (:, -45) / -1, -2, -1, -2, 1, 1 /
- data valid_processes (:, -44) / -1, -1, -1, -1, 2, 2 /
- data valid_processes (:, -43) / -1, 0, -1, 0, 4, 7 /
- data valid_processes (:, -42) / -1, 0, 0, -1, 4, 7 /
- data valid_processes (:, -41) / -1, 1, -6, 6, 3, 3 /
- data valid_processes (:, -40) / -1, 1, -5, 5, 3, 3 /
- data valid_processes (:, -39) / -1, 1, -4, 4, 3, 3 /
- data valid_processes (:, -38) / -1, 1, -3, 3, 3, 3 /
- data valid_processes (:, -37) / -1, 1, -2, 2, 3, 3 /
- data valid_processes (:, -36) / -1, 1, -1, 1, 3, 4 /
- data valid_processes (:, -35) / -1, 1, 0, 0, 3, 5 /
- data valid_processes (:, -34) / -1, 1, 1, -1, 3, 4 /
- data valid_processes (:, -33) / -1, 1, 2, -2, 3, 3 /
- data valid_processes (:, -32) / -1, 1, 3, -3, 3, 3 /
- data valid_processes (:, -31) / -1, 1, 4, -4, 3, 3 /
- data valid_processes (:, -30) / -1, 1, 5, -5, 3, 3 /
- data valid_processes (:, -29) / -1, 1, 6, -6, 3, 3 /
- data valid_processes (:, -28) / -1, 2, -1, 2, 1, 1 /
- data valid_processes (:, -27) / -1, 2, 2, -1, 1, 1 /
- data valid_processes (:, -26) / -1, 3, -1, 3, 1, 1 /
- data valid_processes (:, -25) / -1, 3, 3, -1, 1, 1 /
- data valid_processes (:, -24) / -1, 4, -1, 4, 1, 1 /
- data valid_processes (:, -23) / -1, 4, 4, -1, 1, 1 /
- data valid_processes (:, -22) / -1, 5, -1, 5, 1, 1 /
- data valid_processes (:, -21) / -1, 5, 5, -1, 1, 1 /
- data valid_processes (:, -20) / -1, 6, -1, 6, 1, 1 /
- data valid_processes (:, -19) / -1, 6, 6, -1, 1, 1 /
- data valid_processes (:, -18) / 0, -6, -6, 0, 4, 7 /
- data valid_processes (:, -17) / 0, -6, 0, -6, 4, 7 /
- data valid_processes (:, -16) / 0, -5, -5, 0, 4, 7 /
- data valid_processes (:, -15) / 0, -5, 0, -5, 4, 7 /
- data valid_processes (:, -14) / 0, -4, -4, 0, 4, 7 /
- data valid_processes (:, -13) / 0, -4, 0, -4, 4, 7 /
- data valid_processes (:, -12) / 0, -3, -3, 0, 4, 7 /
- data valid_processes (:, -11) / 0, -3, 0, -3, 4, 7 /
- data valid_processes (:, -10) / 0, -2, -2, 0, 4, 7 /
- data valid_processes (:, -9) / 0, -2, 0, -2, 4, 7 /
- data valid_processes (:, -8) / 0, -1, -1, 0, 4, 7 /
- data valid_processes (:, -7) / 0, -1, 0, -1, 4, 7 /
- data valid_processes (:, -6) / 0, 0, -6, 6, 5, 6 /
- data valid_processes (:, -5) / 0, 0, -5, 5, 5, 6 /
- data valid_processes (:, -4) / 0, 0, -4, 4, 5, 6 /
- data valid_processes (:, -3) / 0, 0, -3, 3, 5, 6 /
- data valid_processes (:, -2) / 0, 0, -2, 2, 5, 6 /
- data valid_processes (:, -1) / 0, 0, -1, 1, 5, 6 /
- data valid_processes (:, 0) / 0, 0, 0, 0, 5, 8 /
- data valid_processes (:, 1) / 0, 0, 1, -1, 5, 6 /
- data valid_processes (:, 2) / 0, 0, 2, -2, 5, 6 /
- data valid_processes (:, 3) / 0, 0, 3, -3, 5, 6 /
- data valid_processes (:, 4) / 0, 0, 4, -4, 5, 6 /
- data valid_processes (:, 5) / 0, 0, 5, -5, 5, 6 /
- data valid_processes (:, 6) / 0, 0, 6, -6, 5, 6 /
- data valid_processes (:, 7) / 0, 1, 0, 1, 4, 7 /
- data valid_processes (:, 8) / 0, 1, 1, 0, 4, 7 /
- data valid_processes (:, 9) / 0, 2, 0, 2, 4, 7 /
- data valid_processes (:, 10) / 0, 2, 2, 0, 4, 7 /
- data valid_processes (:, 11) / 0, 3, 0, 3, 4, 7 /
- data valid_processes (:, 12) / 0, 3, 3, 0, 4, 7 /
- data valid_processes (:, 13) / 0, 4, 0, 4, 4, 7 /
- data valid_processes (:, 14) / 0, 4, 4, 0, 4, 7 /
- data valid_processes (:, 15) / 0, 5, 0, 5, 4, 7 /
- data valid_processes (:, 16) / 0, 5, 5, 0, 4, 7 /
- data valid_processes (:, 17) / 0, 6, 0, 6, 4, 7 /
- data valid_processes (:, 18) / 0, 6, 6, 0, 4, 7 /
- data valid_processes (:, 19) / 1, -6, -6, 1, 1, 1 /
- data valid_processes (:, 20) / 1, -6, 1, -6, 1, 1 /
- data valid_processes (:, 21) / 1, -5, -5, 1, 1, 1 /
- data valid_processes (:, 22) / 1, -5, 1, -5, 1, 1 /
- data valid_processes (:, 23) / 1, -4, -4, 1, 1, 1 /
- data valid_processes (:, 24) / 1, -4, 1, -4, 1, 1 /
- data valid_processes (:, 25) / 1, -3, -3, 1, 1, 1 /
- data valid_processes (:, 26) / 1, -3, 1, -3, 1, 1 /
- data valid_processes (:, 27) / 1, -2, -2, 1, 1, 1 /
- data valid_processes (:, 28) / 1, -2, 1, -2, 1, 1 /
- data valid_processes (:, 29) / 1, -1, -6, 6, 3, 3 /
- data valid_processes (:, 30) / 1, -1, -5, 5, 3, 3 /
- data valid_processes (:, 31) / 1, -1, -4, 4, 3, 3 /
- data valid_processes (:, 32) / 1, -1, -3, 3, 3, 3 /
- data valid_processes (:, 33) / 1, -1, -2, 2, 3, 3 /
- data valid_processes (:, 34) / 1, -1, -1, 1, 3, 4 /
- data valid_processes (:, 35) / 1, -1, 0, 0, 3, 5 /
- data valid_processes (:, 36) / 1, -1, 1, -1, 3, 4 /
- data valid_processes (:, 37) / 1, -1, 2, -2, 3, 3 /
- data valid_processes (:, 38) / 1, -1, 3, -3, 3, 3 /
- data valid_processes (:, 39) / 1, -1, 4, -4, 3, 3 /
- data valid_processes (:, 40) / 1, -1, 5, -5, 3, 3 /
- data valid_processes (:, 41) / 1, -1, 6, -6, 3, 3 /
- data valid_processes (:, 42) / 1, 0, 0, 1, 4, 7 /
- data valid_processes (:, 43) / 1, 0, 1, 0, 4, 7 /
- data valid_processes (:, 44) / 1, 1, 1, 1, 2, 2 /
- data valid_processes (:, 45) / 1, 2, 1, 2, 1, 1 /
- data valid_processes (:, 46) / 1, 2, 2, 1, 1, 1 /
- data valid_processes (:, 47) / 1, 3, 1, 3, 1, 1 /
- data valid_processes (:, 48) / 1, 3, 3, 1, 1, 1 /
- data valid_processes (:, 49) / 1, 4, 1, 4, 1, 1 /
- data valid_processes (:, 50) / 1, 4, 4, 1, 1, 1 /
- data valid_processes (:, 51) / 1, 5, 1, 5, 1, 1 /
- data valid_processes (:, 52) / 1, 5, 5, 1, 1, 1 /
- data valid_processes (:, 53) / 1, 6, 1, 6, 1, 1 /
- data valid_processes (:, 54) / 1, 6, 6, 1, 1, 1 /
- data valid_processes (:, 55) / 2, -6, -6, 2, 1, 1 /
- data valid_processes (:, 56) / 2, -6, 2, -6, 1, 1 /
- data valid_processes (:, 57) / 2, -5, -5, 2, 1, 1 /
- data valid_processes (:, 58) / 2, -5, 2, -5, 1, 1 /
- data valid_processes (:, 59) / 2, -4, -4, 2, 1, 1 /
- data valid_processes (:, 60) / 2, -4, 2, -4, 1, 1 /
- data valid_processes (:, 61) / 2, -3, -3, 2, 1, 1 /
- data valid_processes (:, 62) / 2, -3, 2, -3, 1, 1 /
- data valid_processes (:, 63) / 2, -2, -6, 6, 3, 3 /
- data valid_processes (:, 64) / 2, -2, -5, 5, 3, 3 /
- data valid_processes (:, 65) / 2, -2, -4, 4, 3, 3 /
- data valid_processes (:, 66) / 2, -2, -3, 3, 3, 3 /
- data valid_processes (:, 67) / 2, -2, -2, 2, 3, 4 /
- data valid_processes (:, 68) / 2, -2, -1, 1, 3, 3 /
- data valid_processes (:, 69) / 2, -2, 0, 0, 3, 5 /
- data valid_processes (:, 70) / 2, -2, 1, -1, 3, 3 /
- data valid_processes (:, 71) / 2, -2, 2, -2, 3, 4 /
- data valid_processes (:, 72) / 2, -2, 3, -3, 3, 3 /
- data valid_processes (:, 73) / 2, -2, 4, -4, 3, 3 /
- data valid_processes (:, 74) / 2, -2, 5, -5, 3, 3 /
- data valid_processes (:, 75) / 2, -2, 6, -6, 3, 3 /
- data valid_processes (:, 76) / 2, -1, -1, 2, 1, 1 /
- data valid_processes (:, 77) / 2, -1, 2, -1, 1, 1 /
- data valid_processes (:, 78) / 2, 0, 0, 2, 4, 7 /
- data valid_processes (:, 79) / 2, 0, 2, 0, 4, 7 /
- data valid_processes (:, 80) / 2, 1, 1, 2, 1, 1 /
- data valid_processes (:, 81) / 2, 1, 2, 1, 1, 1 /
- data valid_processes (:, 82) / 2, 2, 2, 2, 2, 2 /
- data valid_processes (:, 83) / 2, 3, 2, 3, 1, 1 /
- data valid_processes (:, 84) / 2, 3, 3, 2, 1, 1 /
- data valid_processes (:, 85) / 2, 4, 2, 4, 1, 1 /
- data valid_processes (:, 86) / 2, 4, 4, 2, 1, 1 /
- data valid_processes (:, 87) / 2, 5, 2, 5, 1, 1 /
- data valid_processes (:, 88) / 2, 5, 5, 2, 1, 1 /
- data valid_processes (:, 89) / 2, 6, 2, 6, 1, 1 /
- data valid_processes (:, 90) / 2, 6, 6, 2, 1, 1 /
- data valid_processes (:, 91) / 3, -6, -6, 3, 1, 1 /
- data valid_processes (:, 92) / 3, -6, 3, -6, 1, 1 /
- data valid_processes (:, 93) / 3, -5, -5, 3, 1, 1 /
- data valid_processes (:, 94) / 3, -5, 3, -5, 1, 1 /
- data valid_processes (:, 95) / 3, -4, -4, 3, 1, 1 /
- data valid_processes (:, 96) / 3, -4, 3, -4, 1, 1 /
- data valid_processes (:, 97) / 3, -3, -6, 6, 3, 3 /
- data valid_processes (:, 98) / 3, -3, -5, 5, 3, 3 /
- data valid_processes (:, 99) / 3, -3, -4, 4, 3, 3 /
- data valid_processes (:, 100) / 3, -3, -3, 3, 3, 4 /
- data valid_processes (:, 101) / 3, -3, -2, 2, 3, 3 /
- data valid_processes (:, 102) / 3, -3, -1, 1, 3, 3 /
- data valid_processes (:, 103) / 3, -3, 0, 0, 3, 5 /
- data valid_processes (:, 104) / 3, -3, 1, -1, 3, 3 /
- data valid_processes (:, 105) / 3, -3, 2, -2, 3, 3 /
- data valid_processes (:, 106) / 3, -3, 3, -3, 3, 4 /
- data valid_processes (:, 107) / 3, -3, 4, -4, 3, 3 /
- data valid_processes (:, 108) / 3, -3, 5, -5, 3, 3 /
- data valid_processes (:, 109) / 3, -3, 6, -6, 3, 3 /
- data valid_processes (:, 110) / 3, -2, -2, 3, 1, 1 /
- data valid_processes (:, 111) / 3, -2, 3, -2, 1, 1 /
- data valid_processes (:, 112) / 3, -1, -1, 3, 1, 1 /
- data valid_processes (:, 113) / 3, -1, 3, -1, 1, 1 /
- data valid_processes (:, 114) / 3, 0, 0, 3, 4, 7 /
- data valid_processes (:, 115) / 3, 0, 3, 0, 4, 7 /
- data valid_processes (:, 116) / 3, 1, 1, 3, 1, 1 /
- data valid_processes (:, 117) / 3, 1, 3, 1, 1, 1 /
- data valid_processes (:, 118) / 3, 2, 2, 3, 1, 1 /
- data valid_processes (:, 119) / 3, 2, 3, 2, 1, 1 /
- data valid_processes (:, 120) / 3, 3, 3, 3, 2, 2 /
- data valid_processes (:, 121) / 3, 4, 3, 4, 1, 1 /
- data valid_processes (:, 122) / 3, 4, 4, 3, 1, 1 /
- data valid_processes (:, 123) / 3, 5, 3, 5, 1, 1 /
- data valid_processes (:, 124) / 3, 5, 5, 3, 1, 1 /
- data valid_processes (:, 125) / 3, 6, 3, 6, 1, 1 /
- data valid_processes (:, 126) / 3, 6, 6, 3, 1, 1 /
- data valid_processes (:, 127) / 4, -6, -6, 4, 1, 1 /
- data valid_processes (:, 128) / 4, -6, 4, -6, 1, 1 /
- data valid_processes (:, 129) / 4, -5, -5, 4, 1, 1 /
- data valid_processes (:, 130) / 4, -5, 4, -5, 1, 1 /
- data valid_processes (:, 131) / 4, -4, -6, 6, 3, 3 /
- data valid_processes (:, 132) / 4, -4, -5, 5, 3, 3 /
- data valid_processes (:, 133) / 4, -4, -4, 4, 3, 4 /
- data valid_processes (:, 134) / 4, -4, -3, 3, 3, 3 /
- data valid_processes (:, 135) / 4, -4, -2, 2, 3, 3 /
- data valid_processes (:, 136) / 4, -4, -1, 1, 3, 3 /
- data valid_processes (:, 137) / 4, -4, 0, 0, 3, 5 /
- data valid_processes (:, 138) / 4, -4, 1, -1, 3, 3 /
- data valid_processes (:, 139) / 4, -4, 2, -2, 3, 3 /
- data valid_processes (:, 140) / 4, -4, 3, -3, 3, 3 /
- data valid_processes (:, 141) / 4, -4, 4, -4, 3, 4 /
- data valid_processes (:, 142) / 4, -4, 5, -5, 3, 3 /
- data valid_processes (:, 143) / 4, -4, 6, -6, 3, 3 /
- data valid_processes (:, 144) / 4, -3, -3, 4, 1, 1 /
- data valid_processes (:, 145) / 4, -3, 4, -3, 1, 1 /
- data valid_processes (:, 146) / 4, -2, -2, 4, 1, 1 /
- data valid_processes (:, 147) / 4, -2, 4, -2, 1, 1 /
- data valid_processes (:, 148) / 4, -1, -1, 4, 1, 1 /
- data valid_processes (:, 149) / 4, -1, 4, -1, 1, 1 /
- data valid_processes (:, 150) / 4, 0, 0, 4, 4, 7 /
- data valid_processes (:, 151) / 4, 0, 4, 0, 4, 7 /
- data valid_processes (:, 152) / 4, 1, 1, 4, 1, 1 /
- data valid_processes (:, 153) / 4, 1, 4, 1, 1, 1 /
- data valid_processes (:, 154) / 4, 2, 2, 4, 1, 1 /
- data valid_processes (:, 155) / 4, 2, 4, 2, 1, 1 /
- data valid_processes (:, 156) / 4, 3, 3, 4, 1, 1 /
- data valid_processes (:, 157) / 4, 3, 4, 3, 1, 1 /
- data valid_processes (:, 158) / 4, 4, 4, 4, 2, 2 /
- data valid_processes (:, 159) / 4, 5, 4, 5, 1, 1 /
- data valid_processes (:, 160) / 4, 5, 5, 4, 1, 1 /
- data valid_processes (:, 161) / 4, 6, 4, 6, 1, 1 /
- data valid_processes (:, 162) / 4, 6, 6, 4, 1, 1 /
- data valid_processes (:, 163) / 5, -6, -6, 5, 1, 1 /
- data valid_processes (:, 164) / 5, -6, 5, -6, 1, 1 /
- data valid_processes (:, 165) / 5, -5, -6, 6, 3, 3 /
- data valid_processes (:, 166) / 5, -5, -5, 5, 3, 4 /
- data valid_processes (:, 167) / 5, -5, -4, 4, 3, 3 /
- data valid_processes (:, 168) / 5, -5, -3, 3, 3, 3 /
- data valid_processes (:, 169) / 5, -5, -2, 2, 3, 3 /
- data valid_processes (:, 170) / 5, -5, -1, 1, 3, 3 /
- data valid_processes (:, 171) / 5, -5, 0, 0, 3, 5 /
- data valid_processes (:, 172) / 5, -5, 1, -1, 3, 3 /
- data valid_processes (:, 173) / 5, -5, 2, -2, 3, 3 /
- data valid_processes (:, 174) / 5, -5, 3, -3, 3, 3 /
- data valid_processes (:, 175) / 5, -5, 4, -4, 3, 3 /
- data valid_processes (:, 176) / 5, -5, 5, -5, 3, 4 /
- data valid_processes (:, 177) / 5, -5, 6, -6, 3, 3 /
- data valid_processes (:, 178) / 5, -4, -4, 5, 1, 1 /
- data valid_processes (:, 179) / 5, -4, 5, -4, 1, 1 /
- data valid_processes (:, 180) / 5, -3, -3, 5, 1, 1 /
- data valid_processes (:, 181) / 5, -3, 5, -3, 1, 1 /
- data valid_processes (:, 182) / 5, -2, -2, 5, 1, 1 /
- data valid_processes (:, 183) / 5, -2, 5, -2, 1, 1 /
- data valid_processes (:, 184) / 5, -1, -1, 5, 1, 1 /
- data valid_processes (:, 185) / 5, -1, 5, -1, 1, 1 /
- data valid_processes (:, 186) / 5, 0, 0, 5, 4, 7 /
- data valid_processes (:, 187) / 5, 0, 5, 0, 4, 7 /
- data valid_processes (:, 188) / 5, 1, 1, 5, 1, 1 /
- data valid_processes (:, 189) / 5, 1, 5, 1, 1, 1 /
- data valid_processes (:, 190) / 5, 2, 2, 5, 1, 1 /
- data valid_processes (:, 191) / 5, 2, 5, 2, 1, 1 /
- data valid_processes (:, 192) / 5, 3, 3, 5, 1, 1 /
- data valid_processes (:, 193) / 5, 3, 5, 3, 1, 1 /
- data valid_processes (:, 194) / 5, 4, 4, 5, 1, 1 /
- data valid_processes (:, 195) / 5, 4, 5, 4, 1, 1 /
- data valid_processes (:, 196) / 5, 5, 5, 5, 2, 2 /
- data valid_processes (:, 197) / 5, 6, 5, 6, 1, 1 /
- data valid_processes (:, 198) / 5, 6, 6, 5, 1, 1 /
- data valid_processes (:, 199) / 6, -6, -6, 6, 3, 4 /
- data valid_processes (:, 200) / 6, -6, -5, 5, 3, 3 /
- data valid_processes (:, 201) / 6, -6, -4, 4, 3, 3 /
- data valid_processes (:, 202) / 6, -6, -3, 3, 3, 3 /
- data valid_processes (:, 203) / 6, -6, -2, 2, 3, 3 /
- data valid_processes (:, 204) / 6, -6, -1, 1, 3, 3 /
- data valid_processes (:, 205) / 6, -6, 0, 0, 3, 5 /
- data valid_processes (:, 206) / 6, -6, 1, -1, 3, 3 /
- data valid_processes (:, 207) / 6, -6, 2, -2, 3, 3 /
- data valid_processes (:, 208) / 6, -6, 3, -3, 3, 3 /
- data valid_processes (:, 209) / 6, -6, 4, -4, 3, 3 /
- data valid_processes (:, 210) / 6, -6, 5, -5, 3, 3 /
- data valid_processes (:, 211) / 6, -6, 6, -6, 3, 4 /
- data valid_processes (:, 212) / 6, -5, -5, 6, 1, 1 /
- data valid_processes (:, 213) / 6, -5, 6, -5, 1, 1 /
- data valid_processes (:, 214) / 6, -4, -4, 6, 1, 1 /
- data valid_processes (:, 215) / 6, -4, 6, -4, 1, 1 /
- data valid_processes (:, 216) / 6, -3, -3, 6, 1, 1 /
- data valid_processes (:, 217) / 6, -3, 6, -3, 1, 1 /
- data valid_processes (:, 218) / 6, -2, -2, 6, 1, 1 /
- data valid_processes (:, 219) / 6, -2, 6, -2, 1, 1 /
- data valid_processes (:, 220) / 6, -1, -1, 6, 1, 1 /
- data valid_processes (:, 221) / 6, -1, 6, -1, 1, 1 /
- data valid_processes (:, 222) / 6, 0, 0, 6, 4, 7 /
- data valid_processes (:, 223) / 6, 0, 6, 0, 4, 7 /
- data valid_processes (:, 224) / 6, 1, 1, 6, 1, 1 /
- data valid_processes (:, 225) / 6, 1, 6, 1, 1, 1 /
- data valid_processes (:, 226) / 6, 2, 2, 6, 1, 1 /
- data valid_processes (:, 227) / 6, 2, 6, 2, 1, 1 /
- data valid_processes (:, 228) / 6, 3, 3, 6, 1, 1 /
- data valid_processes (:, 229) / 6, 3, 6, 3, 1, 1 /
- data valid_processes (:, 230) / 6, 4, 4, 6, 1, 1 /
- data valid_processes (:, 231) / 6, 4, 6, 4, 1, 1 /
- data valid_processes (:, 232) / 6, 5, 5, 6, 1, 1 /
- data valid_processes (:, 233) / 6, 5, 6, 5, 1, 1 /
- data valid_processes (:, 234) / 6, 6, 6, 6, 2, 2 /
-
-@ % valid_processes
-@
-<<Muli interactions: variables>>=
- integer, dimension(2,0:16), parameter, public :: &
- double_pdf_kinds = reshape ( [ &
- 0, 0, &
- 1, 1, &
- 1, 2, &
- 1, 3, &
- 1, 4, &
- 2, 1, &
- 2, 2, &
- 2, 3, &
- 2, 4, &
- 3, 1, &
- 3, 2, &
- 3, 3, &
- 3, 4, &
- 4, 1, &
- 4, 2, &
- 4, 3, &
- 4, 4], [2, 17])
-
-@ %def double_pdf_kinds
-@
-<<Muli interactions: variables>>=
- integer, parameter, dimension(371), public :: int_all = [ &
- -6, -5, -4, -3, -2, -1, 0, 1 , 2, &
- 3, 4, 5, 6, -14, -13, -12, -11, -10, &
- 9, -8, -7, 7, 8, 9, 10, 11, 12, &
- 13, 14, 7, 8, 9, 10,-151,-150,-115, &
- -114, -79, -78, -43, -42, 42, 43, 78, 79, &
- 114, 115, 150, 151,-158,-157,-156,-155,-154, &
- -153,-152,-149,-148,-147,-146,-145,-144,-143, &
- -142,-141,-140,-139,-138,-137,-136,-135,-134, &
- -133,-132,-131,-122,-121,-120,-119,-118,-117, &
- -116,-113,-112,-111,-110,-109,-108,-107,-106, &
- -105,-104,-103,-102,-101,-100, -99, -98, -97, &
- -96, -95, -86, -85, -84, -83, -82, -81, -80, &
- -77, -76, -75, -74, -73, -72, -71, -70, -69, &
- -68, -67, -66, -65, -64, -63, -62, -61, -60, &
- -59, -50, -49, -48, -47, -46, -45, -44, -41, &
- -40, -39, -38, -37, -36, -35, -34, -33, -32, &
- -31, -30, -29, -28, -27, -26, -25, -24, -23, &
- 23, 24, 25, 26, 27, 28, 29, 30, 31, &
- 32, 33, 34, 35, 36, 37, 38, 39, 40, &
- 41, 44, 45, 46, 47, 48, 49, 50, 59, &
- 60, 61, 62, 63, 64, 65, 66, 67, 68, &
- 69, 70, 71, 72, 73, 74, 75, 76, 77, &
- 80, 81, 82, 83, 84, 85, 86, 95, 96, &
- 97, 98, 99, 100, 101, 102, 103, 104, 105, &
- 106, 107, 108, 109, 110, 111, 112, 113, 116, &
- 117, 118, 119, 120, 121, 122, 131, 132, 133, &
- 134, 135, 136, 137, 138, 139, 140, 141, 142, &
- 143, 144, 145, 146, 147, 148, 149, 152, 153, &
- 154, 155, 156, 157, 158,-149,-148,-113,-112, &
- -77, -76, -41, -40, -39, -38, -37, -36, -35, &
- -34, -33, -32, -31, -30, -29, 44, 80, 81, &
- 116, 117, 152, 153,-147,-146,-111,-110, -75, &
- -74, -73, -72, -71, -70, -69, -68, -67, -66, &
- -65, -64, -63, -28, -27, 45, 46, 82, 118, &
- 119, 154, 155, 42, 43, 23, 24, 25, 26, &
- 27, 28, 29, 30, 31, 32, 33, 34, 35, &
- 36, 37, 38, 39, 40, 41, 44, 45, 46, &
- 47, 48, 49, 50, 44, 45, 46, 78, 79, &
- 59, 60, 61, 62, 63, 64, 65, 66, 67, &
- 68, 69, 70, 71, 72, 73, 74, 75, 76, &
- 77, 80, 81, 82, 83, 84, 85, 86, 80, &
- 81, 82 ]
-
-@ %def int_all
-@
-<<Muli interactions: variables>>=
- integer, parameter, dimension(16), public :: int_sizes_all = &
- [13, 16, 2, 2, 16, 208, 26, 26, 2, 26, 1, 2, 2, 26, 2, 1]
-
-@ %def int_sizes_all
-@
-<<Muli interactions: variables>>=
- integer, parameter, dimension(3,0:8), public :: muli_flow_stats = &
- reshape( [ &
- 1, 2, 4, &
- 3, 4, 4, &
- 5, 6, 8, &
- 7, 8, 4, &
- 9, 10, 8, &
- 11, 16, 16, &
- 17, 22, 16, &
- 23, 28, 16, &
- 29, 52, 96 ], &
- [3,9])
-
-@ %def muli_flow_states
-@
-<<Muli interactions: variables>>=
- integer, parameter, dimension(0:4,52), public :: muli_flows = &
- reshape( [ &
- 3, 0, 0, 1, 2, & !1a
- 1, 0, 0, 2, 1, &
- 1, 2, 0, 0, 3, & !1b
- 3, 3, 0, 0, 2, &
- 4, 0, 0, 1, 2, & !2
- 4, 0, 0, 2, 1, &
- 3, 2, 0, 0, 3, & !3
- 1, 3, 0, 0, 2, &
- 4, 2, 0, 0, 3, & !4
- 4, 3, 0, 0, 2, &
- 4, 0, 1, 3, 4, & !5
- 4, 0, 1, 4, 3, &
- 2, 0, 3, 1, 4, &
- 2, 0, 4, 1, 3, &
- 2, 0, 3, 4, 1, &
- 2, 0, 4, 3, 1, &
- 4, 1, 2, 4, 0, & !6
- 2, 1, 4, 2, 0, &
- 4, 2, 1, 4, 0, &
- 2, 4, 1, 2, 0, &
- 2, 2, 4, 1, 0, &
- 2, 4, 2, 1, 0, &
- 2, 0, 1, 2, 4, & !7
- 2, 0, 1, 4, 2, &
- 4, 0, 2, 1, 4, &
- 4, 0, 4, 1, 2, &
- 2, 0, 2, 4, 1, &
- 2, 0, 4, 2, 1, &
- 9, 1, 2, 3, 4, & !8
- 5, 1, 2, 4, 3, &
- 5, 1, 3, 2, 4, &
- 3, 1, 4, 2, 3, &
- 3, 1, 3, 4, 2, &
- 5, 1, 4, 3, 2, &
- 5, 2, 1, 3, 4, &
- 5, 2, 1, 4, 3, &
- 3, 3, 1, 2, 4, &
- 3, 4, 1, 2, 3, &
- 3, 3, 1, 4, 2, &
- 3, 4, 1, 3, 2, &
- 3, 2, 3, 1, 4, &
- 3, 2, 4, 1, 3, &
- 5, 3, 2, 1, 4, &
- 3, 4, 2, 1, 3, &
- 5, 3, 4, 1, 2, &
- 3, 4, 3, 1, 2, &
- 3, 2, 3, 4, 1, &
- 3, 2, 4, 3, 1, &
- 3, 3, 2, 4, 1, &
- 5, 4, 2, 3, 1, &
- 3, 3, 4, 2, 1, &
- 5, 4, 3, 2, 1], [5, 52])
-
-@ %def muli_flows
-@ This value, [[pts2_scale]], seems to be nowhere set in the code.
-<<Muli interactions: variables>>=
- real(default) :: pts2_scale
-@
-<<Muli interactions: interfaces>>=
- abstract interface
- function trafo_in (in)
- use kinds !NODEP!
- real(default), dimension(3) :: trafo_in
- real(default), dimension(3), intent(in) :: in
- end function trafo_in
- end interface
-@ %def trafo_in
-@
-<<Muli interactions: interfaces>>=
- abstract interface
- pure function coord_scalar_in (hyp)
- use kinds !NODEP!
- real(default) :: coord_scalar_in
- real(double), dimension(3), intent(in) :: hyp
- end function coord_scalar_in
- end interface
-@ %def coord_scalar_in
-@
-<<Muli interactions: interfaces>>=
- abstract interface
- subroutine coord_hcd_in (hyp, cart, denom)
- use kinds !NODEP!
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(3), intent(out) :: cart
- real(default), intent(out) :: denom
- end subroutine coord_hcd_in
- end interface
-@ %def coord_hcd_in
-@ This is the interface to the routines [[alphasPDF]] and
-[[evolvePDF]] from LHAPDF or internal PDFs which therefore need to be
-explicitly in [[double]] precision.
-<<Muli interactions: interfaces>>=
- interface
- pure function alphaspdf (Q)
- use kinds !NODEP!
- real(double) :: alphaspdf
- real(double), intent(in) :: Q
- end function alphaspdf
- end interface
-@ %def alphaspdf
-@
-<<Muli interactions: interfaces>>=
- interface
- pure subroutine evolvepdf (x, q, f)
- use kinds !NODEP!
- real(double), intent(in) :: x, q
- real(double), intent(out), dimension(-6:6) :: f
- end subroutine evolvepdf
- end interface
-
-@ %def evolvepdf
-@
-<<Muli interactions: public>>=
- public :: muli_get_state_transformations
-<<Muli interactions: procedures>>=
- pure function muli_get_state_transformations &
- (inout_kind, lha_flavors) result (transformations)
- integer, intent(in) :: inout_kind
- integer, dimension(4), intent(in) :: lha_flavors
- integer, dimension(4) :: signature
- logical, dimension(3) :: transformations
- where (lha_flavors > 0)
- signature = 1
- elsewhere (lha_flavors < 0)
- signature = -1
- elsewhere
- signature = 0
- end where
- ! print *,"inout_kind=",inout_kind
- ! print *,"lha_flavors=",lha_flavors
- ! print *,"signature",signature
- if ((sum(inout_signatures(1:2,inout_kind)) == sum(signature(1:2))) .and. &
- (sum(inout_signatures(3:4,inout_kind)) == sum(signature(3:4)))) then
- transformations(1) = .false.
- else
- transformations(1) = .true.
- signature = -signature
- end if
- if (all (inout_signatures(1:2,inout_kind) == signature(1:2))) then
- transformations(2) = .false.
- else
- transformations(2) = .true.
- end if
- if (all(inout_signatures(3:4,inout_kind) == signature(3:4))) then
- transformations(3) = .false.
- else
- transformations(3) = .true.
- end if
- ! print *,"signature",signature
- ! print *,"transformations=",transformations
- end function muli_get_state_transformations
-
-@ %muli_get_state_transformations
-@
-<<Muli interactions: public>>=
- public :: h_to_c_param
-<<Muli interactions: procedures>>=
- pure function h_to_c_param (hyp)
- real(default), dimension(3) :: h_to_c_param
- real(default), dimension(3), intent(in) :: hyp
- h_to_c_param = [sqrt (sqrt ((((hyp(1)**4) * (one-hyp(3))) + &
- hyp(3))**2 + (((hyp(2)-(5E-1_default))**3)*4)**2) - &
- ((hyp(2)-(5E-1_default))**3)*4), &
- sqrt (sqrt ((((hyp(1)**4)*(one-hyp(3))) + hyp(3))**2 + &
- (((hyp(2)-(5E-1_default))**3)*4)**2) + &
- ((hyp(2)-(5E-1_default))**3)*4), hyp(3)]
- end function h_to_c_param
-
-@ %def h_to_c_param
-@
-<<Muli interactions: public>>=
- public :: c_to_h_param
-<<Muli interactions: procedures>>=
- pure function c_to_h_param (cart)
- real(default), dimension(3) :: c_to_h_param
- real(default), dimension(3), intent(in)::cart
- c_to_h_param= [ (((cart(1)*cart(2)) - cart(3)) / &
- (one - cart(3)))**(1/four), (one + sign(abs((cart(2)**2) - &
- (cart(1)**2))**(1/three), cart(2) - cart(1))) / two, cart(3) ]
- end function c_to_h_param
-
-@ %def c_to_h_param
-@
-<<Muli interactions: public>>=
- public :: h_to_c_param_def
-<<Muli interactions: procedures>>=
- pure function h_to_c_param_def (hyp)
- real(default), dimension(3) :: h_to_c_param_def
- real(default), dimension(3), intent(in) :: hyp
- h_to_c_param_def = h_to_c_param ([hyp(1), hyp(2), pts2_scale])
- end function h_to_c_param_def
-
-@ %def h_to_c_param_def
-@
-<<Muli interactions: public>>=
- public :: h_to_c_ort
-<<Muli interactions: procedures>>=
- pure function h_to_c_ort (hyp)
- real(default), dimension(3) :: h_to_c_ort
- real(default), dimension(3), intent(in) :: hyp
- h_to_c_ort = [sqrt (sqrt (((hyp(1) * (one - hyp(3))) + hyp(3))**2 + &
- (hyp(2) - (5E-1_default))**2) - (hyp(2) - (5E-1_default))), &
- sqrt (sqrt (((hyp(1) * (one - hyp(3))) + hyp(3))**2 + &
- (hyp(2)-(5E-1_default))**2) + (hyp(2) - (5E-1_default))), hyp(3)]
- end function h_to_c_ort
-
-@ %def h_to_c_ort
-@
-<<Muli interactions: public>>=
- public :: c_to_h_ort
-<<Muli interactions: procedures>>=
- pure function c_to_h_ort (cart)
- real(default), dimension(3) :: c_to_h_ort
- real(default), dimension(3), intent(in) :: cart
- c_to_h_ort = [ (cart(3) - (cart(1)*cart(2))) / (cart(3) - one), &
- (one - cart(1)**2 + cart(2)**2) / two, cart(3)]
- end function c_to_h_ort
-
-@ %def c_to_h_ort
-@
-<<Muli interactions: public>>=
- public :: h_to_c_ort_def
-<<Muli interactions: procedures>>=
- pure function h_to_c_ort_def (hyp)
- real(default), dimension(3) :: h_to_c_ort_def
- real(default), dimension(3), intent(in) :: hyp
- h_to_c_ort_def = h_to_c_ort ([hyp(1), hyp(2), pts2_scale])
- end function h_to_c_ort_def
-
-@ %def h_to_c_ort_def
-@
-<<Muli interactions: public>>=
- public :: c_to_h_ort_def
-<<Muli interactions: procedures>>=
- pure function c_to_h_ort_def (cart)
- real(default), dimension(3) :: c_to_h_ort_def
- real(default), dimension(3), intent(in) :: cart
- c_to_h_ort_def = c_to_h_ort ([ cart(1), cart(2), pts2_scale])
- end function c_to_h_ort_def
-
-@ %def c_to_h_ort_def
-@
-<<Muli interactions: public>>=
- public :: h_to_c_noparam
-<<Muli interactions: procedures>>=
- pure function h_to_c_noparam (hyp)
- real(default), dimension(2) :: h_to_c_noparam
- real(default), dimension(2), intent(in) :: hyp
- h_to_c_noparam = [sqrt (sqrt (hyp(1)**8 + (((hyp(2) - &
- (5E-1_default))**3)*4)**2) - ((hyp(2)-(5E-1_default))**3)*4), &
- sqrt (sqrt (hyp(1)**8 + (((hyp(2)-(5E-1_default))**3)*4)**2) + &
- ((hyp(2)-(5E-1_default))**3)*4)]
- end function h_to_c_noparam
-
-@ %def h_to_c_noparam
-@
-<<Muli interactions: public>>=
- public :: c_to_h_noparam
-<<Muli interactions: procedures>>=
- pure function c_to_h_noparam (cart)
- real(default), dimension(2) :: c_to_h_noparam
- real(default), dimension(2), intent(in) :: cart
- c_to_h_noparam = [sqrt (sqrt (cart(1)*cart(2))), &
- (one + sign(abs((cart(2)**2) - (cart(1)**2))**(one/three), &
- cart(2)-cart(1)))/two]
- end function c_to_h_noparam
-
-@ %def c_to_h_noparam
-@
-<<Muli interactions: public>>=
- public :: c_to_h_param_def
-<<Muli interactions: procedures>>=
- pure function c_to_h_param_def (cart)
- real(default), dimension(3) :: c_to_h_param_def
- real(default), dimension(3), intent(in) :: cart
- if (product (cart(1:2)) >= pts2_scale) then
- c_to_h_param_def = c_to_h_param ([cart(1), cart(2), pts2_scale])
- else
- c_to_h_param_def = [-one, -one, -one]
- end if
- end function c_to_h_param_def
-
-@ %def c_to_h_param_def
-@
-<<Muli interactions: public>>=
- public :: h_to_c_smooth
-<<Muli interactions: procedures>>=
- pure function h_to_c_smooth (hyp)
- real(default), dimension(3) :: h_to_c_smooth
- real(default), dimension(3), intent(in) :: hyp
- real(default) :: h2
- h2 = (((hyp(2) - 5E-1_default)**3) * 4._default + hyp(2)-5E-1_default) &
- / two
- h_to_c_smooth = &
- [sqrt (sqrt((((hyp(1)**4)*(one-hyp(3)))+hyp(3))**2+h2**2) - h2), &
- sqrt (sqrt((((hyp(1)**4)*(one-hyp(3)))+hyp(3))**2+h2**2) + h2), &
- hyp(3)]
- end function h_to_c_smooth
-
-@ %def h_to_c_smooth
-@
-<<Muli interactions: public>>=
- public :: c_to_h_smooth
-<<Muli interactions: procedures>>=
- pure function c_to_h_smooth (cart)
- real(default), dimension(3) :: c_to_h_smooth
- real(default), dimension(3), intent(in) :: cart
- c_to_h_smooth = &
- [((product (cart(1:2)) - cart(3)) / (one - cart(3)))**(1/four), &
- (three-three**(two/3) / (-9._default * cart(1)**2 + &
- 9._default * cart(2)**2 + sqrt (three + 81._default * &
- (cart(1)**2 - cart(2)**2)**2))**(one/three)&
- + 3**(one/3)*(-9._default * cart(1)**2 + 9._default*cart(2)**2 &
- + sqrt(three + 81._default*(cart(1)**2&
- - cart(2)**2)**2))**(one/3))/6._default,cart(3)]
- end function c_to_h_smooth
-
-@ %def c_to_h_smooth
-@
-<<Muli interactions: public>>=
- public :: h_to_c_smooth_def
-<<Muli interactions: procedures>>=
- pure function h_to_c_smooth_def (hyp)
- real(default), dimension(3) :: h_to_c_smooth_def
- real(default), dimension(3), intent(in) :: hyp
- h_to_c_smooth_def = h_to_c_smooth ([hyp(1), hyp(2), pts2_scale])
- end function h_to_c_smooth_def
-
-@ %def h_to_c_smooth_def
-@
-<<Muli interactions: public>>=
-@
-<<Muli interactions: procedures>>=
- pure function c_to_h_smooth_def (cart)
- real(default), dimension(3)::c_to_h_smooth_def
- real(default), dimension(3), intent(in) :: cart
- if (product (cart(1:2)) >= pts2_scale) then
- c_to_h_smooth_def = c_to_h_smooth ([cart(1), cart(2), pts2_scale])
- else
- c_to_h_smooth_def = [-one, -one, -one]
- end if
- end function c_to_h_smooth_def
-
-@ %def c_to_h_smooth_def
-@
-<<Muli interactions: public>>=
- public :: voxel_h_to_c_ort
-<<Muli interactions: procedures>>=
- pure function voxel_h_to_c_ort (hyp)
- real(default) :: voxel_h_to_c_ort
- real(default), dimension(3), intent(in) :: hyp
- real(default) :: T, TH1
- T = one - hyp(3)
- TH1 = T * (one - hyp(1))
- voxel_h_to_c_ort = sqrt (T**2 / (five - four*(one-hyp(2))*hyp(2) - &
- four*(two-TH1)*TH1))
- end function voxel_h_to_c_ort
-
-@ %def voxel_h_to_c_ort
-@
-<<Muli interactions: public>>=
- public :: voxel_c_to_h_ort
-<<Muli interactions: procedures>>=
- pure function voxel_c_to_h_ort(cart)
- real(default) :: voxel_c_to_h_ort
- real(default), dimension(3), intent(in) :: cart
- real(default) :: P
- P = product (cart(1:2))
- if (P > cart(3)) then
- voxel_c_to_h_ort = (cart(1)**2 + cart(2)**2) / (one -cart(3))
- else
- voxel_c_to_h_ort = zero
- end if
- end function voxel_c_to_h_ort
-
-@ %def voxel_c_to_h_ort
-@
-<<Muli interactions: public>>=
- public :: voxel_h_to_c_noparam
-<<Muli interactions: procedures>>=
- pure function voxel_h_to_c_noparam (hyp)
- real(default) :: voxel_h_to_c_noparam
- real(default), dimension(3), intent(in) :: hyp
- voxel_h_to_c_noparam = 12._default * sqrt ((hyp(1)**6 * &
- (one - two*hyp(2))**4) / (4*hyp(1)**8 + (one - two*hyp(2))**6))
- end function voxel_h_to_c_noparam
-
-@ %def voxel_h_to_c_noparam
-@
-<<Muli interactions: public>>=
- public :: voxel_c_to_h_noparam
-<<Muli interactions: procedures>>=
- pure function voxel_c_to_h_noparam (cart)
- real(default) :: voxel_c_to_h_noparam
- real(default), dimension(3), intent(in) :: cart
- real(default) :: P
- voxel_c_to_h_noparam = (cart(1)**2 + cart(2)**2) / (12._default * &
- (cart(1)*cart(2))**(three/four) * &
- (cart(2)**2 + cart(1)**2)**(two/three))
- end function voxel_c_to_h_noparam
-
-@ %def voxel_c_to_h_param
-@
-<<Muli interactions: public>>=
- public :: voxel_h_to_c_param
-<<Muli interactions: procedures>>=
- pure function voxel_h_to_c_param (hyp)
- real(default) :: voxel_h_to_c_param
- real(default), dimension(3), intent(in) :: hyp
- voxel_h_to_c_param = 12*Sqrt((hyp(1)**6 * &
- (one - 2._default*hyp(2))**4 * (hyp(3) - one)**2) / &
- ((one - two * hyp(2))**6 + four * &
- (hyp(3)-(hyp(1)**4*(hyp(3)-one)))**2))
- end function voxel_h_to_c_param
-
-@ %def voxel_h_to_c_param
-@
-<<Muli interactions: public>>=
- public :: voxel_c_to_h_param
-<<Muli interactions: procedures>>=
- pure function voxel_c_to_h_param (cart)
- real(default)::voxel_c_to_h_param
- real(default), dimension(3), intent(in) :: cart
- real(default) :: P, T, CP, CM
- P = product (cart(1:2))
- if (P > cart(3)) then
- P = P - cart(3)
- CP = cart(1)**2 + cart(2)**2
- CM = abs(cart(2)**2 - cart(1)**2)
- T = 1 - cart(3)
- voxel_c_to_h_param = (Cp*sqrt(sqrt(P/T))) / (12*Cm**(two/three)*P)
- else
- voxel_c_to_h_param = zero
- end if
- end function voxel_c_to_h_param
-
-@ %def voxel_c_to_h_param
-@
-<<Muli interactions: public>>=
- public :: voxel_h_to_c_smooth
-@
-<<Muli interactions: procedures>>=
- pure function voxel_h_to_c_smooth (hyp)
- real(default) :: voxel_h_to_c_smooth
- real(default), dimension(3), intent(in) :: hyp
- real(default) :: T
- T = one - hyp(3)
- voxel_h_to_c_smooth = 8._default * (hyp(1)**3 * (one + three * &
- (hyp(2) - one)*hyp(2))*T) / sqrt ((one - two*hyp(2) * (two + &
- hyp(2)*(two*hyp(2)-three)))**2 + &
- four * (one + (hyp(1)**4 - one)*T)**2)
- end function voxel_h_to_c_smooth
-
-@ %def voxel_h_to_c_smooth
-@
-<<Muli interactions: public>>=
- public :: voxel_c_to_h_smooth
-<<Muli interactions: procedures>>=
- pure function voxel_c_to_h_smooth (cart)
- real(default) :: voxel_c_to_h_smooth
- real(default), dimension(3), intent(in) :: cart
- real(default) :: P, S, T, CM, CP
- P = product (cart(1:2))
- if (P > cart(3)) then
- P = P - cart(3)
- CP = cart(1)**2 + cart(2)**2
- CM = cart(2)**2 - cart(1)**2
- T = 1 - cart(3)
- S = sqrt(three + 81._default*cm**2)
- voxel_c_to_h_smooth = (three**(one/three) * Cp*(three**(one/three) + &
- (9._default*Cm + S)**(two/three)) * sqrt (sqrt (P/T))) / &
- (four * P * S * (9._default * Cm + S)**(one/three))
- else
- voxel_c_to_h_smooth = zero
- end if
-end function voxel_c_to_h_smooth
-
-@ %def voxel_c_to_h_smooth
-@
-<<Muli interactions: public>>=
- public :: voxel_h_to_c_ort_def
-<<Muli interactions: procedures>>=
- pure function voxel_h_to_c_ort_def (hyp)
- real(default) :: voxel_h_to_c_ort_def
- real(default), dimension(3), intent(in) :: hyp
- voxel_h_to_c_ort_def = voxel_h_to_c_ort (hyp)
- end function voxel_h_to_c_ort_def
-
-@ %def voxel_h_to_c_ort_def
-@
-<<Muli interactions: public>>=
- public :: voxel_c_to_h_ort_def
-<<Muli interactions: procedures>>=
- pure function voxel_c_to_h_ort_def (cart)
- real(default) :: voxel_c_to_h_ort_def
- real(default), dimension(3), intent(in) :: cart
- voxel_c_to_h_ort_def = voxel_c_to_h_ort (cart)
- end function voxel_c_to_h_ort_def
-
-@ %def voxel_c_to_h_ort_def
-@
-<<Muli interactions: public>>=
- public :: voxel_h_to_c_param_def
-<<Muli interactions: procedures>>=
- pure function voxel_h_to_c_param_def (hyp)
- real(default) :: voxel_h_to_c_param_def
- real(default), dimension(3), intent(in) :: hyp
- voxel_h_to_c_param_def = voxel_h_to_c_param (hyp)
- end function voxel_h_to_c_param_def
-
-@ %def voxel_h_to_c_param_def
-@
-<<Muli interactions: public>>=
- public :: voxel_c_to_h_param_def
-<<Muli interactions: procedures>>=
- pure function voxel_c_to_h_param_def (cart)
- real(default) :: voxel_c_to_h_param_def
- real(default), dimension(3), intent(in) :: cart
- voxel_c_to_h_param_def = voxel_c_to_h_param (cart)
- end function voxel_c_to_h_param_def
-
-@ %def voxel_c_to_h_param_def
-@
-<<Muli interactions: public>>=
- public :: voxel_h_to_c_smooth_def
-<<Muli interactions: procedures>>=
- pure function voxel_h_to_c_smooth_def (hyp)
- real(default) :: voxel_h_to_c_smooth_def
- real(default), dimension(3), intent(in) :: hyp
- voxel_h_to_c_smooth_def = voxel_h_to_c_smooth (hyp)
- end function voxel_h_to_c_smooth_def
-
-@ %def voxel_h_to_c_smooth_def
-@
-<<Muli interactions: public>>=
- public :: voxel_c_to_h_smooth_def
-<<Muli interactions: procedures>>=
- pure function voxel_c_to_h_smooth_def (cart)
- real(default) :: voxel_c_to_h_smooth_def
- real(default), dimension(3), intent(in) :: cart
- voxel_c_to_h_smooth_def = voxel_c_to_h_smooth (cart)
- end function voxel_c_to_h_smooth_def
-
-@ %def voxel_c_to_h_smooth_def
-@
-<<Muli interactions: public>>=
- public :: denom_cart
-<<Muli interactions: procedures>>=
- pure function denom_cart (cart)
- real(default) :: denom_cart
- real(default), dimension(3), intent(in) :: cart
- denom_cart = 1._default / (864._default * sqrt (cart(3)**3 * &
- (1._default - cart(3) / product(cart(1:2)))))
- end function denom_cart
-
-@ %def denom_cart
-@
-<<Muli interactions: public>>=
- public :: denom_ort
-<<Muli interactions: procedures>>=
- pure function denom_ort (hyp)
- real(default) :: denom_ort
- real(default), dimension(3), intent(in) :: hyp
- real(default) :: Y, P
- Y = (one - two * hyp(2))**2
- P = one - hyp(3)
- if (hyp(1) > zero .and. hyp(3) > zero) then
- denom_ort = sqrt ((P + (-1 + Hyp(1))*P**2) / &
- (746496*hyp(1)*hyp(3)**3 * (4*(1 + (-1 + hyp(1))*P)**2 + Y)))
- else
- denom_ort = zero
- end if
- end function denom_ort
-
-@ %def denom_ort
-@
-<<Muli interactions: public>>=
- public :: denom_param
-<<Muli interactions: procedures>>=
- pure function denom_param (hyp)
- real(default) :: denom_param
- real(default), dimension(3), intent(in) :: hyp
- real(default) :: X, Y, P
- X = hyp(1)**4
- Y = 1._default - 2._default * hyp(2)
- P = 1._default - hyp(3)
- if (hyp(3) > 0._default) then
- denom_param = sqrt ((P * (1+P*(X-1)) * Sqrt(X)*Y**4) / &
- (5184*(4*(1+P*(X-1))**2+Y**6)*hyp(3)**3))
- else
- denom_param = zero
- end if
- end function denom_param
-
-@ %def denom_param
-@
-<<Muli interactions: public>>=
- public :: denom_param_reg
-<<Muli interactions: procedures>>=
- pure function denom_param_reg (hyp)
- real(default) :: denom_param_reg
- real(default), dimension(3), intent(in) :: hyp
- real(default) :: X, Y, P
- X = hyp(1)**4
- Y = one - two * hyp(2)
- P = one - hyp(3)
- if (hyp(3) > zero) then
- denom_param_reg = sqrt ((P*(1+P*(X-1)) * Sqrt(X)*Y**4) / &
- (5184*(4*(1+P*(X-1))**2+Y**6) * (hyp(3) + norm2_p_t_0)**3))
- else
- denom_param_reg = zero
- end if
- end function denom_param_reg
-
-@ %def denom_param_reg
-@
-<<Muli interactions: public>>=
- public :: denom_smooth
-<<Muli interactions: procedures>>=
- pure function denom_smooth (hyp)
- real(default) :: denom_smooth
- real(default), dimension(3), intent(in) :: hyp
- real(default) :: X, Y, P
- X = hyp(1)**2
- Y = (one - two * hyp(2))**2
- P = one - hyp(3)
- if (hyp(3) > zero) then
- denom_smooth = sqrt ((P * X * (one + P*(-one + X**2)) * &
- (1 + three*Y)**2)/(46656*hyp(3)**3 &
- *(16*(1 + P*(-1 + X**2))**2 + Y + 2*Y**2 + Y**3)))
- else
- denom_smooth = zero
- end if
- end function denom_smooth
-
-@ %def denom_smooth
-@
-<<Muli interactions: public>>=
- public :: denom_smooth_reg
-<<Muli interactions: procedures>>=
- pure function denom_smooth_reg (hyp)
- real(default) :: denom_smooth_reg
- real(default), dimension(3), intent(in) :: hyp
- real(default) :: X, Y, P
- X = hyp(1)**2
- Y = (one - two * hyp(2))**2
- P = one - hyp(3)
- if (hyp(3) > zero) then
- denom_smooth_reg = sqrt ((P * X * (1 + P*(-1 + X**2)) * &
- (1 + 3*Y)**2)/(46656*(hyp(3) + norm2_p_t_0)**3 * &
- (16 * (1 + P*(-1 + X**2))**2 + Y + 2*Y**2 + Y**3)))
- else
- denom_smooth_reg = zero
- end if
- end function denom_smooth_reg
-
-@ %def denom_smooth_reg
-@
-<<Muli interactions: public>>=
- public :: denom_cart_save
-<<Muli interactions: procedures>>=
- pure function denom_cart_save (cart)
- real(default) :: denom_cart_save
- real(default), dimension(3), intent(in) :: cart
- if (product(cart(1:2)) > cart(3)) then
- denom_cart_save = denom_cart (cart)
- else
- denom_cart_save = zero
- end if
- end function denom_cart_save
-
-@ %def denom_cart_save
-@
-<<Muli interactions: public>>=
- public :: denom_ort_save
-<<Muli interactions: procedures>>=
- pure function denom_ort_save (hyp)
- real(default) :: denom_ort_save
- real(default), dimension(3), intent(in) :: hyp
- real(default) :: Y, Z, W
- real(default), dimension(3) :: cart
- cart = h_to_c_ort (hyp)
- if (cart(1) > one .or. cart(2) > one) then
- denom_ort_save = zero
- else
- denom_ort_save = denom_ort (hyp)
- end if
- end function denom_ort_save
-
-@ %def denom_ort_save
-@
-<<Muli interactions: public>>=
- public :: denom_param_save
-<<Muli interactions: procedures>>=
- pure function denom_param_save (hyp)
- real(default) :: denom_param_save
- real(default), dimension(3), intent(in) :: hyp
- real(default) :: Y, Z, W
- real(default), dimension(3) :: cart
- cart=h_to_c_param (hyp)
- if (cart(1) > one .or. cart(2) > one) then
- denom_param_save = zero
- else
- denom_param_save = denom_param (hyp)
- end if
- end function denom_param_save
-
-@ %def denom_param_save
-@
-<<Muli interactions: public>>=
- public :: denom_smooth_save
-<<Muli interactions: procedures>>=
- pure function denom_smooth_save (hyp)
- real(default) :: denom_smooth_save
- real(default), dimension(3), intent(in) :: hyp
- real(default) :: Y, Z, W
- real(default), dimension(3) :: cart
- cart = h_to_c_smooth (hyp)
- if (cart(1) > one .or. cart(2) > one) then
- denom_smooth_save = zero
- else
- denom_smooth_save = denom_smooth (hyp)
- end if
- end function denom_smooth_save
-
-@ %def denom_smooth_save
-@
-<<Muli interactions: public>>=
- public :: denom_cart_cuba_int
-<<Muli interactions: procedures>>=
- subroutine denom_cart_cuba_int (d_cart, cart, d_denom, denom, pt2s)
- real(default), dimension(3), intent(in) :: cart
- real(default), dimension(1), intent(out) :: denom
- real(default), intent(in) :: pt2s
- integer, intent(in) :: d_cart, d_denom
- denom(1) = denom_cart_save ([cart(1), cart(2), pt2s])
- end subroutine denom_cart_cuba_int
-
-@ %def denom_cart_cuba_int
-@
-<<Muli interactions: public>>=
- public :: denom_ort_cuba_int
-<<Muli interactions: procedures>>=
- subroutine denom_ort_cuba_int (d_hyp, hyp, d_denom, denom, pt2s)
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(1), intent(out) :: denom
- real(default), intent(in) :: pt2s
- integer, intent(in) :: d_hyp, d_denom
- denom(1) = denom_ort_save ([hyp(1), hyp(2), pt2s])
- end subroutine denom_ort_cuba_int
-
-@ %def denom_ort_cuba_int
-@
-<<Muli interactions: public>>=
- public :: denom_param_cuba_int
-<<Muli interactions: procedures>>=
- subroutine denom_param_cuba_int (d_hyp, hyp, d_denom, denom, pt2s)
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(1), intent(out) :: denom
- real(default), intent(in) :: pt2s
- integer, intent(in) :: d_hyp, d_denom
- denom(1) = denom_param_save ([hyp(1), hyp(2), pt2s])
- end subroutine denom_param_cuba_int
-
-@ %def denom_param_cuba_int
-@
-<<Muli interactions: public>>=
- public :: denom_smooth_cuba_int
-<<Muli interactions: procedures>>=
- subroutine denom_smooth_cuba_int (d_hyp, hyp, d_denom, denom, pt2s)
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(1), intent(out) :: denom
- real(default), intent(in) :: pt2s
- integer, intent(in) :: d_hyp, d_denom
- denom(1) = denom_smooth_save ([hyp(1), hyp(2), pt2s])
- end subroutine denom_smooth_cuba_int
-
-@ %def denom_smooth_cuba_int
-@
-<<Muli interactions: public>>=
- public :: coordinates_hcd_cart
-<<Muli interactions: procedures>>=
- subroutine coordinates_hcd_cart (hyp, cart, denom)
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(3), intent(out) :: cart
- real(default), intent(out) :: denom
- cart = hyp
- denom = denom_cart_save (cart)
- end subroutine coordinates_hcd_cart
-
-@ %def coordinates_hcd_cart
-@
-<<Muli interactions: public>>=
- public :: coordinates_hcd_ort
-<<Muli interactions: procedures>>=
- subroutine coordinates_hcd_ort (hyp, cart, denom)
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(3), intent(out) :: cart
- real(default), intent(out)::denom
- cart = h_to_c_ort (hyp)
- denom = denom_ort (hyp)
- end subroutine coordinates_hcd_ort
-
-@ %def coordinates_hcd_ort
-@
-<<Muli interactions: public>>=
- public :: coordinates_hcd_param
-<<Muli interactions: procedures>>=
- subroutine coordinates_hcd_param (hyp, cart, denom)
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(3), intent(out) :: cart
- real(default), intent(out) :: denom
- cart = h_to_c_param (hyp)
- denom = denom_param (hyp)
- end subroutine coordinates_hcd_param
-
-@ %def coordinates_hcd_param
-@
-<<Muli interactions: public>>=
- public :: coordinates_hcd_param_reg
-<<Muli interactions: procedures>>=
- subroutine coordinates_hcd_param_reg (hyp, cart, denom)
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(3), intent(out) :: cart
- real(default), intent(out) :: denom
- cart = h_to_c_param (hyp)
- denom = denom_param_reg (hyp)
- end subroutine coordinates_hcd_param_reg
-
-@ %def coordinates_hcd_param_reg
-@
-<<Muli interactions: public>>=
- public :: coordinates_hcd_smooth
-<<Muli interactions: procedures>>=
- subroutine coordinates_hcd_smooth (hyp, cart, denom)
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(3), intent(out) :: cart
- real(default), intent(out) :: denom
- cart = h_to_c_smooth (hyp)
- denom = denom_smooth (hyp)
- end subroutine coordinates_hcd_smooth
-
-@ %def coordinates_hcd_smooth
-@
-<<Muli interactions: public>>=
- public :: coordinates_hcd_smooth_reg
-<<Muli interactions: procedures>>=
- subroutine coordinates_hcd_smooth_reg (hyp, cart, denom)
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(3), intent(out) :: cart
- real(default), intent(out) :: denom
- cart = h_to_c_smooth (hyp)
- denom = denom_smooth_reg (hyp)
- end subroutine coordinates_hcd_smooth_reg
-
-@ %def coordinates_hcd_smooth_reg
-@
-<<Muli interactions: public>>=
- public :: interactions_dddsigma_reg
-<<Muli interactions: procedures>>=
- pure subroutine interactions_dddsigma_reg &
- (process_id, double_pdf_id, hyp, cart, dddsigma)
- real(default), intent(out) :: dddsigma
- integer, intent(in) :: process_id, double_pdf_id
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(3), intent(out) :: cart
- real(default) :: a, pt2shat, gev_pt, gev2_pt
- cart = h_to_c_param (hyp)
- a = product (cart(1:2))
- if (cart(1) <= 1D0 .and. cart(2) <= 1D0) then
- pt2shat = hyp(3) / a
- gev_pt = sqrt(hyp(3)) * gev_pt_max
- gev2_pt = hyp(3) * gev2_pt_max
- ! print *,process_id,pt2shat
- dddsigma = &
- const_pref &
- * alphasPDF (dble (sqrt (gev2_pt+gev2_p_t_0)))**2 &
- * ps_io_pol (process_id, pt2shat) &
- * pdf_in_in_kind &
- (process_id, double_pdf_id, cart(1), cart(2), gev_pt) &
- * denom_param_reg (hyp) / a
- else
- dddsigma = zero
- end if
- end subroutine interactions_dddsigma_reg
-
-@ %def interactions_dddsigma_reg
-@
-<<Muli interactions: public>>=
- public :: pdf_in_in_kind
-<<Muli interactions: procedures>>=
- pure function pdf_in_in_kind (process_id, double_pdf_id, c1, c2, gev_pt)
- real(default) :: pdf_in_in_kind
- real(default), intent(in) :: c1, c2, gev_pt
- integer, intent(in) :: process_id, double_pdf_id
- real(default) :: pdf1, pdf2
- call single_pdf (valid_processes(1, process_id), &
- double_pdf_kinds(1, double_pdf_id), c1, gev_pt, pdf1)
- call single_pdf (valid_processes(2, process_id), &
- double_pdf_kinds(2, double_pdf_id), c2, gev_pt, pdf2)
- pdf_in_in_kind = pdf1 * pdf2
- contains
- pure subroutine single_pdf (flavor, pdf_kind, c, gev_pt, pdf)
- integer, intent(in) :: flavor, pdf_kind
- real(default), intent(in) :: c, gev_pt
- real(default), intent(out) :: pdf
- real(double), dimension(-6:6) :: lha_pdf
- call evolvePDF (dble (c), dble (gev_pt), lha_pdf)
- select case (pdf_kind)
- case (1)
- pdf = lha_pdf (0)
- case (2)
- if (flavor==1 .or. flavor==2) then
- pdf = lha_pdf (-flavor)
- else
- pdf = lha_pdf (flavor)
- end if
- case (3)
- pdf = lha_pdf(1) - lha_pdf(-1)
- case (4)
- pdf = lha_pdf(2) - lha_pdf(-2)
- end select
- end subroutine single_pdf
- end function pdf_in_in_kind
-
-@ %def pdf_in_in_kind
-@
-<<Muli interactions: public>>=
- public :: ps_io_pol
-<<Muli interactions: procedures>>=
- elemental function ps_io_pol (process_io_id, pt2shat)
- real(default) :: ps_io_pol
- integer, intent(in) :: process_io_id
- real(default), intent(in) :: pt2shat
- ps_io_pol = dot_product([1._default, pt2shat, pt2shat**2, pt2shat**3], &
- phase_space_coefficients_inout (1:4, &
- valid_processes (6, process_io_id)))
- end function ps_io_pol
-
-@ %def ps_io_pol
-@
-<<Muli interactions: public>>=
- public :: interactions_dddsigma
-<<Muli interactions: procedures>>=
- pure subroutine interactions_dddsigma &
- (process_id, double_pdf_id, hyp, cart, dddsigma)
- real(default), intent(out) :: dddsigma
- integer, intent(in) :: process_id, double_pdf_id
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(3), intent(out) :: cart
- real(default) :: a, pt2shat, gev_pt
- cart = h_to_c_param (hyp)
- a = product (cart(1:2))
- if (cart(1) <= 1._default .and. cart(2) <= 1._default) then
- pt2shat = hyp(3) / a
- gev_pt = sqrt(hyp(3)) * gev_pt_max
- ! print *,process_id,pt2shat
- dddsigma = const_pref * &
- alphasPDF (dble (gev_pt))**2 * &
- ps_io_pol (process_id, pt2shat) * &
- pdf_in_in_kind &
- (process_id, double_pdf_id, cart(1), cart(2), gev_pt) * &
- denom_param(hyp) / a
- else
- dddsigma = zero
- end if
- end subroutine interactions_dddsigma
-
-@ %def interactions_dddsigma
-@
-<<Muli interactions: public>>=
- public :: interactions_dddsigma_print
-<<Muli interactions: procedures>>=
- subroutine interactions_dddsigma_print &
- (process_id, double_pdf_id, hyp, cart, dddsigma)
- real(default), intent(out) :: dddsigma
- integer, intent(in) :: process_id, double_pdf_id
- real(default), dimension(3), intent(in) :: hyp
- real(default), dimension(3), intent(out) :: cart
- real(default) :: a, pt2shat, gev_pt
- cart = h_to_c_param (hyp)
- a = product (cart(1:2))
- if (cart(1) <= 1._default .and. cart(2) <= 1._default) then
- pt2shat = hyp(3) / a
- gev_pt=sqrt(hyp(3))*gev_pt_max
- ! print *,process_id,pt2shat
- dddsigma = const_pref * &
- ! alphasPDF(dble (gev_pt))**2 * &
- ps_io_pol (process_id, pt2shat) * &
- pdf_in_in_kind &
- (process_id, double_pdf_id, cart(1), cart(2), gev_pt) * &
- denom_param (hyp) / a
- else
- dddsigma = zero
- end if
- write(11, *) dddsigma, pt2shat, &
- pdf_in_in_kind (process_id, double_pdf_id, cart(1), cart(2), &
- gev_pt), ps_io_pol (process_id, pt2shat), const_pref, &
- denom_param(hyp), a
- flush(11)
- end subroutine interactions_dddsigma_print
-
-@ %def interactions_dddsigma_print
-@
-<<Muli interactions: public>>=
- public :: interactions_dddsigma_cart
-<<Muli interactions: procedures>>=
- pure subroutine interactions_dddsigma_cart &
- (process_id, double_pdf_id, cart, dddsigma)
- real(default), intent(out) :: dddsigma
- integer, intent(in) :: process_id, double_pdf_id
- real(default), dimension(3), intent(in) :: cart
- real(default) :: a, pt2shat, gev_pt
- a = product (cart(1:2))
- if (cart(1) <= one .and. cart(2) <= one) then
- pt2shat = cart(3) / a
- gev_pt = sqrt(cart(3)) * gev_pt_max
- ! print *,process_id,pt2shat
- dddsigma = const_pref * &
- alphasPDF (dble (gev_pt))**2 * &
- ps_io_pol (process_id, pt2shat) * &
- pdf_in_in_kind &
- (process_id, double_pdf_id, cart(1), cart(2), gev_pt) * &
- denom_cart (cart) / a
- else
- dddsigma = zero
- end if
- end subroutine interactions_dddsigma_cart
-
-@ %def interactions_dddsigma_cart
-@
-<<Muli interactions: public>>=
- public :: cuba_gg_me_smooth
-<<Muli interactions: procedures>>=
- subroutine cuba_gg_me_smooth (d_hyp, hyp, d_me, me, pt2s)
- integer, intent(in) :: d_hyp, d_me
- real(default), dimension(d_hyp), intent(in) :: hyp
- real(default), dimension(1), intent(out) :: me
- real(default), dimension(3) :: cart
- real(default), intent(in) :: pt2s
- real(default) :: p, p2
- if (d_hyp == 3) then
- p = hyp(3)
- p2 = hyp(3)**2
- else
- if (d_hyp == 2) then
- p = sqrt (pt2s)
- p2 = pt2s
- end if
- end if
- cart = h_to_c_smooth ([hyp(1), hyp(2), p2])
- if (p > pts_min .and. product (cart(1:2)) > p2) then
- me(1) = const_pref * &
- alphasPDF (dble (p*gev_pt_max))**2 * &
- ps_io_pol (109, p2) * &
- pdf_in_in_kind (109, 11, cart(1), cart(2), p2) * &
- denom_smooth ([hyp(1), hyp(2), p2]) / product (cart(1:2))
- else
- me(1) = zero
- end if
- end subroutine cuba_gg_me_smooth
-
-@ %def cuba_gg_me_smooth
-@
-<<Muli interactions: public>>=
- public :: cuba_gg_me_param
-<<Muli interactions: procedures>>=
- subroutine cuba_gg_me_param (d_hyp, hyp, d_me, me, pt2s)
- integer, intent(in)::d_hyp,d_me
- real(default), dimension(d_hyp), intent(in) :: hyp
- real(default), dimension(1), intent(out) :: me
- real(default), dimension(3) :: cart
- real(default), intent(in) :: pt2s
- real(default) :: p, p2
- if (d_hyp == 3) then
- p = hyp(3)
- p2 = hyp(3)**2
- else
- if (d_hyp == 2) then
- p = sqrt (pt2s)
- p2 = pt2s
- end if
- end if
- cart = h_to_c_param ([hyp(1), hyp(2), p2])
- if (p>pts_min .and. product (cart(1:2))>p2) then
- me(1) = const_pref * &
- alphasPDF(dble (p*gev_pt_max))**2 * &
- ps_io_pol (109, p2) * &
- pdf_in_in_kind (109, 11, cart(1), cart(2), p2) * &
- denom_param ([hyp(1), hyp(2), p2]) / product(cart(1:2))
- else
- me(1) = zero
- end if
- end subroutine cuba_gg_me_param
-
-@ %def cuba_gg_me_param
-@
-<<Muli interactions: public>>=
- public :: cuba_gg_me_ort
-<<Muli interactions: procedures>>=
- subroutine cuba_gg_me_ort (d_hyp, hyp, d_me, me, pt2s)
- integer, intent(in) :: d_hyp, d_me
- real(default), dimension(d_hyp), intent(in) :: hyp
- real(default), dimension(1), intent(out) :: me
- real(default), dimension(3) :: cart
- real(default), intent(in) :: pt2s
- real(default) :: p, p2
- if (d_hyp == 3) then
- p = hyp(3)
- p2 = hyp(3)**2
- else
- if (d_hyp == 2) then
- p = sqrt(pt2s)
- p2 = pt2s
- end if
- end if
- cart = h_to_c_ort ([hyp(1), cart(2), p2])
- if (p > pts_min .and. product (cart(1:2)) > p2) then
- me(1) = const_pref * &
- alphasPDF(dble (p*gev_pt_max))**2 * &
- ps_io_pol (109, p2) * &
- pdf_in_in_kind (109, 11, cart(1), cart(2), p2) * &
- denom_ort ([hyp(1), hyp(2), p2]) / product (cart(1:2))
- else
- me(1) = zero
- end if
- end subroutine cuba_gg_me_ort
-
-@ %def cuba_gg_me_ort
-@
-<<Muli interactions: public>>=
- public :: cuba_gg_me_cart
-<<Muli interactions: procedures>>=
- subroutine cuba_gg_me_cart (d_cart, cart, d_me, me, pt2s)
- integer, intent(in) :: d_cart, d_me
- real(default), dimension(d_cart), intent(in) :: cart
- real(default), dimension(1), intent(out) :: me
- real(default), intent(in) :: pt2s
- real(default) :: a, p, p2
- if (d_cart == 3) then
- p = cart(3)
- p2 = cart(3)**2
- else
- if (d_cart == 2) then
- p = sqrt (pt2s)
- p2 = pt2s
- end if
- end if
- a = product (cart(1:2))
- if (p > pts_min .and. a > p2) then
- me(1) = const_pref * &
- alphasPDF (dble (p*gev_pt_max))**2 * &
- ps_io_pol (109, p2) * &
- pdf_in_in_kind (109, 11, cart(1), cart(2), p2) * &
- denom_cart ([cart(1), cart(2), p2]) / a
- else
- me(1) = zero
- end if
- end subroutine cuba_gg_me_cart
-
-@ %def cuba_gg_me_cart
-@
-<<Muli interactions: public>>=
- public :: interactions_proton_proton_integrand_generic_17_reg
-<<Muli interactions: procedures>>=
- subroutine interactions_proton_proton_integrand_generic_17_reg &
- (hyp_2, trafo, f, pt)
- real(default), dimension(2), intent(in) :: hyp_2
- procedure(coord_hcd_in) :: trafo
- real(default), dimension(17), intent(out) :: f
- class(transverse_mom_t), intent(in) :: pt
- real(default), dimension(3) :: cart, hyp_3
- real(default), dimension(5) :: psin
- real(double), dimension(-6:6) :: c_dble, d_dble
- real(default), dimension(-6:6) :: c, d
- real(default) :: gev_pt, gev2_pt, pts, pt2s, pt2shat, a, &
- pdf_seaquark_seaquark, pdf_seaquark_gluon, pdf_gluon_gluon, &
- pdf_up_seaquark, pdf_up_gluon, pdf_down_seaquark, pdf_down_gluon, &
- v1u, v1d, v2u, v2d, denom
-
- pts = pt%get_unit_scale()
- pt2s = pt%get_unit2_scale()
- gev_pt = pt%get_gev_scale()
- gev2_pt = pt%get_gev2_scale()
-
- hyp_3(1:2) = hyp_2
- hyp_3(3) = pt2s
- call trafo (hyp_3, cart, denom)
- a = product (cart(1:2))
- if (cart(1) <= one .and. cart(2) <= one .and. a > pt2s) then
- pt2shat = pt2s / a
- ! phase space polynom
- psin = matmul ([one, pt2shat, pt2shat**2, pt2shat**3], &
- phase_space_coefficients_in)
- ! pdf
- call evolvepdf (dble (cart(1)), dble (gev_pt), c_dble)
- call evolvepdf (dble (cart(2)), dble (gev_pt), d_dble)
- c = c_dble
- d = d_dble
- ! c = [1,1,1,1,1,1,1,1,1,1,1,1,1]*1D0
- ! d = c
- v1d = c(1) - c(-1)
- v1u = c(2) - c(-2)
- v2d = d(1) - d(-1)
- v2u = d(2) - d(-2)
- c(1) = c(-1)
- c(2) = c(-2)
- d(1) = d(-1)
- d(2) = d(-2)
- f(1) = zero
- !!! gluon_gluon
- f( 2) = (c(0)*d(0)) * psin(5)
- !!! type5
- !!! gluon_seaquark
- f( 3) = (c(0)*d(-4) + c(0)*d(-3) + c(0)*d(-2) + c(0)*d(-1) + &
- c(0)*d(1) + c(0)*d(2) + c(0)*d(3) + c(0)*d(4)) * psin(4)
- !!! type4
- !!! gluon_down
- f( 4) = (c(0)*v2d) * psin(4)
- !!! type4
- !!! gluon_up
- f( 5) = (c(0)*v2u) * psin(4)
- !!! type4
- !!! seaquark_gluon
- f( 6) = (c(-4)*d(0) + c(-3)*d(0) + c(-2)*d(0) + c(-1)*d(0) + &
- c(1)*d(0) + c(2)*d(0) + c(3)*d(0) + c(4)*d(0)) * psin(4)
- !!! type4
- !!! seaquark_seaquark
- f( 7) = &
- !!! type1
- (c(-4)*d(-3) + c(-4)*d(-2) + c(-4)*d(-1) + c(-4)*d( 1) + &
- c(-4)*d( 2) + c(-4)*d( 3) + c(-3)*d(-4) + c(-3)*d(-2) + &
- c(-3)*d(-1) + c(-3)*d( 1) + c(-3)*d( 2) + c(-3)*d( 4) + &
- c(-2)*d(-4) + c(-2)*d(-3) + c(-2)*d(-1) + c(-2)*d( 1) + &
- c(-2)*d( 3) + c(-2)*d( 4) + c(-1)*d(-4) + c(-1)*d(-3) + &
- c(-1)*d(-2) + c(-1)*d( 2) + c(-1)*d( 3) + c(-1)*d( 4) + &
- c( 1)*d(-4) + c( 1)*d(-3) + c( 1)*d(-2) + c( 1)*d( 2) + &
- c( 1)*d( 3) + c( 1)*d( 4) + c( 2)*d(-4) + c( 2)*d(-3) + &
- c( 2)*d(-1) + c( 2)*d( 1) + c( 2)*d( 3) + c( 2)*d( 4) + &
- c( 3)*d(-4) + c( 3)*d(-2) + c( 3)*d(-1) + c( 3)*d( 1) + &
- c( 3)*d( 2) + c( 3)*d( 4) + c( 4)*d(-3) + c( 4)*d(-2) + &
- c( 4)*d(-1) + c( 4)*d( 1) + c( 4)*d( 2) + c( 4)*d( 3)) * &
- psin(1) + &
- !!! type2
- (c(-4)*d(-4) + c(-3)*d(-3) + c(-2)*d(-2) + c(-1)*d(-1) + &
- c( 4)*d( 4) + c( 3)*d( 3) + c(2)*d( 2) + c(1)*d( 1)) * &
- psin(2) + &
- !!! type3
- (c(-4)*d( 4) + c(-3)*d( 3) + c(-2)*d( 2) + c(-1)*d( 1) + &
- c( 4)*d(-4) + c( 3)*d(-3) + c(2)*d(-2) + c(1)*d(-1)) * &
- psin(3)
- !!! seaquark_down
- f( 8) = &
- !!! type1
- (c(-4)*v2d + c(-3)*v2d + c(-2)*v2d + c( 2)*v2d + &
- c( 3)*v2d + c( 4)*v2d) * psin(1) + &
- !!! type2
- c( 1)*v2d * psin(2) + &
- !!! type3
- c(-1)*v2d * psin(3)
- !!! seaquark_up
- f( 9) = &
- !!! type1
- (c(-4)*v2u + c(-3)*v2u + c(-1)*v2u + c( 1)*v2u + &
- c( 3)*v2u + c( 4)*v2u) * psin(1) + &
- !!! type2
- c(2)*v2u * psin(2) + &
- !!! type3
- c(-2)*v2u * psin(3)
- !!! down_gluon
- f(10) = (v1d*d( 0)) * psin(4)
- !!! type4
- !!! down_seaquark
- f(11) = &
- !!! type1
- (v1d*d(-4) + v1d*d(-3) + v1d*d(-2) + v1d*d( 2) + &
- v1d*d( 3) + v1d*d( 4)) * psin(1) + &
- !!! type2
- v1d*d( 1) * psin(2) + &
- !!! type3
- v1d*d(-1) * psin(3)
- !!! down_down
- f(12) = v1d*v2d * psin(2)
- !!! down_up
- f(13) = v1d*v2u * psin(1)
- !!! up_gluon
- f(14) = (v1u*d(0)) * psin(4)
- !!! type4
- !!! up_seaquark
- f(15) = &
- !!! type1
- (v1u*d(-4) + v1u*d(-3) + v1u*d(-1) + v1u*d( 1) + &
- v1u*d( 3) + v1u*d( 4)) * psin(1) + &
- !!! type2
- v1u*d(2) * psin(2) + &
- !!! type3
- v1u*d(-2) * psin(3)
- !!! up_down
- f(16) = v1u * v2d * psin(1)
- !!! up_up
- f(17) = v1u * v2u * psin(2)
- f=f * const_pref &
- * alphasPDF (dble (sqrt(gev2_pt+gev2_p_t_0)))**2 &
- * denom / a
- ! print *, const_pref, alphasPDF(gev_pt)**2, denom_smooth (hyp), a
- else
- f = [zero, zero, zero, zero, zero, zero, zero, zero, zero, &
- zero, zero, zero, zero, zero, zero, zero, zero]
- end if
- ! print *, pt2shat, c(0)*d(0), psin(5), const_pref, &
- ! alphasPDF(gev_pt)**2, denom, a
- end subroutine interactions_proton_proton_integrand_generic_17_reg
-
-@ %def interactions_proton_proton_integrand_generic_17_reg
-@
-<<Muli interactions: procedures>>=
- ! subroutine coordinates_proton_proton_integrand_cart_11 &
- ! (d_hyp, hyp_2, d_f, f)
- ! integer, intent(in) :: d_hyp, d_f
- ! real(default), dimension(2), intent(in) :: hyp_2
- ! real(default), dimension(11), intent(out) :: f
- ! call coordinates_proton_proton_integrand_generic_11 &
- ! (hyp_2, coordinates_hcd_cart, f)
- ! ! write (51,*) hyp_2, momentum_get_pts_scale(), f
- ! end subroutine coordinates_proton_proton_integrand_cart_11
-
-@ %def coordinates_proton_proton_integrand_cart_11
-@
-<<Muli interactions: procedures>>=
- ! subroutine coordinates_proton_proton_integrand_ort_11 &
- ! (d_hyp, hyp_2, d_f, f)
- ! integer, intent(in) :: d_hyp, d_f
- ! real(default), dimension(2), intent(in) :: hyp_2
- ! real(default), dimension(11), intent(out) :: f
- ! call coordinates_proton_proton_integrand_generic_11 &
- ! (hyp_2, coordinates_hcd_ort, f)
- ! ! write (52,*) hyp_2, momentum_get_pts_scale(), f
- ! end subroutine coordinates_proton_proton_integrand_ort_11
-
-@ %def coordinates_proton_proton_integrand_ort_11
-@
-<<Muli interactions: procedures>>=
- ! subroutine coordinates_proton_proton_integrand_param_11 &
- ! (d_hyp, hyp_2, d_f, f)
- ! integer, intent(in) :: d_hyp, d_f
- ! real(default), dimension(2), intent(in) :: hyp_2
- ! real(default), dimension(11), intent(out) :: f
- ! call coordinates_proton_proton_integrand_generic_11 &
- ! (hyp_2, coordinates_hcd_param, f)
- ! ! write(53,*) hyp_2, momentum_get_pts_scale(), f
- ! end subroutine coordinates_proton_proton_integrand_param_11
-
-@ %def coordinates_proton_proton_integrand_param_11
-@
-<<Muli interactions: procedures>>=
- ! subroutine coordinates_proton_proton_integrand_smooth_11 &
- ! (d_hyp, hyp_2, d_f, f)
- ! integer, intent(in)::d_hyp,d_f
- ! real(default), dimension(2), intent(in) :: hyp_2
- ! real(default), dimension(11), intent(out) :: f
- ! call coordinates_proton_proton_integrand_generic_11 (hyp_2, &
- ! coordinates_hcd_smooth, f)
- ! ! write (54,*) hyp_2, momentum_get_pts_scale(), f
- ! end subroutine coordinates_proton_proton_integrand_smooth_11
-
-@ %def coordinates_proton_proton_integrand_smooth_11
-@
-<<Muli interactions: public>>=
- public :: interactions_proton_proton_integrand_param_17_reg
-<<Muli interactions: procedures>>=
- subroutine interactions_proton_proton_integrand_param_17_reg &
- (d_hyp, hyp_2, d_f, f, pt)
- integer, intent(in) :: d_hyp, d_f
- real(default), dimension(2), intent(in) :: hyp_2
- real(default), dimension(17), intent(out) :: f
- class(transverse_mom_t), intent(in) :: pt
- call interactions_proton_proton_integrand_generic_17_reg &
- (hyp_2, coordinates_hcd_param_reg, f, pt)
- ! write (53,*) hyp_2,momentum_get_pts_scale(),f
- end subroutine interactions_proton_proton_integrand_param_17_reg
-
-@ %def interactions_proton_proton_integrand_param_17_reg
-@
-<<Muli interactions: public>>=
- public :: interactions_proton_proton_integrand_smooth_17_reg
-<<Muli interactions: procedures>>=
- subroutine interactions_proton_proton_integrand_smooth_17_reg &
- (d_hyp, hyp_2, d_f, f, pt)
- integer, intent(in) :: d_hyp, d_f
- real(default), dimension(2), intent(in) :: hyp_2
- real(default), dimension(17), intent(out) :: f
- class(transverse_mom_t), intent(in) :: pt
- call interactions_proton_proton_integrand_generic_17_reg &
- (hyp_2, coordinates_hcd_smooth_reg, f, pt)
- ! write (53,*)hyp_2,momentum_get_pts_scale(), f
- end subroutine interactions_proton_proton_integrand_smooth_17_reg
-
-@ %def interactions_proton_proton_integrand_smooth_17_reg
-@
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{VEGAS and CUBA integration routines}
-
-This file contains the module [[muli_cuba]], a wrapper for the CUBA
-integration library. Different algorithms and settings have been tried out
-for the integration, including VEGAS, and this wrapper has been mainly
-written for that purpose.
-
-<<[[muli_cuba.f90]]>>=
-<<File header>>
-
-module muli_cuba
-
-<<Use kinds>>
- use constants
- use diagnostics
- use muli_base
- use muli_momentum
-
-<<Standard module head>>
-
-<<Muli CUBA: public>>
-
-<<Muli CUBA: variables>>
-
-<<Muli CUBA: types>>
-
-<<Muli CUBA: interfaces>>
-
-contains
-
-<<Muli CUBA: procedures>>
-
-end module muli_cuba
-@ %def muli_cuba
-@
-<<Muli CUBA: variables>>=
- integer, parameter :: max_maxeval = huge(1)
-
-@ %def max_maxeval
-@
-<<Muli CUBA: public>>=
- public :: cuba_class
-<<Muli CUBA: types>>=
- type, extends (ser_class_t), abstract :: cuba_class
- real(default) :: start_time = zero
- real(default) :: stop_time = zero
- real(default) :: run_time = zero
- integer :: dim_x = 2
- integer :: dim_f = 1
- type(transverse_mom_t) :: userdata
- real(default) :: eps_rel = 1.E-3_default
- real(default) :: eps_abs = 0._default
- integer :: flags = 0
- integer :: seed = 1
- integer :: min_eval = 0
- integer :: max_eval = max_maxeval
- integer :: neval = 0
- integer, public :: fail = -1
- integer :: nregions = 0
- real(default), dimension(:), allocatable :: integral
- real(default), dimension(:), allocatable :: error
- real(default), dimension(:), allocatable :: prob
- procedure(integrand_interface), nopass, pointer :: integrand
- contains
- <<Muli CUBA: cuba class: TBP>>
- end type cuba_class
-
-@ %def cuba_class
-@
-<<Muli CUBA: types>>=
- type, extends (cuba_class) :: cuba_cuhre_t
- private
- integer :: key = 13
- contains
- <<Muli CUBA: cuba cuhre: TBP>>
- end type cuba_cuhre_t
-
-@ %def cuba_cuhre_t
-@
-<<Muli CUBA: types>>=
- type, extends (cuba_class) :: cuba_suave_t
- private
- integer :: nnew = 10000 !1000
- integer :: flatness = 5 !50
- contains
- <<Muli CUBA: cuba suave: TBP>>
- end type cuba_suave_t
-
-@ %def cuba_suave_t
-@
-<<Muli CUBA: public>>=
- public :: cuba_divonne_t
-<<Muli CUBA: types>>=
- type, extends (cuba_class) :: cuba_divonne_t
- private
- integer :: key1 = 13
- integer :: key2 = 13
- integer :: key3 = 13
- integer :: maxpass = 2
- real(default) :: border = zero
- real(default) :: maxchisq = 10._default
- real(default) :: mindeviation = .25_default
- integer :: ngiven = 0
- integer :: ldxgiven = 0
- ! real(default), dimension(ldxgiven,ngiven) :: &
- ! xgiven = reshape( source = [ 0.0,0.0 ], shape = [2,1])
- real(default), dimension(:,:), allocatable :: xgiven
- ! real(default), dimension(2) :: xgiven = [1E-1_default, 5E-1_default]
- integer :: nextra = 0
- contains
- <<Muli CUBA: cuba divonne: TBP>>
- end type cuba_divonne_t
-
-@ %def cuba_divonne_t
-@
-<<Muli CUBA: types>>=
- type, extends (cuba_class) :: cuba_vegas_t
- private
- integer :: nstart = 500
- integer :: nincrease = 1000
- integer :: nbatch = 1000
- integer :: gridno = 0
- character(len=8), pointer :: statefile => null()
- contains
- <<Muli CUBA: cuba vegas: TBP>>
- end type cuba_vegas_t
-
-@ %def cuba_vegas_t
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: write_to_marker => cuba_write_to_marker
-<<Muli CUBA: procedures>>=
- subroutine cuba_write_to_marker (this, marker, status)
- class(cuba_class), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("cuba_class")
- call marker%mark ("dim_x", this%dim_x)
- call marker%mark ("dim_f", this%dim_f)
- call marker%mark ("eps_rel", this%eps_rel)
- call marker%mark ("eps_abs", this%eps_abs)
- call marker%mark ("flags", this%flags)
- call marker%mark ("min_eval", this%min_eval)
- call marker%mark ("max_eval", this%max_eval)
- call marker%mark ("neval", this%neval)
- call marker%mark ("fail", this%fail)
- call marker%mark ("nregions", this%nregions)
- if (allocated (this%integral)) then
- call marker%mark ("integral", this%integral)
- else
- call marker%mark_null ("integral")
- end if
- if (allocated(this%error)) then
- call marker%mark ("error", this%error)
- else
- call marker%mark_null ("error")
-
- end if
- if (allocated (this%prob)) then
- call marker%mark ("prob", this%prob)
- else
- call marker%mark_null ("prob")
- end if
- call marker%mark_null ("cuba_class")
- end subroutine cuba_write_to_marker
-
-@ %def cuba_write_to_marker
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: read_from_marker => cuba_read_from_marker
-<<Muli CUBA: procedures>>=
- subroutine cuba_read_from_marker (this, marker, status)
- class(cuba_class), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out)::status
- call marker%pick_begin ("CUBA_CLASS", status=status)
- call marker%pick ("dim_x", this%dim_x,status)
- call marker%pick ("dim_f", this%dim_f,status)
- call marker%pick ("eps_rel", this%eps_rel,status)
- call marker%pick ("eps_abs", this%eps_abs,status)
- call marker%pick ("flags", this%flags,status)
- call marker%pick ("min_eval", this%min_eval,status)
- call marker%pick ("max_eval", this%max_eval,status)
- call marker%pick ("neval", this%neval,status)
- call marker%pick ("fail", this%fail,status)
- call marker%pick ("nregions", this%nregions,status)
- call marker%verify_nothing("integral",status)
- if (allocated (this%integral)) deallocate (this%integral)
- if (status == serialize_ok) then
- allocate (this%integral (this%dim_f))
- call marker%pick ("integral", this%integral, status)
- end if
- call marker%verify_nothing ("error", status)
- if (allocated (this%error)) deallocate (this%error)
- if (status == serialize_ok) then
- allocate (this%error (this%dim_f))
- call marker%pick ("error", this%error, status)
- end if
- call marker%verify_nothing ("prob", status)
- if (allocated (this%prob)) deallocate (this%prob)
- if (status == serialize_ok) then
- allocate (this%prob (this%dim_f))
- call marker%pick ("prob", this%prob, status)
- end if
- call marker%pick_end ("cuba_class", status)
- end subroutine cuba_read_from_marker
-
-@ %def cuba_read_from_marker
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: print_to_unit => cuba_print_to_unit
-<<Muli CUBA: procedures>>=
- subroutine cuba_print_to_unit (this, unit, parents, components, peers)
- class(cuba_class), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- character(11) :: n
- write (n, '("(",I2,"(E12.4))")') this%dim_f
- write (unit, "(1x,A)") "Components of cuba_class:"
- write (unit, "(3x,A)") "Parameters:"
- write (unit, "(3x,A,I10)") "dim_f: ", this%dim_f
- write (unit, "(3x,A,I10)") "dim_x: ", this%dim_x
- call this%userdata%print_to_unit (unit, parents, components-1, peers)
- write (unit, "(3x,A,E10.4)") "eps_rel: ", this%eps_rel
- write (unit, "(3x,A,E10.4)") "eps_abs: ", this%eps_abs
- write (unit, "(3x,A,I10)") "flags: ", this%flags
- write (unit, "(3x,A,I10)") "seed: ", this%seed
- write (unit, "(3x,A,I10)") "min_eval: ", this%min_eval
- write (unit, "(3x,A,I10)") "max_eval: ", this%max_eval
- write (unit, "(3x,A)") "Results:"
- write (unit, "(3x,A,I10)") "neval: ", this%neval
- write (unit, "(3x,A,I10)") "fail: ", this%fail
- write (unit, "(3x,A)", advance="no") "integral: "
- write (unit, fmt=n) this%integral
- write (unit, "(3x,A)", advance="no") "error: "
- write (unit, fmt=n) this%error
- write (unit, "(3x,A)", advance="no") "prob: "
- write (unit, fmt=n) this%prob
- write (unit, "(3x,A,E10.4)") "time: ", &
- this%stop_time - this%start_time
- ! write(unit,'("time: ",E10.4)') this%run_time
- end subroutine cuba_print_to_unit
-
-@ %def cuba_print_to_unit
-@
-<<Muli CUBA: cuba class: TBP>>=
- generic :: get_integral => get_integral_array, get_integral_1
- procedure :: get_integral_array => cuba_get_integral_array
- procedure :: get_integral_1 => cuba_get_integral_1
-<<Muli CUBA: procedures>>=
- subroutine cuba_get_integral_array (this, integral)
- class(cuba_class) :: this
- real(default), intent(out), dimension(:) :: integral
- integral = this%integral
- end subroutine cuba_get_integral_array
-
-@ %def cuba_get_integral_array
-@
-<<Muli CUBA: procedures>>=
- subroutine cuba_get_integral_1 (this, integral)
- class(cuba_class) :: this
- real(default), intent(out) :: integral
- integral = this%integral(1)
- end subroutine cuba_get_integral_1
-
-@ %def cuba_get_integral_1
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: copy_common => cuba_copy_common
-<<Muli CUBA: procedures>>=
- subroutine cuba_copy_common (this, source)
- class(cuba_class), intent(out) :: this
- class(cuba_class), intent(in) :: source
- this%dim_x = source%dim_x
- this%dim_f = source%dim_f
- this%eps_rel = source%eps_rel
- this%eps_abs = source%eps_abs
- this%flags = source%flags
- this%min_eval = source%min_eval
- this%max_eval = source%max_eval
- call this%alloc()
- end subroutine cuba_copy_common
-
-@ %def cuba_copy_common
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: set_common => cuba_set_common
-@
-<<Muli CUBA: procedures>>=
- subroutine cuba_set_common (this, dim_x, dim_f, eps_rel, eps_abs, &
- flags, seed, min_eval, max_eval, integrand, userdata)
- class(cuba_class), intent(inout) :: this
- integer, intent(in), optional :: dim_x, dim_f, flags, min_eval, &
- max_eval, seed
- real(default), intent(in), optional :: eps_rel,eps_abs
- type(transverse_mom_t), intent(in), optional :: userdata
- procedure(integrand_interface), optional :: integrand
- if (present (dim_x)) then
- call this%set_dim_x (dim_x)
- end if
- if (present (dim_f)) then
- call this%set_dim_f (dim_f)
- end if
- if (present (flags)) then
- this%flags = flags
- end if
- if (present (seed)) then
- this%seed = seed
- end if
- if (present (min_eval)) then
- this%min_eval = min_eval
- end if
- if (present (max_eval)) then
- if (max_eval < max_maxeval) then
- this%max_eval = max_eval
- else
- call msg_warning &
- ("cuba_set_common: Value of max_eval is too large.")
- this%max_eval = max_maxeval
- end if
- end if
- if (present (eps_rel)) then
- this%eps_rel = eps_rel
- end if
- if (present (eps_abs)) then
- this%eps_abs = eps_abs
- end if
- if (present (integrand)) this%integrand=>integrand
- if (present (userdata)) this%userdata=userdata
- end subroutine cuba_set_common
-
-@ %def cuba_set_common
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: set_dim_f => cuba_set_dim_f
-<<Muli CUBA: procedures>>=
- subroutine cuba_set_dim_f (this, new_dim_f)
- class(cuba_class) :: this
- integer, intent(in) :: new_dim_f
- if (new_dim_f > 0) then
- this%dim_f = new_dim_f
- call this%alloc_dim_f
- else
- call msg_error ("cuba_set_dim_f: New value for dim_f is " &
- // "negative. dim_f is not set.")
- end if
- end subroutine cuba_set_dim_f
-
-@ %def cuba_set_dim_f
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: set_dim_x => cuba_set_dim_x
-<<Muli CUBA: procedures>>=
- subroutine cuba_set_dim_x (this, new_dim_x)
- class(cuba_class) :: this
- integer, intent(in) :: new_dim_x
- if (new_dim_x > 0) then
- this%dim_x = new_dim_x
- else
- call msg_error ("cuba_set_dim_x: New value for dim_x is " &
- // "negative. dim_x is not set.")
- end if
- end subroutine cuba_set_dim_x
-
-@ %def cuba_set_dim_x
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: reset_timer => cuba_reset_timer
-<<Muli CUBA: procedures>>=
- subroutine cuba_reset_timer (this)
- class(cuba_class), intent(inout) :: this
- this%start_time = zero
- this%stop_time = zero
- this%run_time = zero
- end subroutine cuba_reset_timer
-
-@ %def cuba_reset_timer
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: integrate_with_timer => cuba_integrate_with_timer
-<<Muli CUBA: procedures>>=
- subroutine cuba_integrate_with_timer (this, integrand)
- class(cuba_class), intent(inout) :: this
- procedure(integrand_interface) :: integrand
- call cpu_time (this%start_time)
- call this%integrate (integrand)
- call cpu_time (this%stop_time)
- this%run_time = this%run_time + this%stop_time - this%start_time
- end subroutine cuba_integrate_with_timer
-
-@ %def cuba_integrate_with_timer
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: integrate_associated => cuba_integrate_associated
-<<Muli CUBA: procedures>>=
- subroutine cuba_integrate_associated (this)
- class(cuba_class), intent(inout) :: this
- call this%integrate_with_timer (this%integrand)
- end subroutine cuba_integrate_associated
-
-@ %def cuba_integrate_associated
-@
-<<Muli CUBA: cuba class: TBP>>=
- generic :: integrate => integrate_nd, integrate_userdata
- procedure(integrate_interface), deferred :: integrate_nd
- procedure(integrate_userdata_interface), deferred :: integrate_userdata
- procedure(cuba_copy_interface), deferred :: copy
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: dealloc_dim_f => cuba_dealloc_dim_f
-<<Muli CUBA: procedures>>=
- subroutine cuba_dealloc_dim_f(this)
- class(cuba_class) :: this
- ! print '("cuba_dealloc_dim_f...")'
- if (allocated (this%integral)) then
- deallocate (this%integral)
- end if
- if (allocated (this%error)) then
- deallocate (this%error)
- end if
- if (allocated (this%prob)) then
- deallocate (this%prob)
- end if
- ! print '("done")'
- end subroutine cuba_dealloc_dim_f
-
-@ %def cuba_dealloc_dim_f
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: alloc_dim_f => cuba_alloc_dim_f
-<<Muli CUBA: procedures>>=
- subroutine cuba_alloc_dim_f (this)
- class(cuba_class) :: this
- call this%dealloc_dim_f ()
- allocate (this%integral (this%dim_f))
- allocate (this%error (this%dim_f))
- allocate (this%prob (this%dim_f))
- end subroutine cuba_alloc_dim_f
-
-@ %def cuba_alloc_dim_f
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: dealloc => cuba_dealloc
-<<Muli CUBA: procedures>>=
- subroutine cuba_dealloc (this)
- class(cuba_class) :: this
- call this%dealloc_dim_f
- end subroutine cuba_dealloc
-
-@ %def cuba_dealloc
-@
-<<Muli CUBA: cuba class: TBP>>=
- procedure :: alloc => cuba_alloc
-<<Muli CUBA: procedures>>=
- subroutine cuba_alloc (this)
- class(cuba_class) :: this
- call this%alloc_dim_f
- end subroutine cuba_alloc
-
-@ %def cuba_alloc
-@
-<<Muli CUBA: cuba vegas: TBP>>=
- procedure :: write_to_marker => cuba_vegas_write_to_marker
-<<Muli CUBA: procedures>>=
- subroutine cuba_vegas_write_to_marker (this, marker, status)
- class(cuba_vegas_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("cuba_vegas_t")
- call cuba_write_to_marker (this, marker, status)
- call marker%mark("nstart", this%nstart)
- call marker%mark("nincrease", this%nincrease)
- call marker%mark_null ("cuba_vegas_t")
- end subroutine cuba_vegas_write_to_marker
-
-@ %def cuba_vegas_write_to_marker
-@
-<<Muli CUBA: cuba vegas: TBP>>=
- procedure :: read_from_marker => cuba_vegas_read_from_marker
-<<Muli CUBA: procedures>>=
- subroutine cuba_vegas_read_from_marker (this, marker, status)
- class(cuba_vegas_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%pick_begin ("cuba_vegas_t", status=status)
- call cuba_read_from_marker (this, marker, status)
- call marker%pick ("nstart", this%nstart, status)
- call marker%pick ("nincrease", this%nincrease, status)
- call marker%pick_end ("cuba_vegas_t", status)
- end subroutine cuba_vegas_read_from_marker
-
-@ %def cuba_vegas_read_from_marker
-@
-<<Muli CUBA: cuba vegas: TBP>>=
- procedure :: print_to_unit => cuba_vegas_print_to_unit
-<<Muli CUBA: procedures>>=
- subroutine cuba_vegas_print_to_unit(this,unit,parents,components,peers)
- class(cuba_vegas_t), intent(in) :: this
- INTEGER, INTENT(IN) :: unit
- integer(dik), intent(in)::parents,components,peers
- if (parents>0)call cuba_print_to_unit(this,unit,parents-1,components,peers)
- write (unit, "(1x,A)") "Components of cuba_vegas_t:"
- write (unit, "(3x,A,I10)") "nstart: ", this%nstart
- write (unit, "(3x,A,I10)") "nincrease: ", this%nincrease
- write (unit, "(3x,A,I10)") "nbatch: ", this%nbatch
- write (unit, "(3x,A,I10)") "gridno: ", this%gridno
- if (associated (this%statefile)) then
- write (unit, "(3x,A,A)") "statefile: ", this%statefile
- else
- write (unit, "(3x,A)") "statefile: not associated"
- end if
- end subroutine cuba_vegas_print_to_unit
-
-@ %def cuba_vegas_print_to_unit
-@
-<<Muli CUBA: cuba vegas: TBP>>=
- procedure, nopass :: get_type => cuba_vegas_get_type
-<<Muli CUBA: procedures>>=
- pure subroutine cuba_vegas_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="cuba_vegas_t")
- end subroutine cuba_vegas_get_type
-
-@ %def cuba_vegas_get_type
-@
-<<Muli CUBA: cuba vegas: TBP>>=
- procedure :: integrate_nd => integrate_vegas
-<<Muli CUBA: procedures>>=
- subroutine integrate_vegas (this, integrand)
- class(cuba_vegas_t), intent(inout) :: this
- procedure(integrand_interface) :: integrand
- ! print '("vegas")'
- ! call vegas (this%dim_x, this%dim_f, integrand, this%userdata, &
- ! this%eps_rel, this%eps_abs, this%flags, this%seed, &
- ! this%min_eval, this%max_eval, this%nstart, this%nincrease, &
- ! this%nbatch, this%gridno, this%statefile, this%neval, &
- ! this%fail, this%integral, this%error, this%prob)
- end subroutine integrate_vegas
-
-@ %def integrate_vegas
-@
-<<Muli CUBA: cuba vegas: TBP>>=
- procedure :: integrate_userdata => integrate_vegas_userdata
-<<Muli CUBA: procedures>>=
- subroutine integrate_vegas_userdata (this, integrand, userdata)
- class(cuba_vegas_t), intent(inout) :: this
- procedure(integrand_interface) :: integrand
- class(transverse_mom_t), intent(in) :: userdata
- ! print '("vegas")'
- ! call vegas(this%dim_x, this%dim_f, integrand, userdata, this%eps_rel, &
- ! this%eps_abs, this%flags, this%seed, this%min_eval, this%max_eval, &
- ! this%nstart, this%nincrease, this%nbatch, this%gridno, &
- ! this%statefile, this%neval, this%fail, this%integral, &
- ! this%error, this%prob)
- end subroutine integrate_vegas_userdata
-
-@ %def integrate_vegas_userdata
-@
-<<Muli CUBA: cuba vegas: TBP>>=
- procedure :: copy => cuba_vegas_copy
-<<Muli CUBA: procedures>>=
- subroutine cuba_vegas_copy (this, source)
- class(cuba_vegas_t), intent(out) :: this
- class(cuba_class), intent(in) :: source
- select type (source)
- class is (cuba_vegas_t)
- call this%copy_common (source)
- this%nstart = source%nstart
- this%nincrease = source%nincrease
- class default
- call msg_error ("cuba_vegas_copy: type of source is not type " &
- // "compatible with cuba_vegas_t.")
- end select
- end subroutine cuba_vegas_copy
-
-@ %def cuba_vegas_copy
-@
-<<Muli CUBA: cuba vegas: TBP>>=
- procedure :: set_deferred => cuba_vegas_set_deferred
-<<Muli CUBA: procedures>>=
- subroutine cuba_vegas_set_deferred &
- (this, n_start, n_increase, nbatch, gridno, statefile)
- class(cuba_vegas_t), intent(inout) :: this
- integer, intent(in), optional :: n_start, n_increase, nbatch, gridno
- character(len=*), intent(in), target, optional :: statefile
- if (present (n_start)) this%nstart = n_start
- if (present (n_increase)) this%nincrease = n_increase
- if (present (nbatch)) this%nbatch = nbatch
- if (present (gridno)) this%gridno = gridno
- if (present (statefile)) this%statefile => statefile
- end subroutine cuba_vegas_set_deferred
-
-@ %def cuba_vegas_set_deferred
-@
-<<Muli CUBA: cuba divonne: TBP>>=
- procedure :: write_to_marker => cuba_divonne_write_to_marker
-<<Muli CUBA: procedures>>=
- subroutine cuba_divonne_write_to_marker (this, marker, status)
- class(cuba_divonne_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("cuba_divonne_t")
- call cuba_write_to_marker (this, marker, status)
- call marker%mark ("key1", this%key1)
- call marker%mark ("key2", this%key2)
- call marker%mark ("key3", this%key3)
- call marker%mark ("maxpass", this%maxpass)
- call marker%mark ("border", this%border)
- call marker%mark ("maxchisq", this%maxchisq)
- call marker%mark ("mindeviation", this%mindeviation)
- call marker%mark ("ngiven", this%ngiven)
- call marker%mark ("ldxgiven", this%ldxgiven)
- call marker%mark ("nextra", this%nextra)
- call marker%mark ("xgiven", this%xgiven)
- call marker%mark_null ("cuba_divonne_t")
- end subroutine cuba_divonne_write_to_marker
-
-@ %def cuba_divonne_write_to_marker
-@
-<<Muli CUBA: cuba divonne: TBP>>=
- procedure :: read_from_marker => cuba_divonne_read_from_marker
-<<Muli CUBA: procedures>>=
- subroutine cuba_divonne_read_from_marker (this, marker, status)
- class(cuba_divonne_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%pick_begin ("cuba_divonne_t", status=status)
- call cuba_read_from_marker (this, marker, status)
- call marker%pick ("key1", this%key1, status)
- call marker%pick ("key2", this%key2, status)
- call marker%pick ("key3", this%key3, status)
- call marker%pick ("maxpass", this%maxpass, status)
- call marker%pick ("border", this%border, status)
- call marker%pick ("maxchisq", this%maxchisq, status)
- call marker%pick ("mindeviation", this%mindeviation, status)
- call marker%pick ("ngiven", this%ngiven, status)
- call marker%pick ("ldxgiven", this%ldxgiven, status)
- call marker%pick ("nextra", this%nextra, status)
- if (allocated (this%xgiven)) deallocate (this%xgiven)
- allocate (this%xgiven (this%ldxgiven, this%ngiven))
- call marker%pick ("xgiven", this%xgiven, status)
- call marker%pick_end ("cuba_divonne_t", status)
- end subroutine cuba_divonne_read_from_marker
-
-@ %def cuba_divonne_read_from_marker
-@
-<<Muli CUBA: cuba divonne: TBP>>=
- procedure :: print_to_unit => cuba_divonne_print_to_unit
-<<Muli CUBA: procedures>>=
- subroutine cuba_divonne_print_to_unit (this, unit, parents, components, peers)
- class(cuba_divonne_t), intent(in) :: this
- INTEGER, INTENT(IN) :: unit
- integer(dik), intent(in) :: parents, components, peers
- if (parents > 0) &
- call cuba_print_to_unit (this, unit, parents-1, components, peers)
- write (unit, "(1x,A)") "Components of cuba_divonne_t:"
- write (unit, "(3x,A,I10)") "key1: ", this%key1
- write (unit, "(3x,A,I10)") "key2: ", this%key2
- write (unit, "(3x,A,I10)") "key3: ", this%key3
- write (unit, "(3x,A,I10)") "maxpass: ", this%maxpass
- write (unit, "(3x,A,I10)") "ngiven: ", this%ngiven
- write (unit, "(3x,A,I10)") "ldxgiven: ", this%ldxgiven
- write (unit, "(3x,A,I10)") "nextra: ", this%nextra
- write (unit, "(3x,A,E10.4)") "border: ", this%border
- write (unit, "(3x,A,E10.4)") "maxchisq: ", this%maxchisq
- write (unit, "(3x,A,E10.4)") "mindeviation:", this%mindeviation
- write (unit, "(3x,A,2(E10.4))") "xgiven: ", this%xgiven
- end subroutine cuba_divonne_print_to_unit
-
-@ %def cuba_divonne_print_to_unit
-@
-<<Muli CUBA: cuba divonne: TBP>>=
- procedure, nopass :: get_type => cuba_divonne_get_type
-<<Muli CUBA: procedures>>=
- pure subroutine cuba_divonne_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate(type, source="cuba_divonne_t")
- end subroutine cuba_divonne_get_type
-
-@ %def cuba_divonne_get_type
-@
-<<Muli CUBA: cuba divonne: TBP>>=
- procedure :: integrate_nd => integrate_divonne
-<<Muli CUBA: procedures>>=
- subroutine integrate_divonne (this, integrand)
- class(cuba_divonne_t), intent(inout) :: this
- procedure(integrand_interface) :: integrand
- ! call this%reset_output()
- ! print '("divonne")'
- ! call divonne(this%dim_x, this%dim_f, integrand, this%userdata, &
- ! this%eps_rel, this%eps_abs, this%flags, this%seed, this%min_eval, &
- ! this%max_eval, this%key1, this%key2, this%key3, this%maxpass, &
- ! this%border, this%maxchisq, this%mindeviation, this%ngiven, &
- ! this%ldxgiven, this%xgiven, this%nextra, &
- ! ! this%peakfinder, &
- ! 0, this%nregions, this%neval, this%fail, this%integral, &
- ! this%error, this%prob)
- end subroutine integrate_divonne
-
-@ %def integrate_divonne
-@
-<<Muli CUBA: cuba divonne: TBP>>=
- procedure :: integrate_userdata => integrate_divonne_userdata
-<<Muli CUBA: procedures>>=
- subroutine integrate_divonne_userdata (this, integrand, userdata)
- class(cuba_divonne_t), intent(inout) :: this
- procedure(integrand_interface) :: integrand
- class(transverse_mom_t), intent(in) :: userdata
- ! call this%reset_output()
- ! print '("divonne")'
- ! call divonne (this%dim_x, this%dim_f, integrand, userdata, &
- ! this%eps_rel, this%eps_abs, this%flags, this%seed, this%min_eval, &
- ! this%max_eval, this%key1, this%key2, this%key3, this%maxpass, &
- ! this%border, this%maxchisq, this%mindeviation, this%ngiven, &
- ! this%ldxgiven, this%xgiven, this%nextra, &
- ! ! this%peakfinder, &
- ! 0, this%nregions, this%neval, this%fail, this%integral, &
- ! this%error, this%prob)
- end subroutine integrate_divonne_userdata
-
-@ %def integrate_divonne_userdata
-@
-<<Muli CUBA: cuba divonne: TBP>>=
- procedure :: copy => cuba_divonne_copy
-<<Muli CUBA: procedures>>=
- subroutine cuba_divonne_copy (this, source)
- class(cuba_divonne_t), intent(out) :: this
- class(cuba_class), intent(in) :: source
- select type (source)
- class is (cuba_divonne_t)
- call this%copy_common(source)
- call this%set_deferred (source%key1, source%key2, source%key3, &
- source%maxpass, source%border, source%maxchisq, &
- source%mindeviation, source%xgiven)
- class default
- call msg_error ("cuba_divonne_copy: type of source is not " &
- // "type compatible with cuba_divonne_t.")
- end select
- end subroutine cuba_divonne_copy
-
-@ %def cuba_divonne_copy
-@
-<<Muli CUBA: cuba divonne: TBP>>=
- procedure :: set_deferred => cuba_divonne_set_deferred
-<<Muli CUBA: procedures>>=
- subroutine cuba_divonne_set_deferred (this, key1, key2, key3, maxpass, &
- border, maxchisq, mindeviation, xgiven, xgiven_flat)
- class(cuba_divonne_t) :: this
- integer, optional, intent(in) :: key1, key2, key3, maxpass
- real(default), optional, intent(in) :: border, maxchisq, mindeviation
- real(default), dimension(:,:), optional, intent(in) :: xgiven
- real(default), dimension(:), optional, intent(in) :: xgiven_flat
- integer, dimension(2) :: s
- if (present (key1)) this%key1 = key1
- if (present (key2)) this%key2 = key2
- if (present (key3)) this%key3 = key3
- if (present (maxpass)) this%maxpass = maxpass
- if (present (border)) this%border = border
- if (present (maxchisq)) this%maxchisq = maxchisq
- if (present (mindeviation)) this%mindeviation = mindeviation
- if (present (xgiven)) then
- if (allocated (this%xgiven)) deallocate (this%xgiven)
- s = shape(xgiven)
- if (s(1) == this%dim_x) then
- allocate (this%xgiven (s(1), s(2)), source=xgiven)
- this%ldxgiven = s(1)
- this%ngiven = s(2)
- else
- call msg_error ("cuba_divonne_set_deferred: shape of xgiven " &
- // "is not [dim_x,:].")
- this%ngiven = 0
- end if
- end if
- if (present (xgiven_flat)) then
- if (allocated (this%xgiven)) deallocate (this%xgiven)
- if (mod(size(xgiven_flat), this%dim_x) == 0) then
- this%ngiven = size(xgiven_flat) / this%dim_x
- this%ldxgiven = this%dim_x
- allocate (this%xgiven (this%ldxgiven,this%ngiven))
- this%xgiven = reshape(xgiven_flat, [this%ldxgiven, this%ngiven])
- else
- call msg_error ("cuba_divonne_set_deferred: size of xgiven_flat " &
- // "is no multiple of dim_x.")
- this%ngiven = 0
- end if
- end if
- end subroutine cuba_divonne_set_deferred
-
-@ %def cuba_divonne_set_deferred
-@
-<<Muli CUBA: cuba cuhre: TBP>>=
- procedure :: write_to_marker => cuba_cuhre_write_to_marker
-<<Muli CUBA: procedures>>=
- subroutine cuba_cuhre_write_to_marker (this, marker, status)
- class(cuba_cuhre_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("cuba_cuhre_t")
- call cuba_write_to_marker (this, marker, status)
- call marker%mark ("key", this%key)
- call marker%pick_end ("cuba_cuhre_t", status)
- end subroutine cuba_cuhre_write_to_marker
-
-@ %def cuba_cuhre_write_to_marker
-@
-<<Muli CUBA: cuba cuhre: TBP>>=
- procedure :: read_from_marker => cuba_cuhre_read_from_marker
-<<Muli CUBA: procedures>>=
- subroutine cuba_cuhre_read_from_marker (this, marker, status)
- class(cuba_cuhre_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%pick_begin ("cuba_cuhre_t", status=status)
- call cuba_read_from_marker (this, marker, status)
- call marker%pick ("key",this%key, status)
- call marker%pick_end ("cuba_cuhre_t", status)
- end subroutine cuba_cuhre_read_from_marker
-
-@ %def cuba_cuhre_read_from_marker
-@
-<<Muli CUBA: cuba cuhre: TBP>>=
- procedure :: print_to_unit => cuba_cuhre_print_to_unit
-<<Muli CUBA: procedures>>=
- subroutine cuba_cuhre_print_to_unit (this, unit, parents, components, peers)
- class(cuba_cuhre_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- if (parents > 0) &
- call cuba_print_to_unit (this, unit, parents-1, components, peers)
- write (unit, "(1x,A)") "Components of cuba_cuhre_t:"
- write (unit, "(3x,A,I10)") "key: ", this%key
- end subroutine cuba_cuhre_print_to_unit
-
-@ %def cuba_cuhre_print_to_unit
-@
-<<Muli CUBA: cuba cuhre: TBP>>=
- procedure, nopass :: get_type => cuba_cuhre_get_type
-<<Muli CUBA: procedures>>=
- pure subroutine cuba_cuhre_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="cuba_cuhre_t")
- end subroutine cuba_cuhre_get_type
-
-@ %def cuba_cuhre_get_type
-@
-<<Muli CUBA: cuba cuhre: TBP>>=
- procedure :: integrate_nd => integrate_cuhre
-<<Muli CUBA: procedures>>=
- subroutine integrate_cuhre (this, integrand)
- class(cuba_cuhre_t), intent(inout) :: this
- procedure(integrand_interface) :: integrand
- ! print '("cuhre")'
- ! call cuhre(this%dim_x, this%dim_f, integrand, this%userdata, &
- ! this%eps_rel, this%eps_abs, this%flags, &
- ! ! this%seed, &
- ! this%min_eval, this%max_eval, this%key, this%nregions, &
- ! this%neval, this%fail, this%integral, this%error, this%prob)
- end subroutine integrate_cuhre
-
-@ %def integrate_cuhre
-@
-<<Muli CUBA: cuba cuhre: TBP>>=
- procedure :: integrate_userdata => integrate_cuhre_userdata
-<<Muli CUBA: procedures>>=
- subroutine integrate_cuhre_userdata (this, integrand, userdata)
- class(cuba_cuhre_t), intent(inout) :: this
- procedure(integrand_interface) :: integrand
- class(transverse_mom_t), intent(in) :: userdata
- ! print '("cuhre")'
- ! call cuhre(this%dim_x, this%dim_f, integrand, userdata, this%eps_rel, &
- ! this%eps_abs, this%flags, &
- ! ! this%seed, &
- ! this%min_eval, this%max_eval, this%key, this%nregions, &
- ! this%neval, this%fail, this%integral, this%error, this%prob)
- end subroutine integrate_cuhre_userdata
-
-@ %def integrate_cuhre_userdata
-@
-<<Muli CUBA: cuba cuhre: TBP>>=
- procedure :: copy => cuba_cuhre_copy
-<<Muli CUBA: procedures>>=
- subroutine cuba_cuhre_copy (this, source)
- class(cuba_cuhre_t), intent(out) :: this
- class(cuba_class), intent(in) :: source
- select type (source)
- class is (cuba_cuhre_t)
- call this%copy_common (source)
- this%key = source%key
- class default
- call msg_error ("cuba_cuhre_copy: type of source is not type " &
- // "compatible with cuba_cuhre_t.")
- end select
- end subroutine cuba_cuhre_copy
-
-@ %def cuba_cuhre_copy
-@
-<<Muli CUBA: cuba cuhre: TBP>>=
- procedure :: set_deferred => cuba_cuhre_set_deferred
-<<Muli CUBA: procedures>>=
- subroutine cuba_cuhre_set_deferred (this, key)
- class(cuba_cuhre_t), intent(inout) :: this
- integer, intent(in) :: key
- this%key = key
- end subroutine cuba_cuhre_set_deferred
-
-@ %def cuba_cuhre_set_deferred
-@
-<<Muli CUBA: cuba suave: TBP>>=
- procedure :: write_to_marker => cuba_suave_write_to_marker
-<<Muli CUBA: procedures>>=
- subroutine cuba_suave_write_to_marker (this, marker, status)
- class(cuba_suave_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("cuba_suave_t")
- call cuba_write_to_marker (this, marker, status)
- call marker%mark ("nnew", this%nnew)
- call marker%mark ("flatness", this%flatness)
- call marker%mark_null ("cuba_suave_t")
- end subroutine cuba_suave_write_to_marker
-
-@ %def cuba_suave_write_to_marker
-@
-<<Muli CUBA: cuba suave: TBP>>=
- procedure :: read_from_marker => cuba_suave_read_from_marker
-<<Muli CUBA: procedures>>=
- subroutine cuba_suave_read_from_marker (this, marker, status)
- class(cuba_suave_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%pick_begin ("cuba_suave_t", status=status)
- call cuba_read_from_marker (this, marker, status)
- call marker%pick ("nnew", this%nnew, status)
- call marker%pick ("flatnes", this%flatness, status)
- call marker%pick_end ("cuba_suave_t", status)
- end subroutine cuba_suave_read_from_marker
-
-@ %def cuba_suave_read_from_marker
-@
-<<Muli CUBA: cuba suave: TBP>>=
- procedure::print_to_unit=>cuba_suave_print_to_unit
-<<Muli CUBA: procedures>>=
- subroutine cuba_suave_print_to_unit (this, unit, parents, components, peers)
- class(cuba_suave_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- if (parents > 0) &
- call cuba_print_to_unit (this, unit, parents-1, components, peers)
- write (unit, "(1x,A)") "Components of cuba_suave_t:"
- write (unit, "(3x,A,I10)") "nnew: ", this%nnew
- write (unit, "(3x,A,I10)") "flatness: ", this%flatness
- end subroutine cuba_suave_print_to_unit
-
-@ %def cuba_suave_print_to_unit
-@
-<<Muli CUBA: cuba suave: TBP>>=
- procedure, nopass :: get_type => cuba_suave_get_type
-<<Muli CUBA: procedures>>=
- pure subroutine cuba_suave_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="cuba_suave_t")
- end subroutine cuba_suave_get_type
-
-@ %def cuba_suave_get_type
-@
-<<Muli CUBA: cuba suave: TBP>>=
- procedure :: integrate_nd => integrate_suave
-<<Muli CUBA: procedures>>=
- subroutine integrate_suave (this, integrand)
- class(cuba_suave_t), intent(inout) :: this
- procedure(integrand_interface) :: integrand
- ! print '("suave")'
- ! call suave(this%dim_x, this%dim_f, integrand, this%userdata, &
- ! this%eps_rel, this%eps_abs, this%flags, this%seed, &
- ! this%min_eval, this%max_eval, this%nnew, this%flatness, &
- ! this%nregions, this%neval, this%fail, this%integral, &
- ! this%error, this%prob)
- end subroutine integrate_suave
-
-@ %def integrate_suave
-@
-<<Muli CUBA: cuba suave: TBP>>=
- procedure :: integrate_userdata => integrate_suave_userdata
-<<Muli CUBA: procedures>>=
- subroutine integrate_suave_userdata (this, integrand, userdata)
- class(cuba_suave_t), intent(inout) :: this
- procedure(integrand_interface) :: integrand
- class(transverse_mom_t), intent(in) :: userdata
- ! print '("suave")'
- ! call suave (this%dim_x, this%dim_f, integrand, userdata, &
- ! this%eps_rel, this%eps_abs, this%flags, this%seed, &
- ! this%min_eval, this%max_eval, this%nnew, this%flatness, &
- ! this%nregions, this%neval, this%fail, this%integral, &
- ! this%error, this%prob)
- end subroutine integrate_suave_userdata
-
-@ %def integrate_suave_userdata
-@
-<<Muli CUBA: cuba suave: TBP>>=
- procedure :: copy => cuba_suave_copy
-<<Muli CUBA: procedures>>=
- subroutine cuba_suave_copy (this, source)
- class(cuba_suave_t), intent(out) :: this
- class(cuba_class), intent(in) :: source
- select type (source)
- class is (cuba_suave_t)
- call this%copy_common (source)
- this%nnew = source%nnew
- this%flatness = source%flatness
- class default
- call msg_error ("cuba_suave_copy: type of source is not type " &
- // "compatible with cuba_suave_t.")
- end select
- end subroutine cuba_suave_copy
-
-@ %def cuba_suave_copy
-@
-<<Muli CUBA: interfaces>>=
- interface
- subroutine integrand_interface (dim_x, x, dim_f, f,userdata)
- <<Use kinds>>
- use muli_momentum
- integer, intent(in) :: dim_x, dim_f
- real(default), dimension(dim_x), intent(in) :: x
- real(default), dimension(dim_f), intent(out) :: f
- class(transverse_mom_t), intent(in) :: userdata
- end subroutine integrand_interface
- end interface
-@ %def integrand_interface
-@
-<<Muli CUBA: interfaces>>=
- interface
- subroutine cuba_copy_interface (this, source)
- import :: cuba_class
- class(cuba_class), intent(out) :: this
- class(cuba_class), intent(in) :: source
- end subroutine cuba_copy_interface
- end interface
-@ %def cuba_copy_interface
-@
-<<Muli CUBA: interfaces>>=
- interface
- subroutine ca_plain (this)
- import :: cuba_class
- class(cuba_class) :: this
- end subroutine ca_plain
- end interface
-@ %def ca_plain
-@
-<<Muli CUBA: interfaces>>=
- interface
- subroutine integrate_interface (this, integrand)
- import :: cuba_class
- class(cuba_class), intent(inout) :: this
- interface
- subroutine integrand (dim_x, x, dim_f, f,userdata)
- <<Use kinds>>
- use muli_momentum
- integer, intent(in) :: dim_x, dim_f
- real(default), dimension(dim_x), intent(in) :: x
- real(default), dimension(dim_f), intent(out) :: f
- class(transverse_mom_t), intent(in) :: userdata
- end subroutine integrand
- end interface
- end subroutine integrate_interface
- end interface
-@ %def integrate_interface
-@
-<<Muli CUBA: interfaces>>=
- interface
- subroutine integrate_userdata_interface (this, integrand,userdata)
- use muli_momentum
- import :: cuba_class
- class(cuba_class), intent(inout) :: this
- interface
- subroutine integrand (dim_x, x, dim_f, f,userdata)
- <<Use kinds>>
- use muli_momentum
- integer, intent(in) :: dim_x, dim_f
- real(default), dimension(dim_x), intent(in) :: x
- real(default), dimension(dim_f), intent(out) :: f
- class(transverse_mom_t), intent(in) :: userdata
- end subroutine integrand
- end interface
- class(transverse_mom_t), intent(in) :: userdata
- end subroutine integrate_userdata_interface
- end interface
-
-@ %def integrate_userdata_interface
-@
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Trapezoidal integration routines}
-
-This file contains the module [["muli_trapezium"]]. The name is
-derived from the trapezoidal integration rule. The purpose of this
-module is to define a binary tree [[muli_trapezium_tree_t]] which
-holds a probability function in terms of trapezoidal segments. Its
-leaves of type [[muli_trapezium_list_t]] are connected to form a list,
-so you can either walk the root function back and forth or pick a
-certain segment in logarithmic time by walking down the tree.
-All nodes extend [[muli_trapezium_t]] which holds the actual
-values. Those are the values of the density function, the integral
-from this segment to the end of the integration area and a probability
-function calculated from these values. All values are taken at the
-upper "right" bound of the segment. Additionally the differences of
-these values to the values of the left neighbor is stored.
-
-<<[[muli_trapezium.f90]]>>=
-<<File header>>
-
-module muli_trapezium
- use, intrinsic :: iso_fortran_env, only: output_unit
-<<Use kinds>>
- use constants
- use diagnostics
- use muli_base
-
-<<Standard module head>>
-
-<<Muli trapezium: variables>>
-
-<<Muli trapezium: public>>
-
-<<Muli trapezium: types>>
-
-<<Muli trapezium: interfaces>>
-
-contains
-
-<<Muli trapezium: procedures>>
-
-end module muli_trapezium
-@ %def muli_trapezium
-@
-<<Muli trapezium: variables>>=
- integer, private, parameter :: value_dimension = 7
- integer, private, parameter :: r_value_index = 1
- integer, private, parameter :: d_value_index = 2
- integer, private, parameter :: r_integral_index = 3
- integer, private, parameter :: d_integral_index = 4
- integer, private, parameter :: r_probability_index = 5
- integer, private, parameter :: d_probability_index = 6
- integer, private, parameter :: error_index = 7
-
-@ %def value_dimension r_value_index d_value_index
-@ %def r_integral_index d_integral_index
-@ %def r_probability_index d_probability_index error_index
-@
-<<Muli trapezium: interfaces>>=
- abstract interface
- subroutine muli_trapezium_append_interface (this, right)
- import muli_trapezium_node_class_t
- class(muli_trapezium_node_class_t), intent(inout), target :: this, right
- end subroutine muli_trapezium_append_interface
- end interface
-@ %def muli_trapezium_append_interface
-@
-<<Muli trapezium: interfaces>>=
- abstract interface
- subroutine muli_trapezium_final_interface (this)
- import muli_trapezium_node_class_t
- class(muli_trapezium_node_class_t), intent(inout) :: this
- end subroutine muli_trapezium_final_interface
- end interface
-
-@ %def muli_trapezium_final_interface
-@ This is the base type [[muli_trapezium_t]]. Its component [[values]]
-has a first index is in $\left\{ 0, \ldots, \text{dim}-1 \right\}$, while the
-second index distingiushes between [[r_value]], [[d_value]],
-[[r_integral]], [[d_integral]], [[r_probability]], [[d_probability]].
-<<Muli trapezium: public>>=
- public :: muli_trapezium_t
-<<Muli trapezium: types>>=
- type, extends (measure_class_t) :: muli_trapezium_t
- private
- integer :: dim = 0
- real(default) :: r_position = 0
- real(default) :: d_position = 0
- real(default) :: measure_comp = 0
- real(default), dimension(:,:), allocatable :: values
- contains
- <<Muli trapezium: trapezium: TBP>>
- end type muli_trapezium_t
-
-@ %def muli_trapezium_t
-@
-<<Muli trapezium: public>>=
- public :: muli_trapezium_node_class_t
-<<Muli trapezium: types>>=
- type, extends (muli_trapezium_t), abstract :: muli_trapezium_node_class_t
- private
- class(muli_trapezium_node_class_t), pointer :: left => null()
- class(muli_trapezium_node_class_t), pointer :: right => null()
- ! real(default) :: criterion
- contains
- <<Muli trapezium: node: TBP>>
- end type muli_trapezium_node_class_t
-
-@ %def muli_trapezium_node_class_t
-@
-<<Muli trapezium: public>>=
- public :: muli_trapezium_tree_t
-<<Muli trapezium: types>>=
- type, extends(muli_trapezium_node_class_t) :: muli_trapezium_tree_t
- class(muli_trapezium_node_class_t), pointer :: down => null()
- contains
- <<Muli trapezium: tree: TBP>>
- end type muli_trapezium_tree_t
-
-@ %def muli_trapezium_tree_t
-@
-<<Muli trapezium: public>>=
- public :: muli_trapezium_list_t
-<<Muli trapezium: types>>=
- type, extends (muli_trapezium_node_class_t) :: muli_trapezium_list_t
- contains
- <<Muli trapezium: list: TBP>>
- end type muli_trapezium_list_t
-
-@ %def muli_trapezium_list_t
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: write_to_marker => muli_trapezium_write_to_marker
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_write_to_marker (this,marker,status)
- class(muli_trapezium_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- integer::dim
- call marker%mark_begin ("muli_trapezium_t")
- call marker%mark ("dim", this%dim)
- call marker%mark ("r_position", this%r_position)
- call marker%mark ("d_position", this%d_position)
- if (allocated(this%values)) then
- call marker%mark ("values", this%values)
- else
- call marker%mark_null ("values")
- end if
- call marker%mark_end ("muli_trapezium_t")
- end subroutine muli_trapezium_write_to_marker
-
-@ %def muli_trapezium_write_to_marker
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: read_from_marker => muli_trapezium_read_from_marker
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_read_from_marker (this,marker,status)
- class(muli_trapezium_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- integer :: dim
- call marker%pick_begin ("muli_trapezium_t", status=status)
- call marker%pick ("dim", this%dim,status)
- call marker%pick ("r_position", this%r_position, status)
- call marker%pick ("d_position", this%d_position, status)
- if (allocated (this%values)) deallocate (this%values)
- call marker%verify_nothing ("values", status)
- if (status == serialize_ok) then
- allocate(this%values(0:this%dim-1,7))
- call marker%pick ("values",this%values, status)
- end if
- call marker%pick_end("muli_trapezium_t",status)
- end subroutine muli_trapezium_read_from_marker
-
-@ %def muli_trapezium_read_from_marker
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: print_to_unit => muli_trapezium_print_to_unit
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_print_to_unit (this, unit, parents, components, peers)
- class(muli_trapezium_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- write (unit, "(1x,A)") "Components of muli_trapezium_t:"
- write (unit, fmt=*)"Dimension: ",this%dim
- write (unit,fmt=*)"Right position: ",this%r_position
- write (unit,fmt=*)"Position step: ",this%d_position
- if (allocated(this%values)) then
- if (components>0) then
- write (unit,fmt=*)"Right values: ",muli_trapezium_get_r_value_array(this)
- write (unit,fmt=*) "Value step: ", this%get_d_value()
- write (unit,fmt=*)"Right integrals: ",this%get_r_integral()
- write (unit,fmt=*)"Integral step: ",this%get_d_integral()
- write (unit,fmt=*)"Right propabilities:",this%get_r_probability()
- write (unit,fmt=*)"Probability step: ",this%get_d_probability()
- write (unit,fmt=*)"Errors: ",this%get_error()
- else
- write (unit, "(3x,A)") "Values are allocated."
- end if
- else
- write (unit, "(3x,A)") "Values are not allocated."
- end if
- end subroutine muli_trapezium_print_to_unit
-
-@ %def muli_trapezium_print_to_unit
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure, nopass :: get_type => muli_trapezium_get_type
-<<Muli trapezium: procedures>>=
- pure subroutine muli_trapezium_get_type (type)
- character(:),allocatable, intent(out) :: type
- allocate (type, source="muli_trapezium_t")
- end subroutine muli_trapezium_get_type
-
-@ %def muli_trapezium_get_type
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure, nopass :: verify_type => muli_trapezium_verify_type
-<<Muli trapezium: procedures>>=
- elemental logical function muli_trapezium_verify_type (type) result (match)
- character(*), intent(in) :: type
- match = type == "muli_trapezium_t"
- end function muli_trapezium_verify_type
-
-@ %def muli_trapezium_verify_type
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: measure => muli_trapezium_measure
-<<Muli trapezium: procedures>>=
- elemental function muli_trapezium_measure (this)
- class(muli_trapezium_t), intent(in) :: this
- real(default) :: muli_trapezium_measure
- muli_trapezium_measure = this%measure_comp
- end function muli_trapezium_measure
-
-@ %def muli_trapezium_measure
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: initialize => muli_trapezium_initialize
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_initialize (this, dim, r_position, d_position)
- class(muli_trapezium_t), intent(inout) :: this
- integer, intent(in) :: dim
- real(default), intent(in) :: r_position, d_position
- integer :: dim1, dim2
- this%dim = dim
- this%r_position = r_position
- this%d_position = d_position
- if (allocated (this%values)) deallocate (this%values)
- allocate (this%values(0:dim-1,value_dimension))
- do dim2 = 1, value_dimension-1
- do dim1 = 0, dim-1
- this%values(dim1,dim2) = zero
- end do
- end do
- do dim1 = 0, dim-1
- this%values(dim1, value_dimension) = huge(one)
- end do
- this%measure_comp = huge(one)
- end subroutine muli_trapezium_initialize
-
-@ %def muli_trapezium_initialize
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: get_dimension => muli_trapezium_get_dimension
-<<Muli trapezium: procedures>>=
- elemental function muli_trapezium_get_dimension (this) result (dim)
- class(muli_trapezium_t), intent(in) :: this
- integer :: dim
- dim = this%dim
- end function muli_trapezium_get_dimension
-
-@ %def muli_trapezium_get_dimension
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: get_l_position => muli_trapezium_get_l_position
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_l_position (this) result (pos)
- class(muli_trapezium_t), intent(in) :: this
- real(default) :: pos
- pos = this%r_position - this%d_position
- end function muli_trapezium_get_l_position
-
-@ %def muli_trapezium_get_l_position
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: get_r_position => muli_trapezium_get_r_position
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_r_position (this) result (pos)
- class(muli_trapezium_t), intent(in) :: this
- real(default) :: pos
- pos = this%r_position
- end function muli_trapezium_get_r_position
-
-@ %def muli_trapezium_get_r_position
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: get_d_position => muli_trapezium_get_d_position
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_d_position (this) result (pos)
- class(muli_trapezium_t), intent(in) :: this
- real(default) :: pos
- pos = this%d_position
- end function muli_trapezium_get_d_position
-
-@ %def muli_trapezium_get_d_position
-@
-<<Muli trapezium: trapezium: TBP>>=
- generic :: get_l_value => get_l_value_array, get_l_value_element
- procedure :: get_l_value_array => muli_trapezium_get_l_value_array
- procedure :: get_l_value_element => muli_trapezium_get_l_value_element
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_l_value_array (this) result (subarray)
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: subarray
- subarray = this%values(0:this%dim-1, r_value_index) - &
- this%values(0:this%dim-1, d_value_index)
- end function muli_trapezium_get_l_value_array
-
-@ %def muli_trapezium_get_l_value_array
-@
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_l_value_element (this, set) result (element)
- class(muli_trapezium_t), intent(in) :: this
- integer, intent(in) :: set
- real(default) :: element
- element = this%values(set, r_value_index) - this%values(set, d_value_index)
- end function muli_trapezium_get_l_value_element
-
-@ %def muli_trapezium_get_l_value_element
-@
-<<Muli trapezium: trapezium: TBP>>=
- generic :: get_r_value => get_r_value_array, get_r_value_element
- procedure :: get_r_value_array => muli_trapezium_get_r_value_array
- procedure :: get_r_value_element => muli_trapezium_get_r_value_element
-@
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_r_value_element (this, set) result (element)
- class(muli_trapezium_t), intent(in) :: this
- integer, intent(in) :: set
- real(default) :: element
- element = this%values (set, r_value_index)
- end function muli_trapezium_get_r_value_element
-
-@ %def muli_trapezium_get_r_value_element
-@
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_r_value_array (this) result (subarray)
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: subarray
- subarray = this%values(0:this%dim-1, r_value_index)
- end function muli_trapezium_get_r_value_array
-
-@ %def muli_trapezium_get_r_value_array
-@
-<<Muli trapezium: trapezium: TBP>>=
- generic :: get_d_value => get_d_value_array, get_d_value_element
- procedure :: get_d_value_array => muli_trapezium_get_d_value_array
- procedure :: get_d_value_element => muli_trapezium_get_d_value_element
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_d_value_element (this, set) result (element)
- class(muli_trapezium_t), intent(in) :: this
- integer, intent(in) :: set
- real(default) :: element
- element=this%values (set, d_value_index)
- end function muli_trapezium_get_d_value_element
-
-@ %def muli_trapezium_get_d_value_element
-@
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_d_value_array (this) result (subarray)
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: subarray
- subarray = this%values(0:this%dim-1, d_value_index)
- end function muli_trapezium_get_d_value_array
-
-@ %def muli_trapezium_get_d_value_array
-@
-<<Muli trapezium: trapezium: TBP>>=
- generic :: get_l_integral => get_l_integral_array, get_l_integral_element
- procedure :: get_l_integral_array => muli_trapezium_get_l_integral_array
- procedure :: get_l_integral_element => muli_trapezium_get_l_integral_element
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_l_integral_element &
- (this, set) result (element)
- class(muli_trapezium_t), intent(in) :: this
- integer, intent(in) :: set
- real(default) :: element
- element = this%values (set, r_integral_index) - &
- this%values (set, d_integral_index)
- end function muli_trapezium_get_l_integral_element
-
-@ %def muli_trapezium_get_l_integral_element
-@
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_l_integral_array (this) result (subarray)
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: subarray
- subarray = this%values (0:this%dim-1, r_integral_index) - &
- this%values (0:this%dim-1, d_integral_index)
- end function muli_trapezium_get_l_integral_array
-
-@ %def muli_trapezium_get_l_integral_array
-@
-<<Muli trapezium: trapezium: TBP>>=
- generic :: get_r_integral => get_r_integral_array, get_r_integral_element
- procedure :: get_r_integral_array => muli_trapezium_get_r_integral_array
- procedure :: get_r_integral_element => muli_trapezium_get_r_integral_element
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_r_integral_element (this, set) result (element)
- class(muli_trapezium_t), intent(in) :: this
- integer, intent(in) :: set
- real(default) :: element
- element = this%values (set, r_integral_index)
- end function muli_trapezium_get_r_integral_element
-
-@ %def muli_trapezium_get_r_integral_element
-@
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_r_integral_array (this) result (subarray)
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: subarray
- subarray = this%values (0:this%dim-1, r_integral_index)
- end function muli_trapezium_get_r_integral_array
-
-@ %def muli_trapezium_get_r_integral_array
-@
-<<Muli trapezium: trapezium: TBP>>=
- generic :: get_d_integral => get_d_integral_array, get_d_integral_element
- procedure :: get_d_integral_array => muli_trapezium_get_d_integral_array
- procedure :: get_d_integral_element => muli_trapezium_get_d_integral_element
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_d_integral_element &
- (this, set) result (element)
- class(muli_trapezium_t), intent(in) :: this
- integer, intent(in) :: set
- real(default) :: element
- element = this%values (set, d_integral_index)
- end function muli_trapezium_get_d_integral_element
-
-@ %def muli_trapezium_get_d_integral_element
-@
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_d_integral_array (this) result (subarray)
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: subarray
- subarray = this%values (0:this%dim-1, d_integral_index)
- end function muli_trapezium_get_d_integral_array
-
-@ %def muli_trapezium_get_d_integral_array
-@
-<<Muli trapezium: trapezium: TBP>>=
- generic :: get_l_probability => &
- get_l_probability_array, get_l_probability_element
- procedure :: get_l_probability_element => &
- muli_trapezium_get_l_probability_element
- procedure :: get_l_probability_array => &
- muli_trapezium_get_l_probability_array
-@
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_l_probability_element &
- (this, set) result (element)
- class(muli_trapezium_t), intent(in) :: this
- integer, intent(in) :: set
- real(default) :: element
- element = this%values (set, r_probability_index) - &
- this%values (set, d_probability_index)
- end function muli_trapezium_get_l_probability_element
-
-@ %def muli_trapezium_get_l_probability_element
-@
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_l_probability_array (this) result (subarray)
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: subarray
- subarray = this%values (0:this%dim-1, r_probability_index) - &
- this%values (0:this%dim-1, d_probability_index)
- end function muli_trapezium_get_l_probability_array
-
-@ %def muli_trapezium_get_l_probability_array
-@
-<<Muli trapezium: trapezium: TBP>>=
- generic :: get_r_probability => &
- get_r_probability_array, get_r_probability_element
- procedure :: get_r_probability_element => &
- muli_trapezium_get_r_probability_element
- procedure :: get_r_probability_array => &
- muli_trapezium_get_r_probability_array
-@
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_r_probability_element &
- (this, set) result (element)
- class(muli_trapezium_t), intent(in) :: this
- integer, intent(in) :: set
- real(default) :: element
- element = this%values (set, r_probability_index)
- end function muli_trapezium_get_r_probability_element
-
-@ %def muli_trapezium_get_r_probability_element
-@
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_r_probability_array (this) result (subarray)
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: subarray
- subarray = this%values (0:this%dim-1, r_probability_index)
- end function muli_trapezium_get_r_probability_array
-
-@ %def muli_trapezium_get_r_probability_array
-@
-<<Muli trapezium: trapezium: TBP>>=
- generic :: get_d_probability => &
- get_d_probability_array, get_d_probability_element
- procedure :: get_d_probability_element => &
- muli_trapezium_get_d_probability_element
- procedure :: get_d_probability_array => &
- muli_trapezium_get_d_probability_array
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_d_probability_array (this) result (subarray)
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: subarray
- subarray = this%values (0:this%dim-1, d_probability_index)
- end function muli_trapezium_get_d_probability_array
-
-@ %def muli_trapezium_get_d_probability_array
-@
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_d_probability_element &
- (this, set) result (element)
- class(muli_trapezium_t), intent(in) :: this
- integer, intent(in) :: set
- real(default) :: element
- element = this%values (set, d_probability_index)
- end function muli_trapezium_get_d_probability_element
-
-@ %def muli_trapezium_get_d_probability_element
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: get_error => muli_trapezium_get_error
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_error_sum (this) result (error)
- class(muli_trapezium_t), intent(in) :: this
- real(default) :: error
- error = sum (this%values (0:this%dim-1, error_index))
- end function muli_trapezium_get_error_sum
-
-@ %def muli_trapezium_get_error_sum
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: get_error_sum => muli_trapezium_get_error_sum
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_error (this) result (error)
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: error
- error = this%values (0:this%dim-1, error_index)
- end function muli_trapezium_get_error
-
-@ %def muli_trapezium_get_error
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: get_integral_sum => muli_trapezium_get_integral_sum
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_get_integral_sum (this) result (error)
- class(muli_trapezium_t), intent(in) :: this
- real(default) :: error
- error = sum (this%values (0:this%dim-1, d_integral_index))
- end function muli_trapezium_get_integral_sum
-
-@ %def muli_trapezium_get_integral_sum
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: get_value_at_position => muli_trapezium_get_value_at_position
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_get_value_at_position (this, pos, subarray)
- class(muli_trapezium_t), intent(in) :: this
- real(default), intent(in) :: pos
- real(default), dimension(this%dim), intent(out) :: subarray
- subarray = this%get_r_value_array() - this%get_d_value() * &
- this%d_position / (this%r_position-pos)
- end subroutine muli_trapezium_get_value_at_position
-
-@ %def muli_trapezium_get_value_at_position
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: set_r_value => muli_trapezium_set_r_value
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_set_r_value (this, subarray)
- class(muli_trapezium_t), intent(inout) :: this
- real(default), intent(in), dimension(0:this%dim-1) :: subarray
- this%values(0:this%dim-1, r_value_index) = subarray
- end subroutine muli_trapezium_set_r_value
-
-@ %def muli_trapezium_set_r_value
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: set_d_value => muli_trapezium_set_d_value
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_set_d_value (this, subarray)
- class(muli_trapezium_t), intent(inout) :: this
- real(default), intent(in), dimension(0:this%dim-1) :: subarray
- this%values(0:this%dim-1,d_value_index) = subarray
- end subroutine muli_trapezium_set_d_value
-
-@ %def muli_trapezium_set_d_value
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: set_r_integral => muli_trapezium_set_r_integral
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_set_r_integral (this, subarray)
- class(muli_trapezium_t), intent(inout) :: this
- real(default), intent(in), dimension(0:this%dim-1) :: subarray
- this%values(0:this%dim-1,r_integral_index) = subarray
- end subroutine muli_trapezium_set_r_integral
-
-@ %def muli_trapezium_set_r_integral
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: set_d_integral => muli_trapezium_set_d_integral
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_set_d_integral (this, subarray)
- class(muli_trapezium_t), intent(inout) :: this
- real(default), intent(in), dimension(0:this%dim-1) :: subarray
- this%values (0:this%dim-1, d_integral_index) = subarray
- end subroutine muli_trapezium_set_d_integral
-
-@ %def muli_trapezium_set_d_integral
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: set_r_probability => muli_trapezium_set_r_probability
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_set_r_probability (this, subarray)
- class(muli_trapezium_t), intent(inout) :: this
- real(default), intent(in), dimension(0:this%dim-1) :: subarray
- this%values (0:this%dim-1,r_probability_index) = subarray
- end subroutine muli_trapezium_set_r_probability
-
-@ %def muli_trapezium_set_r_probability
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: set_d_probability => muli_trapezium_set_d_probability
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_set_d_probability (this, subarray)
- class(muli_trapezium_t), intent(inout) :: this
- real(default), intent(in), dimension(0:this%dim-1) :: subarray
- this%values (0:this%dim-1,d_probability_index) = subarray
- end subroutine muli_trapezium_set_d_probability
-
-@ %def muli_trapezium_set_d_probability
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: set_error => muli_trapezium_set_error
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_set_error (this, subarray)
- class(muli_trapezium_t), intent(inout) :: this
- real(default), intent(in), dimension(0:this%dim-1) :: subarray
- this%values (0:this%dim-1, error_index) = subarray
- this%measure_comp = sum (subarray)
- end subroutine muli_trapezium_set_error
-
-@ %def muli_trapezium_set_error
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: is_left_of => muli_trapezium_is_left_of
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_is_left_of (this, that) result (is_left)
- logical :: is_left
- class(muli_trapezium_t), intent(in) :: this, that
- is_left = this%r_position <= that%r_position !-that%d_position
- ! if (is_left.and.that%r_position < this%r_position) then
- ! print *,"!"
- ! STOP
- ! end if
- end function muli_trapezium_is_left_of
-
-@ %def muli_trapezium_is_left_of
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: includes => muli_trapezium_includes
-<<Muli trapezium: procedures>>=
- elemental logical function muli_trapezium_includes &
- (this, dim, position, value, integral, probability) result (includes)
- class(muli_trapezium_t), intent(in) :: this
- integer, intent(in) :: dim
- real(default), intent(in),optional :: position, value, integral, probability
- includes = .true.
- if (present (position)) then
- if (this%get_l_position() > position .or. &
- position >= this%get_r_position()) includes = .false.
- end if
- if (present (value)) then
- if (this%get_l_value(dim) > value .or. value >= &
- this%get_r_value(dim)) includes = .false.
- end if
- if (present (integral)) then
- if (this%get_l_integral(dim) > integral .or. integral >= &
- this%get_r_integral(dim)) includes = .false.
- end if
- if (present (probability)) then
- if (this%get_l_probability(dim) > probability .or. &
- probability >= this%get_r_probability(dim)) includes = .false.
- end if
- end function muli_trapezium_includes
-
-@ %def muli_trapezium_includes
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: to_node => muli_trapezium_to_node
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_to_node (this, value, list, tree)
- class(muli_trapezium_t), intent(in) :: this
- real(default), intent(in) :: value
- ! class(muli_trapezium_node_class_t), optional, pointer, intent(out) :: node
- class(muli_trapezium_list_t), optional, pointer, intent(out) :: list
- class(muli_trapezium_tree_t), optional, pointer, intent(out) :: tree
- ! if (present (node)) then
- ! allocate (node)
- ! node%dim = this%dim
- ! node%r_position = this%r_position
- ! node%d_position = this%d_position
- ! allocate (node%values (this%dim, value_dimension), source=this%values)
- ! end if
- if (present (list)) then
- allocate (list)
- list%dim = this%dim
- list%r_position = this%r_position
- list%d_position = this%d_position
- allocate (list%values (0:this%dim-1, value_dimension), source=this%values)
- end if
- if (present (tree)) then
- allocate (tree)
- tree%dim = this%dim
- tree%r_position = this%r_position
- tree%d_position = this%d_position
- allocate (tree%values (0:this%dim-1, value_dimension), source=this%values)
- end if
- end subroutine muli_trapezium_to_node
-
-@ %def muli_trapezium_to_node
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: sum_up => muli_trapezium_sum_up
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_sum_up (this)
- class(muli_trapezium_t), intent(inout) :: this
- integer :: i
- if (allocated (this%values)) then
- do i = 1, 7
- this%values (0,i) = sum (this%values (1:this%dim-1,i))
- end do
- end if
- end subroutine muli_trapezium_sum_up
-
-@ %def muli_trapezium_sum_up
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: approx_value => muli_trapezium_approx_value
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_approx_value (this, x) result (val)
- ! returns the values at x
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: val
- real(default), intent(in) :: x
- val = this%get_r_value_array() + (x - this%r_position) * &
- this%get_d_value() / this%d_position
- end function muli_trapezium_approx_value
-
-@ %def muli_trapezium_approx_value_n
-@ This function returns the value at [[x]].
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: approx_value_n => muli_trapezium_approx_value_n
-<<Muli trapezium: procedures>>=
- elemental function muli_trapezium_approx_value_n (this, x, n) result (val)
- class(muli_trapezium_t), intent(in) :: this
- real(default) :: val
- real(default), intent(in) :: x
- integer, intent(in) :: n
- val = this%get_r_value_element(n) + (x - this%r_position) * &
- this%get_d_value_element(n) / this%d_position
- end function muli_trapezium_approx_value_n
-
-@ %def muli_trapezium_approx_value_n
-@ This function returns the integral from [[x]] to [[r_position]].
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: approx_integral => muli_trapezium_approx_integral
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_approx_integral (this, x)
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: muli_trapezium_approx_integral
- real(default), intent(in) :: x
- muli_trapezium_approx_integral = &
- ! this%get_r_integral()+&
- ! (this%r_position-x)*this%get_r_value()+&
- ! (x**2-this%r_position**2)*this%get_d_integral()/(this%d_position*2D0)
- this%get_r_integral() + &
- ((this%r_position - x) * &
- (-this%get_d_value() * (this%r_position - x) + 2 * &
- this%d_position*this%get_r_value_array())) / &
- (2 * this%d_position)
- end function muli_trapezium_approx_integral
-
-@ %def muli_trapezium_approx_integral
-@ This function returns the integral from [[x]] to [[r_position]].
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: approx_integral_n => muli_trapezium_approx_integral_n
-<<Muli trapezium: procedures>>=
- elemental function muli_trapezium_approx_integral_n (this, x, n) result (val)
- class(muli_trapezium_t), intent(in) :: this
- real(default) :: val
- real(default), intent(in) :: x
- integer, intent(in) :: n
- val = this%get_r_integral_element (n) + ((this%r_position - x) * &
- (-this%get_d_value_element (n) * (this%r_position - x) + 2 * &
- this%d_position * this%get_r_value_element (n))) / &
- (2 * this%d_position)
- end function muli_trapezium_approx_integral_n
-
-@ %def muli_trapezium_approx_integral_n
-@ This function returns the values at [[x]].
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: approx_probability => muli_trapezium_approx_probability
-<<Muli trapezium: procedures>>=
- pure function muli_trapezium_approx_probability (this, x) result (prop)
- class(muli_trapezium_t), intent(in) :: this
- real(default), dimension(this%dim) :: prop
- real(default), intent(in) :: x
- prop = exp (- this%approx_integral (x))
- end function muli_trapezium_approx_probability
-
-@ %def muli_trapezium_approx_probability
-@ This function returns the integral from [[x]] to [[r_position]].
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: approx_probability_n => muli_trapezium_approx_probability_n
-<<Muli trapezium: procedures>>=
- elemental function muli_trapezium_approx_probability_n (this, x, n) result (val)
- class(muli_trapezium_t), intent(in) :: this
- real(default) :: val
- real(default), intent(in) :: x
- integer, intent(in) :: n
- val = exp (- this%approx_integral_n (x, n))
- end function muli_trapezium_approx_probability_n
-
-@ %def muli_trapezium_approx_probability_n
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: approx_position_by_integral => &
- muli_trapezium_approx_position_by_integral
-<<Muli trapezium: procedures>>=
- elemental function muli_trapezium_approx_position_by_integral &
- (this, dim, int) result (val)
- class(muli_trapezium_t), intent(in) :: this
- real(default) :: val
- integer, intent(in) :: dim
- real(default), intent(in) :: int
- real(default) :: dpdv
- dpdv = (this%d_position / this%values (dim,d_value_index))
- val = this%r_position - dpdv * (this%values (dim, r_value_index) - &
- sqrt (((this%values (dim, r_integral_index) - int) * two / dpdv) + &
- this%values (dim, r_value_index)**2))
- end function muli_trapezium_approx_position_by_integral
-
-@ %def muli_trapezium_position_by_integral
-@
-<<Muli trapezium: trapezium: TBP>>=
- ! procedure :: choose_partons => muli_trapezium_choose_partons
-@
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: split => muli_trapezium_split
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_split (this, c_value, c_position, new_node)
- class(muli_trapezium_t), intent(inout) :: this
- real(default), intent(in) :: c_position
- real(default), intent(in), dimension(this%dim) :: c_value
- class(muli_trapezium_t), intent(out), pointer :: new_node
- real(default) :: ndpr, ndpl
- real(default), dimension(:), allocatable :: ov, edv
- ndpr = this%r_position - c_position
- ndpl = this%d_position - ndpr
- allocate (ov (0:this%dim-1), source=this%get_r_value_array() - ndpr * &
- this%get_d_value() / this%d_position)
- allocate (edv (0:this%dim-1), source=c_value-ov)
- allocate (new_node)
- call new_node%initialize (dim=this%dim, r_position=c_position, &
- d_position=ndpl)
- call new_node%set_r_value (c_value)
- call new_node%set_d_value (this%get_d_value() + &
- c_value-this%get_r_value_array())
- call new_node%set_d_integral (ndpl*(this%get_d_value() - &
- this%get_r_value_array() - c_value) / two)
- call new_node%set_error (abs((edv*ndpl) / two))
- ! new_node%measure_comp = sum (abs((edv*ndpl) / two))
- this%d_position = ndpr
- call this%set_d_value (this%get_r_value_array() - c_value)
- call this%set_d_integral (- (ndpr*(this%get_r_value_array() + c_value) / two))
- call this%set_error (abs(edv*ndpr / two))
- ! this%measure_comp = sum (abs(edv*ndpr / two))
- ! write (*, "(1x,A)") "muli_trapezium_split: new errors:"
- ! write (*, "(3x,ES14.7)") this%get_error()
- ! write (*, "(3x,ES14.7)") new_node%get_error()
- ! write (*, "(3x,11(ES20.10)") new_node%get_d_integral()
- ! write (*, "(3x,11(ES20.10)") this%get_d_integral()
- end subroutine muli_trapezium_split
-
-@ %def muli_trapezium_split
-@
-<<Muli trapezium: trapezium: TBP>>=
- procedure :: update => muli_trapezium_update
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_update (this)
- class(muli_trapezium_t), intent(inout) :: this
- real(default), dimension(:), allocatable :: integral
- real(default), dimension(0:this%dim-1) :: d_int
- !!! !!! !!! Workaround for gfortran 5.0 ICE
- d_int = this%get_d_integral ()
- allocate (integral (0:this%dim-1), source=d_int)
- call this%set_d_integral (-this%d_position * (this%get_r_value_array() &
- - this%get_d_value() / 2))
- call this%set_error (abs (this%get_d_integral() - integral))
- ! write (*, "(3x,11(ES20.10)") this%get_d_integral()
- end subroutine muli_trapezium_update
-
-@ %def muli_trapezium_update
-@
-<<Muli trapezium: node: TBP>>=
- procedure :: deserialize_from_marker => &
- muli_trapezium_node_deserialize_from_marker
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_node_deserialize_from_marker (this, name, marker)
- class(muli_trapezium_node_class_t), intent(out) :: this
- character(*), intent(in) :: name
- class(marker_t), intent(inout) :: marker
- integer(dik) :: status
- class(ser_class_t), pointer :: ser
- allocate (muli_trapezium_tree_t :: ser)
- call marker%push_reference (ser)
- allocate (muli_trapezium_list_t::ser)
- call marker%push_reference (ser)
- call serializable_deserialize_from_marker (this, name, marker)
- call marker%pop_reference (ser)
- deallocate (ser)
- call marker%pop_reference (ser)
- deallocate (ser)
- end subroutine muli_trapezium_node_deserialize_from_marker
-
-@ %def muli_trapezium_node_deserialize_from_marker
-@
-<<Muli trapezium: node: TBP>>=
- procedure(muli_trapezium_append_interface), deferred :: append
-@
-@
-<<Muli trapezium: node: TBP>>=
- procedure(muli_trapezium_final_interface), deferred :: finalize
-@
-@
-<<Muli trapezium: list: TBP>>=
- procedure :: append => muli_trapezium_list_append
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_list_append (this, right)
- class(muli_trapezium_list_t), intent(inout), target :: this
- class(muli_trapezium_node_class_t), intent(inout), target :: right
- this%right => right
- right%left => this
- end subroutine muli_trapezium_list_append
-
-@ %def muli_trapezium_list_append
-@
-<<Muli trapezium: node: TBP>>=
- procedure :: nullify => muli_trapezium_node_nullify
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_node_nullify (this)
- class(muli_trapezium_node_class_t), intent(out) :: this
- nullify (this%left)
- nullify (this%right)
- end subroutine muli_trapezium_node_nullify
-
-@ %def muli_trapezium_node_nullify
-@
-<<Muli trapezium: node: TBP>>=
- procedure :: get_left => muli_trapezium_node_get_left
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_node_get_left (this, left)
- class(muli_trapezium_node_class_t), intent(in) :: this
- class(muli_trapezium_node_class_t), pointer, intent(out) :: left
- left => this%left
- end subroutine muli_trapezium_node_get_left
-
-@ %def muli_trapezium_get_left
-@
-<<Muli trapezium: node: TBP>>=
- procedure :: get_right => muli_trapezium_node_get_right
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_node_get_right (this, right)
- class(muli_trapezium_node_class_t), intent(in) :: this
- class(muli_trapezium_node_class_t), pointer, intent(out) :: right
- right => this%right
- end subroutine muli_trapezium_node_get_right
-
-@ %def muli_trapezium_get_right
-@
-<<Muli trapezium: node: TBP>>=
- procedure :: get_leftmost => muli_trapezium_node_get_leftmost
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_node_get_leftmost (this, node)
- class(muli_trapezium_node_class_t), intent(in) :: this
- class(muli_trapezium_node_class_t), pointer, intent(out) :: node
- if (associated (this%left)) then
- node => this%left
- do while (associated (node%left))
- node => node%left
- end do
- else
- nullify (node)
- end if
- end subroutine muli_trapezium_node_get_leftmost
-
-@ %def muli_trapezium_get_leftmost
-@
-<<Muli trapezium: node: TBP>>=
- procedure :: get_rightmost => muli_trapezium_node_get_rightmost
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_node_get_rightmost (this, right)
- class(muli_trapezium_node_class_t), intent(in) :: this
- class(muli_trapezium_node_class_t), pointer, intent(out) :: right
- if (associated (this%right)) then
- right => this%right
- do while (associated (right%right))
- right => right%right
- end do
- else
- nullify (right)
- end if
- end subroutine muli_trapezium_node_get_rightmost
-
-@ %def muli_trapezium_node_get_rightmost
-@
-<<Muli trapezium: node: TBP>>=
- generic :: decide => decide_by_value, decide_by_position
- procedure :: decide_by_value => muli_trapezium_node_decide_by_value
- procedure :: decide_by_position => muli_trapezium_node_decide_by_position
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_node_decide_by_value (this, value, dim, record, node)
- class(muli_trapezium_node_class_t), intent(in) :: this
- real(default), intent(in) :: value
- integer, intent(in) :: record, dim
- class(muli_trapezium_node_class_t), pointer, intent(out) :: node
- if (this%values (dim, record) > value) then
- node => this%left
- else
- node => this%right
- end if
- end subroutine muli_trapezium_node_decide_by_value
-
-@ %def muli_trapezium_node_decide_by_value
-@
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_node_decide_by_position (this, position, node)
- class(muli_trapezium_node_class_t), intent(in) :: this
- real(default), intent(in) :: position
- class(muli_trapezium_node_class_t), pointer, intent(out) :: node
- if (this%r_position > position) then
- node => this%left
- else
- node => this%right
- end if
- end subroutine muli_trapezium_node_decide_by_position
-
-@ %def muli_trapezium_node_decide_by_position
-@
-<<Muli trapezium: node: TBP>>=
- procedure :: decide_decreasing => muli_trapezium_node_decide_decreasing
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_node_decide_decreasing &
- (this, value, dim, record, node)
- class(muli_trapezium_node_class_t), intent(in) :: this
- real(default), intent(in) :: value
- integer, intent(in) :: record, dim
- class(muli_trapezium_node_class_t), pointer, intent(out) :: node
- if (this%values (dim, record) <= value) then
- node => this%left
- else
- node => this%right
- end if
- end subroutine muli_trapezium_node_decide_decreasing
-
-@ %def muli_trapezium_node_decide_decreasing
-@
-<<Muli trapezium: node: TBP>>=
- procedure :: to_tree => muli_trapezium_node_to_tree
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_node_to_tree (this, out_tree)
- class(muli_trapezium_node_class_t), target, intent(in) :: this
- class(muli_trapezium_tree_t), intent(out) :: out_tree
- out_tree%left => this%left
- out_tree%right => this%right
- end subroutine muli_trapezium_node_to_tree
-
-@ %def muli_trapezium_node_to_tree
-@
-<<Muli trapezium: node: TBP>>=
- procedure :: untangle => muli_trapezium_node_untangle
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_node_untangle(this)
- class(muli_trapezium_node_class_t), intent(inout), target :: this
- if (associated (this%left)) then
- if (associated (this%left%right, this)) then
- nullify (this%left%right)
- nullify (this%left)
- end if
- end if
- end subroutine muli_trapezium_node_untangle
-
-@ %def muli_trapezium_node_untangle
-@
-<<Muli trapezium: node: TBP>>=
- procedure :: apply => muli_trapezium_node_apply
-<<Muli trapezium: procedures>>=
- recursive subroutine muli_trapezium_node_apply(this,proc)
- class(muli_trapezium_node_class_t), intent(inout) :: this
- interface
- subroutine proc(this)
- import muli_trapezium_node_class_t
- class(muli_trapezium_node_class_t), intent(inout) :: this
- end subroutine proc
- end interface
- if (associated(this%right))call proc(this%right)
- if (associated(this%left))call proc(this%left)
- call proc(this)
- end subroutine muli_trapezium_node_apply
-
-@ %def muli_trapezium_node_apply
-@
-<<Muli trapezium: node: TBP>>=
- ! procedure :: copy => muli_trapezium_node_copy
- ! generic :: assignment(=) => copy
- ! procedure, deferred :: approx => muli_trapezium_node_approx
-@
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: write_to_marker => muli_trapezium_tree_write_to_marker
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_write_to_marker (this, marker, status)
- class(muli_trapezium_tree_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- class(muli_trapezium_list_t), pointer :: list
- class(ser_class_t), pointer :: ser
- call marker%mark_begin ("muli_trapezium_tree_t")
- call this%get_left_list (list)
- ser => list
- call marker%mark_pointer ("list", ser)
- call marker%mark_end ("muli_trapezium_tree_t")
- end subroutine muli_trapezium_tree_write_to_marker
-
-@ %def muli_trapezium_tree_write_to_marker
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: read_from_marker => muli_trapezium_tree_read_from_marker
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_read_from_marker (this, marker, status)
- class(muli_trapezium_tree_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- class(ser_class_t), pointer :: ser
- call marker%pick_begin ("muli_trapezium_tree_t", status=status)
- call marker%pick_pointer ("list", ser)
- if (associated (ser)) then
- select type (ser)
- class is (muli_trapezium_list_t)
- call ser%to_tree (this)
- class default
- nullify (this%left)
- nullify (this%right)
- nullify (this%down)
- end select
- else
- nullify (this%left)
- nullify (this%right)
- nullify (this%down)
- end if
- call marker%pick_end ("muli_trapezium_tree_t", status)
- end subroutine muli_trapezium_tree_read_from_marker
-
-@ %def muli_trapezium_tree_read_from_marker
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: print_to_unit => muli_trapezium_tree_print_to_unit
-<<Muli trapezium: procedures>>=
- recursive subroutine muli_trapezium_tree_print_to_unit &
- (this, unit, parents, components, peers)
- class(muli_trapezium_tree_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- class(ser_class_t), pointer :: ser
- if (parents > 0) call muli_trapezium_print_to_unit &
- (this, unit, parents-1, components, peers)
- ser => this%down
- call serialize_print_peer_pointer (ser, unit, i_one, i_zero, i_one, "DOWN")
- if (associated (this%left)) then
- select type (sertmp => this%left)
- class is (muli_trapezium_list_t)
- ser => sertmp
- call serialize_print_peer_pointer &
- (ser, unit, parents, components, i_zero, "LEFT")
- class default
- call serialize_print_peer_pointer &
- (ser, unit, parents, components, peers, "LEFT")
- end select
- else
- write (unit, "(1x,A)") "Left is not associated."
- end if
- if (associated (this%right)) then
- select type (sertmp => this%right)
- class is (muli_trapezium_list_t)
- ser => sertmp
- call serialize_print_peer_pointer &
- (ser, unit, parents, components, i_zero, "RIGHT")
- class default
- call serialize_print_peer_pointer &
- (ser, unit, parents, components, peers, "RIGHT")
- end select
- else
- write (unit, "(1x,A)") "Right is not associated."
- end if
- end subroutine muli_trapezium_tree_print_to_unit
-
-@ %def muli_trapezium_tree_print_to_unit
-@
-<<Muli trapezium: tree: TBP>>=
- procedure, nopass :: get_type => muli_trapezium_tree_get_type
-<<Muli trapezium: procedures>>=
- pure subroutine muli_trapezium_tree_get_type (type)
- character(:),allocatable, intent(out) :: type
- allocate (type, source="muli_trapezium_tree_t")
- end subroutine muli_trapezium_tree_get_type
-
-@ %def muli_trapezium_tree_get_type
-@
-<<Muli trapezium: tree: TBP>>=
- procedure, nopass :: verify_type => muli_trapezium_tree_verify_type
-<<Muli trapezium: procedures>>=
- elemental logical function muli_trapezium_tree_verify_type (type) result (match)
- character(*), intent(in) :: type
- match = type == "muli_trapezium_tree_t"
- end function muli_trapezium_tree_verify_type
-
-@ %def muli_trapezium_tree_verify_type
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: nullify => muli_trapezium_tree_nullify
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_nullify (this)
- class(muli_trapezium_tree_t), intent(out) :: this
- call muli_trapezium_node_nullify (this)
- nullify (this%down)
- end subroutine muli_trapezium_tree_nullify
-
-@ %def muli_trapezium_tree_nullify
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: finalize => muli_trapezium_tree_finalize
-<<Muli trapezium: procedures>>=
- recursive subroutine muli_trapezium_tree_finalize (this)
- class(muli_trapezium_tree_t), intent(inout) :: this
- if (associated (this%right)) then
- call this%right%untangle ()
- call this%right%finalize ()
- deallocate (this%right)
- end if
- if (associated (this%left)) then
- call this%left%untangle ()
- call this%left%finalize ()
- deallocate (this%left)
- end if
- this%dim = 0
- end subroutine muli_trapezium_tree_finalize
-
-@ %def muli_trapezium_tree_finalize
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: decide_by_value => muli_trapezium_tree_decide_by_value
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_decide_by_value (this, value, dim, record, node)
- class(muli_trapezium_tree_t), intent(in) :: this
- real(default), intent(in) :: value
- integer, intent(in) :: record, dim
- class(muli_trapezium_node_class_t), pointer, intent(out) :: node
- if (this%down%values (dim, record) > value) then
- node => this%left
- else
- node => this%right
- end if
- end subroutine muli_trapezium_tree_decide_by_value
-
-@ %def muli_trapezium_tree_decide_by_value
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: decide_by_position => muli_trapezium_tree_decide_by_position
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_decide_by_position (this, position, node)
- class(muli_trapezium_tree_t), intent(in) :: this
- real(default), intent(in) :: position
- class(muli_trapezium_node_class_t), pointer, intent(out) :: node
- if (this%down%r_position > position) then
- node => this%left
- else
- node => this%right
- end if
- end subroutine muli_trapezium_tree_decide_by_position
-
-@ %def muli_trapezium_tree_decide_by_position
-<<Muli trapezium: tree: TBP>>=
- procedure :: decide_decreasing => muli_trapezium_tree_decide_decreasing
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_decide_decreasing &
- (this, value, dim, record, node)
- class(muli_trapezium_tree_t), intent(in) :: this
- real(default), intent(in) :: value
- integer, intent(in) :: record, dim
- ! integer, save :: count=0
- class(muli_trapezium_node_class_t), pointer, intent(out) :: node
- ! count = count + 1
- if (this%down%values (dim, record) <= value) then
- ! print ('("Decide: value(",I2,",",I1,")=",E20.7," > ",E20.7, &
- ! ": go left.")'), dim, record, this%down%values(dim, record), value
- node => this%left
- else
- ! print ('("Decide: value(",I2,",",I1,")=",E20.7," <= ", &
- ! E20.7,": go right.")'), &
- ! dim, record, this%down%values(dim, record), value
- node => this%right
- end if
- end subroutine muli_trapezium_tree_decide_decreasing
-
-@ %def muli_trapezium_tree_decide_decreasing
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: get_left_list => muli_trapezium_tree_get_left_list
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_get_left_list (this, list)
- class(muli_trapezium_tree_t), intent(in) :: this
- class(muli_trapezium_list_t), pointer, intent(out) :: list
- class(muli_trapezium_node_class_t), pointer::node
- call this%get_leftmost (node)
- if (associated (node)) then
- select type (node)
- class is (muli_trapezium_list_t)
- list => node
- class default
- nullify (list)
- end select
- else
- nullify (list)
- end if
- end subroutine muli_trapezium_tree_get_left_list
-
-@ %def muli_trapezium_tree_get_left_list
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: get_right_list => muli_trapezium_tree_get_right_list
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_get_right_list (this, list)
- class(muli_trapezium_tree_t), intent(in) :: this
- class(muli_trapezium_list_t), pointer, intent(out) :: list
- class(muli_trapezium_node_class_t), pointer::node
- call this%get_rightmost (node)
- if (associated (node)) then
- select type (node)
- class is (muli_trapezium_list_t)
- list => node
- class default
- nullify (list)
- end select
- else
- nullify (list)
- end if
- end subroutine muli_trapezium_tree_get_right_list
-
-@ %def muli_trapezium_tree_get_right_list
-@
-<<Muli trapezium: tree: TBP>>=
- generic :: find => find_by_value, find_by_position
- procedure :: find_by_value => muli_trapezium_tree_find_by_value
- procedure :: find_by_position => muli_trapezium_tree_find_by_position
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_find_by_value (this, value, dim, record, node)
- class(muli_trapezium_tree_t), intent(in), target :: this
- real(default), intent(in) :: value
- integer, intent(in) :: record, dim
- class(muli_trapezium_node_class_t), pointer, intent(out) :: node
- node => this
- do while (.not. allocated (node%values))
- call node%decide (value, dim, record, node)
- end do
- end subroutine muli_trapezium_tree_find_by_value
-
-@ %def muli_trapezium_tree_find_by_value
-@
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_find_by_position (this, position, node)
- class(muli_trapezium_tree_t), intent(in), target :: this
- real(default), intent(in) :: position
- class(muli_trapezium_node_class_t), pointer, intent(out) :: node
- node => this
- do while (.not. allocated (node%values))
- call node%decide (position, node)
- end do
- end subroutine muli_trapezium_tree_find_by_position
-
-@ %def muli_trapezium_tree_find_by_position
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: find_decreasing => muli_trapezium_tree_find_decreasing
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_find_decreasing (this, value, dim, node)
- class(muli_trapezium_tree_t), intent(in), target :: this
- real(default), intent(in) :: value
- integer, intent(in) :: dim
- class(muli_trapezium_node_class_t), pointer, intent(out) :: node
- node => this
- do while (.not. allocated (node%values))
- call node%decide_decreasing (value, dim, r_integral_index, node)
- end do
- end subroutine muli_trapezium_tree_find_decreasing
-
-@ %def muli_trapezium_tree_find_decreasing
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: approx_by_integral => muli_trapezium_tree_approx_by_integral
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_approx_by_integral &
- (this, int, dim, in_range, position, value, integral, content)
- class(muli_trapezium_tree_t), intent(in), target :: this
- real(default), intent(in) :: int
- integer, intent(in) :: dim
- logical, intent(out) :: in_range
- class(muli_trapezium_node_class_t), pointer, intent(out), optional :: content
- real(default), intent(out), optional :: position, value, integral
- integer :: i
- real(default) :: DINT !,l_prop,r_prop,d_prop
- real(default) :: RP, DP, RV, DV, RI !FC = gfortran
- class(muli_trapezium_node_class_t), pointer :: node
- node => this
- do while (.not. allocated (node%values))
- call node%decide_decreasing(INT, dim, r_integral_index, node)
- end do
- if ( int<=node%values(dim,r_integral_index)-node%values(dim,d_integral_index)&
- &.and.&
- &int>=node%values(dim,r_integral_index)) then
- in_range=.true.
-! associate(&!FC = nagfor
-! &RP=>node%r_position,&!FC = nagfor
-! &DP=>node%d_position,&!FC = nagfor
-! &RV=>node%values(dim,r_value_index),&!FC = nagfor
-! &DV=>node%values(dim,d_value_index),&!FC = nagfor
-! &RI=>node%values(dim,r_integral_index))!FC = nagfor
- RP=node%r_position!FC = gfortran
- DP=node%d_position!FC = gfortran
- RV=node%values(dim,r_value_index)!FC = gfortran
- DV=node%values(dim,d_value_index)!FC = gfortran
- RI=node%values(dim,r_integral_index)!FC = gfortran
- if (present(position)) then
- DINT=(ri-int)*2D0*dv/dp
- position=rp-(dp/dv)*(rv-sqrt(dint+rv**2))
- end if
- if (present(value)) then
- value=Sqrt(dp*(-2*dv*int + 2*dv*ri + dp*rv**2))/dp
- end if
- if (present(integral)) then
- integral=int
- end if
- if (present(content)) then
- content=>node
- end if
-! end associate!FC = nagfor
- else
- in_range=.false.
- end if
- end subroutine muli_trapezium_tree_approx_by_integral
-
-@ %def muli_trapezium_tree_approx_by_integral
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: approx_by_probability => muli_trapezium_tree_approx_by_probability
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_approx_by_probability &
- (this, prop, dim, in_range, position, value, integral, content)
- class(muli_trapezium_tree_t), intent(in), target :: this
- real(default), intent(in) :: prop
- integer, intent(in) :: dim
- logical, intent(out) :: in_range
- class(muli_trapezium_node_class_t), pointer, intent(out), optional :: content
- real(default), intent(out), optional :: position, value, integral
- integer :: i
- real(default) :: int
- class(muli_trapezium_node_class_t), pointer :: node
- if (zero < prop .and. prop < one) then
- node => this
- int = -log (prop)
- call muli_trapezium_tree_approx_by_integral &
- (this, int, dim, in_range, position, value, integral, content)
- else
- in_range = .false.
- end if
- end subroutine muli_trapezium_tree_approx_by_probability
-
-@ %def muli_trapezium_tree_approx_by_probability
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: to_tree => muli_trapezium_tree_to_tree
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_to_tree (this, out_tree)
- class(muli_trapezium_tree_t), target, intent(in) :: this
- class(muli_trapezium_tree_t), intent(out) :: out_tree
- out_tree%left => this%left
- out_tree%right => this%right
- out_tree%down => this%down
- end subroutine muli_trapezium_tree_to_tree
-
-@ %def muli_trapezium_tree_to_tree
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: append => muli_trapezium_tree_append
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_append(this,right)
- class(muli_trapezium_tree_t), intent(inout), target :: this
- class(muli_trapezium_node_class_t), intent(inout), target :: right
- call msg_error ("muli_trapezium_tree_append: Not yet implemented.")
- end subroutine muli_trapezium_tree_append
-
-@ %def muli_trapezium_tree_append
-@
-<<Muli trapezium: tree: TBP>>=
- procedure :: gnuplot => muli_trapezium_tree_gnuplot
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_tree_gnuplot (this, dir)
- class(muli_trapezium_tree_t), intent(in) :: this
- character(len=*), intent(in) :: dir
- class(muli_trapezium_list_t), pointer :: list
- call this%get_left_list (list)
- call list%gnuplot (dir)
- end subroutine muli_trapezium_tree_gnuplot
-
-@ %def muli_trapezium_tree_gnuplot
-@
-<<Muli trapezium: list: TBP>>=
- procedure :: write_to_marker => muli_trapezium_list_write_to_marker
-<<Muli trapezium: procedures>>=
- recursive subroutine muli_trapezium_list_write_to_marker (this, marker, status)
- class(muli_trapezium_list_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- class(ser_class_t), pointer :: ser
- call marker%mark_begin ("muli_trapezium_list_t")
- call muli_trapezium_write_to_marker (this, marker, status)
- ser => this%right
- call marker%mark_pointer ("right", ser)
- call marker%mark_end ("muli_trapezium_list_t")
- end subroutine muli_trapezium_list_write_to_marker
-
-@ %def muli_trapezium_list_write_to_marker
-@
-<<Muli trapezium: list: TBP>>=
- procedure :: read_from_marker => muli_trapezium_list_read_from_marker
-<<Muli trapezium: procedures>>=
- recursive subroutine muli_trapezium_list_read_from_marker (this, marker, status)
- class(muli_trapezium_list_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call msg_warning ("muli_trapezium_list_read_from_marker: " // &
- "You cannot deserialize a list with this subroutine.")
- call msg_error ("Use muli_trapezium_list_read_target_from_marker instead.")
- end subroutine muli_trapezium_list_read_from_marker
-
-@ %def muli_trapezium_list_read_from_marker
-@
-<<Muli trapezium: list: TBP>>=
- procedure :: read_target_from_marker => &
- muli_trapezium_list_read_target_from_marker
-<<Muli trapezium: procedures>>=
- recursive subroutine muli_trapezium_list_read_target_from_marker &
- (this, marker, status)
- class(muli_trapezium_list_t), target, intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- class(ser_class_t), pointer :: ser
- call marker%pick_begin ("muli_trapezium_list_t", status=status)
- call muli_trapezium_read_from_marker (this, marker, status)
- call marker%pick_pointer ("right", ser)
- if (associated (ser)) then
- select type (ser)
- class is (muli_trapezium_list_t)
- this%right => ser
- ser%left => this
- class default
- nullify (this%right)
- call msg_error ("muli_trapezium_list_read_target_from_marker: " &
- // "Unexpected type for right component.")
- end select
- else
- nullify (this%right)
- end if
- call marker%pick_end ("muli_trapezium_list_t", status)
- end subroutine muli_trapezium_list_read_target_from_marker
-
-@ %def muli_trapezium_list_read_target_from_marker
-@
-<<Muli trapezium: list: TBP>>=
- procedure :: print_to_unit => muli_trapezium_list_print_to_unit
-<<Muli trapezium: procedures>>=
- recursive subroutine muli_trapezium_list_print_to_unit &
- (this, unit, parents, components, peers)
- class(muli_trapezium_list_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- class(ser_class_t), pointer :: ser
- if (parents > 0) call muli_trapezium_print_to_unit &
- (this, unit, parents-1, components, peers)
- ser => this%left
- call serialize_print_peer_pointer &
- (ser, unit, -i_one, -i_one, -i_one, "LEFT")
- ser => this%right
- call serialize_print_peer_pointer &
- (ser, unit, parents, components, peers, "RIGHT")
- end subroutine muli_trapezium_list_print_to_unit
-
-@ %def muli_trapezium_list_print_to_unit
-@
-<<Muli trapezium: list: TBP>>=
- procedure, nopass :: get_type => muli_trapezium_list_get_type
-<<Muli trapezium: procedures>>=
- pure subroutine muli_trapezium_list_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="muli_trapezium_list_t")
- end subroutine muli_trapezium_list_get_type
-
-@ %def muli_trapezium_list_get_type
-@
-<<Muli trapezium: list: TBP>>=
- procedure, nopass :: verify_type => muli_trapezium_list_verify_type
-@
-<<Muli trapezium: procedures>>=
- elemental logical function muli_trapezium_list_verify_type (type) result (match)
- character(*), intent(in) :: type
- match = type == "muli_trapezium_list_t"
- end function muli_trapezium_list_verify_type
-
-@ %def muli_trapezium_list_verify_type
-@
-<<Muli trapezium: list: TBP>>=
- procedure :: finalize => muli_trapezium_list_finalize
-@
-<<Muli trapezium: procedures>>=
- recursive subroutine muli_trapezium_list_finalize(this)
- class(muli_trapezium_list_t), intent(inout)::this
- if (associated(this%right)) then
- call this%right%finalize()
- deallocate(this%right)
- end if
- this%dim=0
- end subroutine muli_trapezium_list_finalize
-
-@ %def muli_trapezium_list_finalize
-@
-<<Muli trapezium: list: TBP>>=
- generic :: insert_right => insert_right_a !, insert_right_b
- procedure :: insert_right_a => muli_trapezium_list_insert_right_a
- ! procedure :: insert_right_b => muli_trapezium_list_insert_right_b
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_list_insert_right_a (this, value, content, new_node)
- class(muli_trapezium_list_t), intent(inout), target :: this
- real(default), intent(in) :: value
- class(muli_trapezium_t), intent(in) :: content
- class(muli_trapezium_list_t), pointer, intent(out) :: new_node
- class(muli_trapezium_list_t), pointer :: tmp_list
- call content%to_node (value, list=tmp_list)
- if (associated (this%right)) then
- this%right%left => tmp_list
- tmp_list%right => this%right
- else
- nullify (tmp_list%right)
- end if
- this%right => tmp_list
- tmp_list%left => this
- new_node => tmp_list
- end subroutine muli_trapezium_list_insert_right_a
-
-@ %def muli_trapezium_list_insert_right_a
-@
-<<Muli trapezium: list: TBP>>=
- generic :: insert_left => insert_left_a !, insert_left_b
- procedure :: insert_left_a => muli_trapezium_list_insert_left_a
- ! procedure :: insert_left_b => muli_trapezium_list_insert_left_b
-@
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_list_insert_left_a (this, value, content, new_node)
- class(muli_trapezium_list_t), intent(inout), target :: this
- real(default), intent(in) :: value
- class(muli_trapezium_t), intent(in) :: content
- class(muli_trapezium_list_t), pointer, intent(out) :: new_node
- call content%to_node (value, list=new_node)
- new_node%right => this
- if (associated (this%left)) then
- new_node%left => this%left
- this%left%right => new_node
- else
- nullify (new_node%left)
- end if
- this%left => new_node
- end subroutine muli_trapezium_list_insert_left_a
-
-@ %def muli_trapezium_list_insert_left_a
-@
-<<Muli trapezium: list: TBP>>=
- procedure :: to_tree => muli_trapezium_list_to_tree
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_list_to_tree (this, out_tree)
- class(muli_trapezium_list_t), target, intent(in) :: this
- class(muli_trapezium_tree_t), intent(out) :: out_tree
- type(muli_trapezium_tree_t),target :: do_list
- class(muli_trapezium_node_class_t),pointer :: this_entry,do_list_entry,node
- class(muli_trapezium_tree_t),pointer :: tree1,tree2
- integer :: ite,log,n_deep,n_leaves
- n_leaves=0
- this_entry => this
- count: do while(associated(this_entry))
- n_leaves=n_leaves+1
- this_entry=>this_entry%right
- end do count
- call ilog2(n_leaves,log,n_deep)
- this_entry => this
- do_list_entry => do_list
- deep: do ite=0,n_deep-1
- allocate(tree1)
- tree1%down=>this_entry%right
- allocate(tree2)
- tree2%down=>this_entry
- tree2%left=>this_entry
- tree2%right=>this_entry%right
- tree1%left=>tree2
- this_entry => this_entry%right%right
- do_list_entry%right=>tree1
- do_list_entry=>tree1
- end do deep
- rest: do while(associated(this_entry))
- allocate(tree1)
- tree1%down=>this_entry
- tree1%left=>this_entry
- do_list_entry%right => tree1
- do_list_entry => tree1
- this_entry => this_entry%right
- ite=ite+1
- end do rest
- tree: do while(ite>2)
- do_list_entry => do_list%right
- node=>do_list
- level: do while(associated(do_list_entry))
- node%right=>do_list_entry%right
- node=>do_list_entry%right
- do_list_entry%right=>node%left
- node%left=>do_list_entry
- do_list_entry=>node%right
- ite=ite-1
- end do level
- end do tree
- node=>do_list%right
- select type(node)
- type is (muli_trapezium_tree_t)
- call node%to_tree(out_tree)
- class default
- print *,"muli_trapezium_list_to_tree"
- print *,"unexpeted type for do_list%right"
- end select
- out_tree%right=>out_tree%right%left
- if (allocated(out_tree%values)) then
- deallocate(out_tree%values)
- end if
- deallocate(do_list%right%right)
- deallocate(do_list%right)
- end subroutine muli_trapezium_list_to_tree
-
-@ %def muli_trapezium_
-@
-<<Muli trapezium: list: TBP>>=
- procedure :: gnuplot => muli_trapezium_list_gnuplot
-@
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_list_gnuplot (this, dir)
- class(muli_trapezium_list_t), intent(in), target :: this
- character(len=*), intent(in) :: dir
- character(len=*), parameter :: val_file = "/value.plot"
- character(len=*), parameter :: int_file = "/integral.plot"
- character(len=*), parameter :: err_file = "/integral_error.plot"
- character(len=*), parameter :: pro_file = "/probability.plot"
- character(len=*), parameter :: den_file = "/density.plot"
- character(len=*), parameter :: fmt = "(ES20.10)"
- class(muli_trapezium_node_class_t), pointer :: list
- integer :: val_unit, err_unit, int_unit, pro_unit, den_unit
- list => this
- call generate_unit (val_unit, 100, 1000)
- open (val_unit, file = dir // val_file)
- call generate_unit (int_unit, 100, 1000)
- open (int_unit, file = dir // int_file)
- call generate_unit (err_unit, 100, 1000)
- open (err_unit, file = dir // err_file)
- call generate_unit (pro_unit, 100, 1000)
- open (pro_unit, file = dir // pro_file)
- call generate_unit (den_unit, 100, 1000)
- open (den_unit, file = dir // den_file)
- do while (associated (list))
- ! print *,list%r_position,list%get_r_value()
- !!! !!! !!! gfortran 5.0.0 ICE
- ! write (val_unit, fmt, advance="no") list%r_position
- ! call write_array (val_unit, list%get_r_value_array(), fmt)
- ! write (int_unit,fmt,advance="no") list%r_position
- ! call write_array (int_unit, list%get_r_integral(), fmt)
- ! write (err_unit, fmt, advance="no") list%r_position
- ! call write_array (err_unit, list%get_error(), fmt)
- ! write (pro_unit, fmt, advance="no") list%r_position
- ! call write_array (pro_unit, list%get_r_probability(), fmt)
- ! write (den_unit, fmt, advance="no") list%r_position
- ! call write_array (den_unit, list%get_r_probability() * &
- ! list%get_r_value_array(), fmt)
- list => list%right
- end do
- close (val_unit)
- close (int_unit)
- close (err_unit)
- close (pro_unit)
- close (den_unit)
- contains
- subroutine write_array (unit, array, form)
- integer, intent(in) :: unit
- real(default), dimension(:), intent(in) :: array
- character(len=*), intent(in) :: form
- integer :: n
- do n = 1, size(array)
- write (unit, form, advance="no") array(n)
- flush (unit)
- end do
- write (unit, *)
- end subroutine write_array
- end subroutine muli_trapezium_list_gnuplot
-
-@ %def muli_trapezium_list_gnuplot
-@
-<<Muli trapezium: list: TBP>>=
- procedure :: integrate => muli_trapezium_list_integrate
-<<Muli trapezium: procedures>>=
- subroutine muli_trapezium_list_integrate (this, integral_sum, error_sum)
- class(muli_trapezium_list_t), intent(in), target :: this
- real(default), intent(out) :: error_sum, integral_sum
- real(default), dimension(:), allocatable :: integral
- class(muli_trapezium_node_class_t), pointer :: node
- allocate (integral (0:this%dim-1))
- call this%get_rightmost (node)
- integral = 0._default
- integral_sum = 0._default
- error_sum = 0._default
- integrate: do while (associated (node))
- node%values(1,r_value_index) = sum(node%values(1:this%dim-1,r_value_index))
- node%values(1,d_value_index) = sum(node%values(1:this%dim-1,d_value_index))
- ! node%values (1, r_integral_index) = &
- ! sum (node%values (1:this%dim-1, r_integral_index))
- ! node%values (1, d_integral_index) = &
- ! sum (node%values (1:this%dim-1, d_integral_index))
- node%values(1, error_index) = sum (node%values(1:this%dim-1, error_index))
- error_sum = error_sum + node%values (1, error_index)
- !!! !!! !!! gfortran 5.0.0 ICE
- ! call node%set_d_integral (node%get_d_position() * &
- ! (node%get_d_value() / 2 - node%get_r_value_array ()))
- call node%set_r_probability (exp (-integral))
- call node%set_r_integral (integral)
- !!! !!! !!! gfortran 5.0.0 ICE
- ! integral = integral - node%get_d_integral()
- ! call node%set_d_probability (node%get_r_probability() - exp(-integral))
- ! call muli_trapezium_write (node, output_unit)
- call node%get_left (node)
- end do integrate
- integral_sum = integral (1)
- end subroutine muli_trapezium_list_integrate
-
-@ %def muli_trapezium_list_integrate
-@
-<<Muli trapezium: list: TBP>>=
- procedure :: check => muli_trapezium_list_check
-<<Muli trapezium: procedures>>=
- recursive subroutine muli_trapezium_list_check (this)
- class(muli_trapezium_list_t), intent(in),target :: this
- class(muli_trapezium_node_class_t), pointer :: tn, next
- real(default), parameter :: eps = 1E-10_default
- logical::test
- if (associated(this%right)) then
- next=>this%right
- test=(this%r_position.le.this%right%get_l_position()+eps)
- print *,"position check: ",test
- if (.not.test) then
- call this%print_parents()
- call next%print_parents()
- end if
- select type (next)
- class is (muli_trapezium_list_t)
- tn=>this
- print *,"structure check: ",associated(tn,next%left)
- print *,"class check: T"
- call next%check()
- class default
- print *,"class check: F"
- end select
- else
- print *,"end of list at ",this%r_position
- end if
- end subroutine muli_trapezium_list_check
-
-@ %def muli_trapezium_list_check
-@
-<<Muli trapezium: list: TBP>>=
- procedure :: apply => muli_trapezium_list_apply
-<<Muli trapezium: procedures>>=
- recursive subroutine muli_trapezium_list_apply (this, proc)
- class(muli_trapezium_list_t), intent(inout) :: this
- interface
- subroutine proc (this)
- import muli_trapezium_node_class_t
- class(muli_trapezium_node_class_t), intent(inout) :: this
- end subroutine proc
- end interface
- if (associated (this%right))call this%right%apply (proc)
- call proc (this)
- end subroutine muli_trapezium_list_apply
-
-@ %def muli_trapezium_list_apply
-@
-<<Muli trapezium: procedures>>=
-! subroutine muli_trapezium_list_insert_right_old &
-! (this, value, content, new_node)
-! class(muli_trapezium_list_t), intent(inout), target :: this
-! real(default), intent(in) :: value
-! class(muli_trapezium_t), intent(in) :: content
-! class(muli_trapezium_list_t), pointer, intent(out) :: new_node
-! call content%to_node (value, list=new_node)
-! new_node%left => this
-! if (associated (this%right)) then
-! new_node%right => this%right
-! this%right%left => new_node
-! else
-! nullify (new_node%right)
-! end if
-! this%right => new_node
-! end subroutine muli_trapezium_list_insert_right_old
-
-@ %def muli_trapezium_list_insert_right_old
-@
-<<Muli trapezium: procedures>>=
-! subroutine muli_trapezium_node_error_no_content (this)
-! class(muli_trapezium_node_class_t), intent(in) :: this
-!! print ("muli_trapezium_node: Trying to access unallocated content.")
-!! call this%print()
-! end subroutine muli_trapezium_node_error_no_content
-
-@ %def muli_trapezium_node_error_no_content
-@
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Fibonacci trees}
-
-This file contains the module [[muli_fibonacci_tree]]. A fibonacci
-tree is a self-balancing binary tree. "Balanced" means that the depth
-of the left successor may differ from the depth of the right successor
-in any node by maximally one. The maximally unbalanced tree is maximally
-unbalanced in every node. So the number of leaves of a maximally
-unbalanced fibonacci tree of depth $n$ is precisely the $n$th fibonacci
-number.
-
-We use this tree for the adaptive quadrature. In every iteration of the
-algorithm, we have to pick the segment with largest integration error,
-cut it into pieces and calculate the new integration error for the pieces.
-A binary tree is obvioulsly a good choice for soring these segments. The
-problem is, that we always pick leaves from the same side of the tree. So
-the tree must decline at one side and grow at the other side. Sorting gets
-less efficient and finally most of the overall CPU time gets wasted for
-sorting. This tree outperforms a naive binary tree significantly in
-this particular job.
-
-<<File header>>=
-<<[[muli_fibonacci_tree.f90]]>>=
-
-module muli_fibonacci_tree
-
-<<Use kinds>>
- use diagnostics
- use muli_base
-
-<<Standard module head>>
-
-<<Muli fibonacci: public>>
-
-<<Muli fibonacci: variables>>
-
-<<Muli fibonacci: types>>
-
-contains
-
-<<Muli fibonacci: procedures>>
-
-end module muli_fibonacci_tree
-
-@ %def muli_fibonacci_tree
-@
-<<Muli fibonacci: variables>>=
- character(*), parameter :: no_par = "edge=\noparent"
- character(*), parameter :: no_ret = "edge=\noreturn"
- character(*), parameter :: no_kid = "edge=\nochild"
- character(*), parameter :: le_kid = "edge=\childofleave"
-
-@ %def no_par no_ret no_kid le_kid
-@
-<<Muli fibonacci: public>>=
- public :: fibonacci_node_t
-<<Muli fibonacci: types>>=
- type, extends (measure_class_t) :: fibonacci_node_t
- ! private
- class(fibonacci_node_t), pointer :: up => null()
- class(measure_class_t), pointer :: down => null()
- class(fibonacci_node_t), pointer :: left => null()
- class(fibonacci_node_t), pointer :: right => null()
- integer :: depth = 0
- ! real(default) :: value
- contains
- <<Muli fibonacci: fibonacci node: TBP>>
- end type fibonacci_node_t
-
-@ %def fibonacci_node_t
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: write_to_marker => fibonacci_node_write_to_marker
-<<Muli fibonacci: procedures>>=
- recursive subroutine fibonacci_node_write_to_marker (this, marker, status)
- class(fibonacci_node_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- class(ser_class_t), pointer :: ser
- call marker%mark_begin ("fibonacci_node_t")
- ser => this%left
- call marker%mark_pointer ("left", ser)
- ser => this%right
- call marker%mark_pointer ("right", ser)
- ser => this%down
- call marker%mark_pointer ("down", ser)
- call marker%mark_end ("fibonacci_node_t")
- end subroutine fibonacci_node_write_to_marker
-
-@ %def fibonacci_node_wrote_to_marker
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: read_from_marker => fibonacci_node_read_from_marker
-<<Muli fibonacci: procedures>>=
- recursive subroutine fibonacci_node_read_from_marker (this, marker, status)
- class(fibonacci_node_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call msg_warning ("fibonacci_node_read_from_marker: You cannot " // &
- "deserialize a list with this subroutine.")
- call msg_error ("Use fibonacci_node_read_target_from_marker instead.")
- end subroutine fibonacci_node_read_from_marker
-
-@ %def fibonacci_node_read_from_marker
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: read_target_from_marker => fibonacci_node_read_target_from_marker
-<<Muli fibonacci: procedures>>=
- recursive subroutine fibonacci_node_read_target_from_marker &
- (this, marker, status)
- class(fibonacci_node_t), target, intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- class(ser_class_t), pointer :: ser
- call marker%pick_begin ("fibonacci_node_t", status=status)
- call marker%pick_pointer ("left", ser)
- if (status == 0) then
- select type (ser)
- class is (fibonacci_node_t)
- this%left => ser
- this%left%up => this
- end select
- end if
- call marker%pick_pointer ("right", ser)
- if (status == 0) then
- select type (ser)
- class is (fibonacci_node_t)
- this%right => ser
- this%right%up => this
- end select
- end if
- call marker%pick_pointer ("down", ser)
- if (status == 0) then
- select type (ser)
- class is (measure_class_t)
- this%down => ser
- end select
- end if
- call marker%pick_end ("fibonacci_node_t", status)
- end subroutine fibonacci_node_read_target_from_marker
-
-@ %def fibonacci_node_read_target_from_marker
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: print_to_unit => fibonacci_node_print_to_unit
-<<Muli fibonacci: procedures>>=
- recursive subroutine fibonacci_node_print_to_unit &
- (this, unit, parents, components, peers)
- class(fibonacci_node_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- class(ser_class_t), pointer :: ser
- write (unit, "(1x,A)") "Components of fibonacci_node_t:"
- write (unit, "(3x,A,I22)") "Depth: ", this%depth
- write (unit, "(3x,A,E23.16)") "Value: ", this%measure ()
- ser => this%up
- call serialize_print_comp_pointer &
- (ser, unit, parents, -i_one, -i_one, "Up: ")
- ser => this%left
- call serialize_print_peer_pointer &
- (ser, unit, parents, components, peers, "Left: ")
- ser => this%right
- call serialize_print_peer_pointer &
- (ser, unit, parents, components, peers, "Right: ")
- end subroutine fibonacci_node_print_to_unit
-
-@ %def fibonacci_node_print_to_unit
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure, nopass :: get_type => fibonacci_node_get_type
-<<Muli fibonacci: procedures>>=
- pure subroutine fibonacci_node_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="fibonacci_node_t")
- end subroutine fibonacci_node_get_type
-
-@ %def fibonacci_node_get_type
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: deserialize_from_marker => fibonacci_node_deserialize_from_marker
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_deserialize_from_marker (this, name, marker)
- class(fibonacci_node_t), intent(out) :: this
- character(*), intent(in) :: name
- class(marker_t), intent(inout) :: marker
- class(ser_class_t), pointer :: ser
- allocate (fibonacci_leave_t :: ser)
- call marker%push_reference (ser)
- allocate (fibonacci_node_t :: ser)
- call marker%push_reference (ser)
- call serializable_deserialize_from_marker (this, name, marker)
- call marker%pop_reference (ser)
- deallocate (ser)
- call marker%pop_reference (ser)
- deallocate (ser)
- end subroutine fibonacci_node_deserialize_from_marker
-
-@ %def fibonacci_node_deserialize_from_marker
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: measure => fibonacci_node_measure
-<<Muli fibonacci: procedures>>=
- elemental function fibonacci_node_measure (this)
- class(fibonacci_node_t), intent(in) :: this
- real(default) :: fibonacci_node_measure
- fibonacci_node_measure = this%down%measure ()
- end function fibonacci_node_measure
-
-@ %def fibonacci_node_measure
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: deallocate_tree => fibonacci_node_deallocate_tree
-<<Muli fibonacci: procedures>>=
- recursive subroutine fibonacci_node_deallocate_tree (this)
- class(fibonacci_node_t), intent(inout) :: this
- if (associated (this%left)) then
- call this%left%deallocate_tree ()
- deallocate (this%left)
- end if
- if (associated (this%right)) then
- call this%right%deallocate_tree ()
- deallocate (this%right)
- end if
- call this%set_depth (0)
- end subroutine fibonacci_node_deallocate_tree
-
-@ %def fibonacci_node_deallocate_tree
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: deallocate_all => fibonacci_node_deallocate_all
-<<Muli fibonacci: procedures>>=
- recursive subroutine fibonacci_node_deallocate_all (this)
- class(fibonacci_node_t), intent(inout) :: this
- if (associated (this%left)) then
- call this%left%deallocate_all ()
- deallocate (this%left)
- end if
- if (associated (this%right)) then
- call this%right%deallocate_all ()
- deallocate (this%right)
- end if
- call this%set_depth (0)
- end subroutine fibonacci_node_deallocate_all
-
-@ %def fibonacci_node_deallocate_all
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: get_depth => fibonacci_node_get_depth
-<<Muli fibonacci: procedures>>=
- elemental function fibonacci_node_get_depth (this)
- class(fibonacci_node_t), intent(in) :: this
- integer :: fibonacci_node_get_depth
- fibonacci_node_get_depth = this%depth
- end function fibonacci_node_get_depth
-
-@ %def fibonacci_node_get_depth
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: count_leaves => fibonacci_node_count_leaves
-<<Muli fibonacci: procedures>>=
- recursive subroutine fibonacci_node_count_leaves (this, n)
- class(fibonacci_node_t), intent(in) :: this
- integer, intent(out) :: n
- integer :: n1, n2
- if (associated (this%left) .and. associated (this%right)) then
- call fibonacci_node_count_leaves (this%left, n1)
- call fibonacci_node_count_leaves (this%right, n2)
- n = n1 + n2
- else
- n = 1
- end if
- end subroutine fibonacci_node_count_leaves
-
-@ %def fibonacci_node_count_leaves
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure,public,nopass :: is_leave => fibonacci_node_is_leave
-<<Muli fibonacci: procedures>>=
- elemental function fibonacci_node_is_leave ()
- logical :: fibonacci_node_is_leave
- fibonacci_node_is_leave = .false.
- end function fibonacci_node_is_leave
-
-@ %def fibonacci_node_is_leave
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure,public,nopass :: is_root => fibonacci_node_is_root
-<<Muli fibonacci: procedures>>=
- elemental function fibonacci_node_is_root ()
- logical :: fibonacci_node_is_root
- fibonacci_node_is_root = .false.
- end function fibonacci_node_is_root
-
-@ %def fibonacci_node_is_root
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure,public,nopass :: is_inner => fibonacci_node_is_inner
-<<Muli fibonacci: procedures>>=
- elemental function fibonacci_node_is_inner ()
- logical :: fibonacci_node_is_inner
- fibonacci_node_is_inner = .true.
- end function fibonacci_node_is_inner
-
-@ %def fibonacci_node_is_inner
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: write_association => fibonacci_node_write_association
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_write_association (this, that)
- class(fibonacci_node_t), intent(in), target :: this
- class(fibonacci_node_t), intent(in), target :: that
- if (associated (that%left, this)) then
- write(*, "(A)") "This is left child of that"
- end if
- if (associated (that%right, this)) then
- write(*, "(A)") "This is right child of that"
- end if
- if (associated (that%up, this)) then
- write(*, "(A)") "This is parent of that"
- end if
- if (associated (this%left, that)) then
- write(*, "(A)") "That is left child of this"
- end if
- if (associated (this%right, that)) then
- write(*, "(A)") "That is right child of this"
- end if
- if (associated (this%up, that)) then
- write(*, "(A)") "That is parent of this"
- end if
- end subroutine fibonacci_node_write_association
-
-@ %def fibonacci_node_write_association
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: write_contents => fibonacci_node_write_contents
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_write_contents (this, unit)
- class(fibonacci_node_t), intent(in), target :: this
- integer, intent(in), optional :: unit
- call this%apply_to_leaves (fibonacci_leave_write_content, unit)
- end subroutine fibonacci_node_write_contents
-
-@ %def fibonacci_node_write_contents
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: write_values => fibonacci_node_write_values
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_write_values (this, unit)
- class(fibonacci_node_t), intent(in), target :: this
- integer, intent(in), optional :: unit
- call this%apply_to_leaves (fibonacci_leave_write_value, unit)
- end subroutine fibonacci_node_write_values
-
-@ %def fibonacci_node_write_values
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: write_leaves => fibonacci_node_write_leaves
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_write_leaves (this, unit)
- class(fibonacci_node_t), intent(in), target :: this
- integer, intent(in),optional :: unit
- call this%apply_to_leaves (fibonacci_leave_write, unit)
- end subroutine fibonacci_node_write_leaves
-
-@ %def fibonacci_node_write_leaves
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- ! procedure :: write => fibonacci_node_write_contents
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: write_pstricks => fibonacci_node_write_pstricks
-<<Muli fibonacci: procedures>>=
- recursive subroutine fibonacci_node_write_pstricks (this, unitnr)
- class(fibonacci_node_t), intent(in), target :: this
- integer, intent(in) :: unitnr
- if (associated (this%up)) then
- if (associated (this%up%left, this) .neqv. &
- (associated (this%up%right, this))) then
- ! write (unitnr,'("\begin{psTree}{\Toval{$",i3,"$}}")') int(this%depth)
- write (unitnr, &
- '("\begin{psTree}{\Toval{\node{",i3,"}{",f9.3,"}}}")') &
- int(this%depth), this%measure()
- else
- write (unitnr, &
- '("\begin{psTree}{\Toval[",a,"]{\node{",i3,"}{",f9.3,"}}}")') &
- no_ret, int(this%depth), this%measure()
- end if
- else
- write (unitnr, &
- '("\begin{psTree}{\Toval[",a,"]{\node{",i3,"}{",f9.3,"}}}")') &
- no_par, int(this%depth), this%measure()
- end if
- if (associated (this%left)) then
- call this%left%write_pstricks (unitnr)
- else
- write (unitnr,'("\Tr[edge=brokenline]{}")')
- end if
- if (associated (this%right)) then
- call this%right%write_pstricks (unitnr)
- else
- write (unitnr, '("\Tr[edge=brokenline]{}")')
- end if
- write (unitnr, '("\end{psTree}")')
- end subroutine fibonacci_node_write_pstricks
-
-@ %def fibonacci_node_write_pstricks
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: copy_node => fibonacci_node_copy_node
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_copy_node (this, primitive)
- class(fibonacci_node_t), intent(out) :: this
- class(fibonacci_node_t), intent(in) :: primitive
- this%up => primitive%up
- this%left => primitive%left
- this%right => primitive%right
- this%depth = primitive%depth
- this%down => primitive%down
- end subroutine fibonacci_node_copy_node
-
-@ %def fibonacci_node_copy_node
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: find_root => fibonacci_node_find_root
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_find_root (this, root)
- class(fibonacci_node_t), intent(in), target :: this
- class(fibonacci_root_t), pointer, intent(out) :: root
- class(fibonacci_node_t), pointer :: node
- node => this
- do while (associated (node%up))
- node => node%up
- end do
- select type (node)
- class is (fibonacci_root_t)
- root => node
- class default
- nullify (root)
- call msg_error ("fibonacci_node_find_root: root is not type " // &
- "compatible to fibonacci_root_t. Retured NULL().")
- end select
- end subroutine fibonacci_node_find_root
-
-@ %def fibonacci_node_find_root
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: find_leftmost => fibonacci_node_find_leftmost
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_find_leftmost (this, leave)
- class(fibonacci_node_t), intent(in), target :: this
- class(fibonacci_leave_t), pointer, intent(out) :: leave
- class(fibonacci_node_t), pointer :: node
- node => this
- do while (associated (node%left))
- node => node%left
- end do
- select type (node)
- class is (fibonacci_leave_t)
- leave => node
- class default
- leave => null()
- end select
- end subroutine fibonacci_node_find_leftmost
-
-@ %def fibonacci_node_find_leftmost
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: find_rightmost => fibonacci_node_find_rightmost
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_find_rightmost (this, leave)
- class(fibonacci_node_t), intent(in), target :: this
- class(fibonacci_leave_t), pointer, intent(out) :: leave
- class(fibonacci_node_t), pointer :: node
- node => this
- do while (associated (node%right))
- node => node%right
- end do
- select type (node)
- class is (fibonacci_leave_t)
- leave => node
- class default
- leave => null()
- end select
- end subroutine fibonacci_node_find_rightmost
-
-@ %def fibonacci_node_find_rightmost
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: find => fibonacci_node_find
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_find (this, value, leave)
- class(fibonacci_node_t), intent(in), target :: this
- real(default), intent(in) :: value
- class(fibonacci_leave_t), pointer, intent(out) :: leave
- class(fibonacci_node_t), pointer :: node
- node => this
- do
- if (node >= value) then
- if (associated (node%left)) then
- node => node%left
- else
- call msg_warning ("fibonacci_node_find: broken tree!")
- leave => null()
- return
- end if
- else
- if (associated (node%right)) then
- node => node%right
- else
- call msg_warning ("fibonacci_node_find: broken tree!")
- leave => null()
- return
- end if
- end if
- select type (node)
- class is (fibonacci_leave_t)
- leave => node
- exit
- end select
- end do
- end subroutine fibonacci_node_find
-
-@ %def fibonacci_node_find
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: find_left_leave => fibonacci_node_find_left_leave
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_find_left_leave (this, leave)
- class(fibonacci_node_t), intent(in), target :: this
- class(fibonacci_node_t), pointer :: node
- class(fibonacci_leave_t), pointer, intent(out) :: leave
- nullify(leave)
- node => this
- do while (associated (node%up))
- if (associated (node%up%right, node)) then
- node => node%up%left
- do while (associated (node%right))
- node => node%right
- end do
- select type (node)
- class is (fibonacci_leave_t)
- leave => node
- end select
- exit
- end if
- node => node%up
- end do
- end subroutine fibonacci_node_find_left_leave
-
-@ %def fibonacci_node_find_left_leave
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: find_right_leave => fibonacci_node_find_right_leave
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_find_right_leave (this, leave)
- class(fibonacci_node_t), intent(in), target :: this
- class(fibonacci_node_t), pointer :: node
- class(fibonacci_leave_t), pointer, intent(out) :: leave
- nullify (leave)
- node => this
- do while (associated (node%up))
- if (associated (node%up%left, node)) then
- node => node%up%right
- do while (associated (node%left))
- node => node%left
- end do
- select type (node)
- class is (fibonacci_leave_t)
- leave => node
- end select
- exit
- end if
- node => node%up
- end do
- end subroutine fibonacci_node_find_right_leave
-
-@ %def fibonacci_node_find_right_leave
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: apply_to_leaves => fibonacci_node_apply_to_leaves
-<<Muli fibonacci: procedures>>=
- recursive subroutine fibonacci_node_apply_to_leaves (node, func, unit)
- class(fibonacci_node_t), intent(in), target :: node
- interface
- subroutine func (this, unit)
- import fibonacci_leave_t
- class(fibonacci_leave_t), intent(in), target :: this
- integer, intent(in), optional :: unit
- end subroutine func
- end interface
- integer, intent(in), optional :: unit
- select type (node)
- class is (fibonacci_leave_t)
- call func (node, unit)
- class default
- call node%left%apply_to_leaves (func, unit)
- call node%right%apply_to_leaves (func, unit)
- end select
- end subroutine fibonacci_node_apply_to_leaves
-
-@ %def fibonacci_node_apply_to_leaves
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: apply_to_leaves_rl => fibonacci_node_apply_to_leaves_rl
-<<Muli fibonacci: procedures>>=
- recursive subroutine fibonacci_node_apply_to_leaves_rl (node, func, unit)
- class(fibonacci_node_t), intent(in), target :: node
- interface
- subroutine func (this, unit)
- import fibonacci_leave_t
- class(fibonacci_leave_t), intent(in), target :: this
- integer, intent(in), optional :: unit
- end subroutine func
- end interface
- integer, intent(in), optional :: unit
- select type (node)
- class is (fibonacci_leave_t)
- call func (node, unit)
- class default
- call node%right%apply_to_leaves_rl (func, unit)
- call node%left%apply_to_leaves_rl (func, unit)
- end select
- end subroutine fibonacci_node_apply_to_leaves_rl
-
-@ %def fibonacci_node_apply_to_leaves_rl
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: set_depth => fibonacci_node_set_depth
-@
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_set_depth (this, depth)
- class(fibonacci_node_t), intent(inout) :: this
- integer, intent(in) :: depth
- this%depth = depth
- end subroutine fibonacci_node_set_depth
-
-@ %def fibonacci_node_set_depth
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: append_left => fibonacci_node_append_left
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_append_left(this,new_branch)
- class(fibonacci_node_t),target :: this
- class(fibonacci_node_t),target :: new_branch
- this%left => new_branch
- new_branch%up => this
- end subroutine fibonacci_node_append_left
-
-@ %def fibonacci_node_append_left
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: append_right => fibonacci_node_append_right
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_append_right (this, new_branch)
- class(fibonacci_node_t), intent(inout), target :: this
- class(fibonacci_node_t), target :: new_branch
- this%right => new_branch
- new_branch%up => this
- end subroutine fibonacci_node_append_right
-
-@ %def fibonacci_node_append_right
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: replace => fibonacci_node_replace
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_replace (this, old_node)
- class(fibonacci_node_t), intent(inout), target :: this
- class(fibonacci_node_t), target :: old_node
- if (associated (old_node%up)) then
- if (old_node%is_left_child ()) then
- old_node%up%left => this
- else
- if (old_node%is_right_child ()) then
- old_node%up%right => this
- end if
- end if
- this%up => old_node%up
- else
- nullify (this%up)
- end if
- end subroutine fibonacci_node_replace
-
-@ %def fibonacci_node_replace
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: swap => fibonacci_node_swap_nodes
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_swap_nodes (left, right)
- class(fibonacci_node_t), target, intent(inout) :: left, right
- class(fibonacci_node_t), pointer :: left_left, right_right
- class(measure_class_t), pointer::down
- ! swap branches
- left_left => left%left
- right_right => right%right
- left%left => right%right
- right%right => left_left
- ! repair up components
- right_right%up => left
- left_left%up => right
- ! repair down components
- down => left%down
- left%down => right%down
- right%down => down
- end subroutine fibonacci_node_swap_nodes
-
-! subroutine fibonacci_node_swap_nodes (this, that)
-! class(fibonacci_node_t),target :: this
-! class(fibonacci_node_t), pointer, intent(in) :: that
-! class(fibonacci_node_t), pointer :: par_i, par_a
-! par_i => this%up
-! par_a => that%up
-! if (associated (par_i%left, this)) then
-! par_i%left => that
-! else
-! par_i%right => that
-! end if
-! if (associated (par_a%left, that)) then
-! par_a%left => this
-! else
-! par_a%right => this
-! end if
-! this%up => par_a
-! that%up => par_i
-! end subroutine fibonacci_node_swap_nodes
-
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: flip => fibonacci_node_flip_children
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_flip_children (this)
- class(fibonacci_node_t), intent(inout) :: this
- class(fibonacci_node_t), pointer :: child
- child => this%left
- this%left => this%right
- this%right => child
- end subroutine fibonacci_node_flip_children
-
-@ %def fibonacci_node_flip_children
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: rip => fibonacci_node_rip
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_rip (this)
- class(fibonacci_node_t), intent(inout), target :: this
- if (this%is_left_child ()) then
- nullify (this%up%left)
- end if
- if (this%is_right_child ()) then
- nullify (this%up%right)
- end if
- nullify (this%up)
- end subroutine fibonacci_node_rip
-
-@ %def fibonacci_node_rip
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: remove_and_keep_parent => fibonacci_node_remove_and_keep_parent
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_remove_and_keep_parent (this, pa)
- class(fibonacci_node_t), intent(inout), target :: this
- class(fibonacci_node_t), intent(out), pointer :: pa
- class(fibonacci_node_t), pointer :: twin
- if (.not. (this%is_root ())) then
- pa => this%up
- if (this%is_left_child ()) then
- twin => pa%right
- else
- twin => pa%left
- end if
- twin%up => pa%up
- if (associated (twin%left)) then
- twin%left%up => pa
- end if
- if (associated (twin%right)) then
- twin%right%up => pa
- end if
- call pa%copy_node (twin)
- select type (pa)
- class is (fibonacci_root_t)
- call pa%set_leftmost ()
- call pa%set_rightmost ()
- end select
- if (associated (this%right)) then
- this%right%left => this%left
- end if
- if (associated (this%left)) then
- this%left%right => this%right
- end if
- nullify (this%left)
- nullify (this%right)
- nullify (this%up)
- deallocate (twin)
- else
- pa => this
- end if
- end subroutine fibonacci_node_remove_and_keep_parent
-
-@ %def fibonacci_node_remove_and_keep_parent
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: remove_and_keep_twin => fibonacci_node_remove_and_keep_twin
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_remove_and_keep_twin (this, twin)
- class(fibonacci_node_t), intent(inout), target :: this
- class(fibonacci_node_t), intent(out), pointer :: twin
- class(fibonacci_node_t), pointer :: pa
- if (.not. (this%is_root ())) then
- pa => this%up
- if (.not. pa%is_root ()) then
- if (this%is_left_child ()) then
- twin => pa%right
- else
- twin => pa%left
- end if
- if (pa%is_left_child ()) then
- pa%up%left => twin
- else
- pa%up%right => twin
- end if
- end if
- twin%up => pa%up
- if (associated (this%right)) then
- this%right%left => this%left
- end if
- if (associated (this%left)) then
- this%left%right => this%right
- end if
- nullify (this%left)
- nullify (this%right)
- nullify (this%up)
- deallocate (pa)
- end if
- end subroutine fibonacci_node_remove_and_keep_twin
-
-@ %def fibonacci_node_remove_and_keep_twin
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: rotate_left => fibonacci_node_rotate_left
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_rotate_left (this)
- class(fibonacci_node_t), intent(inout), target :: this
- call this%swap (this%right)
- call this%right%flip ()
- call this%right%update_depth_unsave ()
- call this%flip ()
- ! value = this%value
- ! this%value = this%left%value
- ! this%left%value = value
- end subroutine fibonacci_node_rotate_left
-
-@ %def fibonacci_node_rotate_left
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: rotate_right => fibonacci_node_rotate_right
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_rotate_right (this)
- class(fibonacci_node_t), intent(inout), target :: this
- call this%left%swap (this)
- call this%left%flip ()
- call this%left%update_depth_unsave ()
- call this%flip ()
- ! value = this%value
- ! this%value = this%right%value
- ! this%right%value = value
- end subroutine fibonacci_node_rotate_right
-
-@ %def fibonacci_node_rotate_right
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: rotate => fibonacci_node_rotate
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_rotate (this)
- class(fibonacci_node_t), intent(inout), target :: this
- if (this%is_left_short ()) then
- call this%rotate_left ()
- else
- if (this%is_right_short ()) then
- call this%rotate_right ()
- end if
- end if
- end subroutine fibonacci_node_rotate
-
-@ %def fibonacci_node_rotate
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: balance_node => fibonacci_node_balance_node
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_balance_node (this, changed)
- class(fibonacci_node_t), intent(inout), target :: this
- logical, intent(out) :: changed
- changed = .false.
- if (this%is_left_too_short ()) then
- if (this%right%is_right_short ()) then
- call this%right%rotate_right
- end if
- call this%rotate_left ()
- changed = .true.
- else
- if (this%is_right_too_short ()) then
- if (this%left%is_left_short ()) then
- call this%left%rotate_left
- end if
- call this%rotate_right ()
- changed = .true.
- end if
- end if
- end subroutine fibonacci_node_balance_node
-
-@ %def fibonacci_node_balance_node
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: update_depth_save => fibonacci_node_update_depth_save
-@
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_update_depth_save (this, updated)
- class(fibonacci_node_t), intent(inout) :: this
- logical, intent(out) :: updated
- integer :: left, right, new_depth
- if (associated (this%left)) then
- left = this%left%depth + 1
- else
- left = -1
- end if
- if (associated (this%right)) then
- right = this%right%depth + 1
- else
- right = -1
- end if
- new_depth = max(left, right)
- if (this%depth == new_depth) then
- updated = .false.
- else
- this%depth = new_depth
- updated = .true.
- end if
- end subroutine fibonacci_node_update_depth_save
-
-@ %def fibonacci_node_update_depth_save
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: update_depth_unsave => fibonacci_node_update_depth_unsave
-@
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_update_depth_unsave (this)
- class(fibonacci_node_t), intent(inout) :: this
- this%depth = max (this%left%depth+1, this%right%depth+1)
- end subroutine fibonacci_node_update_depth_unsave
-
-@ %def fibonacci_node_update_depth_unsave
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: repair => fibonacci_node_repair
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_repair (this)
- class(fibonacci_node_t), intent(inout), target :: this
- class(fibonacci_node_t), pointer:: node
- logical :: new_depth, new_balance
- new_depth = .true.
- node => this
- do while ((new_depth .or. new_balance) .and. (associated (node)))
- call node%balance_node (new_balance)
- call node%update_depth_save (new_depth)
- node => node%up
- end do
- end subroutine fibonacci_node_repair
-
-@ %def fibonacci_node_repair
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: is_left_short => fibonacci_node_is_left_short
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_node_is_left_short(this)
- class(fibonacci_node_t), intent(in) :: this
- fibonacci_node_is_left_short = (this%left%depth < this%right%depth)
- end function fibonacci_node_is_left_short
-
-@ %def fibonacci_node_is_left_short
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: is_right_short => fibonacci_node_is_right_short
-@
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_node_is_right_short (this)
- class(fibonacci_node_t), intent(in) :: this
- fibonacci_node_is_right_short = (this%right%depth < this%left%depth)
- end function fibonacci_node_is_right_short
-
-@ %def fibonacci_node_is_right_short
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: is_unbalanced => fibonacci_node_is_unbalanced
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_node_is_unbalanced (this)
- class(fibonacci_node_t), intent(in) :: this
- fibonacci_node_is_unbalanced = &
- (this%is_left_short () .or. this%is_right_short ())
- end function fibonacci_node_is_unbalanced
-
-@ %def fibonacci_node_is_unbalanced
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: is_left_too_short => fibonacci_node_is_left_too_short
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_node_is_left_too_short (this)
- class(fibonacci_node_t), intent(in) :: this
- fibonacci_node_is_left_too_short = (this%left%depth+1 < this%right%depth)
- end function fibonacci_node_is_left_too_short
-
-@ %def fibonacci_node_is_left_too_short
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: is_right_too_short => fibonacci_node_is_right_too_short
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_node_is_right_too_short (this)
- class(fibonacci_node_t), intent(in) :: this
- fibonacci_node_is_right_too_short = (this%right%depth+1 < this%left%depth)
- end function fibonacci_node_is_right_too_short
-
-@ %def fibonacci_node_is_right_too_short
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: is_too_unbalanced => fibonacci_node_is_too_unbalanced
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_node_is_too_unbalanced (this)
- class(fibonacci_node_t), intent(in) :: this
- fibonacci_node_is_too_unbalanced = &
- (this%is_left_too_short() .or. this%is_right_too_short())
- end function fibonacci_node_is_too_unbalanced
-
-@ %def fibonacci_node_is_too_unbalanced
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: is_left_child => fibonacci_node_is_left_child
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_node_is_left_child (this)
- class(fibonacci_node_t), intent(in),target :: this
- fibonacci_node_is_left_child = associated (this%up%left, this)
- end function fibonacci_node_is_left_child
-
-@ %def fibonacci_node_is_left_child
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- procedure :: is_right_child => fibonacci_node_is_right_child
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_node_is_right_child (this)
- class(fibonacci_node_t), intent(in),target :: this
- fibonacci_node_is_right_child = associated (this%up%right, this)
- end function fibonacci_node_is_right_child
-
-@ %def fibonacci_node_is_right_child
-@
-<<Muli fibonacci: fibonacci node: TBP>>=
- ! user
- ! node
- ! tree
- ! procedure :: balance
- ! procedure :: sort
- ! procedure :: merge
- ! procedure :: split
-@
-<<Muli fibonacci: public>>=
- public :: fibonacci_leave_t
-<<Muli fibonacci: types>>=
- type, extends (fibonacci_node_t) :: fibonacci_leave_t
- ! class(measure_class_t), pointer :: content
- contains
- <<Muli fibonacci: fibonacci leave: TBP>>
- end type fibonacci_leave_t
-
-@ %def fibonacci_leave_t
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- ! procedure :: write_to_marker => fibonacci_leave_write_to_marker
- ! procedure :: read_from_marker => fibonacci_leave_read_from_marker
- procedure :: print_to_unit => fibonacci_leave_print_to_unit
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_print_to_unit &
- (this, unit, parents, components, peers)
- class(fibonacci_leave_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- class(ser_class_t), pointer :: ser
- if (parents > 0) call fibonacci_node_print_to_unit &
- (this, unit, parents-i_one, components, -i_one)
- write(unit, "(A)") "Components of fibonacci_leave_t:"
- ser => this%down
- call serialize_print_comp_pointer &
- (ser, unit, parents, components, peers, "Content:")
- end subroutine fibonacci_leave_print_to_unit
-
-@ %def fibonacci_leave_print_to_unit
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure, nopass :: get_type => fibonacci_leave_get_type
-<<Muli fibonacci: procedures>>=
- pure subroutine fibonacci_leave_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="fibonacci_leave_t")
- end subroutine fibonacci_leave_get_type
-
-@ %def fibonacci_leave_get_type
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: deallocate_all => fibonacci_leave_deallocate_all
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_deallocate_all (this)
- class(fibonacci_leave_t), intent(inout) :: this
- if (associated (this%down)) then
- deallocate (this%down)
- end if
- end subroutine fibonacci_leave_deallocate_all
-
-@ %def fibonacci_leave_deallocate_all
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: pick => fibonacci_leave_pick
-@
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_pick (this)
- class(fibonacci_leave_t), target, intent(inout) :: this
- class(fibonacci_node_t), pointer :: other
- class(fibonacci_root_t), pointer :: root
- ! call this%up%print_parents()
- call this%find_root (root)
- if (associated (this%up, root)) then
- if (this%up%depth < 2) then
- call msg_error ("fibonacci_leave_pick: Cannot pick leave. " // &
- "Tree must have at least three leaves.")
- else
- call this%remove_and_keep_parent (other)
- call other%repair ()
- end if
- else
- call this%remove_and_keep_twin (other)
- call other%up%repair ()
- end if
- if (associated (root%leftmost, this)) call root%set_leftmost ()
- if (associated (root%rightmost, this)) call root%set_rightmost ()
- end subroutine fibonacci_leave_pick
-
-@ %def fibonacci_leave_pick
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: get_left => fibonacci_leave_get_left
-@
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_get_left (this, leave)
- class(fibonacci_leave_t), intent(in) :: this
- class(fibonacci_leave_t), intent(out), pointer :: leave
- class(fibonacci_node_t), pointer :: node
- node => this%left
- select type (node)
- class is (fibonacci_leave_t)
- leave => node
- end select
- end subroutine fibonacci_leave_get_left
-
-@ %def fibonacci_leave_get_left
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: get_right => fibonacci_leave_get_right
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_get_right (this, leave)
- class(fibonacci_leave_t), intent(in) :: this
- class(fibonacci_leave_t), intent(out), pointer :: leave
- class(fibonacci_node_t), pointer :: node
- ! print *,"fibonacci_leave_get_right"
- ! call this%down%print_little
- if (associated (this%right)) then
- node => this%right
- ! call node%down%print_little
- select type (node)
- class is (fibonacci_leave_t)
- leave => node
- end select
- else
- ! print *,"no right leave"
- nullify (leave)
- end if
- end subroutine fibonacci_leave_get_right
-
-@ %def fibonacci_leave_get_right
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: write_pstricks => fibonacci_leave_write_pstricks
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_write_pstricks (this, unitnr)
- class(fibonacci_leave_t), intent(in), target :: this
- integer, intent(in) :: unitnr
- write (unitnr, "(A,I3,A,F9.3,A)") &
- "\begin{psTree}{\Toval[linecolor=green]{\node{", this%depth, "}{", &
- this%measure(), "}}}"
- if (associated (this%left)) then
- write (unitnr, "(A,A,A)") "\Tr[", le_kid, "]{}"
- end if
- if (associated (this%right)) then
- write (unitnr, "(A,A,A)") "\Tr[", le_kid, "]{}"
- end if
- write (unitnr, "(A)") "\end{psTree}"
- end subroutine fibonacci_leave_write_pstricks
-
-@ %def fibonacci_leave_write_pstricks
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: copy_content => fibonacci_leave_copy_content
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_copy_content (this, content)
- class(fibonacci_leave_t) :: this
- class(measure_class_t), intent(in) :: content
- allocate (this%down, source=content)
- end subroutine fibonacci_leave_copy_content
-
-@ %def fibonacci_leave_copy_content
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: set_content => fibonacci_leave_set_content
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_set_content (this, content)
- class(fibonacci_leave_t) :: this
- class(measure_class_t), target, intent(in) :: content
- this%down => content
- end subroutine fibonacci_leave_set_content
-
-@ %def fibonacci_leave_set_content
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: get_content => fibonacci_leave_get_content
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_get_content (this, content)
- class(fibonacci_leave_t), intent(in) :: this
- class(measure_class_t), pointer :: content
- content => this%down
- end subroutine fibonacci_leave_get_content
-
-@ %def fibonacci_leave_get_content
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure, nopass :: is_inner => fibonacci_leave_is_inner
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_leave_is_inner ()
- fibonacci_leave_is_inner = .false.
- end function fibonacci_leave_is_inner
-
-@ %def fibonacci_leave_is_inner
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure, nopass :: is_leave => fibonacci_leave_is_leave
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_leave_is_leave ()
- fibonacci_leave_is_leave = .true.
- end function fibonacci_leave_is_leave
-
-@ %def fibonacci_leave_is_leave
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: insert_leave_by_node => fibonacci_leave_insert_leave_by_node
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_insert_leave_by_node (this, new_leave)
- class(fibonacci_leave_t), target, intent(inout) :: this,new_leave
- class(fibonacci_node_t), pointer :: parent, new_node
- parent => this%up
- !print *, associated (this%left), associated (this%right)
- if (this < new_leave) then
- call fibonacci_node_spawn (new_node, this, new_leave, this%left, this%right)
- ! print *,"Repair! ",this%measure(),new_leave%measure()
- else
- call fibonacci_node_spawn (new_node, new_leave, this, this%left, this%right)
- end if
- if (associated (parent%left, this)) then
- call parent%append_left (new_node)
- else
- call parent%append_right (new_node)
- end if
- call parent%repair ()
- end subroutine fibonacci_leave_insert_leave_by_node
-
-@ %def fibonacci_leave_insert_leave_by_node
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: is_left_short => fibonacci_leave_is_left_short
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_leave_is_left_short (this)
- class(fibonacci_leave_t), intent(in) :: this
- fibonacci_leave_is_left_short = .false.
- end function fibonacci_leave_is_left_short
-
-@ %def fibonacci_leave_is_left_short
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: is_right_short => fibonacci_leave_is_right_short
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_leave_is_right_short (this)
- class(fibonacci_leave_t), intent(in) :: this
- fibonacci_leave_is_right_short = .false.
- end function fibonacci_leave_is_right_short
-
-@ %def fibonacci_leave_is_right_short
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: is_unbalanced => fibonacci_leave_is_unbalanced
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_leave_is_unbalanced (this)
- class(fibonacci_leave_t), intent(in) :: this
- fibonacci_leave_is_unbalanced = .false.
- end function fibonacci_leave_is_unbalanced
-
-@ %def fibonacci_leave_is_unbalanced
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: is_left_too_short => fibonacci_leave_is_left_too_short
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_leave_is_left_too_short (this)
- class(fibonacci_leave_t), intent(in) :: this
- fibonacci_leave_is_left_too_short = .false.
- end function fibonacci_leave_is_left_too_short
-
-@ %def fibonacci_leave_is_left_too_short
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: is_right_too_short => fibonacci_leave_is_right_too_short
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_leave_is_right_too_short (this)
- class(fibonacci_leave_t), intent(in) :: this
- fibonacci_leave_is_right_too_short = .false.
- end function fibonacci_leave_is_right_too_short
-
-@ %def fibonacci_leave_is_right_too_short
-@
-<<Muli fibonacci: fibonacci leave: TBP>>=
- procedure :: is_too_unbalanced => fibonacci_leave_is_too_unbalanced
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_leave_is_too_unbalanced (this)
- class(fibonacci_leave_t), intent(in) :: this
- fibonacci_leave_is_too_unbalanced = .false.
- end function fibonacci_leave_is_too_unbalanced
-
-@ %def fibonacci_leave_is_too_unbalanced
-@
-<<Muli fibonacci: public>>=
- public :: fibonacci_root_t
-<<Muli fibonacci: types>>=
- type, extends (fibonacci_node_t) :: fibonacci_root_t
- logical::is_valid_c=.false.
- class(fibonacci_leave_t),pointer :: leftmost => null()
- class(fibonacci_leave_t),pointer :: rightmost => null()
- contains
- <<Muli fibonacci: fibonacci root: TBP>>
- procedure :: is_left_child => fibonacci_root_is_left_child
- procedure :: is_right_child => fibonacci_root_is_right_child
- end type fibonacci_root_t
-
-@ %def fibonacci_root_t
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: write_to_marker => fibonacci_root_write_to_marker
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_write_to_marker (this, marker, status)
- class(fibonacci_root_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- ! call marker%mark_begin ("fibonacci_root_t")
- call fibonacci_node_write_to_marker (this, marker, status)
- ! marker%mark_end ("fibonacci_root_t")
- end subroutine fibonacci_root_write_to_marker
-
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: read_target_from_marker => fibonacci_root_read_target_from_marker
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_read_target_from_marker (this, marker, status)
- class(fibonacci_root_t), target, intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- ! call marker%pick_begin ("fibonacci_root_t", status)
- call fibonacci_node_read_from_marker (this, marker, status)
- call this%find_leftmost (this%leftmost)
- call this%find_rightmost (this%rightmost)
- ! call marker%pick_end ("fibonacci_root_t", status)
- end subroutine fibonacci_root_read_target_from_marker
-
-@ %def fibonacci_root_read_target_from_marker
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: print_to_unit => fibonacci_root_print_to_unit
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_print_to_unit (this, unit, parents, components, peers)
- class(fibonacci_root_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- class(ser_class_t), pointer :: ser
- if (parents > 0) call fibonacci_node_print_to_unit &
- (this, unit, parents-1, components, peers)
- write (unit, "(A)") "Components of fibonacci_root_t:"
- ser => this%leftmost
- call serialize_print_peer_pointer &
- (ser, unit, parents, components, min(peers, i_one), "Leftmost: ")
- ser => this%rightmost
- call serialize_print_peer_pointer &
- (ser, unit, parents, components, min(peers, i_one), "Rightmost:")
- end subroutine fibonacci_root_print_to_unit
-
-@ %def fibonacci_root_print_to_unit
-@
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_root_is_left_child (this)
- class(fibonacci_root_t),target, intent(in) :: this
- fibonacci_root_is_left_child = .false.
- end function fibonacci_root_is_left_child
-
-@ %def fibonacci_root_is_left_child
-@
-<<Muli fibonacci: procedures>>=
- elemental logical function fibonacci_root_is_right_child (this)
- class(fibonacci_root_t),target, intent(in) :: this
- fibonacci_root_is_right_child = .false.
- end function fibonacci_root_is_right_child
-
-@ %def fibonacci_root_is_right_child
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure, nopass :: get_type => fibonacci_root_get_type
-@
-<<Muli fibonacci: procedures>>=
- pure subroutine fibonacci_root_get_type (type)
- character(:),allocatable, intent(out) :: type
- allocate (type, source="fibonacci_root_t")
- end subroutine fibonacci_root_get_type
-
-@ %def fibonacci_root_get_type
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: get_leftmost=>fibonacci_root_get_leftmost
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_get_leftmost (this, leftmost)
- class(fibonacci_root_t), intent(in) :: this
- class(fibonacci_leave_t), pointer :: leftmost
- leftmost => this%leftmost
- end subroutine fibonacci_root_get_leftmost
-
-@ %def fibonacci_root_get_leftmost
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: get_rightmost=>fibonacci_root_get_rightmost
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_get_rightmost (this, rightmost)
- class(fibonacci_root_t), intent(in) :: this
- class(fibonacci_leave_t),pointer :: rightmost
- rightmost => this%rightmost
- end subroutine fibonacci_root_get_rightmost
-
-@ %def fibonacci_root_get_rightmost
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure, nopass :: is_root => fibonacci_root_is_root
-<<Muli fibonacci: procedures>>=
- elemental function fibonacci_root_is_root ()
- logical::fibonacci_root_is_root
- fibonacci_root_is_root = .true.
- end function fibonacci_root_is_root
-
-@ %def fibonacci_root_is_root
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure, nopass :: is_inner => fibonacci_root_is_inner
-<<Muli fibonacci: procedures>>=
- elemental function fibonacci_root_is_inner ()
- logical::fibonacci_root_is_inner
- fibonacci_root_is_inner = .false.
- end function fibonacci_root_is_inner
-
-@ %def fibonacci_root_is_inner
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: is_valid => fibonacci_root_is_valid
-<<Muli fibonacci: procedures>>=
- elemental function fibonacci_root_is_valid (this)
- class(fibonacci_root_t), intent(in) :: this
- logical :: fibonacci_root_is_valid
- fibonacci_root_is_valid = this%is_valid_c
- end function fibonacci_root_is_valid
-
-@ %def fibonacci_root_is_valid
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: count_leaves => fibonacci_root_count_leaves
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_count_leaves (this, n)
- class(fibonacci_root_t), intent(in) :: this
- integer, intent(out) :: n
- n = 0
- call fibonacci_node_count_leaves (this, n)
- end subroutine fibonacci_root_count_leaves
-
-@ %def fibonacci_root_count_leaves
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: write_pstricks => fibonacci_root_write_pstricks
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_write_pstricks (this, unitnr)
- class(fibonacci_root_t), intent(in), target :: this
- integer, intent(in) :: unitnr
- logical :: is_opened
- character :: is_sequential, is_formatted, is_writeable
- print *,"pstricks"
- inquire (unitnr, opened=is_opened, sequential=is_sequential, &
- formatted=is_formatted, write=is_writeable)
- if (is_opened) then
- if (is_sequential == "Y" .and. is_formatted == "Y " &
- .and. is_writeable == "Y") then
- ! write (unitnr, "(A,I3,A)") &
- ! "\begin{psTree}{\Toval[linecolor=blue]{$", int(this%depth), "$}}"
- write (unitnr, "(A,I3,A,F9.3,A)") &
- "\begin{psTree}{\Toval[linecolor=blue]{\node{", this%depth, &
- "}{", this%measure(), "}}}"
- if (associated (this%leftmost)) then
- call this%leftmost%write_pstricks (unitnr)
- else
- write (unitnr, "(A,A,A)") "\Tr[", no_kid, "]{}"
- end if
- if (associated (this%left)) then
- call this%left%write_pstricks (unitnr)
- else
- write (unitnr, "(A,A,A)") "\Tr[", no_kid, "]{}"
- end if
- if (associated (this%right)) then
- call this%right%write_pstricks (unitnr)
- else
- write (unitnr, "(A,A,A)") "\Tr[", no_kid, "]{}"
- end if
- if (associated (this%rightmost)) then
- call this%rightmost%write_pstricks (unitnr)
- else
- write(unitnr,'("\Tr[",a,"]{}")') no_kid
- end if
- write (unitnr, "(A)") "\end{psTree}"
- write (unitnr, "(A)") "\\"
- else
- write (*, "(A,I2,A)") &
- "fibonacci_node_write_pstricks: Unit ", unitnr, &
- " is not opened properly."
- write (*, "(A)") "No output is written to unit."
- end if
- else
- write (*, "(A,I2,A)") &
- "fibonacci_node_write_pstricks: Unit ", unitnr, &
- " is not opened."
- write (*, "(A)") "No output is written to unit."
- end if
- end subroutine fibonacci_root_write_pstricks
-
-@ %def fibonacci_root_write_pstricks
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: copy_root => fibonacci_root_copy_root
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_copy_root (this, primitive)
- class(fibonacci_root_t), intent(out) :: this
- class(fibonacci_root_t), intent(in) :: primitive
- call fibonacci_node_copy_node (this, primitive)
- this%leftmost => primitive%leftmost
- this%rightmost => primitive%rightmost
- end subroutine fibonacci_root_copy_root
-
-@ %def fibonacci_root_copy_root
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: push_by_content => fibonacci_root_push_by_content
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_push_by_content (this, content)
- class(fibonacci_root_t), target, intent(inout) :: this
- class(measure_class_t), target, intent(in) :: content
- class(fibonacci_leave_t), pointer :: node
- ! print *,"fibonacci_root_push_by_content: ",content%measure()
- allocate (node)
- node%down => content
- call this%push_by_leave (node)
- end subroutine fibonacci_root_push_by_content
-
-@ %def fibonacci_root_push_by_content
-@ This is a workaround for gfortran bug 44696. This subroutine is a
-merge of [[fibonacci_tree_push_by_node]], [[fibonacci_node_find]], and
-[[fibonacci_leave_insert_leave_by_node]].
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: push_by_leave => fibonacci_root_push_by_leave
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_push_by_leave (this, new_leave)
- class(fibonacci_root_t), target, intent(inout) :: this
- class(fibonacci_leave_t), pointer, intent(inout) :: new_leave
- class(fibonacci_leave_t), pointer :: old_leave
- class(fibonacci_node_t), pointer :: node, new_node, leave_c
- ! write (11, fmt=*) "push by leave(", new_leave%measure(), ")\\" !PSTRICKS
- ! flush(11) !PSTRICKS
- if (new_leave <= this%leftmost) then
- old_leave => this%leftmost
- this%leftmost => new_leave
- node => old_leave%up
- call fibonacci_node_spawn &
- (new_node, new_leave, old_leave, old_leave%left, old_leave%right)
- call node%append_left (new_node)
- else
- if (new_leave > this%rightmost) then
- old_leave => this%rightmost
- this%rightmost => new_leave
- node => old_leave%up
- call fibonacci_node_spawn &
- (new_node, old_leave, new_leave, old_leave%left, old_leave%right)
- call node%append_right (new_node)
- else
- node => this
- do
- if (new_leave <= node) then
- leave_c => node%left
- select type (leave_c)
- class is (fibonacci_leave_t)
- if (new_leave <= leave_c) then
- ! print *,"left left"
- call fibonacci_node_spawn (new_node, new_leave, &
- leave_c, leave_c%left, leave_c%right)
- else
- ! print *,"left right"
- call fibonacci_node_spawn (new_node, leave_c, &
- new_leave, leave_c%left, leave_c%right)
- end if
- call node%append_left (new_node)
- exit
- class default
- ! print *,"left"
- node => node%left
- end select
- else
- leave_c => node%right
- select type (leave_c)
- class is (fibonacci_leave_t)
- if (new_leave <= leave_c) then
- ! print *,"right left"
- call fibonacci_node_spawn (new_node, new_leave, &
- leave_c, leave_c%left, leave_c%right)
- else
- ! print *,"right right"
- call fibonacci_node_spawn (new_node, leave_c, &
- new_leave, leave_c%left, leave_c%right)
- end if
- call node%append_right (new_node)
- exit
- class default
- ! print *,"right"
- node => node%right
- end select
- end if
- end do
- end if
- end if
- ! call this%write_pstricks(11) ! PSTRICKS
- ! flush(11) ! PSTRICKS
- ! write(11,fmt=*)"repair\\" ! PSTRICKS
- call node%repair ()
- ! call this%write_pstricks (11) !PSTRICKS
- ! flush(11) !PSTRICKS
- ! call node%update_value (right_value)
- ! call this%write_pstricks (11)
- ! print *, new_node%value, new_node%left%value, new_node%right%value
- end subroutine fibonacci_root_push_by_leave
-
-@ %def fibonacci_root_push_by_leave
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: pop_left => fibonacci_root_pop_left
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_pop_left (this, leave)
- class(fibonacci_root_t), intent(inout), target :: this
- class(fibonacci_leave_t), pointer, intent(out) :: leave
- class(fibonacci_node_t), pointer :: parent, grand
- ! write (11,fmt=*) "fibonacci root pop left\\" ! PSTRICKS
- ! flush (11) ! PSTRICKS
- leave => this%leftmost
- if (this%left%depth >= 1) then
- parent => leave%up
- grand => parent%up
- grand%left => parent%right
- parent%right%up => grand
- deallocate (parent)
- parent => grand%left
- if (.not. parent%is_leave ()) then
- parent => parent%left
- end if
- select type (parent)
- class is (fibonacci_leave_t)
- this%leftmost => parent
- class default
- call parent%print_all()
- call msg_fatal ("fibonacci_root_pop_left: ERROR: leftmost is no leave.")
- end select
- ! call this%write_pstricks (11) ! PSTRICKS
- ! flush (11) ! PSTRICKS
- ! write (11,fmt=*) "fibonacci node repair\\" ! PSTRICKS
- ! flush (11) ! PSTRICKS
- call grand%repair ()
- else
- if (this%left%depth == 0 .and. this%right%depth == 1) then
- parent => this%right
- parent%right%up => this
- parent%left%up => this
- this%left => parent%left
- this%right => parent%right
- this%depth = 1
- deallocate (parent)
- parent => this%left
- select type (parent)
- class is (fibonacci_leave_t)
- this%leftmost => parent
- end select
- this%down => this%leftmost%down
- end if
- end if
- nullify (leave%right%left)
- nullify (leave%up)
- nullify (leave%right)
- nullify (this%leftmost%left)
- ! call this%write_pstricks (11) ! PSTRICKS
- ! flush (11) ! PSTRICKS
- end subroutine fibonacci_root_pop_left
-
-@ %def fibonacci_root_pop_left
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: pop_right => fibonacci_root_pop_right
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_pop_right (this, leave)
- class(fibonacci_root_t), intent(inout), target :: this
- class(fibonacci_leave_t), pointer, intent(out) :: leave
- class(fibonacci_node_t), pointer :: parent, grand
- leave => this%rightmost
- if (this%right%depth >= 1) then
- parent => leave%up
- grand => parent%up
- grand%right => parent%left
- parent%left%up => grand
- deallocate (parent)
- parent => grand%right
- if (.not. parent%is_leave ()) then
- parent => parent%right
- end if
- select type (parent)
- class is (fibonacci_leave_t)
- this%rightmost => parent
- class default
- call parent%print_all()
- call msg_fatal ("fibonacci_root_pop_left: ERROR: leftmost is no leave.")
- end select
- call grand%repair ()
- else
- if (this%right%depth == 0 .and. this%left%depth == 1) then
- parent => this%left
- parent%left%up => this
- parent%right%up => this
- this%right => parent%right
- this%left => parent%left
- this%depth = 1
- deallocate (parent)
- parent => this%right
- select type (parent)
- class is (fibonacci_leave_t)
- this%rightmost => parent
- end select
- this%down => this%rightmost%down
- end if
- end if
- end subroutine fibonacci_root_pop_right
-
-@ %def fibonacci_root_pop_right
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: list_to_tree => fibonacci_root_list_to_tree
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_list_to_tree (this, n_leaves, leave_list_target)
- class(fibonacci_root_t), target, intent(inout) :: this
- integer, intent(in) :: n_leaves
- type(fibonacci_leave_list_t), target, intent(in) :: leave_list_target
- ! class(fibonacci_root_t), pointer, intent(out) :: tree
- integer :: depth, n_deep, n_merge
- class(fibonacci_node_t), pointer :: node
- class(fibonacci_leave_list_t), pointer :: leave_list
- class(fibonacci_leave_t), pointer :: content
- real(default) :: up_value
- leave_list => leave_list_target
- call ilog2 (n_leaves, depth, n_deep)
- n_deep = n_deep * 2
- n_merge = 0
- this%depth = depth
- node => this
- OUTER: do
- do while (depth > 1)
- depth = depth - 1
- allocate (node%left)
- node%left%up => node
- node => node%left
- node%depth = depth
- end do
- node%left => leave_list%leave
- node%down => leave_list%leave%down
- leave_list => leave_list%next
- node%right => leave_list%leave
- content => leave_list%leave
- leave_list => leave_list%next
- n_merge = n_merge + 2
- INNER: do
- if (associated (node%up)) then
- if (node%is_left_child ()) then
- if (n_merge == n_deep .and. depth == 1) then
- node => node%up
- node%right => leave_list%leave
- node%right%up => node
- node%down => content%down
- content => leave_list%leave
- leave_list => leave_list%next
- n_merge = n_merge + 1
- cycle
- end if
- exit INNER
- else
- node => node%up
- depth = depth + 1
- end if
- else
- exit OUTER
- end if
- end do INNER
- node => node%up
- node%down => content%down
- allocate (node%right)
- node%right%up => node
- node => node%right
- if (n_deep == n_merge) then
- depth = depth - 1
- end if
- node%depth = depth
- end do OUTER
- call this%set_leftmost
- call this%set_rightmost
- end subroutine fibonacci_root_list_to_tree
-
-@ %def fibonacci_root_list_to_tree
-@ This subroutine has neither been used nor revised for a long time,
-so it might be broken.
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: merge => fibonacci_root_merge
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_merge(this_tree,that_tree,merge_tree)
- class(fibonacci_root_t), intent(in) :: this_tree
- class(fibonacci_root_t), intent(in) :: that_tree
- class(fibonacci_root_t), pointer, intent(out) :: merge_tree
- class(fibonacci_leave_t), pointer :: this_leave, that_leave, old_leave
- type(fibonacci_leave_list_t), target :: leave_list
- class(fibonacci_leave_list_t), pointer :: last_leave
- integer :: n_leaves
- if (associated (this_tree%leftmost) .and. associated (that_tree%leftmost)) then
- n_leaves = 1
- this_leave => this_tree%leftmost
- that_leave => that_tree%leftmost
- if (this_leave < that_leave) then
- allocate (leave_list%leave, source=this_leave)
- call this_leave%find_right_leave (this_leave)
- else
- allocate (leave_list%leave, source=that_leave)
- call that_leave%find_right_leave (that_leave)
- end if
- last_leave => leave_list
- do while (associated (this_leave) .and. associated (that_leave))
- if (this_leave < that_leave) then
- old_leave => this_leave
- call this_leave%find_right_leave (this_leave)
- else
- old_leave=>that_leave
- call that_leave%find_right_leave (that_leave)
- end if
- allocate (last_leave%next)
- last_leave => last_leave%next
- allocate (last_leave%leave, source=old_leave)
- n_leaves = n_leaves + 1
- end do
- if (associated (this_leave)) then
- old_leave => this_leave
- else
- old_leave => that_leave
- end if
- do while (associated (old_leave))
- allocate (last_leave%next)
- last_leave => last_leave%next
- allocate (last_leave%leave, source=old_leave)
- n_leaves = n_leaves + 1
- call old_leave%find_right_leave (old_leave)
- end do
- allocate (merge_tree)
- call merge_tree%list_to_tree (n_leaves, leave_list)
- else
- n_leaves = 0
- end if
- if (associated (leave_list%next)) then
- last_leave => leave_list%next
- do while (associated (last_leave%next))
- leave_list%next => last_leave%next
- deallocate (last_leave)
- last_leave => leave_list%next
- end do
- deallocate (last_leave)
- end if
- end subroutine fibonacci_root_merge
-
-@ %def fibonacci_root_merge
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: set_leftmost => fibonacci_root_set_leftmost
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_set_leftmost (this)
- class(fibonacci_root_t) :: this
- call this%find_leftmost (this%leftmost)
- end subroutine fibonacci_root_set_leftmost
-
-@ %def fibonacci_root_set_leftmost
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: set_rightmost => fibonacci_root_set_rightmost
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_set_rightmost (this)
- class(fibonacci_root_t) :: this
- call this%find_rightmost (this%rightmost)
- end subroutine fibonacci_root_set_rightmost
-
-@ %def fibonacci_root_set_rightmost
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: init_by_leave => fibonacci_root_init_by_leave
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_init_by_leave (this, left_leave, right_leave)
- class(fibonacci_root_t), target, intent(out) :: this
- class(fibonacci_leave_t), target, intent(in) :: left_leave, right_leave
- if (left_leave <= right_leave) then
- this%left => left_leave
- this%right => right_leave
- this%leftmost => left_leave
- this%rightmost => right_leave
- else
- this%left => right_leave
- this%right => left_leave
- this%leftmost => right_leave
- this%rightmost => left_leave
- end if
- this%left%up => this
- this%right%up => this
- this%down => this%leftmost%down
- this%depth = 1
- this%leftmost%right => this%rightmost
- this%rightmost%left => this%leftmost
- this%is_valid_c = .true.
- end subroutine fibonacci_root_init_by_leave
-
-@ %def fibonacci_root_init_by_leave
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: init_by_content => fibonacci_root_init_by_content
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_init_by_content (this, left_content, right_content)
- class(fibonacci_root_t), target, intent(out) :: this
- class(measure_class_t), intent(in), target :: left_content, right_content
- call this%reset ()
- print *, "fibonacci_root_init_by_content: ", left_content%measure (), &
- right_content%measure ()
- if (left_content < right_content) then
- call this%leftmost%set_content (left_content)
- call this%rightmost%set_content (right_content)
- else
- call this%leftmost%set_content (right_content)
- call this%rightmost%set_content (left_content)
- end if
- this%down => this%leftmost%down
- this%is_valid_c = .true.
- end subroutine fibonacci_root_init_by_content
-
-@ %def fibonacci_root_init_by_content
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: reset => fibonacci_root_reset
-@
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_root_reset (this)
- class(fibonacci_root_t), target, intent(inout) :: this
- call this%deallocate_tree ()
- allocate (this%leftmost)
- allocate (this%rightmost)
- this%depth = 1
- this%leftmost%depth = 0
- this%rightmost%depth = 0
- this%left => this%leftmost
- this%right => this%rightmost
- this%left%up => this
- this%right%up => this
- this%leftmost%right => this%rightmost
- this%rightmost%left => this%leftmost
- end subroutine fibonacci_root_reset
-
-@ %def fibonacci_root_reset
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: deallocate_tree => fibonacci_root_deallocate_tree
-<<Muli fibonacci: procedures>>=
- recursive subroutine fibonacci_root_deallocate_tree (this)
- class(fibonacci_root_t), intent(inout) :: this
- call this%deallocate_tree ()
- nullify (this%leftmost)
- nullify (this%rightmost)
- end subroutine fibonacci_root_deallocate_tree
-
-@ %def fibonacci_root_deallocate_tree
-@
-<<Muli fibonacci: fibonacci root: TBP>>=
- procedure :: deallocate_all => fibonacci_root_deallocate_all
-@
-<<Muli fibonacci: procedures>>=
- recursive subroutine fibonacci_root_deallocate_all (this)
- class(fibonacci_root_t), intent(inout) :: this
- call this%deallocate_all ()
- nullify (this%leftmost)
- nullify (this%rightmost)
- end subroutine fibonacci_root_deallocate_all
-
-@ %def fibonacci_root_deallocate_all
-@
-<<Muli fibonacci: types>>=
- ! class(serializable_ref_type), pointer :: ref_list
-@
-<<Muli fibonacci: types>>=
- type, extends (fibonacci_root_t) :: fibonacci_stub_t
- contains
- <<Muli fibonacci: fibonacci stub: TBP>>
- end type fibonacci_stub_t
-
-@ %def fibonacci_stub_t
-@
-<<Muli fibonacci: fibonacci stub: TBP>>=
- procedure :: write_to_marker => fibonacci_stub_write_to_marker
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_stub_write_to_marker (this, marker, status)
- class(fibonacci_stub_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- end subroutine fibonacci_stub_write_to_marker
-
-@ %def fibonacci_stub_write_to_marker
-@
-<<Muli fibonacci: fibonacci stub: TBP>>=
- procedure :: read_target_from_marker => fibonacci_stub_read_target_from_marker
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_stub_read_target_from_marker (this, marker, status)
- class(fibonacci_stub_t), target, intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- end subroutine fibonacci_stub_read_target_from_marker
-
-@ %def fibonacci_stub_read_target_from_marker
-@
-<<Muli fibonacci: fibonacci stub: TBP>>=
- ! procedure :: print_to_unit => fibonacci_stub_print_to_unit
-@
-<<Muli fibonacci: fibonacci stub: TBP>>=
- procedure, nopass :: get_type => fibonacci_stub_get_type
-@
-<<Muli fibonacci: procedures>>=
- pure subroutine fibonacci_stub_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="fibonacci_stub_t")
- end subroutine fibonacci_stub_get_type
-
-@ %def fibonacci_stub_get_type
-@
-<<Muli fibonacci: fibonacci stub: TBP>>=
- procedure :: push_by_content => fibonacci_stub_push_by_content
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_stub_push_by_content (this, content)
- class(fibonacci_stub_t), target, intent(inout) :: this
- class(measure_class_t), target, intent(in) :: content
- class(fibonacci_leave_t), pointer :: leave
- allocate (leave)
- call leave%set_content (content)
- call this%push_by_leave (leave)
- end subroutine fibonacci_stub_push_by_content
-
-@ %def fibonacci_stub_push_by_content
-@
-<<Muli fibonacci: fibonacci stub: TBP>>=
- procedure :: push_by_leave => fibonacci_stub_push_by_leave
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_stub_push_by_leave (this, new_leave)
- class(fibonacci_stub_t), target, intent(inout) :: this
- class(fibonacci_leave_t), pointer, intent(inout) :: new_leave
- class(fibonacci_leave_t), pointer :: old_leave
- if (this%depth < 1) then
- if (associated (this%leftmost)) then
- old_leave => this%leftmost
- call this%init_by_leave (old_leave, new_leave)
- else
- this%leftmost => new_leave
- end if
- else
- call fibonacci_root_push_by_leave (this, new_leave)
- end if
- end subroutine fibonacci_stub_push_by_leave
-
-@ %def fibonacci_stub_push_by_leave
-@
-<<Muli fibonacci: fibonacci stub: TBP>>=
- procedure :: pop_left => fibonacci_stub_pop_left
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_stub_pop_left (this, leave)
- class(fibonacci_stub_t), intent(inout), target :: this
- class(fibonacci_leave_t), pointer, intent(out) :: leave
- if (this%depth < 2) then
- if (this%depth == 1) then
- leave => this%leftmost
- this%leftmost => this%rightmost
- nullify (this%rightmost)
- nullify (this%right)
- nullify (this%left)
- this%depth = 0
- this%is_valid_c = .false.
- else
- if (associated (this%leftmost)) then
- leave => this%leftmost
- nullify (this%leftmost)
- end if
- end if
- else
- call fibonacci_root_pop_left (this, leave)
- end if
- end subroutine fibonacci_stub_pop_left
-
-@ %def fibonacci_stub_pop_left
-@
-<<Muli fibonacci: fibonacci stub: TBP>>=
- procedure :: pop_right => fibonacci_stub_pop_right
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_stub_pop_right (this, leave)
- class(fibonacci_stub_t), intent(inout), target :: this
- class(fibonacci_leave_t), pointer, intent(out) :: leave
- if (this%depth < 2) then
- if (this%depth == 1) then
- this%is_valid_c = .false.
- if (associated (this%rightmost)) then
- leave => this%rightmost
- nullify (this%rightmost)
- nullify (this%right)
- else
- if (associated (this%leftmost)) then
- leave => this%leftmost
- nullify (this%leftmost)
- nullify (this%left)
- else
- nullify (leave)
- end if
- end if
- end if
- else
- call fibonacci_root_pop_right (this, leave)
- end if
- end subroutine fibonacci_stub_pop_right
-
-@ %def fibonacci_stub_pop_right
-@
-<<Muli fibonacci: public>>=
- public :: fibonacci_leave_list_t
-<<Muli fibonacci: types>>=
- type fibonacci_leave_list_t
- class(fibonacci_leave_t), pointer :: leave => null()
- class(fibonacci_leave_list_t), pointer :: next => null()
- end type fibonacci_leave_list_t
-
-@ %def fibonacci_leave_list_t
-@
-<<Muli fibonacci: procedures>>=
-! subroutine fibonacci_node_update_value (this, right_value)
-! class(fibonacci_node_t), target :: this
-! class(fibonacci_node_t), pointer:: node
-! real(default), intent(in) :: right_value
-! if (associated (this%left) .and. associated (this%right)) then
-! node => this
-! ! node%value = node%left%value
-! ! right_value = node%right%value
-! INNER: do while (associated (node%up))
-! if (node%is_right_child ()) then
-! node => node%up
-! else
-! node%up%value = right_value
-! exit
-! end if
-! end do INNER
-! end if
-! end subroutine fibonacci_node_update_value
-
-@ %def fibonacci_node_update_value
-@
-<<Muli fibonacci: procedures>>=
-! subroutine fibonacci_root_copy_node (this, primitive)
-! class(fibonacci_root_t), intent(out) :: this
-! type(fibonacci_node_t), intent(in) :: primitive
-! call fibonacci_node_copy_node (this, primitive)
-! call primitive%find_leftmost (this%leftmost)
-! call primitive%find_rightmost (this%rightmost)
-! end subroutine fibonacci_root_copy_node
-
-@ %def fibonacci_root_copy_node
-@
-<<Muli fibonacci: procedures>>=
-! subroutine fibonacci_root_push_by_node (this, new_leave)
-! class(fibonacci_root_t), target, intent(inout) :: this
-! class(fibonacci_leave_t), pointer, intent(inout) :: new_leave
-! class(fibonacci_leave_t), pointer :: old_leave
-! if (new_leave <= this%leftmost) then
-! old_leave => this%leftmost
-! this%leftmost => new_leave
-! else
-! if (new_leave > this%rightmost) then
-! old_leave => this%rightmost
-! this%rightmost => new_leave
-! else
-! call this%find (new_leave%measure(), old_leave)
-! end if
-! end if
-! ! call old_leave%insert_leave_by_node (new_leave)
-! call fibonacci_leave_insert_leave_by_node (old_leave, new_leave)
-! call new_leave%up%repair ()
-! ! call new_leave%up%update_value ()
-! end subroutine fibonacci_root_push_by_node
-
-@ %def fibonacci_root_push_by_node
-@
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_write_content (this, unit)
- class(fibonacci_leave_t), intent(in), target :: this
- integer,optional, intent(in) :: unit
- call this%down%print_all (unit)
- end subroutine fibonacci_leave_write_content
-
-@ %def fibonacci_leave_write_content
-@
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_write (this, unit)
- class(fibonacci_leave_t), intent(in), target :: this
- integer,optional, intent(in) :: unit
- call this%print_all (unit)
- end subroutine fibonacci_leave_write
-
-@ %def fibonacci_leave_write
-@
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_leave_write_value (this, unit)
- class(fibonacci_leave_t), intent(in), target :: this
- integer, intent(in), optional :: unit
- if (present (unit)) then
- write(unit, fmt=*) this%measure ()
- else
- print *, this%measure ()
- end if
- ! call this%print_little (unit)
- end subroutine fibonacci_leave_write_value
-
-@ %def fibonacci_leave_write_value
-@
-<<Muli fibonacci: procedures>>=
- subroutine fibonacci_node_spawn (new_node, left_leave, right_leave, &
- left_left_leave, right_right_leave)
- class(fibonacci_node_t), pointer, intent(out) :: new_node
- class(fibonacci_leave_t), target, intent(inout) :: left_leave, right_leave
- class(fibonacci_node_t), pointer, intent(inout) :: left_left_leave, &
- right_right_leave
- allocate (new_node)
- new_node%depth = 1
- if (associated (left_left_leave)) then
- left_left_leave%right => left_leave
- left_leave%left => left_left_leave
- else
- nullify (left_leave%left)
- end if
- if (associated (right_right_leave)) then
- right_right_leave%left => right_leave
- right_leave%right => right_right_leave
- else
- nullify (right_leave%right)
- end if
- new_node%left => left_leave
- new_node%right => right_leave
- new_node%down => left_leave%down
- new_node%depth = 1
- left_leave%up => new_node
- right_leave%up => new_node
- left_leave%right => right_leave
- right_leave%left => left_leave
- end subroutine fibonacci_node_spawn
-
-@ %def fibonacci_node_spawn
-@
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Adaptive Quadrature}
-
-This file contains the module [[muli_aq]] which is an acronym for
-adaptive quadrature. The abstract type [[aq_class]] is extended
-and the deferred procedure [[evaluate]] is defined. [[muli_aq]] calls
-[[evaluate]] to evaluate the integrand at any point in the given
-range. We have tried to use a procedure pointer instead of the
-deferred type-bound procedure, but no compiler was able to handle
-procedure pointers plus cuba was not able to handle parameters, to wit
-dimensions of the integrand that should not get integrated. So we
-switched to this odd way of using inheritance. Meanwhile these
-problems got solved and we could go for a more straightforward
-solution, but it works fine as it is.
-
-[[aq_class]] uses [[muli_trapezium]] to approximate the integral. It
-still has to do the subdivision of segments and has to check whether
-the precision goal is reached.
-
-Finally, the result is written do disc using the serialization framework
-defined in [[muli_base]]. Since QCD is not expected to change frequently,
-the only reason to regenerate this function is a change of the used PDF set.
-Then you can read the integral from disc each time you run a simulation with
-the same PDF set.
-
-<<[[muli_aq.f90]]>>=
-<<File header>>
-
-module muli_aq
-
-<<Use kinds>>
- use constants
- use diagnostics
- use muli_base
- use muli_cuba
- use muli_trapezium
- use muli_fibonacci_tree
-
-<<Standard module head>>
-
-<<Muli aq: public>>
-
-<<Muli aq: types>>
-
-<<Muli aq: interfaces>>
-
-contains
-
-<<Muli aq: procedures>>
-
-end module muli_aq
-
-@ %def muli_aq
-@ The variables [[error_goal]], [[err_tree]] and [[int_list]] must be
-initialised before the main loop can be called. Additionaly, the nodes
-and segments should be preprocessed by [[first_run]] before the main
-loop is called.
-<<Muli aq: public>>=
- public :: aq_class
-<<Muli aq: types>>=
- type, extends (identified_t), abstract :: aq_class
- logical :: is_deferred_initialised = .false.
- logical :: is_error_tree_initialised = .false.
- logical :: is_goal_set = .false.
- logical :: is_initialised = .false.
- logical :: is_run = .false.
- logical :: is_goal_reached = .false.
- logical :: is_integrated = .false.
- integer(dik) :: n_nodes = 0
- integer(dik) :: max_nodes = 10000
- integer :: dim_integral = 1
- real(default) :: abs_error_goal = 0._default
- real(default) :: rel_error_goal = 0.1_default
- real(default) :: scaled_error_goal = 0._default
- real(default) :: integral = 1._default
- real(default) :: integral_error = 0._default
- real(default), dimension(2) :: region = [0._default, 1._default]
- real(default), dimension(:,:), allocatable :: convergence
- real(default) :: total_time = 0
- real(default) :: loop_time = 0
- real(default) :: int_time = 0
- real(default) :: cuba_time = 0
- real(default) :: init_time = 0
- real(default) :: cpu_time = 0
- real(default) :: error_goal = 0._default
- class(fibonacci_root_t), pointer :: err_tree => null()
- class(muli_trapezium_list_t), pointer :: int_list => null()
- contains
- <<Muli aq: aq class: TBP>>
- end type aq_class
-
-@ %def aq_class
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: basic_write_to_marker => aq_write_to_marker
- procedure :: write_to_marker => aq_write_to_marker
-<<Muli aq: procedures>>=
- subroutine aq_write_to_marker (this, marker, status)
- class(aq_class), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- class(ser_class_t), pointer :: ser
- call marker%mark_begin ("aq_class")
- call this%base_write_to_marker (marker, status)
- call marker%mark ("is_deferred_initialised", &
- this%is_deferred_initialised)
- call marker%mark ("is_error_tree_initialised", &
- this%is_error_tree_initialised)
- call marker%mark ("is_goal_set", this%is_goal_set)
- call marker%mark ("is_initialised", this%is_initialised)
- call marker%mark ("is_run", this%is_run)
- call marker%mark ("is_goal_reached", this%is_goal_reached)
- call marker%mark ("is_integrated", this%is_integrated)
- call marker%mark ("n_nodes", this%n_nodes)
- call marker%mark ("max_nodes", this%max_nodes)
- call marker%mark ("dim_integral", this%dim_integral)
- call marker%mark ("abs_error_goal", this%abs_error_goal)
- call marker%mark ("rel_error_goal", this%rel_error_goal)
- call marker%mark ("scaled_error_goal", this%scaled_error_goal)
- call marker%mark ("error_goal", this%error_goal)
- call marker%mark ("integral", this%integral)
- call marker%mark ("integral_error", this%integral_error)
- call marker%mark ("region", this%region(1:2))
- ser => this%err_tree
- call marker%mark_pointer ("err_tree", ser)
- ser => this%int_list
- call marker%mark_pointer ("int_list", ser)
- call marker%mark_end ("aq_class")
- end subroutine aq_write_to_marker
-
-@ %def aq_write_to_marker
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: basic_read_from_marker => aq_read_from_marker
- procedure :: read_from_marker => aq_read_from_marker
-<<Muli aq: procedures>>=
- subroutine aq_read_from_marker (this, marker, status)
- class(aq_class), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- class(ser_class_t), pointer :: ser
- call marker%pick_begin ("aq_class", status=status)
- call this%base_read_from_marker (marker, status)
- call marker%pick ("is_deferred_initialised", &
- this%is_deferred_initialised, status)
- call marker%pick ("is_error_tree_initialised", &
- this%is_error_tree_initialised, status)
- call marker%pick ("is_goal_set", this%is_goal_set, status)
- call marker%pick ("is_initialised", this%is_initialised, status)
- call marker%pick ("is_run", this%is_run, status)
- call marker%pick ("is_goal_reached", this%is_goal_reached, status)
- call marker%pick ("is_integrated", this%is_integrated, status)
- call marker%pick ("n_nodes", this%n_nodes, status)
- call marker%pick ("max_nodes", this%max_nodes, status)
- call marker%pick ("dim_integral", this%dim_integral, status)
- call marker%pick ("abs_error_goal", this%abs_error_goal, status)
- call marker%pick ("rel_error_goal", this%rel_error_goal, status)
- call marker%pick ("scaled_error_goal", this%scaled_error_goal, status)
- call marker%pick ("error_goal", this%error_goal, status)
- call marker%pick ("integral", this%integral, status)
- call marker%pick ("integral_error", this%integral_error, status)
- call marker%pick ("region", this%region(1:2), status)
- call marker%pick_pointer ("err_tree", ser)
- if (associated (ser)) then
- select type (ser)
- class is (fibonacci_root_t)
- this%err_tree => ser
- class default
- nullify (this%err_tree)
- end select
- end if
- call marker%pick_pointer ("int_list", ser)
- if (associated (ser)) then
- select type (ser)
- class is (muli_trapezium_list_t)
- this%int_list => ser
- class default
- nullify (this%int_list)
- end select
- end if
- call marker%pick_end ("aq_class", status)
- end subroutine aq_read_from_marker
-
-@ %def aq_read_from_marker
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: basic_print_to_unit => aq_print_to_unit
- procedure :: print_to_unit => aq_print_to_unit
-<<Muli aq: procedures>>=
- subroutine aq_print_to_unit (this, unit, parents, components, peers)
- class(aq_class), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- integer :: ite
- class(ser_class_t), pointer :: ser
- if (parents > 0) call this%base_print_to_unit &
- (unit, parents-1, components, peers)
- write (unit, "(A)") "Components of aq_class"
- write (unit, "(A,L1)") "Deferred class initialised: ", &
- this%is_deferred_initialised
- write (unit, "(A,L1)") "Error tree initialised: ", &
- this%is_error_tree_initialised
- write (unit, "(A,L1)") "Accuracy goal set: ", this%is_goal_set
- write (unit, "(A,L1)") "Ready for run: ", this%is_initialised
- write (unit, "(A,L1)") "Is run: ", this%is_run
- write (unit, "(A,L1)") "Accuracy goal reached: ", this%is_goal_reached
- write (unit, "(A,L1)") "Integral calculated: ", this%is_integrated
- write (unit, "(A,I10)") "Number of nodes: ", this%n_nodes
- write (unit, "(A,I10)") "Maximal number of nodes: ", this%max_nodes
- write (unit, "(A,I10)") "Dimension of integral: ", this%dim_integral
- write (unit, "(A,E20.10)") "Given abs. error goal: ", this%abs_error_goal
- write (unit, "(A,E20.10)") "Given rel. error goal: ", this%rel_error_goal
- write (unit, "(A,E20.10)") "Guessed abs error goal:", this%scaled_error_goal
- write (unit, "(A,E20.10)") "Actual abs error goal: ", this%error_goal
- write (unit, "(A,E20.10)") "Integral ", this%integral
- write (unit, "(A,E20.10)") "Estimated abs. error: ", this%integral_error
- ! if (this%integral == 0) then
- ! write (unit, "(A,E20.10)") "Estimated rel. error: ", &
- ! this%integral_error / this%integral
- ! else
- ! write (unit, "(A,E20.10)") "Estimated rel. error: INF"
- ! end if
- write (unit, "(A,E10.5,A,E10.5,A)") "Integration region = (", &
- this%region(1), " : ", this%region(2), ")"
- ser => this%err_tree
- call serialize_print_comp_pointer &
- (ser, unit, parents, components, peers, "error tree")
- ser => this%int_list
- call serialize_print_comp_pointer &
- (ser, unit, parents, components, peers, "integral list")
- end subroutine aq_print_to_unit
-
-@ %def aq_print_to_unit
-@
-<<Muli aq: aq class: TBP>>=
- procedure, nopass :: get_type => aq_get_type
-<<Muli aq: procedures>>=
- pure subroutine aq_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="aq_type")
- end subroutine aq_get_type
-
-@ %def aq_get_type
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: deserialize_from_marker => aq_deserialize_from_marker
-<<Muli aq: procedures>>=
- subroutine aq_deserialize_from_marker (this, name, marker)
- class(aq_class), intent(out) :: this
- character(*), intent(in) :: name
- class(marker_t), intent(inout) :: marker
- class(ser_class_t), pointer :: ser
- allocate (muli_trapezium_t :: ser)
- call marker%push_reference (ser)
- allocate (fibonacci_root_t :: ser)
- call marker%push_reference (ser)
- allocate (fibonacci_leave_t :: ser)
- call marker%push_reference (ser)
- allocate (fibonacci_node_t :: ser)
- call marker%push_reference (ser)
- call serializable_deserialize_from_marker (this, name, marker)
- call marker%pop_reference (ser)
- deallocate (ser)
- call marker%pop_reference (ser)
- deallocate (ser)
- call marker%pop_reference (ser)
- deallocate (ser)
- call marker%pop_reference (ser)
- deallocate (ser)
- end subroutine aq_deserialize_from_marker
-
-@ %def aq_deserialize_from_marker
-@ The relative error goal is supposed to be $10^{-4}$.
-<<Muli aq: aq class: TBP>>=
- generic :: initialize => aq_initialize
- procedure :: aq_initialize
-<<Muli aq: procedures>>=
- subroutine aq_initialize (this, id, name, goal, max_nodes, dim, init)
- class(aq_class), intent(out) :: this
- integer(dik), intent(in) :: id, max_nodes
- integer, intent(in) :: dim
- character, intent(in) :: name
- real(default) :: goal
- real(default), dimension(:), intent(in) :: init
- call this%initialize (id, name)
- this%rel_error_goal = goal
- this%max_nodes = max_nodes
- call this%init_error_tree (dim, init)
- end subroutine aq_initialize
-
-@ %def aq_initialize
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: print_times => aq_print_times
-<<Muli aq: procedures>>=
- subroutine aq_print_times (this)
- class(aq_class), intent(in) :: this
- write (*, "(A,E20.10)") "Initialization time: ", this%init_time
- write (*, "(A,E20.10)") "Main loop time: ", this%loop_time
- write (*, "(A,E20.10)") "Integration time: ", this%int_time
- write (*, "(A,E20.10)") "Overall run time: ", this%total_time
- write (*, "(A,E20.10)") "Cuba integration time:", this%cuba_time
- end subroutine aq_print_times
-
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: write_convergence => aq_write_convergence
-<<Muli aq: procedures>>=
- subroutine aq_write_convergence (this, unit)
- class(aq_class), intent(in) :: this
- integer, intent(in) :: unit
- integer, dimension(2) :: s
- integer :: node
- if (allocated (this%convergence)) then
- s = shape (this%convergence)
- do node = 1, s(2)
- write (unit, *) node, this%convergence (1:2, node)
- end do
- end if
- end subroutine aq_write_convergence
-
-@ %def aq_write_convergence
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: reset => aq_reset
-<<Muli aq: procedures>>=
- subroutine aq_reset (this)
- class(aq_class) :: this
- this%is_deferred_initialised = .false.
- this%is_error_tree_initialised = .false.
- this%is_goal_set = .false.
- this%is_initialised = .false.
- this%is_run = .false.
- this%is_goal_reached = .false.
- this%is_integrated = .false.
- this%n_nodes = 0
- this%max_nodes = 10000
- this%dim_integral = 1
- this%abs_error_goal = 1._default
- this%rel_error_goal = 0.1_default
- this%scaled_error_goal = 0.0_default
- this%error_goal = 0.0_default
- this%integral = 0.0_default
- this%integral_error = 0.0_default
- this%region = [ 0.0_default, 1._default ]
- this%total_time = 0
- this%loop_time = 0
- this%int_time = 0
- this%init_time = 0
- call this%dealloc_trees ()
- end subroutine aq_reset
-
-@ %def aq_reset
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: dealloc_trees => aq_dealloc_trees
- procedure :: finalize => aq_dealloc_trees
-<<Muli aq: procedures>>=
- subroutine aq_dealloc_trees (this)
- class(aq_class) :: this
- if (associated (this%err_tree)) then
- call this%err_tree%deallocate_all ()
- deallocate (this%err_tree)
- end if
- if (associated (this%int_list)) then
- call this%int_list%finalize ()
- deallocate (this%int_list)
- end if
- end subroutine aq_dealloc_trees
-
-@ %def aq_dealloc_trees
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: init_error_tree => aq_init_error_tree
-<<Muli aq: procedures>>=
- subroutine aq_init_error_tree (this, dim_integral, x_array)
- class(aq_class) :: this
- integer, intent(in) :: dim_integral
- real(default), dimension(:), intent(in) :: x_array
- real(default) :: center
- real(default), dimension(:), allocatable :: l_val, c_val, r_val
- class(muli_trapezium_t), pointer :: left_node => null()
- class(muli_trapezium_t), pointer :: right_node => null()
- integer :: x_size, pos
- ! print '("Entermarker aq_init_error_tree...")'
- call cpu_time (this%init_time)
- this%is_initialised = .false.
- this%integral = 0._default
- this%dim_integral = dim_integral
- x_size = size(x_array)
- if (x_size < 2) then
- call msg_error ("aq_init_error_tree: I need at least two real values")
- else
- allocate (l_val (0:dim_integral-1))
- allocate (c_val (0:dim_integral-1))
- allocate (r_val (0:dim_integral-1))
- this%region = [x_array(1), x_array(x_size)]
- if (x_size < 3) then
- center = (x_array(2) - x_array(1)) / 2._default
- call this%evaluate (x_array(1), l_val)
- call this%evaluate (center, c_val)
- call this%evaluate (x_array(2), r_val)
- allocate (left_node)
- call left_node%initialize (dim=dim_integral, &
- r_position=center, d_position=center-x_array(1))
- call left_node%set_r_value (c_val)
- call left_node%set_d_value (c_val - l_val)
- allocate (right_node)
- call right_node%initialize (dim=dim_integral, &
- r_position=x_array(2), d_position=x_array(2)-center)
- call right_node%set_r_value (r_val)
- call right_node%set_d_value (r_val - c_val)
- else
- call this%evaluate (x_array(1), l_val)
- call this%evaluate (x_array(2), c_val)
- call this%evaluate (x_array(3), r_val)
- allocate (left_node)
- call left_node%initialize (dim=dim_integral, &
- r_position=x_array(2), d_position=x_array(2)-x_array(1))
- call left_node%set_r_value (c_val)
- call left_node%set_d_value (c_val - l_val)
- allocate (right_node)
- call right_node%initialize (dim=dim_integral, &
- r_position=x_array(3), d_position=x_array(3)-x_array(2))
- call right_node%set_r_value (r_val)
- call right_node%set_d_value (r_val - c_val)
- end if
- call left_node%update ()
- call right_node%update ()
- this%integral = sum (left_node%get_d_integral () + &
- right_node%get_d_integral ())
- if (.not. associated (this%err_tree)) then
- allocate(this%err_tree)
- end if
- print *, left_node%measure ()
- print *, right_node%measure ()
- call this%err_tree%init_by_content (left_node, right_node)
- ! call this%err_tree%write_pstricks (11)
- if (x_size > 3) then
- do pos = 4, x_size
- print *, "aq_init_error_tree", pos, "/", x_size
- l_val = right_node%get_r_value_array ()
- call this%evaluate (x_array(pos), r_val)
- c_val = r_val - l_val
- allocate (right_node)
- call right_node%initialize (dim=dim_integral, &
- r_position=x_array(pos), &
- d_position=x_array(pos)-x_array(pos-1))
- call right_node%set_r_value (r_val)
- call right_node%set_d_value (c_val)
- call right_node%update ()
- call this%err_tree%push_by_content (right_node)
- ! call this%err_tree%write_pstricks (11)
- this%integral = this%integral + sum (right_node%get_d_integral())
- end do
- this%n_nodes = x_size
- end if
- this%is_error_tree_initialised = .true.
- end if
- call this%set_goal ()
- this%is_initialised = .true.
- call cpu_time (this%cpu_time)
- this%init_time = this%cpu_time - this%init_time
- this%cuba_time = this%init_time
- allocate (this%convergence (2, this%n_nodes:this%max_nodes))
- end subroutine aq_init_error_tree
-
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: set_rel_goal => aq_set_rel_goal
-<<Muli aq: procedures>>=
- subroutine aq_set_rel_goal (this, goal)
- class(aq_class) :: this
- real(default) :: goal
- this%rel_error_goal = goal
- call this%set_goal
- end subroutine aq_set_rel_goal
-
-@ %def aq_set_rel_goal
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: set_abs_goal => aq_set_abs_goal
-<<Muli aq: procedures>>=
- subroutine aq_set_abs_goal (this, goal)
- class(aq_class) :: this
- real(default) :: goal
- this%abs_error_goal = goal
- call this%set_goal
- end subroutine aq_set_abs_goal
-
-@ %def aq_set_abs_goal
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: set_goal => aq_set_goal
-<<Muli aq: procedures>>=
- subroutine aq_set_goal (this)
- class(aq_class) :: this
- this%scaled_error_goal = this%rel_error_goal * abs(this%integral)
- if ((this%scaled_error_goal == zero) .and. &
- (this%abs_error_goal == zero)) then
- this%is_goal_set = .false.
- this%error_goal = zero
- else
- if (this%scaled_error_goal == zero) then
- this%error_goal = this%abs_error_goal
- else
- if (this%abs_error_goal == zero) then
- this%error_goal = this%scaled_error_goal
- else
- this%error_goal = max(this%scaled_error_goal, &
- this%abs_error_goal)
- end if
- end if
- if (this%error_goal > zero) then
- this%is_goal_set = .true.
- else
- this%is_goal_set = .false.
- end if
- end if
- end subroutine aq_set_goal
-
-@ %def aq_set_goal
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: check_init => aq_check_init
-<<Muli aq: procedures>>=
- subroutine aq_check_init (this)
- class(aq_class) :: this
- this%is_initialised = this%is_error_tree_initialised .and. &
- this%is_deferred_initialised
- end subroutine aq_check_init
-
-@ %def aq_check_init
-@ This routine is unsafe, when [[n_nodes]] $< 4$.
-<<Muli aq: aq class: TBP>>=
- procedure :: main_loop => aq_main_loop
-<<Muli aq: procedures>>=
- subroutine aq_main_loop (this)
- class(aq_class) :: this
- class(fibonacci_leave_t), pointer :: rightmost
- class(measure_class_t), pointer :: content
- class(muli_trapezium_t), pointer :: new_node !,debug
- logical :: limit = .false.
- real(default) :: center
- real(default), dimension(:), allocatable :: c_val
- allocate (c_val (0:this%dim_integral-1))
- LOOP: do
- call this%err_tree%pop_right (rightmost)
- if (rightmost < this%error_goal / this%n_nodes) then
- this%is_goal_reached = .true.
- exit LOOP
- else
- call rightmost%get_content (content)
- select type (content)
- class is (muli_trapezium_t)
- write (*, "(A,I5,A,E14.7,A,E14.7,A,E14.7,A,E14.7)") &
- "nodes: ", this%n_nodes, " error: ", &
- rightmost%measure() * this%n_nodes, &
- " goal: ", this%error_goal, " node at: ", &
- content%get_l_position(), "-", content%get_r_position()
- this%convergence (1, this%n_nodes) = this%error_goal / this%n_nodes
- this%convergence (2, this%n_nodes) = rightmost%measure ()
- center = content%get_r_position () - &
- content%get_d_position () / two
- call cpu_time (this%cpu_time)
- this%cuba_time = this%cuba_time - this%cpu_time
- call this%evaluate (center, c_val)
- call cpu_time (this%cpu_time)
- this%cuba_time = this%cuba_time + this%cpu_time
- call content%split (c_val, center, new_node)
- call this%err_tree%push_by_leave (rightmost)
- call this%err_tree%push_by_content (new_node)
- end select
- this%n_nodes = this%n_nodes + 1
- if (this%n_nodes > this%max_nodes) then
- limit = .true.
- exit LOOP
- end if
- end if
- end do LOOP
- call this%err_tree%push_by_leave (rightmost)
- end subroutine aq_main_loop
-
-@ %def aq_main_loop
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: run => aq_run
-<<Muli aq: procedures>>=
- subroutine aq_run (this)
- class(aq_class) :: this
- call cpu_time (this%total_time)
- if (.not. this%is_error_tree_initialised) then
- call this%init_error_tree (this%dim_integral, this%region)
- end if
- this%is_run = .false.
- this%is_goal_reached = .false.
- call this%main_loop ()
- this%is_run = .true.
- call cpu_time (this%cpu_time)
- this%total_time = this%cpu_time - this%total_time
- end subroutine aq_run
-
-@ %def aq_run
-@
-<<Muli aq: aq class: TBP>>=
- procedure :: integrate => aq_integrate
-<<Muli aq: procedures>>=
- subroutine aq_integrate (this, int_tree)
- class(aq_class) :: this
- class(muli_trapezium_node_class_t), pointer :: node
- type(muli_trapezium_tree_t), intent(out) :: int_tree
- real(default) :: sum
- this%is_integrated = .false.
- this%integral_error = zero
- if (this%is_run) then
- call cpu_time (this%int_time)
- call fibonacci_tree_resort_and_convert_to_trapezium_list &
- (this%err_tree, this%int_list)
- ! call this%int_list%print_all ()
- call this%int_list%integrate (this%integral, this%integral_error)
- call this%int_list%to_tree (int_tree)
- this%is_integrated = .true.
- call cpu_time (this%cpu_time)
- this%int_time = this%cpu_time - this%int_time
- end if
- end subroutine aq_integrate
-
-@ %def aq_integrate
-@
-<<Muli aq: aq class: TBP>>=
- procedure(evaluate_if), deferred :: evaluate
- ! procedure(evaluate_ratios_if), deferred :: evaluate_ratios
-<<Muli aq: procedures>>=
-@ Usually, the tree is sorted by the sum of errors. Now it shall be
-sorted by the right position. When at least one branch of the tree is
-itself a tree, i.e. each branch has got at least two leaves, then
-process each branch and merge the results. Now we got two sorted
-lists. Which one's leftmost node has got the lowest value of
-[[r_position]]? That one shall be the beginning of the merged list
-[[lin_list]]. Everything is prepared for the algorithm: [[lin_list]]
-is the beginning of the sorted list, [[last_node]] is its
-end. [[left_node]] and [[right_node]] are the leftmost nodes of the
-remainders of [[left_list]] and [[right_list]]. The latter will get
-stripped from left to right, until one of them ends. Then, either
-[[left_list]] or [[right_list]] is completely merged into
-[[lin_list]]. The other one gets appended to [[lin_list]]. In the
-second part of the big if clause, the tree has got two leaves at
-most. Is it more than one? There, [[fib_tree]] is a single leave with
-an allocated "[[content]]" component of type [[muli_trapezium_t]]. If
-"[[content]]" is not type-compatible with [[muli_trapezium_t]], then
-this whole conversion cannot succeed. We allocate a new node of type
-[[muli_trapezium_list_t]]. This list does not contain the content of
-[[fib_tree]], it {\em is} a copy of the content, for
-[[muli_trapezium_list_t]] is an extension of [[muli_trapezium_t]]. In
-the next step, each branch of [[fib_tree]] is a single leave. We could
-call this soubroutine for each branch, but we do copy and paste for
-each branch instead. Finally we append one list to the other, the
-lowest value of [[r_position]] comes first.
-<<Muli aq: procedures>>=
- recursive subroutine fibonacci_tree_resort_and_convert_to_trapezium_list &
- (fib_tree, lin_list)
- class(fibonacci_node_t), intent(in) :: fib_tree
- class(fibonacci_node_t),pointer :: leave
- class(muli_trapezium_list_t), pointer, intent(out) :: lin_list
- class(muli_trapezium_list_t), pointer :: left_list, right_list
- class(muli_trapezium_node_class_t), pointer :: &
- left_node, right_node, last_node
- class(measure_class_t), pointer :: content
- if (fib_tree%depth > 1) then
- ! print *,"3A"
- call fibonacci_tree_resort_and_convert_to_trapezium_list &
- (fib_tree%left, left_list)
- call fibonacci_tree_resort_and_convert_to_trapezium_list &
- (fib_tree%right, right_list)
- if (left_list%is_left_of (right_list)) then
- lin_list => left_list
- call left_list%get_right (left_node)
- right_node => right_list
- else
- lin_list => right_list
- left_node => left_list
- call right_list%get_right (right_node)
- end if
- last_node => lin_list
- do while (associated (left_node) .and. associated (right_node))
- if (left_node%is_left_of (right_node)) then
- call last_node%append (left_node)
- call last_node%get_right (last_node)
- call left_node%get_right (left_node)
- else
- call last_node%append (right_node)
- call last_node%get_right (last_node)
- call right_node%get_right (right_node)
- end if
- end do
- if (associated (left_node)) then
- call last_node%append (left_node)
- else
- call last_node%append (right_node)
- end if
- !!! It's done.
- ! print *,"3E"
- else
- if (fib_tree%depth == 0) then
- ! print *,"1A"
- select type (fib_tree)
- class is (fibonacci_leave_t)
- call fib_tree%get_content (content)
- select type (content)
- class is (muli_trapezium_t)
- call content%to_node (content%get_r_position(), list=lin_list)
- class default
- call msg_fatal &
- ("fibonacci_tree_resort_and_convert_to_trapezium_list: " // &
- "Content of fibonacci_tree is not type compatible " // &
- "to muli_trapezium_t")
- end select
- end select
- ! print *,"1E"
- else
- ! print *,"2A"
- leave => fib_tree%left
- select type (leave)
- class is (fibonacci_leave_t)
- call leave%get_content (content)
- select type (content)
- class is (muli_trapezium_t)
- call content%to_node (content%get_r_position(), list=left_list)
- class default
- call msg_fatal &
- ("fibonacci_tree_resort_and_convert_to_trapezium_list: " // &
- "Content of fibonacci_tree is not type compatible " // &
- "to muli_trapezium_t")
- end select
- end select
- leave => fib_tree%right
- select type (leave)
- class is (fibonacci_leave_t)
- call leave%get_content (content)
- select type (content)
- class is (muli_trapezium_t)
- call content%to_node (content%get_r_position(), list=right_list)
- class default
- call msg_fatal &
- ("fibonacci_tree_resort_and_convert_to_trapezium_list: " // &
- "Content of fibonacci_tree is not type compatible " // &
- "to muli_trapezium_t")
- end select
- end select
- if (left_list%is_left_of (right_list)) then
- call left_list%append (right_list)
- lin_list => left_list
- else
- call right_list%append (left_list)
- lin_list => right_list
- end if
- ! print *,"2E"
- end if
- end if
- ! call lin_list%print_all ()
- ! call lin_list%check ()
- end subroutine fibonacci_tree_resort_and_convert_to_trapezium_list
-
-@ %def fibonacci_tree_resort_and_convert_to_trapezium_list
-@
-<<Muli aq: interfaces>>=
- interface
- subroutine evaluate_if (this, x, y)
- use kinds !NODEP!
- import aq_class
- class(aq_class), intent(inout) :: this
- real(default), intent(in) :: x
- real(default), intent(out) , dimension(:) :: y
- end subroutine evaluate_if
-
- ! subroutine evaluate_ratios_if (this, cont)
- ! use kinds
- ! use lin_approx_tree_module, only: muli_trapezium_t
- ! import aq_class
- ! class(aq_class) :: this
- ! class(muli_trapezium_t), intent(inout), pointer :: cont
- ! end subroutine evaluate_ratios_if
- end interface
-
-@ %def evaluate_if evaluate_ratios_if
-@
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-<<[[muli_parameters.f90]]>>=
-! This is a dummy for muli_parameters_module
-module muli_parameters_module
-end module muli_parameters_module
-
-@ %def muli_parameters_module
-@
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Integrands for Multiple Interactions}
-
-This file contains the module [[muli_dsigma]]. Its only type
-[[muli_dsigma_t]] provides an integrand to [[aq_class]]. The actual
-integrand is the normalized differential cross section of a QCD $2\to
-2$ process $1/\sigma_0 \times d^3 \sigma / ( d p_T^2 d x_1 d x_2)$.
-We need a root function of this integrand in terms of $p_T$, so we have
-to integrate out $x_1$ and $x_2$ and have to approximate the root
-function of the leftover variable $p_T$. Integration of $x_1$ and
-$x_2$ is done by CUBA, the root function is approximated by
-[[muli_aq]].
-
-<<[[muli_dsigma.f90]]>>=
-<<File header>>
-
-module muli_dsigma
-<<Use kinds>>
- use constants
- use muli_base
- use muli_momentum
- use muli_interactions
- use muli_cuba
- use muli_trapezium
- use muli_aq
-
-<<Standard module head>>
-
-<<Muli dsigma: variables>>
-
-<<Muli dsigma: public>>
-
-<<Muli dsigma: types>>
-
-contains
-
-<<Muli dsigma: procedures>>
-
-end module muli_dsigma
-
-@ %def muli_dsigma
-@
-<<Muli dsigma: variables>>=
- integer, parameter :: dim_f = 17
-
-@ %def dim_f
-@
-<<Muli dsigma: public>>=
- public :: muli_dsigma_t
-<<Muli dsigma: types>>=
- type, extends (aq_class) :: muli_dsigma_t
- private
- type(transverse_mom_t) :: pt
- type(cuba_divonne_t) :: cuba_int
- contains
- <<Muli dsigma: dsigma: TBP>>
- end type muli_dsigma_t
-
-@ %def muli_dsigma_t
-@
-<<Muli dsigma: dsigma: TBP>>=
- procedure :: write_to_marker => muli_dsigma_write_to_marker
-<<Muli dsigma: procedures>>=
- subroutine muli_dsigma_write_to_marker (this, marker, status)
- class(muli_dsigma_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- class(ser_class_t), pointer :: ser
- call marker%mark_begin ("muli_dsigma_t")
- call this%basic_write_to_marker (marker, status)
- call this%cuba_int%serialize (marker, "cuba_int")
- call marker%mark_end ("muli_dsigma_t")
- end subroutine muli_dsigma_write_to_marker
-
-@ %def muli_dsigma_write_to_marker
-@
-<<Muli dsigma: dsigma: TBP>>=
- procedure :: read_from_marker => muli_dsigma_read_from_marker
-<<Muli dsigma: procedures>>=
- subroutine muli_dsigma_read_from_marker (this, marker, status)
- class(muli_dsigma_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%pick_begin ("muli_dsigma_t", status=status)
- call this%basic_read_from_marker (marker, status)
- call this%cuba_int%deserialize ("cuba_int", marker)
- call marker%pick_end ("muli_dsigma_t", status)
- end subroutine muli_dsigma_read_from_marker
-
-@ %def muli_dsigma_read_from_marker
-@
-<<Muli dsigma: dsigma: TBP>>=
- procedure :: print_to_unit => muli_dsigma_print_to_unit
-<<Muli dsigma: procedures>>=
- subroutine muli_dsigma_print_to_unit &
- (this, unit, parents, components, peers)
- class(muli_dsigma_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- integer :: ite
- if (parents > 0) call this%basic_print_to_unit &
- (unit, parents-1, components, peers)
- write (unit, "(A)") "Components of muli_dsigma_t"
- if (components > 0) then
- write (unit, "(A)") "Printing components of cuba_int:"
- call this%cuba_int%print_to_unit (unit, parents, components-1, peers)
- else
- write (unit, "(A)") "Skipping components of cuba_int:"
- end if
- end subroutine muli_dsigma_print_to_unit
-
-@ %def muli_dsigma_print_to_unit
-@
-<<Muli dsigma: dsigma: TBP>>=
- procedure, nopass :: get_type => muli_dsigma_get_type
-@
-<<Muli dsigma: procedures>>=
- pure subroutine muli_dsigma_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="muli_dsigma_t")
- end subroutine muli_dsigma_get_type
-
-@ %def muli_dsigma_get_type
-@
-<<Muli dsigma: dsigma: TBP>>=
- procedure :: generate => muli_dsigma_generate
-<<Muli dsigma: procedures>>=
- subroutine muli_dsigma_generate (this, gev2_scale_cutoff, gev2_s, int_tree)
- class(muli_dsigma_t), intent(inout) :: this
- real(default), intent(in) :: gev2_scale_cutoff, gev2_s
- type(muli_trapezium_tree_t), intent(out) :: int_tree
- real(default), dimension(ceiling (log (gev2_s/gev2_scale_cutoff)/two)) :: &
- initial_values
- integer :: n
- print *, gev2_s/gev2_scale_cutoff, &
- ceiling (log (gev2_s/gev2_scale_cutoff)/two)
- ! allocate (initial_values (ceiling (-log (gev2_scale_cutoff))/2))
- ! allocate (real(default), &
- ! dimension (ceiling (log(gev2_scale_cutoff))/2) :: initial_values)
- initial_values(1) = sqrt(gev2_scale_cutoff/gev2_s) * two
- do n = 2, size(initial_values) - 1
- initial_values(n) = initial_values(n-1) * euler
- end do
- initial_values(n) = one
- print *, initial_values
- ! stop
- call this%initialize (i_one, "dsigma")
- call this%pt%initialize (gev2_s)
- this%abs_error_goal = zero
- this%rel_error_goal = scale(one, -12) !-12
- this%max_nodes = 1000
- call this%cuba_int%set_common (dim_f=dim_f, dim_x=2, &
- eps_rel=scale(this%rel_error_goal,-8), flags = 0)
- call this%cuba_int%set_deferred (xgiven_flat = [1.E-2_default, &
- 5.E-1_default + epsilon(1._default), 1.E-2_default, &
- 5.E-1_default - epsilon(1._default)])
- print *, "muli_dsigma_generate:"
- ! print *, "Cuba Error Goal: ", this%cuba_int%eps_rel
- print *, "Overall Error Goal: ", this%rel_error_goal
- call this%init_error_tree (dim_f, initial_values)
- call this%run ()
- call this%integrate (int_tree)
- call this%err_tree%deallocate_all ()
- deallocate (this%err_tree)
- nullify (this%int_list)
- end subroutine muli_dsigma_generate
-
-@ %def muli_dsigma_generate
-@
-<<Muli dsigma: dsigma: TBP>>=
- procedure :: evaluate => muli_dsigma_evaluate
-<<Muli dsigma: procedures>>=
- subroutine muli_dsigma_evaluate (this, x, y)
- class(muli_dsigma_t), intent(inout) :: this
- real(default), intent(in) :: x
- real(default), intent(out), dimension(:):: y
- call this%pt%set_unit_scale (x)
- ! print *, "muli_dsigma_evaluate x=", x
- ! call this%cuba_int%integrate_userdata &
- ! (interactions_proton_proton_integrand_param_17_reg, this%pt)
- ! if (this%cuba_int%fail == 0) then
- ! call this%cuba_int%print_all ()
- call this%cuba_int%get_integral_array (y)
- ! else
- ! print *, "muli_dsigma_evaluate: failed."
- ! stop
- ! end if
- end subroutine muli_dsigma_evaluate
-
-@ %def muli_dsigma_evaluate
-@
-<<Muli dsigma: dsigma: TBP>>=
- generic :: initialize => muli_dsigma_initialize
- procedure :: muli_dsigma_initialize
-<<Muli dsigma: procedures>>=
- subroutine muli_dsigma_initialize &
- (this, id, name, goal, max_nodes, dim, cuba_goal)
- class(muli_dsigma_t), intent(inout) :: this
- integer(dik), intent(in) :: id, max_nodes
- integer, intent(in) :: dim
- character(*), intent(in) :: name
- real(default), intent(in) :: goal, cuba_goal
- call this%initialize (id,name)
- ! 1E-4
- this%rel_error_goal = goal
- this%max_nodes = max_nodes
- call this%cuba_int%set_common (dim_f=dim, dim_x=2, &
- ! 1E-6
- eps_rel=cuba_goal, flags = 0)
- call this%cuba_int%set_deferred (xgiven_flat = [1.E-2_default, &
- 5.E-1_default + epsilon(1._default), &
- 1.E-2_default, 5.E-1_default - epsilon(1._default)])
- ! call aq_initialize (this, id, name, d_goal, max_nodes, dim_f, &
- ! [8E-1_default/7E3_default, 2E-3_default, 1E-2_default, &
- ! 1E-1_default, one])
- call this%init_error_tree (dim, [8.E-1_default/7.E3_default, &
- 2.E-3_default, 1.E-2_default, 1.E-1_default, &
- 1._default])
- this%is_deferred_initialised = .true.
- end subroutine muli_dsigma_initialize
-
-@ %def muli_dsigma_initialize
-@
-<<Muli dsigma: dsigma: TBP>>=
- ! procedure :: reset => muli_dsigma_reset
-<<Muli dsigma: procedures>>=
- ! subroutine muli_dsigma_reset (this)
- ! class(muli_dsigma_t), intent(inout) :: this
- ! call aq_reset (this)
- ! call this%initialize &
- ! (id, name, d_goal, max_nodes, dim_f, init, cuba_goal)
- ! end subroutine muli_dsigma_reset
-
-@ %def muli_dsigma_reset
-@
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{MC Integrations for QCD $2\to 2$ processes}
-
-
-This file contains the module [[muli_mcint]] which is the Monte Carlo
-generator for QCD $2\to 2$ interactions at given evolution parameter
-and given stratus. While [[muli_t]] takes care of generating the
-evolution parameter and the stratus, this module is about bookkeeping
-the strati and implementing a downstream importance sampling. The
-evolution parameter is a measure of transferred momentum and a ``stratus''
-is a PDF category or, to be more precise, is whether the incoming partons
-are gluons or sea quarks or valence quarks.
-
-The importance sampling then subdivides the phase space of variables
-$\left\{ x_1, x_2, p_T \right\}$ into $n^3$ regions such that each
-region holds approximately $n$ interactions. Thus, we can generate a
-phase space point very quickly just by randomly picking a region,
-randomly picking a point within this region and comparing its exact
-cross section with the mean cross section for this actual evolution
-parameter and the actual stratus times the area of the picked phase space
-region.
-
-The mean values must be generated in the module [[muli_dsigma]] before
-and are given to the procedure
-[[sample_inclusive_generate_hit]]. Finally the generated subregions
-should be written to a file via [[write_to_marker]] and then reused
-for each later \whizard\ run.
-
-The type [[sample_inclusive_t]] holds the 16 strati, while the type
-[[sample_int_kind_t]] represents a single stratus, [[sample_3d_t]] is
-the whole $\left\{ x_1, x_2, p_T \right\}$ phase space for each
-stratus, [[sample_2d_t]] is the $\left\{ x_1, x_2 \right\}$ plane with
-a slice of $p_T$ and [[sample_region_t]] finally is a phase space
-region.
-
-<<[[muli_mcint.f90]]>>=
-<<File header>>
-
-module muli_mcint
-<<Use kinds>>
- use constants
- use muli_base
- use tao_random_numbers !NODEP!
- use muli_interactions
-
-<<Standard module head>>
-
-<<Muli MC int: variables>>
-
-<<Muli MC int: public>>
-
-<<Muli MC int: types>>
-
-contains
-
-<<Muli MC int: procedures>>
-
-end module muli_mcint
-
-@ %def muli_mcint
-@
-<<Muli MC int: variables>>=
- integer, parameter :: max_n = 2**30
-<<Muli MC int: variables>>=
- real(default), parameter :: max_d = one * max_n
-<<Muli MC int: variables>>=
- real(default), parameter, dimension(2,2) :: &
- unit_square = reshape([zero,zero,one,one], [2,2])
-
-@ %def max_n max_d unit_square
-@
-<<Muli MC int: public>>=
- public :: sample_region_t
-<<Muli MC int: types>>=
- type, extends (ser_class_t) :: sample_region_t
- integer :: n_hits = 0
- integer :: n_alloc = 0
- real(default), dimension(2,2) :: corners = unit_square
- real(default), dimension(:,:), allocatable :: hyp_hits
- contains
- <<Muli MC int: sample region: TBP>>
- end type sample_region_t
-
-@ %def sample_region_t
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: write_to_marker => sample_region_write_to_marker
-<<Muli MC int: procedures>>=
- subroutine sample_region_write_to_marker (this, marker, status)
- class(sample_region_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- integer :: n
- call marker%mark_begin ("sample_region_t")
- call marker%mark ("n_hits", this%n_hits)
- call marker%mark ("n_alloc", this%n_alloc)
- call marker%mark ("lower_corner", this%corners(1:2,1))
- call marker%mark ("upper_corner", this%corners(1:2,2))
- if (allocated (this%hyp_hits)) then
- call marker%mark ("hyp_hits", this%hyp_hits (1:3,:this%n_hits))
- else
- call marker%mark_nothing ("hyp_hits")
- end if
- call marker%mark_end ("sample_region_t")
- end subroutine sample_region_write_to_marker
-
-@ %def sample_region_write_to_marker
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: read_from_marker => sample_region_read_from_marker
-<<Muli MC int: procedures>>=
- subroutine sample_region_read_from_marker (this, marker, status)
- class(sample_region_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- integer :: n
- call marker%pick_begin ("sample_region_t", status=status)
- call marker%pick ("n_hits", this%n_hits, status)
- call marker%pick ("n_alloc", this%n_alloc, status)
- call marker%pick ("lower_corner", this%corners(1:2,1), status)
- call marker%pick ("upper_corner", this%corners(1:2,2), status)
- if (allocated (this%hyp_hits)) deallocate (this%hyp_hits)
- call marker%verify_nothing ("hyp_hits", status)
- if (.not. status == serialize_nothing) then
- allocate (this%hyp_hits (3,this%n_alloc))
- call marker%pick ("hyp_hits", this%hyp_hits (1:3,:this%n_hits), status)
- end if
- call marker%pick_end ("sample_region_t", status)
- end subroutine sample_region_read_from_marker
-
-@ %def sample_region_read_from_marker
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: print_to_unit => sample_region_print_to_unit
-<<Muli MC int: procedures>>=
- subroutine sample_region_print_to_unit &
- (this, unit, parents, components, peers)
- class(sample_region_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- write (unit, "(1x,A)") "components of sample_region_t"
- write (unit, "(3x,A,I10)") "n_hits: ", this%n_hits
- write (unit, "(3x,A,I10)") "n_alloc: ", this%n_alloc
- write (unit, "(3x,4(E20.10))") "corners: ", this%corners
- if (allocated (this%hyp_hits) .and. this%n_hits > 0) then
- if (components > 0) then
- write (unit,"(3x,A)") "hits:"
- print *, shape (this%hyp_hits)
- write (unit, "(3(e20.10))") this%hyp_hits (1:3, this%n_hits)
- else
- write (unit, "(3x,A)") "skipping hits."
- end if
- else
- write (unit, "(3x,A)") "hits are not allocated."
- end if
- end subroutine sample_region_print_to_unit
-
-@ %def sample_region_print_to_unit
-@
-<<Muli MC int: sample region: TBP>>=
- procedure, nopass :: get_type => sample_region_get_type
-<<Muli MC int: procedures>>=
- pure subroutine sample_region_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="sample_region_t")
- end subroutine sample_region_get_type
-
-@ %def sample_region_get_type
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: initialize => sample_region_initialize
-<<Muli MC int: procedures>>=
- subroutine sample_region_initialize (this, n_alloc)
- class(sample_region_t), intent(out) :: this
- integer, intent(in) :: n_alloc
- if (allocated (this%hyp_hits)) deallocate (this%hyp_hits)
- allocate (this%hyp_hits (3,n_alloc))
- this%n_alloc = n_alloc
- end subroutine sample_region_initialize
-
-@ %def sample_region_initialize
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: generate_hit => sample_region_generate_hit
-<<Muli MC int: procedures>>=
- pure subroutine sample_region_generate_hit (this, rnd, area, hit)
- class(sample_region_t), intent(in) :: this
- integer, intent(in), dimension(2) :: rnd
- real(default), dimension(2), intent(out) :: hit
- real(default), intent(out) :: area
- call muli_mcint_generate_hit (rnd, this%corners, hit)
- area = this%area ()
- end subroutine sample_region_generate_hit
-
-@ %def sample_region_generate_hit
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: confirm_hit => sample_region_confirm_hit
-<<Muli MC int: procedures>>=
- subroutine sample_region_confirm_hit (this, hit)
- class(sample_region_t), intent(inout) :: this
- real(default), dimension(3), intent(in) :: hit
- ! print *,"sample_region_confirm_hit: ", this%n_hits, this%n_alloc, hit
- this%n_hits = this%n_hits + 1
- if (this%n_hits <= this%n_alloc) then
- this%hyp_hits (1:3, this%n_hits) = hit
- else
- print *, "sample_region_confirm_hit: Region is already full."
- end if
- end subroutine sample_region_confirm_hit
-
-@ %def sample_region_confirm_hit
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: split => sample_region_split
-<<Muli MC int: procedures>>=
- subroutine sample_region_split (this, pos, dimX, n_alloc, lower, upper)
- class(sample_region_t), intent(in) :: this
- type(sample_region_t), intent(out) :: lower, upper
- real(default), dimension(3) :: hit
- real(default), intent(in) :: pos
- integer, intent(in) :: dimX, n_alloc
- integer :: n_hit
- call lower%initialize (n_alloc)
- call upper%initialize (n_alloc)
- do n_hit = 1, this%n_hits
- hit = this%hyp_hits (1:3, n_hit)
- if (hit(dimX) < pos) then
- call lower%confirm_hit (hit)
- else
- call upper%confirm_hit (hit)
- end if
- end do
- lower%corners = this%corners
- upper%corners = this%corners
- if (dimX < 3) then
- lower%corners(dimX,2) = pos
- upper%corners(dimX,1) = pos
- end if
- end subroutine sample_region_split
-
-@ %def sample_region_split
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: write_hits => sample_region_write_hits
-<<Muli MC int: procedures>>=
- subroutine sample_region_write_hits (this, unit)
- class(sample_region_t), intent(in) :: this
- integer, intent(in) :: unit
- integer :: n
- do n = 1, this%n_hits
- write (unit, *) this%hyp_hits (1:3,n)
- end do
- end subroutine sample_region_write_hits
-
-@ %def sample_region_write_hits
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: is_full => sample_region_is_full
-<<Muli MC int: procedures>>=
- elemental logical function sample_region_is_full (this)
- class(sample_region_t), intent(in) :: this
- sample_region_is_full = this%n_alloc == this%n_hits
- end function sample_region_is_full
-
-@ %def sample_region_is_full
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: move_components => sample_region_move_components
-<<Muli MC int: procedures>>=
- subroutine sample_region_move_components (this, that)
- class(sample_region_t), intent(inout) :: this
- class(sample_region_t), intent(out) :: that
- that%n_alloc = this%n_alloc
- that%n_hits = this%n_hits
- that%corners = this%corners
- call move_alloc (this%hyp_hits, that%hyp_hits)
- this%n_alloc = 0
- this%n_hits = 0
- end subroutine sample_region_move_components
-
-@ %def sample_region_move_components
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: mean => sample_region_mean
-<<Muli MC int: procedures>>=
- elemental function sample_region_mean (this, dim)
- real(default) :: sample_region_mean
- class(sample_region_t), intent(in) :: this
- integer, intent(in) :: dim
- sample_region_mean = sum (this%hyp_hits (dim,1:this%n_hits)) / this%n_hits
- end function sample_region_mean
-
-@ %def sample_region_mean
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: area => sample_region_area
-<<Muli MC int: procedures>>=
- elemental function sample_region_area (this)
- real(default) :: sample_region_area
- class(sample_region_t), intent(in) :: this
- sample_region_area = product (this%corners(1:2,2) - this%corners(1:2,1))
- end function sample_region_area
-
-@ %def sample_region_area
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: density => sample_region_density
-<<Muli MC int: procedures>>=
- elemental function sample_region_density (this)
- real(default) :: sample_region_density
- class(sample_region_t), intent(in) :: this
- sample_region_density = this%n_hits / this%area ()
- end function sample_region_density
-
-@ %def sample_region_density
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: contains => sample_region_contains
-<<Muli MC int: procedures>>=
- pure logical function sample_region_contains (this, hit)
- class(sample_region_t), intent(in) :: this
- real(default), intent(in), dimension(3) :: hit
- sample_region_contains = (this%corners(1,1) <= hit(1) .and. &
- hit(1) <= this%corners(1,2) .and. &
- this%corners(2,1) <= hit(2) .and. &
- hit(2) <= this%corners(2,2))
- end function sample_region_contains
-
-@ %def sample_region_contains
-@
-<<Muli MC int: sample region: TBP>>=
- procedure :: to_generator => sample_region_to_generator
-<<Muli MC int: procedures>>=
- subroutine sample_region_to_generator (this)
- class(sample_region_t), intent(inout) :: this
- if (allocated (this%hyp_hits)) deallocate (this%hyp_hits)
- this%n_alloc = 0
- end subroutine sample_region_to_generator
-
-@ %def sample_region_to_generator
-@
-<<Muli MC int: public>>=
- public :: sample_2d_t
-<<Muli MC int: types>>=
- type, extends (ser_class_t) :: sample_2d_t
- integer :: n_regions = 0
- integer :: n_alloc = 0
- integer :: n_hits = 0
- real(default), dimension(2) :: range = [0,1]
- type(sample_region_t), dimension(:), allocatable :: regions
- contains
- <<Muli MC int: sample 2D: TBP>>
- end type sample_2d_t
-
-@ %def sample_2d_t
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: write_to_marker => sample_2d_write_to_marker
-<<Muli MC int: procedures>>=
- subroutine sample_2d_write_to_marker (this, marker, status)
- class(sample_2d_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- integer :: n
- call marker%mark_begin ("sample_2d_t")
- call marker%mark ("n_regions", this%n_regions)
- call marker%mark ("n_alloc", this%n_alloc)
- call marker%mark ("n_hits", this%n_hits)
- call marker%mark ("range", this%range)
- if (this%n_regions > 0) then
- call marker%mark_instance_begin &
- (this%regions(1), name="sample_2d_t", shape=shape (this%regions))
- do n = 1, this%n_regions
- call sample_region_write_to_marker (this%regions(n), marker, status)
- end do
- call marker%mark_instance_end ()
- end if
- call marker%mark_end ("sample_2d_t")
- end subroutine sample_2d_write_to_marker
-
-@ %def sample_2d_write_to_marker
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: read_from_marker => sample_2d_read_from_marker
-<<Muli MC int: procedures>>=
- subroutine sample_2d_read_from_marker (this, marker, status)
- class(sample_2d_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- integer :: n
- call marker%pick_begin ("sample_2d_t", status=status)
- call marker%pick ("n_regions", this%n_regions, status)
- call marker%pick ("n_alloc", this%n_alloc, status)
- call marker%pick ("n_hits", this%n_hits, status)
- call marker%pick ("range", this%range, status)
- if (this%n_regions > 0) then
- call marker%pick_begin ("regions", status=status)
- allocate (this%regions (this%n_regions))
- do n = 1, this%n_regions
- call sample_region_read_from_marker (this%regions(n), marker, status)
- end do
- call marker%pick_end ("regions", status)
- end if
- call marker%pick_end ("sample_2d_t", status)
- end subroutine sample_2d_read_from_marker
-
-@ %def sample_2d_read_from_marker
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: print_to_unit => sample_2d_print_to_unit
-<<Muli MC int: procedures>>=
- subroutine sample_2d_print_to_unit (this, unit, parents, components, peers)
- class(sample_2d_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- integer :: n
- write (unit, "(1x,A)") "components of sample_2d_t"
- write (unit, "(3x,A,I10)") "n_regions: ", this%n_regions
- write (unit, "(3x,A,I10)") "n_alloc: ", this%n_alloc
- write (unit, "(3x,A,2(E20.10))") "range: ", this%range
- if (allocated (this%regions)) then
- if (components > 0) then
- write (unit, "(3x,A)") "regions:"
- do n = 1, this%n_regions
- call this%regions(n)%print_to_unit &
- (unit, parents, components-1, peers)
- end do
- else
- write (unit, "(3x,A)") "skipping regions."
- end if
- else
- write (unit, "(3x,A)") "regions are not allocated."
- end if
- end subroutine sample_2d_print_to_unit
-
-@ %def sample_2d_print_to_unit
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure, nopass :: get_type => sample_2d_get_type
-<<Muli MC int: procedures>>=
- pure subroutine sample_2d_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="sample_2d_t")
- end subroutine sample_2d_get_type
-
-@ %def sample_2d_get_type
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: initialize => sample_2d_initialize
-<<Muli MC int: procedures>>=
- subroutine sample_2d_initialize (this, n_alloc)
- class(sample_2d_t), intent(out) :: this
- integer, intent(in) :: n_alloc
- integer :: n
- if (allocated (this%regions)) deallocate (this%regions)
- allocate (this%regions (n_alloc))
- this%n_alloc = n_alloc
- this%n_regions = 1
- call this%regions(1)%initialize (n_alloc)
- ! do n = 1, n_alloc
- ! call this%regions(n)%initialize (n_alloc)
- ! end do
- end subroutine sample_2d_initialize
-
-@ %def sample_2d_initialize
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: contains => sample_2d_contains
-<<Muli MC int: procedures>>=
- pure logical function sample_2d_contains (this, pts2)
- class(sample_2d_t), intent(in) :: this
- real(default), intent(in) :: pts2
- sample_2d_contains = this%range(1) <= pts2 .and. pts2 <= this%range(2)
- end function sample_2d_contains
-
-@ %def sample_2d_contains
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: generate_hit => sample_2d_generate_hit
-<<Muli MC int: procedures>>=
- pure subroutine sample_2d_generate_hit (this, rnd, boost, hit, region)
- class(sample_2d_t), intent(in) :: this
- integer, dimension(3), intent(in) :: rnd
- integer, intent(out) :: region
- integer :: n, sum
- real(default), dimension(2), intent(out) :: hit
- real(default), intent(out) :: boost
- if (0 < this%n_hits .and. this%n_hits < 10) then
- !!! this should be improved
- sum = modulo(rnd(1),this%n_hits) + 1
- region = 0
- do while (sum > 0)
- region = region + 1
- sum = sum - this%regions(region)%n_hits
- end do
- call this%regions(region)%generate_hit (rnd(2:3), boost, hit)
- boost = boost * this%n_hits / this%regions(region)%n_hits
- else
- if (this%n_regions > 1) then
- !!! this should be improved
- region = modulo(rnd(1), this%n_regions) + 1
- call this%regions(region)%generate_hit (rnd(2:3), boost, hit)
- boost = boost * this%n_regions
- else
- region = 1
- call this%regions(1)%generate_hit (rnd(2:3), boost, hit)
- end if
- end if
- end subroutine sample_2d_generate_hit
-
-! pure subroutine sample_2d_generate_hit (this, rnd, boost, hit, region)
-! class(sample_2d_t), intent(in) :: this
-! integer, dimension(3), intent(in) :: rnd
-! integer, intent(out) :: region
-! real(double), dimension(2), intent(out) :: hit
-! real(double), intent(out) :: boost
-! region = modulo(rnd(1), this%n_regions) + 1 !!! this should be improved
-! call this%regions(region)%generate_hit (rnd(2:3), boost, hit)
-! boost = boost * this%n_regions
-! end subroutine sample_2d_generate_hit
-
-@ %def sample_2d_generate_hit
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: confirm_hit => sample_2d_confirm_hit
-<<Muli MC int: procedures>>=
- subroutine sample_2d_confirm_hit (this, hit, region, full)
- class(sample_2d_t), intent(inout) :: this
- integer, intent(in) :: region
- real(default), dimension(3), intent(in) :: hit
- type(sample_region_t), allocatable :: old_region
- real(default), dimension(2) :: mean, var, diff, cm, cv, c
- integer :: n, n_alloc, dim
- logical, intent(out) :: full
- this%n_hits = this%n_hits + 1
- if (region <= this%n_alloc) then
- full = .false.
- call this%regions(region)%confirm_hit (hit)
- n_alloc = this%regions(region)%n_alloc
- if (this%regions(region)%is_full()) then
- if (this%is_full()) then
- full = .true.
- else
- this%n_regions = this%n_regions + 1
- allocate (old_region)
- call this%regions(region)%move_components (old_region)
- mean = sum (old_region%hyp_hits(1:2,:), dim=2) / n_alloc
- var = 0
- do n = 1, n_alloc
- var = var + abs(mean-old_region%hyp_hits(1:2,n))
- end do
- var = var / n_alloc
- diff = old_region%corners(1:2,2) - old_region%corners(1:2,1)
- cm = abs ([0.5_default,0.5_default] - &
- (old_region%corners(1:2,2) - mean) / diff)
- cv = abs(2*([0.25_default,0.25_default] - var / diff))
- c = max(cm,cv)
- if (c(1) < c(2)) then
- dim = 2
- else
- dim = 1
- end if
- call old_region%split (mean(dim), dim, this%n_alloc, &
- this%regions(region), this%regions(this%n_regions))
- end if
- end if
- else
- write (*,*) "sample_2d_confirm_hit: Region ", region, &
- " not allocated."
- end if
- end subroutine sample_2d_confirm_hit
-
-@ %def sample_2d_confirm_hit
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: split => sample_2d_split
-<<Muli MC int: procedures>>=
- recursive subroutine sample_2d_split (this, n_alloc, pos, lower, upper)
- class(sample_2d_t), intent(in) :: this
- integer, intent(in) :: n_alloc
- real(default), intent(in) :: pos
- type(sample_2d_t), intent(out) :: lower, upper
- integer :: n_r, n_h
- real(default), dimension(3) :: hit
- ! print *,"sample_2d_split: ", pos, this%range
- call lower%initialize (4*n_alloc)
- call upper%initialize (4*n_alloc)
- do n_r = this%n_regions, 1, -1
- do n_h = 1, this%regions(n_r)%n_hits
- hit = this%regions(n_r)%hyp_hits (1:3,n_h)
- if (hit(3) > pos) then
- call upper%push (hit)
- else
- call lower%push (hit)
- end if
- end do
- end do
- lower%range = [this%range(1), pos]
- upper%range = [pos, this%range(2)]
- end subroutine sample_2d_split
-
-! subroutine sample_2d_split (this, n_alloc, pos, lower, upper)
-! class(sample_2d_t), intent(in) :: this
-! integer, intent(in) :: n_alloc
-! real(default), intent(in) :: pos
-! type(sample_2d_t), intent(out) :: lower, upper
-! integer :: n, n_hit
-! real(default), dimension(3) :: hit
-! allocate (lower%regions (n_alloc))
-! allocate (upper%regions (n_alloc))
-! !$OMP PARALLEL DO FIRSTPRIVATE (this, pos, n_alloc) SHARED (lower, upper)
-! do n = 1, this%n_regions
-! call sample_region_split (this%regions(n), pos, 3, n_alloc, &
-! lower%regions(n),upper%regions(n))
-! end do
-! !$OMP END PARALLEL DO
-! lower%n_regions = this%n_regions
-! upper%n_regions = this%n_regions
-! lower%n_alloc = n_alloc
-! upper%n_alloc = n_alloc
-! lower%range = [this%range(1), pos]
-! upper%range = [pos, this%range(2)]
-! end subroutine sample_2d_split
-
-@ %def sample_2d_split
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: push => sample_2d_push
-<<Muli MC int: procedures>>=
- subroutine sample_2d_push (this, hit)
- class(sample_2d_t), intent(inout) :: this
- real(default), dimension(3), intent(in) :: hit
- integer :: region
- logical :: full
- do region = 1, this%n_regions
- if (this%regions(region)%contains (hit)) then
- call this%confirm_hit (hit, region, full)
- ! call this%regions(region)%confirm_hit (hit)
- if (full) print *,"sample_2d_push: region is full now"
- exit
- end if
- end do
- if (region > this%n_regions) &
- print *, "sample_2d_push: no region contains ", hit
- end subroutine sample_2d_push
-
-@ %def sample_2d_push
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: write_hits => sample_2d_write_hits
-<<Muli MC int: procedures>>=
- subroutine sample_2d_write_hits (this, unit)
- class(sample_2d_t), intent(in) :: this
- integer, intent(in) :: unit
- integer :: n
- do n = 1, this%n_regions
- call this%regions(n)%write_hits (unit)
- end do
- end subroutine sample_2d_write_hits
-
-@ %def sample_2d_write_hits
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: is_full => sample_2d_is_full
-<<Muli MC int: procedures>>=
- elemental logical function sample_2d_is_full (this)
- class(sample_2d_t), intent(in) :: this
- sample_2d_is_full = this%n_alloc == this%n_regions
- end function sample_2d_is_full
-
-@ %def sample_2d_is_full
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: move_components => sample_2d_move_components
-<<Muli MC int: procedures>>=
- subroutine sample_2d_move_components (this, that)
- class(sample_2d_t), intent(inout) :: this
- class(sample_2d_t), intent(out) :: that
- that%n_alloc = this%n_alloc
- that%n_regions = this%n_regions
- that%n_hits = this%n_hits
- that%range = this%range
- call move_alloc (this%regions, that%regions)
- this%n_alloc = 0
- this%n_regions = 0
- this%n_hits = 0
- this%range = [zero,zero]
- end subroutine sample_2d_move_components
-
-@ %def sample_2d_move_components
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: thickness => sample_2d_thickness
-<<Muli MC int: procedures>>=
- elemental function sample_2d_thickness (this)
- class(sample_2d_t), intent(in) :: this
- real(default) :: sample_2d_thickness
- sample_2d_thickness = this%range(2) - this%range(1)
- end function sample_2d_thickness
-
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: analyse => sample_2d_analyse
-<<Muli MC int: procedures>>=
- subroutine sample_2d_analyse (this, dir, file)
- class(sample_2d_t), intent(in) :: this
- character(*), intent(in) :: dir, file
- integer :: u
- real(default), dimension(1:2,0:100,0:100) :: grid
- integer, dimension(0:100,0:100) :: i_grid
- integer :: r, x, y
- integer, dimension(2,2) :: i
- call generate_unit (u)
- print *, "sample_2d_analyse: ", dir // "/" // file
- open (u, file=dir//"/"//file)
- do x = 0, 100
- do y = 0, 100
- grid(1:2,x,y) = [-one,-one]
- end do
- end do
- do r = 1, this%n_regions
- i = int(this%regions(r)%corners*1E2_default)
- do x = i(1,1), i(1,2)
- do y = i(2,1), i(2,2)
- i_grid(x,y) = this%regions(r)%n_hits
- grid(1,x,y) = one / this%regions(r)%area ()
- grid(2,x,y) = this%regions(r)%density ()
- end do
- end do
- end do
- do x = 0, 100
- do y = 0, 100
- write (u, *) x, y, i_grid(x,y), grid(1:2,x,y)
- end do
- write (u, *)
- end do
- close (u)
- end subroutine sample_2d_analyse
-
-@ %def sample_2d_analyse
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: to_generator => sample_2d_to_generator
-<<Muli MC int: procedures>>=
- subroutine sample_2d_to_generator (this)
- class(sample_2d_t), intent(inout) :: this
- integer :: region
- do region = 1, this%n_regions
- call this%regions(region)%to_generator ()
- end do
- end subroutine sample_2d_to_generator
-
-@ %def sample_2d_to_generator
-@
-<<Muli MC int: sample 2D: TBP>>=
- procedure :: mean => sample_2d_mean
-<<Muli MC int: procedures>>=
- elemental function sample_2d_mean (this, dim) result (mean)
- class(sample_2d_t), intent(in) :: this
- integer, intent(in) :: dim
- real(default) :: mean
- integer :: region, hit
- mean = zero
- do region = 1, this%n_regions
- do hit = 1, this%regions(region)%n_hits
- mean = mean + this%regions(region)%hyp_hits (dim, hit)
- end do
- end do
- mean = mean / this%n_hits
- end function sample_2d_mean
-
-@ %def sample_2d_mean
-@
-<<Muli MC int: public>>=
- public :: sample_3d_t
-<<Muli MC int: types>>=
- type, extends (ser_class_t) :: sample_3d_t
- integer::n_slices=0
- integer::n_alloc=0
- type(sample_2d_t), dimension(:),allocatable::slices
- contains
- <<Muli MC int: sample 3D: TBP>>
- end type sample_3d_t
-
-@ %def sample_3d_t
-@
-<<Muli MC int: sample 3D: TBP>>=
- procedure :: write_to_marker => sample_3d_write_to_marker
-<<Muli MC int: procedures>>=
- subroutine sample_3d_write_to_marker (this, marker, status)
- class(sample_3d_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- integer :: n
- call marker%mark_begin ("sample_3d_t")
- call marker%mark ("n_slices", this%n_slices)
- call marker%mark ("n_alloc", this%n_alloc)
- if (this%n_slices > 0) then
- call marker%mark_instance_begin &
- (this%slices(1), "slices", shape=shape(this%slices))
- do n = 1, this%n_slices
- call sample_2d_write_to_marker (this%slices(n), marker, status)
- end do
- call marker%mark_instance_end ()
- end if
- call marker%mark_end ("sample_3d_t")
- end subroutine sample_3d_write_to_marker
-
-@ %def sample_3d_write_to_marker
-@
-<<Muli MC int: sample 3D: TBP>>=
- procedure :: read_from_marker => sample_3d_read_from_marker
-<<Muli MC int: procedures>>=
- subroutine sample_3d_read_from_marker (this, marker, status)
- class(sample_3d_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- integer :: n
- call marker%pick_begin ("sample_3d_t", status=status)
- call marker%pick ("n_slices", this%n_slices, status)
- call marker%pick ("n_alloc", this%n_alloc, status)
- if (this%n_slices > 0) then
- call marker%pick_instance_begin ("slices", status=status)
- allocate(this%slices (this%n_slices))
- do n = 1, this%n_slices
- call sample_2d_read_from_marker (this%slices(n), marker, status)
- end do
- call marker%pick_instance_end (status)
- end if
- call marker%pick_end ("sample_3d_t", status)
- end subroutine sample_3d_read_from_marker
-
-@ %def sample_3d_read_from_marker
-@
-<<Muli MC int: sample 3D: TBP>>=
- procedure :: print_to_unit => sample_3d_print_to_unit
-<<Muli MC int: procedures>>=
- subroutine sample_3d_print_to_unit (this, unit, parents, components, peers)
- class(sample_3d_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- integer :: n
- write (unit, "(1x,A)") "components of sample_3d_t"
- write (unit, "(3x,A,I10)") "n_slices: ", this%n_slices
- write (unit, "(3x,A,I10)") "n_alloc: ", this%n_alloc
- if (allocated (this%slices)) then
- if (components > 0) then
- do n = 1, this%n_slices
- call this%slices(n)%print_to_unit (unit, parents, components-1, peers)
- end do
- else
- write (unit, "(3x,A)") "skipping slices."
- end if
- else
- write (unit, "(3x,A)") "slices are not allocated."
- end if
- end subroutine sample_3d_print_to_unit
-
-@ %def sample_3d_print_to_unit
-@
-<<Muli MC int: sample 3D: TBP>>=
- procedure, nopass :: get_type => sample_3d_get_type
-<<Muli MC int: procedures>>=
- pure subroutine sample_3d_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="sample_3d_t")
- end subroutine sample_3d_get_type
-
-@ %def sample_3d_get_type
-@
-<<Muli MC int: sample 3D: TBP>>=
- procedure :: measure => sample_3d_measure
-<<Muli MC int: procedures>>=
- elemental function sample_3d_measure (this)
- real(default) :: sample_3d_measure
- class(sample_3d_t), intent(in) :: this
- sample_3d_measure = one
- end function sample_3d_measure
-
-@ %def sample_3d_measure
-@
-<<Muli MC int: sample 3D: TBP>>=
- procedure :: to_generator => sample_3d_to_generator
-<<Muli MC int: procedures>>=
- subroutine sample_3d_to_generator(this)
- class(sample_3d_t), intent(inout)::this
- integer::slice
- do slice=1,this%n_slices
- call this%slices(slice)%to_generator()
- end do
- end subroutine sample_3d_to_generator
-
-@ %def sample_3d_to_generator
-@
-<<Muli MC int: sample 3D: TBP>>=
- generic :: initialize => sample_3d_initialize
- procedure :: sample_3d_initialize
-<<Muli MC int: procedures>>=
- subroutine sample_3d_initialize (this, n_alloc)
- class(sample_3d_t), intent(out) :: this
- integer, intent(in) :: n_alloc
- if (allocated (this%slices)) deallocate (this%slices)
- if (n_alloc > 0) then
- allocate (this%slices (n_alloc))
- this%n_alloc = n_alloc
- this%n_slices = 1
- call this%slices(1)%initialize (n_alloc)
- else
- this%n_alloc = 0
- end if
- end subroutine sample_3d_initialize
-
-@ %def sample_3d_initialize
-@
-<<Muli MC int: sample 3D: TBP>>=
- procedure :: sample_3d_generate_hit
- generic :: generate_hit => sample_3d_generate_hit
-<<Muli MC int: procedures>>=
- pure subroutine sample_3d_generate_hit &
- (this, rnd, pts2, boost, hit, region, slice)
- class(sample_3d_t), intent(in) :: this
- integer, intent(in), dimension(3) :: rnd
- real(default), intent(in) :: pts2
- integer, intent(out) :: slice, region
- real(default), dimension(3), intent(out) :: hit
- real(default), intent(out) :: boost
- if (this%n_slices == 0) then
- call muli_mcint_generate_hit (rnd, unit_square, hit(1:2))
- boost = 1._default
- slice = 1
- region = 1
- else
- do slice = 1, this%n_slices
- if (this%slices(slice)%contains (pts2)) exit
- end do
- call this%slices(slice)%generate_hit (rnd, boost, hit(1:2), region)
- end if
- hit(3) = pts2
- end subroutine sample_3d_generate_hit
-
-@ %def sample_3d_generate_hit
-@
-<<Muli MC int: sample 3D: TBP>>=
- procedure :: sample_3d_confirm_hit
- generic :: confirm_hit => sample_3d_confirm_hit
-<<Muli MC int: procedures>>=
- subroutine sample_3d_confirm_hit (this, hit, region, slice)
- class(sample_3d_t), intent(inout) :: this
- integer, intent(in) :: slice, region
- real(default), intent(in), dimension(3) :: hit
- type(sample_2d_t), allocatable :: old_slice
- integer :: n
- logical :: full
- if (this%n_alloc < slice) then
- print *, "sample_3d_confirm_hit: Slice ", slice, " not allocated."
- else
- ! if (.not. allocated (this%slices)) call this%initialize (2)
- call this%slices(slice)%confirm_hit (hit, region, full)
- if (full) then
- if (this%n_alloc == this%n_slices) call this%enlarge ()
- this%n_slices = this%n_slices + 1
- allocate (old_slice)
- call this%slices(slice)%move_components (old_slice)
- call sample_2d_split (old_slice, this%n_alloc, &
- old_slice%mean(3), this%slices(slice), &
- this%slices(this%n_slices))
- end if
- end if
- end subroutine sample_3d_confirm_hit
-
-@ %def sample_3d_confirm_hit
-@
-<<Muli MC int: sample 3D: TBP>>=
- procedure :: enlarge => sample_3d_enlarge
-<<Muli MC int: procedures>>=
- subroutine sample_3d_enlarge (this)
- class(sample_3d_t), intent(inout) :: this
- type(sample_2d_t), allocatable, dimension(:) :: old_slices
- integer :: n
- print *, "sample_3d_enlarge"
- call move_alloc (this%slices, old_slices)
- this%n_alloc = this%n_alloc * 2
- allocate (this%slices (this%n_alloc))
- do n = 1, size(old_slices)
- call old_slices(n)%move_components(this%slices(n))
- end do
- end subroutine sample_3d_enlarge
-
-@ %def sample_3d_enlarge
-@
-<<Muli MC int: public>>=
- public :: sample_int_kind_t
-<<Muli MC int: types>>=
- type, extends (sample_3d_t) :: sample_int_kind_t
- integer :: n_proc = 0
- integer(kind=i64) :: n_tries = 0
- integer :: n_hits = 0
- integer :: n_over = 0
- integer, dimension(:), allocatable :: hits, weights, processes
- real(default) :: overall_boost = 1E-1_default
- contains
- <<Muli MC int: sample int: TBP>>
- end type sample_int_kind_t
-
-@ %def sample_int_kind_t
-@
-<<Muli MC int: sample int: TBP>>=
- procedure :: write_to_marker => sample_int_kind_write_to_marker
-<<Muli MC int: procedures>>=
- subroutine sample_int_kind_write_to_marker (this, marker, status)
- class(sample_int_kind_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("sample_int_kind_t")
- call sample_3d_write_to_marker (this, marker, status)
- call marker%mark ("n_hits", this%n_hits)
- call marker%mark ("n_proc", this%n_proc)
- call marker%mark ("boost", this%overall_boost)
- if (this%n_hits > 0) then
- call marker%mark ("hits", this%hits)
- end if
- if (this%n_proc > 0) then
- call marker%mark ("processes", this%processes)
- call marker%mark ("weights", this%weights)
- end if
- call marker%mark_end ("sample_int_kind_t")
- end subroutine sample_int_kind_write_to_marker
-
-@ %def sample_int_kind_write_to_marker
-@
-<<Muli MC int: sample int: TBP>>=
- procedure :: read_from_marker => sample_int_kind_read_from_marker
-<<Muli MC int: procedures>>=
- subroutine sample_int_kind_read_from_marker (this, marker, status)
- class(sample_int_kind_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%pick_begin ("sample_int_kind_t", status=status)
- call sample_3d_read_from_marker (this, marker, status)
- call marker%pick ("n_hits", this%n_hits, status)
- call marker%pick ("n_proc", this%n_proc, status)
- call marker%pick ("boost", this%overall_boost, status)
- if (this%n_hits > 0) then
- allocate (this%hits (this%n_hits))
- call marker%pick ("hits", this%hits, status)
- end if
- if (this%n_proc > 0) then
- allocate (this%processes (this%n_proc))
- call marker%pick ("processes", this%processes, status)
- allocate (this%weights (this%n_proc))
- call marker%pick ("weights", this%weights, status)
- end if
- call marker%pick_end ("sample_int_kind_t", status)
- end subroutine sample_int_kind_read_from_marker
-
-@ %def sample_int_kind_read_from_marker
-@
-<<Muli MC int: sample int: TBP>>=
- procedure :: print_to_unit => sample_int_kind_print_to_unit
-<<Muli MC int: procedures>>=
-
- subroutine sample_int_kind_print_to_unit (this, unit, parents, components, peers)
- class(sample_int_kind_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- integer :: n
- if (parents > 0) call sample_3d_print_to_unit &
- (this, unit, parents, components, peers)
- write (unit, "(1x,A)") "components of sample_int_kind_t"
- write (unit, "(3x,A,I10)") "n_hits: ", this%n_hits
- write (unit, "(3x,A,I10)") "n_proc: ", this%n_proc
- write (unit, "(3x,A,E14.7)") "overall_boost: ", this%overall_boost
- write (unit, "(3x,A)") "hits:"
- write (unit, "(3x,10(I0,1x))") this%hits(1:this%n_hits)
- write (unit, "(3x,A)") "weights:"
- write (unit, "(3x,10(I0,1x))") this%weights
- write (unit, "(3x,A)") "processes:"
- write (unit, "(3x,2(I0,1x))") this%processes
- end subroutine sample_int_kind_print_to_unit
-
-@ %def sample_int_kind_print_to_unit
-@
-<<Muli MC int: sample int: TBP>>=
- procedure, nopass :: get_type => sample_int_kind_get_type
-<<Muli MC int: procedures>>=
- pure subroutine sample_int_kind_get_type (type)
- character(:),allocatable, intent(out) :: type
- allocate (type, source="sample_int_kind_t")
- end subroutine sample_int_kind_get_type
-
-@ %def sample_int_kind_get_type
-@
-<<Muli MC int: sample int: TBP>>=
- procedure :: to_generator => sample_int_kind_to_generator
-<<Muli MC int: procedures>>=
- subroutine sample_int_kind_to_generator(this)
- class(sample_int_kind_t), intent(inout)::this
- integer::int_kind
- if (allocated(this%hits))deallocate(this%hits)
- call sample_3d_to_generator(this)
- end subroutine sample_int_kind_to_generator
-
-@ %def sample_int_kind_to_generator
-@
-<<Muli MC int: sample int: TBP>>=
- procedure :: process_id => sample_int_kind_process_id
-<<Muli MC int: procedures>>=
- elemental integer function sample_int_kind_process_id (this, subprocess)
- class(sample_int_kind_t), intent(in) :: this
- integer, intent(in) :: subprocess
- sample_int_kind_process_id = this%processes(subprocess)
- end function sample_int_kind_process_id
-
-@ %def sample_int_kind_process_id
-@
-<<Muli MC int: sample int: TBP>>=
- procedure :: sample_int_kind_initialize
- generic :: initialize => sample_int_kind_initialize
-<<Muli MC int: procedures>>=
- subroutine sample_int_kind_initialize (this, n_alloc, processes, overall_boost)
- class(sample_int_kind_t), intent(out) :: this
- integer, intent(in) :: n_alloc
- integer, intent(in), dimension(:) :: processes
- real(default), optional, intent(in) :: overall_boost
- integer :: s, n
- s = size(processes)
- call sample_3d_initialize (this, n_alloc)
- if (allocated (this%hits)) deallocate (this%hits)
- allocate (this%hits (n_alloc))
- if (allocated (this%weights)) deallocate (this%weights)
- allocate (this%weights(s))
- if (allocated (this%processes)) deallocate (this%processes)
- allocate (this%processes(s), source=processes)
- do n = 1, s
- this%weights(n) = 0
- end do
- this%n_alloc = n_alloc
- this%n_hits = 0
- this%n_proc = s
- if (present (overall_boost)) this%overall_boost = overall_boost
- this%overall_boost = this%overall_boost * this%n_proc
- ! print *, this%weights
- end subroutine sample_int_kind_initialize
-
-@ %sample_int_kind_initialize
-@
-<<Muli MC int: sample int: TBP>>=
- procedure :: sample_int_kind_generate_hit
-<<Muli MC int: procedures>>=
- pure subroutine sample_int_kind_generate_hit &
- (this, rnd, pts2, boost, hit, region, slice, subprocess)
- class(sample_int_kind_t), intent(in) :: this
- integer, dimension(4), intent(in) :: rnd
- real(default), intent(in) :: pts2
- real(default), dimension(3), intent(out) :: hit
- integer, intent(out) :: region, slice, subprocess
- real(default), intent(out) :: boost
- integer :: n_n
- ! print *, rnd, pts2, boost, hit, region, slice, subprocess
- call sample_3d_generate_hit &
- (this, rnd(2:4), pts2, boost, hit, region, slice)
- n_n = modulo(rnd(1), this%n_hits + size(this%weights)) + 1
- if (n_n > this%n_hits) then
- subprocess = n_n - this%n_hits
- else
- subprocess = this%hits(n_n)
- end if
- boost = boost * this%overall_boost * (this%n_proc + this%n_hits) / &
- (this%n_proc * (this%weights(subprocess) + 1))
- end subroutine sample_int_kind_generate_hit
-
-@ %def sample_int_kind_generate_hit
-@
-<<Muli MC int: sample int: TBP>>=
- procedure :: mcgenerate_hit => sample_int_kind_mcgenerate_hit
- generic :: generate_hit => sample_int_kind_generate_hit
-<<Muli MC int: procedures>>=
- subroutine sample_int_kind_mcgenerate_hit (this, pts2, mean, &
- integrand_kind, tao_rnd, process_id, cart_hit)
- class(sample_int_kind_t), intent(inout) :: this
- integer, intent(in) :: integrand_kind
- real(default), intent(in) :: pts2, mean
- type(tao_random_state), intent(inout) :: tao_rnd
- real(default), dimension(3), intent(out) :: cart_hit
- integer, intent(out) :: process_id
- real(default) :: boost
- integer :: region, slice, subprocess
- integer, dimension(4) :: i_rnd
- real(default) :: dddsigma, d_rnd
- real(default), dimension(3) :: hyp_hit
- MC: do
- this%n_tries = this%n_tries + 1
- call tao_random_number (tao_rnd, i_rnd)
- call tao_random_number (tao_rnd, d_rnd)
- ! print *, pts2, mean, integrand_kind, process_id, cart_hit
- call this%generate_hit (i_rnd, pts2, boost, hyp_hit, region, &
- slice, subprocess)
- process_id = this%process_id(subprocess)
- call interactions_dddsigma_reg (process_id, integrand_kind, &
- hyp_hit, cart_hit, dddsigma)
- dddsigma = dddsigma * boost
- if (d_rnd*mean < dddsigma) then
- exit MC
- end if
- end do MC
- if (mean < dddsigma) then
- call this%confirm_hit (hyp_hit, region, slice, subprocess, .true.)
- else
- call this%confirm_hit (hyp_hit, region, slice, subprocess, .false.)
- end if
- end subroutine sample_int_kind_mcgenerate_hit
-
-@ %def sample_int_kind_mcgenerate_hit
-@
-<<Muli MC int: sample int: TBP>>=
- procedure :: sample_int_kind_confirm_hit
- generic :: confirm_hit => sample_int_kind_confirm_hit
-<<Muli MC int: procedures>>=
- subroutine sample_int_kind_confirm_hit &
- (this, hit, region, slice, subprocess, over)
- class(sample_int_kind_t), intent(inout) :: this
- real(default), dimension(3), intent(in) :: hit
- integer, intent(in) :: region, slice, subprocess
- integer, dimension(:), allocatable :: tmp_hits
- logical, optional, intent(in) :: over
- this%n_hits = this%n_hits + 1
- if (present(over)) then
- if (over) then
- this%n_over = this%n_over + 1
- this%overall_boost = this%overall_boost / 1.1_default
- else
- this%overall_boost = this%overall_boost * 1.0001_default
- end if
- end if
- if (0 < size(this%hits)) then
- if (this%n_hits > size(this%hits)) then
- call move_alloc (this%hits, tmp_hits)
- allocate (this%hits (2*size(tmp_hits)))
- this%hits (1:size(tmp_hits)) = tmp_hits
- end if
- this%hits(this%n_hits) = subprocess
- end if
- this%weights(subprocess) = this%weights(subprocess) + 1
- call sample_3d_confirm_hit (this, hit, region, slice)
- end subroutine sample_int_kind_confirm_hit
-
-@ %def sample_int_kind_confirm_hit
-@
-<<Muli MC int: sample int: TBP>>=
- procedure :: analyse => sample_int_kind_analyse
-<<Muli MC int: procedures>>=
- subroutine sample_int_kind_analyse (this, dir, prefix)
- class(sample_int_kind_t), intent(in) :: this
- character(*), intent(in) :: dir, prefix
- integer :: slices_unit, subprocs_unit
- integer :: n, slice
- character(3) :: slice_name
- integer, dimension(:), allocatable :: int_a
- real(default), dimension(:), allocatable :: real_a
- call generate_unit (slices_unit)
- print *, "sample_int_kind_analyse: ", dir // "/" // prefix // &
- "slice_distribution.plot"
- open (slices_unit, file=dir // "/" // prefix // "slice_distribution.plot")
- call generate_unit (subprocs_unit)
- print *, "sample_int_kind_analyse: ", dir // "/" // prefix // &
- "subproc_distribution.plot"
- open (subprocs_unit, file=dir // "/" // prefix // &
- "subproc_distribution.plot")
- allocate (real_a (this%n_slices))
- allocate (int_a (this%n_slices))
- do n = 1, this%n_slices
- real_a(n) = this%slices(n)%range(1)
- end do
- call misc_sort (real_a, int_a)
- do n = 1, size (this%weights)
- if (this%n_hits > 0) then
- write (subprocs_unit, fmt=*) real(this%weights(n)), &
- real(this%weights(n)+1) / this%n_hits
- else
- write (subprocs_unit, fmt=*) 0, 0
- end if
- end do
- do n = 1, this%n_slices
- slice = int_a (n)
- call integer_with_leading_zeros (n, 3, slice_name)
- call sample_2d_analyse (this%slices(slice), dir, prefix // &
- slice_name // ".plot")
- print *, this%n_hits, this%slices(slice)%range(2) - &
- this%slices(slice)%range(1)
- if (this%n_hits > 0) then
- write (slices_unit, *) this%slices(slice)%range(1), &
- this%slices(slice)%range(2), this%slices(slice)%n_hits, &
- real (this%slices(slice)%n_hits) / (this%n_hits * &
- (this%slices(slice)%range(2) - this%slices(slice)%range(1)))
- else
- write (slices_unit, *) this%slices(slice)%range(1), &
- this%slices(slice)%range(2), this%slices(slice)%n_hits, zero
- end if
- end do
- write (slices_unit, *) one, zero, zero, zero
- close (slices_unit)
- close (subprocs_unit)
- end subroutine sample_int_kind_analyse
-
-@ %def sample_int_kind_analyse
-@
-<<Muli MC int: public>>=
- public :: sample_inclusive_t
-<<Muli MC int: types>>=
- type, extends (ser_class_t) :: sample_inclusive_t
- integer :: n_alloc = 0
- integer(kind=i64) :: n_tries_sum = i_zero
- integer(kind=i64) :: n_over_sum = i_zero
- integer(kind=i64) :: n_hits_sum = i_zero
- type(sample_int_kind_t), dimension(:), allocatable :: int_kinds
- contains
- <<Muli MC int: sample inclusive: TBP>>
- end type sample_inclusive_t
-
-@ %def sample_inclusive_t
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: write_to_marker => sample_inclusive_write_to_marker
-<<Muli MC int: procedures>>=
- subroutine sample_inclusive_write_to_marker (this, marker, status)
- class(sample_inclusive_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- integer :: n
- call marker%mark_begin ("sample_inclusive_t")
- call marker%mark ("n_alloc", this%n_alloc)
- if (allocated (this%int_kinds)) then
- call marker%mark_begin (tag="int_kinds", shape=shape(this%int_kinds))
- do n = 1, size(this%int_kinds)
- call this%int_kinds(n)%write_to_marker (marker, status)
- end do
- call marker%mark_instance_end ()
- else
- call marker%mark_empty (tag="int_kinds", shape=[0])
- end if
- call marker%mark_end ("sample_inclusive_t")
- end subroutine sample_inclusive_write_to_marker
-
-@ %def sample_inclusive_write_to_marker
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: read_from_marker => sample_inclusive_read_from_marker
-<<Muli MC int: procedures>>=
- subroutine sample_inclusive_read_from_marker (this, marker, status)
- class(sample_inclusive_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- integer :: n
- integer, dimension(:), allocatable :: s
- call marker%pick_begin ("sample_inclusive_t", status=status)
- call marker%pick ("n_alloc", this%n_alloc, status)
- call marker%pick_begin ("int_kinds", shape=s, status=status)
- if (s(1) > 0) then
- do n = 1, size(this%int_kinds)
- call this%int_kinds(n)%read_from_marker (marker, status)
- end do
- call marker%pick_end ("int_kinds",status)
- end if
- call marker%pick_end ("sample_inclusive_t", status)
- end subroutine sample_inclusive_read_from_marker
-
-@ %def sample_inclusive_read_from_marker
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: print_to_unit => sample_inclusive_print_to_unit
-<<Muli MC int: procedures>>=
- subroutine sample_inclusive_print_to_unit (this, unit, parents, components, peers)
- class(sample_inclusive_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- integer :: n
- write (unit, "(1x,A)") "components of sample_inclusive_t"
- write (unit, "(3x,A,I10)") "n_alloc: ", this%n_alloc
- if (allocated (this%int_kinds)) then
- if (components > 0) then
- write (unit, "(3x,A)") "int_kinds:"
- do n = 1, this%n_alloc
- call this%int_kinds(n)%print_to_unit &
- (unit, parents, components-1, peers)
- end do
- else
- write (unit, "(3x,A)") "skipping int_kinds."
- end if
- else
- write (unit, "(3x,A)") "int_kinds are not allocated."
- end if
- end subroutine sample_inclusive_print_to_unit
-
-@ %def sample_inclusive_print_to_unit
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure, nopass :: get_type => sample_inclusive_get_type
-<<Muli MC int: procedures>>=
- pure subroutine sample_inclusive_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source = "sample_inclusive_t")
- end subroutine sample_inclusive_get_type
-
-@ %def sample_inclusive_get_type
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: process_id => sample_inclusive_process_id
-<<Muli MC int: procedures>>=
- elemental integer function sample_inclusive_process_id &
- (this, subprocess, int_kind)
- class(sample_inclusive_t), intent(in) :: this
- integer, intent(in) :: subprocess, int_kind
- sample_inclusive_process_id = &
- this%int_kinds(int_kind)%processes (subprocess)
- end function sample_inclusive_process_id
-
-@ %def sample_inclusive_process_id
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: initialize => sample_inclusive_initialize
-<<Muli MC int: procedures>>=
- subroutine sample_inclusive_initialize &
- (this, n_alloc, sizes, processes, overall_boost)
- class(sample_inclusive_t), intent(out) :: this
- integer, intent(in) :: n_alloc
- integer, dimension(:), intent(in) :: sizes, processes
- real(default), optional, intent(in) :: overall_boost
- integer :: n, sum
- this%n_tries_sum = i_zero
- this%n_over_sum = 0
- this%n_alloc = size(sizes)
- if (allocated(this%int_kinds)) deallocate (this%int_kinds)
- allocate (this%int_kinds (this%n_alloc))
- sum = 0
- do n = 1, this%n_alloc
- call this%int_kinds(n)%initialize (n_alloc, &
- processes(sum+1:sum+sizes(n)), overall_boost)
- sum = sum + sizes(n)
- end do
- end subroutine sample_inclusive_initialize
-
-@ %def sample_inclusive_initialize
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: finalize => sample_inclusive_finalize
-<<Muli MC int: procedures>>=
- subroutine sample_inclusive_finalize (this)
- class(sample_inclusive_t), intent(inout) :: this
- deallocate (this%int_kinds)
- this%n_alloc = 0
- end subroutine sample_inclusive_finalize
-
-@ %def sample_inclusive_finalize
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: generate_hit => sample_inclusive_generate_hit
-<<Muli MC int: procedures>>=
- pure subroutine sample_inclusive_generate_hit &
- (this, rnd, pts2, int_kind, hit, region, boost, slice, process)
- class(sample_inclusive_t), intent(in) :: this
- integer, dimension(4), intent(in) :: rnd
- real(default), intent(in) :: pts2
- integer, intent(in) :: int_kind
- real(default), dimension(3), intent(out) :: hit
- integer, intent(out) :: region, slice, process
- real(default), intent(out) :: boost
- call this%int_kinds(int_kind)%generate_hit &
- (rnd, pts2, boost, hit, region, slice, process)
- end subroutine sample_inclusive_generate_hit
-
-@ %def sample_inclusive_generate_hit
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: mcgenerate_hit => sample_inclusive_mcgenerate_hit
-<<Muli MC int: procedures>>=
- subroutine sample_inclusive_mcgenerate_hit &
- (this, pts2, mean, integrand_kind, tao_rnd, process_id, cart_hit)
- class(sample_inclusive_t), intent(inout) :: this
- real(default), intent(in) :: pts2, mean
- integer, intent(in) :: integrand_kind
- type(tao_random_state), intent(inout) :: tao_rnd
- real(default), dimension(3), intent(out) :: cart_hit
- integer, intent(out) :: process_id
- ! print *, "sample_inclusive_mcgenerate_hit &
- ! (this,",pts2,mean,integrand_kind,process_id,cart_hit,")"
- ! print *, allocated (this%int_kinds)
- call sample_int_kind_mcgenerate_hit (this%int_kinds(integrand_kind), &
- pts2, mean, integrand_kind, tao_rnd, process_id, cart_hit)
- end subroutine sample_inclusive_mcgenerate_hit
-
-@ %def sample_inclusive_mcgenerate_hit
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: confirm_hit => sample_inclusive_confirm_hit
-<<Muli MC int: procedures>>=
- subroutine sample_inclusive_confirm_hit &
- (this, hit, int_kind, region, slice, process, over)
- class(sample_inclusive_t), intent(inout) :: this
- real(default), dimension(3), intent(in) :: hit
- integer, intent(in) :: int_kind, region, slice, process
- logical, optional, intent(in) :: over
- call this%int_kinds(int_kind)%confirm_hit &
- (hit, region, slice, process, over)
- end subroutine sample_inclusive_confirm_hit
-
-@ %def sample_inclusive_confirm_hit
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: sum_up => sample_inclusive_sum_up
-<<Muli MC int: procedures>>=
- subroutine sample_inclusive_sum_up (this)
- class(sample_inclusive_t), intent(inout) :: this
- integer :: n
- this%n_tries_sum = i_zero
- this%n_hits_sum = i_zero
- this%n_over_sum = i_zero
- do n = 1, this%n_alloc
- this%n_tries_sum = this%n_tries_sum+this%int_kinds(n)%n_tries
- this%n_hits_sum = this%n_hits_sum+this%int_kinds(n)%n_hits
- this%n_over_sum = this%n_over_sum+this%int_kinds(n)%n_over
- end do
- end subroutine sample_inclusive_sum_up
-
-@ %def sample_inclusive_sum_up
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: analyse => sample_inclusive_analyse
-<<Muli MC int: procedures>>=
- subroutine sample_inclusive_analyse (this, dir, subdirs)
- class(sample_inclusive_t), intent(in) :: this
- character(*), intent(in) :: dir
- logical, intent(in) :: subdirs
- integer :: inclusive_unit
- integer :: n, n_hits
- character(2) :: sample_name
- call generate_unit (inclusive_unit)
- open (inclusive_unit, file = dir // "/int_kinds.plot")
- n_hits = 0
- do n = 1, size(this%int_kinds)
- n_hits = n_hits + this%int_kinds(n)%n_hits
- end do
- do n = 1, size(this%int_kinds)
- write (inclusive_unit, *) n, real(this%int_kinds(n)%n_hits) / n_hits
- call integer_with_leading_zeros (n, 2, sample_name)
- if (subdirs) then
- call sample_int_kind_analyse (this%int_kinds(n), &
- dir // "/" // sample_name, "")
- else
- call sample_int_kind_analyse (this%int_kinds(n), &
- dir, sample_name // "_")
- end if
- end do
- close (inclusive_unit)
- end subroutine sample_inclusive_analyse
-
-@ %def sample_inclusive_analyse
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: to_generator => sample_inclusive_to_generator
-<<Muli MC int: procedures>>=
- subroutine sample_inclusive_to_generator (this)
- class(sample_inclusive_t), intent(inout) :: this
- integer :: int_kind
- do int_kind = 1, size(this%int_kinds)
- call this%int_kinds(int_kind)%to_generator ()
- end do
- end subroutine sample_inclusive_to_generator
-
-@ %def sample_inclusive_to_generator
-@
-<<Muli MC int: sample inclusive: TBP>>=
- procedure :: allocate => sample_inclusive_allocate
-<<Muli MC int: procedures>>=
- subroutine sample_inclusive_allocate (this, n_alloc)
- class(sample_inclusive_t), intent(out) :: this
- integer, intent(in) :: n_alloc
- allocate (this%int_kinds (n_alloc))
- this%n_alloc = n_alloc
- end subroutine sample_inclusive_allocate
-
-@ %def sample_inclusive_allocate
-@
-<<Muli MC int: procedures>>=
- pure subroutine muli_mcint_generate_hit (rnd, corners, hit)
- real(default), dimension(2), intent(out) :: hit
- integer, intent(in), dimension(2) :: rnd
- real(default), dimension(2,2), intent(in) :: corners
- ! print *, hit
- ! print *, corners
- ! print *, (corners(1:2,2) - corners(1:2,1))
- hit = (rnd / max_d) * (corners(1:2,2) - corners(1:2,1)) + corners(1:2,1)
- end subroutine muli_mcint_generate_hit
-
-@ %def muli_mcint_generate_hit
-@
-<<Muli MC int: procedures>>=
- subroutine plot_pstvue3d (unit, corners, density)
- integer, intent(in) :: unit
- real(default), dimension(2,2), intent(in) :: corners
- real(default), intent(in) :: density
- real(default), dimension(2) :: width, mean
- real(default), dimension(3,3) :: plot
- width = (corners(:,2) - corners(:,1)) / two
- mean = (corners(:,1) + corners(:,2)) / two
- plot(1,1) = width(1)
- plot(2,1) = width(2)
- plot(3,1) = density / two
- plot(1,2) = mean(1)
- plot(2,2) = mean(2)
- plot(3,2) = density / two
- call log_color_code (density, plot(1:3,3))
- if (density > one) then
- write (unit, fmt='("\mybigcube{",F14.7,"}{",F14.7,"}{",F14.7,"} &
- & {",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"} &
- & {",F14.7,"}")') plot
- return
- end if
- write (unit, fmt='("\mycube{",F14.7,"}{",F14.7,"}{",F14.7,"} &
- & {",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"}{",F14.7,"} &
- & {",F14.7,"}")') plot
- end subroutine plot_pstvue3d
-
-@ %def plot_pstvue3d
-@
-<<Muli MC int: procedures>>=
- subroutine log_color_code (number, rgb)
- real(default), intent(in) :: number
- real(default), dimension(3), intent(out) :: rgb
- if (number < exp(-five)) then
- rgb = [zero, zero, exp(five)*number]
- else
- if (number < exp(-four)) then
- rgb = [zero, (number-exp(-five))/(exp(-four)-exp(-five)), one]
- else
- if (number < exp(-three)) then
- rgb = [zero, one, one-((number-exp(-four))/(exp(-three)-exp(-four)))]
- else
- if (number < exp(-two)) then
- rgb = [(number-exp(-three))/(exp(-two)-exp(-three)), one, zero]
- else
- if (number < exp(-one)) then
- rgb = [one, one-(number-exp(-two))/(exp(-one)-exp(-two)), zero]
- else
- if (number < one) then
- rgb = [one, zero, (number-exp(-three))/(one-exp(-three))]
- else
- rgb = [exp(one), one, one] * exp(-number)
- return
- end if
- end if
- end if
- end if
- end if
- end if
- end subroutine log_color_code
-
-@ %def log_color_code
-@
-<<Muli MC int: procedures>>=
- recursive subroutine misc_sort (in, out)
- real(default), dimension(:), intent(in) :: in
- integer, dimension(:), intent(out) :: out
- integer, dimension(:), allocatable :: tmp
- integer :: n, k, l, cut
- if (size(in) == 1) then
- out = [1]
- else
- if (size(in) == 2) then
- if (in(1) <= in(2)) then
- out = [1,2]
- else
- out = [2,1]
- end if
- else
- cut = size(in) / 2
- k = 1
- l = cut + 1
- allocate (tmp (size(in)))
- call misc_sort (in(1:cut), tmp(1:cut))
- call misc_sort (in(cut+1:), tmp(cut+1:))
- do n = cut + 1, size(in)
- tmp(n) = tmp(n) + cut
- end do
- do n = 1, size(in)
- if (k > cut) then
- out(n) = tmp(l)
- l = l + 1
- else
- if (l > size(tmp)) then
- out(n) = tmp(k)
- k = k + 1
- else
- if (in(tmp(k)) < in(tmp(l))) then
- out(n) = tmp(k)
- k = k + 1
- else
- out(n) = tmp(l)
- l = l + 1
- end if
- end if
- end if
- end do
- end if
- end if
- end subroutine misc_sort
-
-@ %def misc_sort
-@
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\section{Proton remnants}
-
-This file contains the module [[muli_remnant]]. All bookkeeping of the
-proton remnants and twin quarks is done here. Furthermore, reweighting of the
-PDFs to derive remnant PDFs is done here.
-
-<<[[muli_remnant.f90]]>>=
-<<File header>>
-
-module muli_remnant
- use, intrinsic :: iso_fortran_env
-<<Use kinds with double>>
-<<Use strings>>
- use string_utils
- use constants
- use diagnostics
- use pdf_builtin !NODEP!
- use tao_random_numbers !NODEP!
- use muli_base
- use muli_interactions
- use muli_momentum
-! use sf_lhapdf !NODEP!
-
-<<Standard module head>>
-
-<<Muli remnant: variables>>
-
-<<Muli remnant: public>>
-
-<<Muli remnant: types>>
-
-<<Muli remnant: interfaces>>
-
-contains
-
-<<Muli remnant: procedures>>
-
-end module muli_remnant
-
-@ %def muli_remnant
-@
-<<Muli remnant: public>>=
- public :: pdfnorm_t
-<<Muli remnant: types>>=
- type, extends (ser_class_t) :: pdfnorm_t
- real(default) :: qmin, qmax, dq
- real(default), dimension(-6:6, 0:nq) :: pdf_int
- real(default), dimension(0:4, 0:nq) :: pdf_norm
- contains
- <<Muli remnant: pdfnorm: TBP>>
- end type pdfnorm_t
-
-@ %def pdfnorm_t
-@
-<<Muli remnant: pdfnorm: TBP>>=
- procedure :: write_to_marker => pdfnorm_write_to_marker
-<<Muli remnant: procedures>>=
- subroutine pdfnorm_write_to_marker (this, marker, status)
- class(pdfnorm_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("pdfnorm_t")
- call marker%mark ("qmin", this%qmin)
- call marker%mark ("qmax", this%qmax)
- call marker%mark ("dq", this%dq)
- call marker%mark ("pdf_int", this%pdf_int)
- call marker%mark ("pdf_norm", this%pdf_norm)
- call marker%mark_end ("pdfnorm_t")
- end subroutine pdfnorm_write_to_marker
-
-@ %def pdfnorm_write_to_marker
-@
-<<Muli remnant: pdfnorm: TBP>>=
- procedure :: read_from_marker => pdfnorm_read_from_marker
-<<Muli remnant: procedures>>=
- subroutine pdfnorm_read_from_marker (this, marker, status)
- class(pdfnorm_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- character(:), allocatable :: name
- call marker%pick_begin ("pdfnorm_t", status=status)
- call marker%pick ("qmin", this%qmin, status)
- call marker%pick ("qmax", this%qmax, status)
- call marker%pick ("dq", this%dq, status)
- call marker%pick ("pdf_int", this%pdf_int, status)
- call marker%pick ("pdf_norm", this%pdf_norm, status)
- call marker%pick_end ("pdfnorm_t", status=status)
- end subroutine pdfnorm_read_from_marker
-
-@ %def pdfnorm_read_from_marker
-@
-<<Muli remnant: pdfnorm: TBP>>=
- procedure :: print_to_unit => pdfnorm_print_to_unit
-<<Muli remnant: procedures>>=
- recursive subroutine pdfnorm_print_to_unit &
- (this, unit, parents, components, peers)
- class(pdfnorm_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- write (unit, "(1x,A)") "Components of pdfnorm_t:"
- write (unit, "(3x,A,F7.6)") "qmin: ", this%qmin
- write (unit, "(3x,A,F7.6)") "qmax: ", this%qmax
- write (unit, "(3x,A,F7.6)") "dq: ", this%dq
- if (components > 0) then
- write(unit, "(3x,A,13(F8.6,1x))") "pdf_int: ", this%pdf_int
- write(unit, "(3x,A,5(F8.6,1x))") "pdf_norm: ", this%pdf_norm
- else
- write(unit, "(3x,A)") "Skipping pdf_int"
- write(unit, "(3x,A)") "Skipping pdf_norm"
- end if
- end subroutine pdfnorm_print_to_unit
-
-@ %def pdfnorm_print_to_unit
-@
-<<Muli remnant: procedures>>=
-@
-<<Muli remnant: pdfnorm: TBP>>=
- procedure, nopass :: get_type => pdfnorm_get_type
-<<Muli remnant: procedures>>=
- pure subroutine pdfnorm_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="pdfnorm_t")
- end subroutine pdfnorm_get_type
-
-@ %def pdfnorm_get_type
-@
-<<Muli remnant: pdfnorm: TBP>>=
- procedure, nopass :: verify_type => pdfnorm_verify_type
-<<Muli remnant: procedures>>=
- elemental logical function pdfnorm_verify_type (type) result (match)
- character(*), intent(in) :: type
- match = type == "pdfnorm_t"
- end function pdfnorm_verify_type
-
-@ %def pdfnorm_verify_type
-@
-<<Muli remnant: pdfnorm: TBP>>=
- procedure :: scan => pdfnorm_scan
-<<Muli remnant: procedures>>=
- subroutine pdfnorm_scan (this)
- class(pdfnorm_t), intent(out) :: this
- integer :: ix, iq
- real(double) :: xmin, xmax, dx
- real(double) :: q, q2min, q2max
- real(double), dimension(-6:6) :: f
- real(double), dimension(0:2) :: x
- call getxmin (0, xmin)
- call getxmax (0, xmax)
- call getq2min (0, q2min)
- call getq2max (0, q2max)
- this%qmin = sqrt(sqrt(q2min))
- this%qmax = sqrt(sqrt(q2max))
- this%dq = (this%qmax - this%qmin) / nq
- xmin = sqrt(xmin)
- xmax = sqrt(xmax)
- dx= (xmax - xmin) / nx
- do iq = 0, nq
- print *, "iq=", iq, "/", nq
- q = (this%qmin + iq * this%dq)**2
- x(0) = xmin**2
- x(1) = (xmin+dx)**2
- call evolvePDF (x(0), q, f)
- f(1) = f(1) - f(-1)
- f(2) = f(2) - f(-2)
- this%pdf_int(:,iq) = (x(1) - x(0)) * f
- do ix = 2, nx
- x(2) = (xmin + ix*dx)**2
- call evolvePDF (x(1), q, f)
- f(1) = f(1) - f(-1)
- f(2) = f(2) - f(-2)
- this%pdf_int(:,iq) = this%pdf_int(:,iq) + f*(x(2) - x(0))
- x(0) = x(1)
- x(1) = x(2)
- end do
- call evolvePDF (x(1), q, f)
- f(1) = f(1) - f(-1)
- f(2) = f(2) - f(-2)
- this%pdf_int(:,iq) = (this%pdf_int(:,iq) + f*(x(1)-x(0))) / two
- this%pdf_norm(4,iq) = this%pdf_int(2,iq)
- this%pdf_norm(3,iq) = this%pdf_int(1,iq)
- this%pdf_int(2,iq) = this%pdf_int(2,iq) + this%pdf_int(-2,iq)
- this%pdf_int(1,iq) = this%pdf_int(1,iq) + this%pdf_int(-1,iq)
- this%pdf_norm(1,iq) = this%pdf_int(0,iq)
- this%pdf_norm(2,iq) = sum (this%pdf_int(-6:-1,iq)) + &
- sum(this%pdf_int(-2:-1,iq)) + sum(this%pdf_int(3:6,iq))
- this%pdf_norm(0,iq) = sum(this%pdf_int(:,iq))
- this%pdf_norm(1,iq) = this%pdf_norm(1,iq) / this%pdf_norm(0,iq)
- this%pdf_norm(2,iq) = this%pdf_norm(2,iq) / this%pdf_norm(0,iq)
- this%pdf_norm(3,iq) = this%pdf_norm(3,iq) / this%pdf_norm(0,iq)
- this%pdf_norm(4,iq) = this%pdf_norm(4,iq) / this%pdf_norm(0,iq)
- ! print *, this%pdf_norm(0,iq) - one
- end do
- end subroutine pdfnorm_scan
-
-@ %def pdfnorm_scan
-@
-<<Muli remnant: pdfnorm: TBP>>=
- procedure :: get_norm => pdfnorm_get_norm
-<<Muli remnant: procedures>>=
- subroutine pdfnorm_get_norm (this, gev_q, dim, kind, norm)
- class(pdfnorm_t), intent(in) :: this
- real(default), intent(in) :: gev_q
- integer, intent(in) :: dim, kind
- real(default), intent(out)::norm
- integer :: iq
- real(default) :: x,q , z0, z1, z2, z3, z4
- norm = -one
- q = sqrt(gev_q) - this%qmin
- iq = floor(q / this%dq)
- x = q / this%dq - iq
- if (iq < 0) then
- print *, "pdfnorm_getnorm: q < q_min ", gev_q, this%qmin**2
- norm = this%pdf_norm (kind, 0)
- else
- if (iq >= nq) then
- print *, "pdfnorm_getnorm: q >= q_max ", gev_q, this%qmax**2
- norm = this%pdf_norm (kind, nq)
- else
- select case (dim)
- case (0)
- norm = this%pdf_norm (kind, iq)
- case (1)
- norm = this%pdf_norm(kind,iq) * (one - x) + &
- this%pdf_norm(kind,iq+1) * x
- case (2)
- x = x + mod(iq,2)
- iq = iq - mod(iq,2)
- z0 = this%pdf_norm(kind, iq)
- z1 = this%pdf_norm(kind, iq+1)
- z2 = this%pdf_norm(kind, iq+2)
- norm = ((z0 - 2D0*z1 + z2) * x - (three*z0 - four*z1 + z2)) * &
- x / two + z0
- case (3)
- x = x + mod(iq,3)
- iq = iq - mod(iq,3)
- z0 = this%pdf_norm(kind, iq)
- z1 = this%pdf_norm(kind, iq+1)
- z2 = this%pdf_norm(kind, iq+2)
- z3 = this%pdf_norm(kind, iq+3)
- norm = (( - (z0 - 3*z1 + 3*z2 -z3) * x + 3 * (2*z0 - &
- 5*z1 + 4*z2 - z3))*x - (11*z0 - 18*z1 + 9*z2 - 2*z3)) * &
- x / 6._default + z0
- case (4)
- x = x + mod(iq,4)
- iq = iq - mod(iq,4)
- z0 = this%pdf_norm(kind, iq)
- z1 = this%pdf_norm(kind, iq+1)
- z2 = this%pdf_norm(kind, iq+2)
- z3 = this%pdf_norm(kind, iq+3)
- z4 = this%pdf_norm(kind, iq+4)
- norm = (((((z0 - 4*z1 + 6*z2 - 4*z3 + z4) * x &
- -2 * (5*z0 - 18*z1 + 24*z2 - 14*z3 + 3*z4)) * x &
- + (35*z0 - 104*z1 + 114*z2 - 56*z3 + 11*z4)) * x &
- -2 * (25*z0 - 48*z1 + 36*z2 - 16*z3 + 3*z4)) * x) / &
- 24._default + z0
- case default
- norm = this%pdf_norm(kind, iq) * (one - x) + &
- this%pdf_norm(kind, iq+1) * x
- end select
- ! print *, iq, x, norm
- end if
- end if
- end subroutine pdfnorm_get_norm
-
-@ %def pdfnorm_get_norm
-@
-<<Muli remnant: variables>>=
- integer, parameter :: nx = 10000000
-<<Muli remnant: variables>>=
- integer, parameter :: nq = 60
-<<Muli remnant: public>>=
- public :: remnant_weight_model
-<<Muli remnant: variables>>=
- integer :: remnant_weight_model = 2
-<<Muli remnant: variables>>=
- integer :: gluon_exp = 4
-
-@ %def nx nq remnant_weight_model gluon_exp
-@
-<<Muli remnant: public>>=
- public :: muli_parton_t
-<<Muli remnant: types>>=
- type, extends (ser_class_t) :: muli_parton_t
- private
- integer :: id = -1
- integer :: lha_flavor
- real(default) :: momentum = -1
- class(muli_parton_t), pointer :: twin => null()
- class(muli_parton_t), pointer :: next => null()
- contains
- <<Muli remnant: muli parton: TBP>>
- end type muli_parton_t
-
-@ %def muli_parton_t
-@
-<<Muli remnant: muli parton: TBP>>=
- procedure :: write_to_marker => parton_write_to_marker
-<<Muli remnant: procedures>>=
- subroutine parton_write_to_marker (this, marker, status)
- class(muli_parton_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("muli_parton_t")
- call marker%mark ("id", this%id)
- call marker%mark ("lha", this%lha_flavor)
- call marker%mark ("momentum", this%momentum)
- call marker%mark_end ("muli_parton_t")
- end subroutine parton_write_to_marker
-
-@ %def parton_write_to_marker
-@
-<<Muli remnant: muli parton: TBP>>=
- procedure :: read_from_marker => parton_read_from_marker
-<<Muli remnant: procedures>>=
- subroutine parton_read_from_marker (this, marker, status)
- class(muli_parton_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- character(:), allocatable :: name
- call marker%pick_begin ("muli_parton_t", status=status)
- call marker%pick ("id", this%id, status)
- call marker%pick ("lha", this%lha_flavor, status)
- call marker%pick ("momentum", this%momentum, status)
- call marker%pick_end ("muli_parton_t", status=status)
- end subroutine parton_read_from_marker
-
-@ %def parton_read_from_marker
-@
-<<Muli remnant: muli parton: TBP>>=
- procedure :: print_to_unit => parton_print_to_unit
-<<Muli remnant: procedures>>=
- recursive subroutine parton_print_to_unit &
- (this, unit, parents, components, peers)
- class(muli_parton_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- class(ser_class_t), pointer :: ser
- write (unit, "(1x,A)") "Components of muli_parton_t:"
- write (unit, "(3x,A,I7)") "id: ", this%id
- write (unit, "(3x,A,I7)") "lha flavor: ", this%lha_flavor
- write (unit, "(3x,A,F7.6)") "momentum: ", this%momentum
- ser => this%next
- call serialize_print_peer_pointer &
- (ser, unit, parents, components, peers-i_one, "next")
- ser => this%twin
- call serialize_print_comp_pointer &
- (ser, unit, parents, components, peers-i_one, "twin")
- end subroutine parton_print_to_unit
-
-@ %def parton_print_to_unit
-@
-<<Muli remnant: muli parton: TBP>>=
- procedure, nopass :: get_type => parton_get_type
-<<Muli remnant: procedures>>=
- pure subroutine parton_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="muli_parton_t")
- end subroutine parton_get_type
-
-@ %def parton_get_type
-@
-<<Muli remnant: muli parton: TBP>>=
- procedure :: unweighted_pdf => twin_unweighted_pdf
-<<Muli remnant: procedures>>=
- pure function twin_unweighted_pdf (this, momentum_fraction) result (pdf)
- !parton pdf
- class(muli_parton_t), intent(in) :: this
- real(default), intent(in) :: momentum_fraction
- real(default) :: pdf
- if (momentum_fraction + this%twin%momentum < one) then
- pdf = remnant_twin_pdf_p (momentum_fraction, &
- this%twin%momentum, gluon_exp)
- else
- pdf = zero
- end if
- end function twin_unweighted_pdf
-
-@ %def twin_unweighted_pdf
-@
-<<Muli remnant: muli parton: TBP>>=
- procedure :: deallocate => twin_deallocate
-<<Muli remnant: procedures>>=
- recursive subroutine twin_deallocate (this)
- class(muli_parton_t) :: this
- if (associated (this%next)) then
- call this%next%deallocate
- deallocate (this%next)
- end if
- end subroutine twin_deallocate
-
-@ %def twin_deallocate
-@
-<<Muli remnant: muli parton: TBP>>=
- procedure :: push => parton_push
-<<Muli remnant: procedures>>=
- subroutine parton_push (this, parton)
- class(muli_parton_t), intent(inout) :: this
- class(muli_parton_t), intent(inout), pointer :: parton
- ! print *, "parton_push ", parton%id
- parton%next => this%next
- this%next => parton
- end subroutine parton_push
-
-@ %def parton_push
-@
-<<Muli remnant: muli parton: TBP>>=
- generic :: pop => pop_by_id, pop_by_association
- procedure :: pop_by_id => parton_pop_by_id
- procedure :: pop_by_association => parton_pop_by_association
-<<Muli remnant: procedures>>=
- subroutine parton_pop_by_id (this, id, parton)
- class(muli_parton_t), target, intent(inout) :: this
- integer, intent(in) :: id
- class(muli_parton_t), intent(out), pointer :: parton
- class(muli_parton_t), pointer :: tmp_parton
- tmp_parton => this
- do while (associated (tmp_parton%next))
- if (tmp_parton%next%id == id) exit
- tmp_parton => tmp_parton%next
- end do
- if (associated (tmp_parton%next)) then
- parton => tmp_parton%next
- tmp_parton%next => parton%next
- nullify (parton%next)
- ! print *,"parton_pop ",id,parton%id
- else
- nullify (parton)
- print *,"parton_pop ", id, "NULL"
- end if
- end subroutine parton_pop_by_id
-
-@ %def parton_pop_by_id
-@
-<<Muli remnant: procedures>>=
- subroutine parton_pop_by_association (this, parton)
- class(muli_parton_t), target, intent(inout) :: this
- class(muli_parton_t), intent(inout), target :: parton
- class(muli_parton_t), pointer :: tmp_parton
- tmp_parton => this
- do while (associated (tmp_parton%next))
- if (associated (tmp_parton%next, parton)) exit
- tmp_parton=>tmp_parton%next
- end do
- if (associated(tmp_parton%next)) then
- tmp_parton%next => parton%next
- nullify (parton%next)
- ! print *,"parton_pop ", parton%id
- else
- print *, "parton_pop NULL"
- end if
- end subroutine parton_pop_by_association
-
-@ %def parton_pop_by_association
-@
-<<Muli remnant: public>>=
- public :: proton_remnant_t
-<<Muli remnant: types>>=
- type, extends (ser_class_t) :: proton_remnant_t
- private
- integer, dimension(2) :: valence_content = [1,2]
- integer :: n_twins = 0
- !!! [gluon, sea quark, valence down, valence up, twin]
- real(default), dimension(5) :: pdf_int_weight = [one, one, one, one, one]
- real(default) :: momentum_fraction = one
- real(default) :: twin_norm = one
- type(muli_parton_t) :: twin_partons
- type(muli_parton_t) :: is_partons
- type(muli_parton_t) :: fs_partons
- !!! These pointers shall not be allocated, deallocated,
- !!! serialized or deserialized explicitly.
- class(pdfnorm_t), pointer :: pdf_norm => null()
- contains
- <<Muli remnant: proton remnant: TBP>>
- end type proton_remnant_t
-
-@ %def proton_remnant_t
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: remove_valence_quark => proton_remnant_remove_valence_quark
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_remove_valence_quark &
- (this, id, GeV_scale, momentum_fraction, lha_flavor)
- class(proton_remnant_t), intent(inout) :: this
- integer, intent(in) :: id
- real(default), intent(in) :: GeV_scale, momentum_fraction
- integer, intent(in) :: lha_flavor !!! d=1, u=2
- if (lha_flavor == 1 .or. lha_flavor == 2) then
- associate (q => this%valence_content (lha_flavor))
- if (q > 0) then
- q = q - 1
- call this%push_is_parton (id, lha_flavor, momentum_fraction)
- this%momentum_fraction = this%momentum_fraction * (one - momentum_fraction)
- call this%calculate_weight (GeV_scale)
- else
- write (*, "(1x,A,I2,A)") "proton_remnant_remove_valence_quark: " // &
- "Cannot remove parton ", lha_flavor, ": There are no such " // &
- "partons left."
- call this%print_all ()
- end if
- end associate
- else
- write (*, "(1x,A,I2,A)") "proton_remnant_remove_valence_quark: Cannot " // &
- "remove parton ", lha_flavor, ": There are no such valence partons."
- end if
- end subroutine proton_remnant_remove_valence_quark
-
-@ %def proton_remnant_remove_valence_quark
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: remove_sea_quark => proton_remnant_remove_sea_quark
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_remove_sea_quark &
- (this, id, GeV_scale, momentum_fraction, lha_flavor)
- class(proton_remnant_t), intent(inout) :: this
- integer, intent(in) :: id
- real(default), intent(in) :: GeV_scale, momentum_fraction
- integer, intent(in) :: lha_flavor
- ! print *, "proton_remnant_remove_sea_quark", momentum_fraction
- if (lha_flavor > -6 .and. lha_flavor < 6 .and. lha_flavor .ne. 0) then
- this%momentum_fraction = this%momentum_fraction * &
- (one - momentum_fraction)
- call this%push_twin (id, lha_flavor, momentum_fraction, GeV_scale)
- end if
- end subroutine proton_remnant_remove_sea_quark
-
-@ %def proton_remnant_remove_sea_quark
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: remove_gluon => proton_remnant_remove_gluon
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_remove_gluon &
- (this, id, GeV_scale, momentum_fraction)
- class(proton_remnant_t), intent(inout) :: this
- integer, intent(in) :: id
- real(default), intent(in) :: GeV_scale, momentum_fraction
- this%momentum_fraction = this%momentum_fraction * (one - momentum_fraction)
- call this%push_is_parton (id, LHA_FLAVOR_g, momentum_fraction)
- end subroutine proton_remnant_remove_gluon
-
-@ %def proton_remnant_remove_gluon
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: remove_valence_up_quark => proton_remnant_remove_valence_up_quark
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_remove_valence_up_quark &
- (this, id, GeV_scale, momentum_fraction)
- class(proton_remnant_t), intent(inout) :: this
- integer, intent(in) :: id
- real(default), intent(in) :: GeV_scale, momentum_fraction
- associate (q => this%valence_content (LHA_FLAVOR_u))
- if (q > 0) then
- q = q - 1
- call this%push_is_parton (id, LHA_FLAVOR_u, momentum_fraction)
- this%momentum_fraction = this%momentum_fraction * (one - momentum_fraction)
- call this%calculate_weight (GeV_scale)
- else
- write (*, "(1x,A,I2,A)") "proton_remnant_remove_valence_up_quark: " // &
- "Cannot remove parton ", LHA_FLAVOR_u, ": There are no such " // &
- "partons left."
- call this%print_all
- end if
- end associate
- end subroutine proton_remnant_remove_valence_up_quark
-
-@ %def proton_remnant_remove_valence_up_quark
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: remove_valence_down_quark => &
- proton_remnant_remove_valence_down_quark
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_remove_valence_down_quark &
- (this, id, GeV_scale, momentum_fraction)
- class(proton_remnant_t), intent(inout) :: this
- integer, intent(in) :: id
- real(default), intent(in) :: GeV_scale, momentum_fraction
- associate (q => this%valence_content(LHA_FLAVOR_d))
- if (q > 0) then
- q = q - 1
- call this%push_is_parton (id, LHA_FLAVOR_d, momentum_fraction)
- this%momentum_fraction = this%momentum_fraction * &
- (one - momentum_fraction)
- call this%calculate_weight (GeV_scale)
- else
- write (*, "(1x,A,I2,A)") "proton_remnant_remove_valence_down_quark:" // &
- "Cannot remove parton ", LHA_FLAVOR_d, ": There are no " // &
- "such partons left."
- call this%print_all
- end if
- end associate
- end subroutine proton_remnant_remove_valence_down_quark
-
-@ %def proton_remnant_remove_valence_down_quark
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: remove_twin => proton_remnant_remove_twin
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_remove_twin (this, id, GeV_scale)
- class(proton_remnant_t), intent(inout) :: this
- integer, intent(in) :: id
- real(default), intent(in) :: GeV_scale
- class(muli_parton_t), pointer :: twin
- call this%twin_partons%pop (id, twin)
- call this%fs_partons%push (twin)
- this%twin_norm = this%twin_norm - twin%momentum
- this%n_twins = this%n_twins - 1
- call this%calculate_weight (GeV_scale)
- end subroutine proton_remnant_remove_twin
-
-@ %def proton_remnant_remove_twin
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: momentum_twin_pdf => proton_remnant_momentum_twin_pdf
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_momentum_twin_pdf &
- (this, lha_flavor, momentum_fraction,pdf)
- class(proton_remnant_t), intent(in) :: this
- integer, intent(in) :: lha_flavor
- real(default), intent(in) :: momentum_fraction
- real(default), intent(out) :: pdf
- call this%parton_twin_pdf (lha_flavor, momentum_fraction, pdf)
- pdf = pdf * momentum_fraction
- end subroutine proton_remnant_momentum_twin_pdf
-
-@ %def proton_remnant_momentum_twin_pdf
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: momentum_twin_pdf_array => proton_remnant_momentum_twin_pdf_array
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_momentum_twin_pdf_array &
- (this, momentum_fraction, pdf)
- class(proton_remnant_t), intent(in) :: this
- real(default), intent(in) :: momentum_fraction
- real(default), dimension(this%n_twins), intent(out) :: pdf
- call this%parton_twin_pdf_array (momentum_fraction, pdf)
- pdf = pdf * momentum_fraction
- end subroutine proton_remnant_momentum_twin_pdf_array
-
-@ %def proton_remnant_momentum_twin_pdf_array
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: momentum_kind_pdf => proton_remnant_momentum_kind_pdf
-<<Muli remnant: procedures>>=
-
- subroutine proton_remnant_momentum_kind_pdf (this, GeV_scale, &
- momentum_fraction, lha_flavor, valence_pdf, sea_pdf, twin_pdf)
- class(proton_remnant_t), intent(in) :: this
- real(default), intent(in) :: GeV_scale, momentum_fraction
- integer, intent(in) :: lha_flavor !!! g, u, d, etc.
- real(default), intent(out) :: valence_pdf, sea_pdf, twin_pdf
- real(double), dimension(-6:6) :: pdf_array
- call evolvePDF (dble (momentum_fraction), dble (GeV_scale), pdf_array)
- select case (lha_flavor)
- case (0) !!! gluon
- valence_pdf = zero
- sea_pdf=pdf_array(0)
- case (1) !!! down
- valence_pdf = this%get_valence_down_weight() * (pdf_array(1) - pdf_array(-1))
- sea_pdf = pdf_array(-1)
- case (2) !!! up
- valence_pdf = this%get_valence_up_weight() * (pdf_array(2) - pdf_array(-2))
- sea_pdf = pdf_array(-2)
- case default
- valence_pdf = zero
- sea_pdf = pdf_array (lha_flavor)
- end select
- sea_pdf = sea_pdf * this%get_sea_weight()
- call this%momentum_twin_pdf (lha_flavor, momentum_fraction, twin_pdf)
- end subroutine proton_remnant_momentum_kind_pdf
-
-@ %def proton_remnant_momentum_kind_pdf
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: momentum_flavor_pdf => proton_remnant_momentum_flavor_pdf
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_momentum_flavor_pdf (this, GeV_scale, &
- momentum_fraction, lha_flavor, pdf)
- class(proton_remnant_t), intent(in) :: this
- real(default), intent(in) :: GeV_scale, momentum_fraction
- integer, intent(in) :: lha_flavor !!! g, u, d, etc.
- real(default), intent(out) :: pdf
- real(default) :: valence_pdf, sea_pdf, twin_pdf
- call this%momentum_kind_pdf (GeV_scale, momentum_fraction, &
- lha_flavor, valence_pdf, sea_pdf, twin_pdf)
- pdf = valence_pdf + sea_pdf + twin_pdf
- end subroutine proton_remnant_momentum_flavor_pdf
-
-@ %def proton_remnant_momentum_flavor_pdf
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: momentum_kind_pdf_array => &
- proton_remnant_momentum_kind_pdf_array
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_momentum_kind_pdf_array (this, GeV_scale, &
- momentum_fraction, valence_pdf, sea_pdf)
- class(proton_remnant_t), intent(in) :: this
- real(default), intent(in) :: GeV_scale, momentum_fraction
- real(default), dimension(2), intent(out) :: valence_pdf
- real(double), dimension(-6:6), intent(out) :: sea_pdf
- call evolvePDF (dble (momentum_fraction), dble (GeV_scale), sea_pdf)
- valence_pdf(1) = (sea_pdf(1) - sea_pdf(-1)) * &
- this%pdf_int_weight (PDF_VALENCE_DOWN)
- valence_pdf(2) = (sea_pdf(2) - sea_pdf(-2)) * &
- this%pdf_int_weight (PDF_VALENCE_UP)
- sea_pdf(1) = sea_pdf(-1)
- sea_pdf(2) = sea_pdf(-2)
- sea_pdf = sea_pdf * this%get_sea_weight()
- !!! no twin yet
- end subroutine proton_remnant_momentum_kind_pdf_array
-
-@ %def proton_remnant_momentum_kind_pdf_array
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: momentum_flavor_pdf_array => proton_remnant_momentum_flavor_pdf_array
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_momentum_flavor_pdf_array &
- (this, GeV_scale, momentum_fraction, pdf)
- class(proton_remnant_t), intent(in) :: this
- real(default), intent(in) :: GeV_scale, momentum_fraction
- real(double), dimension(-6:6), intent(out) :: pdf
- real(default), dimension(2) :: valence_pdf
- call this%momentum_kind_pdf_array &
- (GeV_scale, momentum_fraction, valence_pdf, pdf)
- pdf(1:2) = pdf(1:2) + valence_pdf
- !!! no twin yet
- end subroutine proton_remnant_momentum_flavor_pdf_array
-
-@ %def proton_remnant_momentum_flavor_pdf_array
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: parton_twin_pdf => proton_remnant_parton_twin_pdf
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_parton_twin_pdf &
- (this, lha_flavor, momentum_fraction, pdf)
- class(proton_remnant_t), intent(in) :: this
- integer, intent(in) :: lha_flavor
- real(default), intent(in) :: momentum_fraction
- real(default) :: pdf
- class(muli_parton_t), pointer :: tmp_twin
- pdf = 0D0
- tmp_twin => this%twin_partons%next
- do while (associated (tmp_twin))
- if (tmp_twin%lha_flavor == lha_flavor) pdf = pdf &
- + tmp_twin%unweighted_pdf (momentum_fraction)
- tmp_twin => tmp_twin%next
- end do
- pdf = pdf * this%get_twin_weight ()
- end subroutine proton_remnant_parton_twin_pdf
-
-@ %def proton_remnant_parton_twin_pdf
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: parton_twin_pdf_array => proton_remnant_parton_twin_pdf_array
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_parton_twin_pdf_array &
- (this, momentum_fraction, pdf)
- class(proton_remnant_t), intent(in) :: this
- real(default), intent(in) :: momentum_fraction
- real(default), dimension(this%n_twins), intent(out) :: pdf
- class(muli_parton_t), pointer :: tmp_twin
- integer :: l
- tmp_twin => this%twin_partons%next
- l = 0
- do while (associated (tmp_twin))
- l = l + 1
- pdf(l) = tmp_twin%unweighted_pdf (momentum_fraction) * this%twin_norm
- tmp_twin => tmp_twin%next
- end do
- end subroutine proton_remnant_parton_twin_pdf_array
-
-@ %def proton_remnant_parton_twin_pdf_array
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: parton_kind_pdf => proton_remnant_parton_kind_pdf
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_parton_kind_pdf (this, GeV_scale, momentum_fraction, &
- lha_flavor, valence_pdf, sea_pdf, twin_pdf)
- class(proton_remnant_t), intent(in) :: this
- real(default), intent(in) :: GeV_scale, momentum_fraction
- integer, intent(in) :: lha_flavor !!! g, u, d, etc.
- real(default), intent(out) :: valence_pdf, sea_pdf, twin_pdf
- call this%momentum_kind_pdf (GeV_scale, momentum_fraction, &
- lha_flavor, valence_pdf, sea_pdf, twin_pdf)
- valence_pdf = valence_pdf / momentum_fraction
- sea_pdf = sea_pdf / momentum_fraction
- twin_pdf = twin_pdf / momentum_fraction
- end subroutine proton_remnant_parton_kind_pdf
-
-@ %def proton_remnant_parton_kind_pdf
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: parton_flavor_pdf => proton_remnant_parton_flavor_pdf
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_parton_flavor_pdf (this, GeV_scale, &
- momentum_fraction, lha_flavor, pdf)
- class(proton_remnant_t), intent(in) :: this
- real(default), intent(in) :: GeV_scale, momentum_fraction
- integer, intent(in) :: lha_flavor !g,u,d,etc.
- real(default), intent(out) :: pdf
- call this%momentum_flavor_pdf (GeV_scale, momentum_fraction, &
- lha_flavor, pdf)
- pdf = pdf / momentum_fraction
- end subroutine proton_remnant_parton_flavor_pdf
-
-@ %def proton_remnant_parton_flavor_pdf
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: parton_kind_pdf_array => proton_remnant_parton_kind_pdf_array
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_parton_kind_pdf_array &
- (this, GeV_scale, momentum_fraction, valence_pdf, sea_pdf)
- class(proton_remnant_t), intent(in) :: this
- real(default), intent(in) :: GeV_scale, momentum_fraction
- real(default), dimension(2), intent(out) :: valence_pdf
- real(double), dimension(-6:6), intent(out) :: sea_pdf
- call evolvePDF (dble (momentum_fraction), dble (GeV_scale), sea_pdf)
- sea_pdf = sea_pdf / momentum_fraction
- valence_pdf(1) = (sea_pdf(1) - sea_pdf(-1)) * this%valence_content(1)
- valence_pdf(2) = (sea_pdf(2) - sea_pdf(-2)) * (this%valence_content(2) / two)
- sea_pdf(1) = sea_pdf(-1)
- sea_pdf(2) = sea_pdf(-2)
- valence_pdf = valence_pdf * this%get_valence_weight()
- sea_pdf = sea_pdf * this%get_sea_weight()
- !!! no twin yet
- end subroutine proton_remnant_parton_kind_pdf_array
-
-@ %def proton_remnant_parton_kind_pdf_array
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: parton_flavor_pdf_array => proton_remnant_parton_flavor_pdf_array
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_parton_flavor_pdf_array &
- (this, GeV_scale, momentum_fraction, pdf)
- class(proton_remnant_t), intent(in) :: this
- real(default), intent(in) :: GeV_scale, momentum_fraction
- real(double), dimension(-6:6), intent(out) :: pdf
- real(double), dimension(2) :: valence_pdf
- real(double), dimension(-6:6) :: twin_pdf
- call msg_error ("proton_remnant_flavor_pdf_array: Not yet implemented.")
- end subroutine proton_remnant_parton_flavor_pdf_array
-
-@ %def proton_remnant_parton_flavor_pdf_array
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: get_pdf_int_weight => proton_remnant_get_pdf_int_weight
-<<Muli remnant: procedures>>=
- pure function proton_remnant_get_pdf_int_weight (this) result(weight)
- class(proton_remnant_t), intent(in) :: this
- real(default), dimension(5) :: weight
- weight = this%pdf_int_weight
- end function proton_remnant_get_pdf_int_weight
-
-@ %def proton_remnant_get_pdf_int_weight
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: get_valence_down_weight => proton_remnant_get_valence_down_weight
-<<Muli remnant: procedures>>=
- elemental function proton_remnant_get_valence_down_weight (this) result (weight)
- class(proton_remnant_t), intent(in) :: this
- real(default) :: weight
- weight = this%pdf_int_weight (PDF_VALENCE_DOWN)
- end function proton_remnant_get_valence_down_weight
-
-@ %def proton_remnant_get_valence_down_weight
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: get_valence_up_weight => proton_remnant_get_valence_up_weight
-<<Muli remnant: procedures>>=
- elemental function proton_remnant_get_valence_up_weight (this) result (weight)
- class(proton_remnant_t), intent(in) :: this
- real(default) :: weight
- weight = this%pdf_int_weight (PDF_VALENCE_UP)
- end function proton_remnant_get_valence_up_weight
-
-@ %def proton_remnant_get_valence_up_weight
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: get_valence_weight => proton_remnant_get_valence_weight
-<<Muli remnant: procedures>>=
- pure function proton_remnant_get_valence_weight (this) result (weight)
- class(proton_remnant_t), intent(in) :: this
- real(default), dimension(2) :: weight
- weight = this%pdf_int_weight(3:4)
- end function proton_remnant_get_valence_weight
-
-@ %def proton_remnant_get_valence_weight
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: get_gluon_weight => proton_remnant_get_gluon_weight
-<<Muli remnant: procedures>>=
- elemental function proton_remnant_get_gluon_weight (this) result (weight)
- class(proton_remnant_t), intent(in) :: this
- real(default) :: weight
- weight = this%pdf_int_weight (PDF_GLUON)
- end function proton_remnant_get_gluon_weight
-
-@ %def proton_remnant_get_gluon_weight
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: get_sea_weight => proton_remnant_get_sea_weight
-<<Muli remnant: procedures>>=
- elemental function proton_remnant_get_sea_weight (this) result (weight)
- class(proton_remnant_t), intent(in) :: this
- real(default) :: weight
- weight = this%pdf_int_weight (PDF_SEA)
- end function proton_remnant_get_sea_weight
-
-@ %def proton_remnant_get_sea_weight
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: get_twin_weight => proton_remnant_get_twin_weight
-@
-<<Muli remnant: procedures>>=
- elemental function proton_remnant_get_twin_weight (this) result (weight)
- class(proton_remnant_t), intent(in) :: this
- real(default) :: weight
- weight = this%pdf_int_weight (PDF_TWIN)
- end function proton_remnant_get_twin_weight
-
-@ %def proton_remnant_get_twin_weight
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: get_valence_content => proton_remnant_get_valence_content
-<<Muli remnant: procedures>>=
- pure function proton_remnant_get_valence_content (this) result (valence)
- class(proton_remnant_t), intent(in) :: this
- integer, dimension(2) :: valence
- valence = this%valence_content
- end function proton_remnant_get_valence_content
-
-@ %def proton_remnant_get_valence_content
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: get_momentum_fraction => proton_remnant_get_momentum_fraction
-<<Muli remnant: procedures>>=
- elemental function proton_remnant_get_momentum_fraction (this) result (momentum)
- class(proton_remnant_t), intent(in) :: this
- real(default) :: momentum
- momentum = this%momentum_fraction
- end function proton_remnant_get_momentum_fraction
-
-@ %def proton_remnant_get_momentum_fraction
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: deallocate => proton_remnant_deallocate
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_deallocate (this)
- class(proton_remnant_t), intent(inout) :: this
- call this%is_partons%deallocate
- call this%fs_partons%deallocate
- call this%twin_partons%deallocate
- this%twin_norm = zero
- this%n_twins = 0
- end subroutine proton_remnant_deallocate
-
-@ %def proton_remnant_deallocate
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: initialize => proton_remnant_initialize
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_initialize (this, pdf_norm)
- class(proton_remnant_t), intent(out) :: this
- class(pdfnorm_t),target, intent(in) :: pdf_norm
- this%pdf_norm => pdf_norm
- end subroutine proton_remnant_initialize
-
-@ %def proton_remnant_initialize
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: finalize => proton_remnant_finalize
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_finalize (this)
- class(proton_remnant_t), intent(inout) :: this
- call this%deallocate ()
- nullify (this%pdf_norm)
- end subroutine proton_remnant_finalize
-
-@ %def proton_remnant_finalize
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: apply_initial_splitting => proton_remnant_apply_initial_splitting
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_apply_initial_splitting &
- (this, id, pdg_flavor, x, gev_scale, rnd)
- class(proton_remnant_t), intent(inout) :: this
- integer, intent(in) :: id, pdg_flavor
- real(default), intent(in) :: x, gev_scale, rnd
- real(default) :: valence_pdf, sea_pdf, twin_pdf
- select case (pdg_flavor)
- case (PDG_FLAVOR_g)
- call this%remove_gluon (id, gev_scale, x)
- case (PDG_FLAVOR_u)
- call this%parton_kind_pdf (gev_scale, x, pdg_flavor, &
- valence_pdf, sea_pdf, twin_pdf)
- if (valence_pdf / (valence_pdf + sea_pdf) < rnd) then
- call this%remove_sea_quark (id, gev_scale, x, pdg_flavor)
- else
- call this%remove_valence_up_quark (id, gev_scale, x)
- end if
- case (PDG_FLAVOR_d)
- call this%parton_kind_pdf (gev_scale, x, &
- pdg_flavor, valence_pdf, sea_pdf, twin_pdf)
- if (valence_pdf / (valence_pdf + sea_pdf) < rnd) then
- call this%remove_sea_quark (id, gev_scale, x, pdg_flavor)
- else
- call this%remove_valence_down_quark (id, gev_scale, x)
- end if
- case default
- call this%remove_sea_quark (id, gev_scale, x, pdg_flavor)
- end select
- this%momentum_fraction = (one - x)
- end subroutine proton_remnant_apply_initial_splitting
-
-@ %def proton_remnant_apply_initial_splitting
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: reset => proton_remnant_reset
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_reset (this)
- class(proton_remnant_t), intent(inout) :: this
- call this%deallocate ()
- this%valence_content = [1, 2]
- this%pdf_int_weight = [one, one, one, one, one]
- this%momentum_fraction = one
- end subroutine proton_remnant_reset
-
-@ %def proton_remnant_reset
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: calculate_weight => proton_remnant_calculate_weight
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_calculate_weight (this, GeV_scale)
- class(proton_remnant_t), intent(inout) :: this
- real(default), intent(in) :: GeV_scale
- real(default) :: all, gluon, sea, vu, vd, valence, twin, weight
- call this%pdf_norm%get_norm (GeV_scale, 1, 0, all)
- call this%pdf_norm%get_norm (GeV_scale, 1, PDF_GLUON, gluon)
- call this%pdf_norm%get_norm (GeV_scale, 1, PDF_SEA, sea)
- call this%pdf_norm%get_norm (GeV_scale, 1, PDF_VALENCE_DOWN, vd)
- call this%pdf_norm%get_norm (GeV_scale, 1, PDF_VALENCE_UP, vu)
- valence = vd * this%valence_content (LHA_FLAVOR_d) + &
- vu * this%valence_content (LHA_FLAVOR_u) / two
- twin = this%twin_norm / all
- ! print *, all, gluon + sea + valence + twin, gluon, sea, valence, twin
- ! pdf_rescale = (one - n_d_valence * mean_d1 - n_u_valence * mean_u2) / &
- ! (1.E-1_default * mean_d1 - two * mean_u2) !!! pythia
- select case (remnant_weight_model)
- case (0) !!! no reweighting
- this%pdf_int_weight = [one, one, one, one, one]
- case (2) !!! pythia-like, only sea
- weight = (one - valence - twin) / (sea + gluon)
- this%pdf_int_weight = [weight, weight, one, one, one]
- case (3) !!! only valence and twin
- weight = (one - sea - gluon) / (valence + twin)
- this%pdf_int_weight = [one, one, weight, weight, weight]
- case (4) !!! only sea and twin
- weight = (one - valence) / (sea + gluon + twin)
- this%pdf_int_weight = [one, weight, one, one, weight]
- case default !!! equal weight
- weight = one / (valence + sea + gluon + twin)
- this%pdf_int_weight = [weight, weight, weight, weight, weight]
- end select
- this%pdf_int_weight(PDF_VALENCE_DOWN) = &
- this%pdf_int_weight(PDF_VALENCE_DOWN) * this%valence_content(1)
- this%pdf_int_weight(PDF_VALENCE_UP) = &
- this%pdf_int_weight(PDF_VALENCE_UP) * this%valence_content(2) * &
- 5.E-1_default
- ! print('("New rescale factors are: ",2(I10),7(E14.7))'),&
- ! this%valence_content,&
- ! this%pdf_int_weight,&
- ! sea_norm,&
- ! valence_norm,&
- ! this%twin_norm
- end subroutine proton_remnant_calculate_weight
-
-@ %def proton_remnant_calculate_weight
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: push_is_parton => proton_remnant_push_is_parton
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_push_is_parton &
- (this, id, lha_flavor, momentum_fraction)
- class(proton_remnant_t), intent(inout) :: this
- integer, intent(in) :: id, lha_flavor
- real(default), intent(in) :: momentum_fraction
- class(muli_parton_t), pointer :: tmp_parton
- allocate (tmp_parton)
- tmp_parton%id = id
- tmp_parton%lha_flavor = lha_flavor
- tmp_parton%momentum = momentum_fraction
- call this%is_partons%push (tmp_parton)
- end subroutine proton_remnant_push_is_parton
-
-@ %def proton_remnant_push_is_parton
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: push_twin => proton_remnant_push_twin
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_push_twin &
- (this, id, lha_flavor, momentum_fraction, gev_scale)
- class(proton_remnant_t), intent(inout) :: this
- integer, intent(in) :: id, lha_flavor !!! of IS parton
- real(default), intent(in) :: momentum_fraction !!! of IS parton
- real(default), intent(in) :: GeV_scale
- class(muli_parton_t), pointer :: new_is, new_twin
- real(default) :: norm
- ! print *, "proton_remnant_push_twin", momentum_fraction
- allocate (new_is)
- allocate (new_twin)
- !!! IS initialization
- new_is%id = id
- new_is%lha_flavor = lha_flavor
- new_is%momentum = momentum_fraction
- new_is%twin => new_twin
- !!! twin initialization
- new_twin%id = -id
- new_twin%lha_flavor = -lha_flavor
- new_twin%momentum = remnant_twin_momentum_4 (momentum_fraction)
- new_twin%twin => new_is
- !!! remnant update
- this%n_twins = this%n_twins + 1
- this%twin_norm = this%twin_norm + new_twin%momentum
- call this%is_partons%push (new_is)
- call this%twin_partons%push (new_twin)
- call this%calculate_weight (GeV_scale)
- end subroutine proton_remnant_push_twin
-
-@ %def proton_remnant_push_twin
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: calculate_twin_norm => proton_remnant_calculate_twin_norm
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_calculate_twin_norm (this)
- class(proton_remnant_t), intent(inout) :: this
- class(muli_parton_t), pointer :: twin
- integer :: n
- if (associated (this%twin_partons%next)) then
- this%twin_norm = zero
- twin => this%twin_partons%next
- do while (associated (twin))
- this%twin_norm = this%twin_norm + twin%momentum
- twin => twin%next
- end do
- else
- this%twin_norm = zero
- end if
- end subroutine proton_remnant_calculate_twin_norm
-
-@ %def proton_remnant_calculate_twin_norm
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: replace_is_parton => proton_remnant_replace_is_parton
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_replace_is_parton &
- (this, old_id, new_id, pdg_f, x_proton, gev_scale)
- class(proton_remnant_t), intent(inout) :: this
- integer, intent(in) :: old_id, new_id, pdg_f
- real(default), intent(in) :: x_proton, gev_scale
- class(muli_parton_t), pointer :: old_is_parton
- integer :: lha_flavor
- real(default) :: momentum_fraction
- momentum_fraction = x_proton / this%momentum_fraction
- !!! convert PDG flavor numbers to LHA flavor numbers
- if (pdg_f == PDG_FLAVOR_g) then
- lha_flavor = LHA_FLAVOR_g
- else
- lha_flavor = pdg_f
- end if
- !!! we remove the old initial state parton from initial state stack.
- call this%is_partons%pop (old_id, old_is_parton)
- !!! this check has no physical meaning, it's just a check for consistency.
- if (associated (old_is_parton)) then
- !!! do we emit a gluon?
- if (lha_flavor == old_is_parton%lha_flavor) then
- !!! has the old initial state parton been a sea quark?
- if (associated (old_is_parton%twin)) then
- !!! the connection of the old IS parton with its twin was
- !!! provisional. We remove it now
- call this%twin_partons%pop (old_is_parton%twin)
- call this%fs_partons%push (old_is_parton%twin)
- this%n_twins = this%n_twins - 1
- !!! and generate a new initial state parton - twin pair.
- call this%push_twin &
- (new_id, lha_flavor, momentum_fraction, gev_scale)
- else
- !!! there is no twin, so we just insert the new initial state parton.
- call this%push_is_parton (new_id, lha_flavor, momentum_fraction)
- end if
- else
- ! we emit a quark. is this a g->qqbar splitting?
- if (lha_flavor==LHA_FLAVOR_g) then
- !!! we insert the new initial state gloun.
- call this%push_is_parton (new_id, lha_flavor, momentum_fraction)
- !!! has the old initial state quark got a twin?
- if (associated (old_is_parton%twin)) then
- !!! we assume that this twin is the second splitting particle.
- !!! so the twin becomes a final state particle now and
- !!! must be removed from the is stack.
- call this%remove_twin (-old_id, GeV_scale)
- else
- !!! the old initial state quark has been a valence quark.
- !!! what should we do now? is this splitting sensible at all?
- !!! we don't know but allow these splittings. The most trivial
- !!! treatment is to restore the former valence quark.
- this%valence_content (old_is_parton%lha_flavor) = &
- this%valence_content (old_is_parton%lha_flavor) + 1
- end if
- else
- !!! this is a q->qg splitting. the new initial state quark emits
- !!! the preceding initial state gluon. yeah, backward evolution is
- !!! confusing! the new initial state quark is not part of the
- !!! proton remnant any longer. how do we remove a quark from
- !!! the remnant? we add a conjugated twin parton and assume,
- !!! that this twin is created in a not yet resolved g->qqbar splitting.
- call this%push_twin (new_id, lha_flavor, momentum_fraction, gev_scale)
- end if
- end if
- !!! everything is done. what shall we do with the old initial state
- !!! parton? we don't need it any more but we store it anyway.
- call this%fs_partons%push (old_is_parton)
- !!! the new initial state parton has taken away momentum, so we update
- !!! the remnant momentum fraction.
- this%momentum_fraction = this%momentum_fraction * (1 - &
- momentum_fraction) / (1 - old_is_parton%momentum)
- else
- !!! this is a bug.
- print *, "proton_remnant_replace_is_parton: parton #", old_id, &
- " not found on ISR stack."
- if (associated (this%is_partons%next)) then
- print *, "actual content of isr stack:"
- call this%is_partons%next%print_peers ()
- else
- print *, "ISR stack is not associated."
- end if
- stop
- end if
- end subroutine proton_remnant_replace_is_parton
-
-@ %def proton_remnant_replace_is_parton
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: write_to_marker => proton_remnant_write_to_marker
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_write_to_marker (this, marker, status)
- class(proton_remnant_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("proton_remnant_t")
- call marker%mark ("valence_content", this%valence_content)
- call marker%mark ("momentum_fraction", this%momentum_fraction)
- call marker%mark ("pdf_int_weight", this%pdf_int_weight)
- call marker%mark_end ("proton_remnant_t")
- end subroutine proton_remnant_write_to_marker
-
-@ %def proton_remnant_write_to_marker
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: read_from_marker => proton_remnant_read_from_marker
-<<Muli remnant: procedures>>=
-
- subroutine proton_remnant_read_from_marker (this, marker, status)
- class(proton_remnant_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- character(:), allocatable :: name
- call marker%pick_begin ("proton_remnant_t", status=status)
- call marker%pick ("valence_content", this%valence_content, status)
- call marker%pick ("momentum_fraction", this%momentum_fraction, status)
- call marker%pick ("pdf_int_weight", this%pdf_int_weight, status)
- call marker%pick_end ("proton_remnant_t", status=status)
- end subroutine proton_remnant_read_from_marker
-
-@ %def proton_remnant_read_from_marker
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: print_to_unit => proton_remnant_print_to_unit
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_print_to_unit (this, unit, parents, components, peers)
- class(proton_remnant_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- write (unit, '("Components of proton_remnant_t:")')
- write (unit, '("Valence Content: ",I1,":",I1)')this&
- &%valence_content
- write (unit, "(1x,A,I1)") "N Twins: ", this%n_twins
- write (unit, "(1x,A,5(F7.3))") "INT weights [g,s,d,u,t] ", &
- this%pdf_int_weight
- write (unit, "(1x,A,F7.3)") "Total Momentum Fraction: ", &
- this%momentum_fraction
- write (unit, "(1x,A,F7.3)") "Twin Norm: ", this%twin_norm
- end subroutine proton_remnant_print_to_unit
-
-@ %def proton_remnant_print_to_unit
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure, nopass :: get_type => proton_remnant_get_type
-<<Muli remnant: procedures>>=
- pure subroutine proton_remnant_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="proton_remnant_t")
- end subroutine proton_remnant_get_type
-
-@ %def proton_remnant_get_type
-@
-<<Muli remnant: proton remnant: TBP>>=
- procedure :: gnuplot_momentum_kind_pdf_array => &
- proton_remnant_gnuplot_momentum_kind_pdf_array
-<<Muli remnant: procedures>>=
- subroutine proton_remnant_gnuplot_momentum_kind_pdf_array &
- (this, momentum_unit, parton_unit, GeV_scale)
- class(proton_remnant_t), intent(in) :: this
- integer, intent(in) :: momentum_unit, parton_unit
- real(default), intent(in) :: GeV_scale
- real(default), dimension(2) :: valence_pdf
- real(double), dimension(-6:6) :: sea_pdf
- real(default), dimension(this%n_twins) :: twin_pdf
- integer :: x
- real(default) :: momentum_fraction
- do x = 1, 100
- momentum_fraction = x * 1E-2_default
- call this%momentum_kind_pdf_array (GeV_scale, momentum_fraction, &
- valence_pdf, sea_pdf)
- call this%momentum_twin_pdf_array (momentum_fraction, twin_pdf)
- write (momentum_unit, fmt=*) momentum_fraction, &
- sum(valence_pdf) + sum(sea_pdf) + sum(twin_pdf), &
- valence_pdf, sea_pdf, twin_pdf
- call this%parton_kind_pdf_array (GeV_scale, momentum_fraction, &
- valence_pdf, sea_pdf)
- call this%parton_twin_pdf_array (momentum_fraction, twin_pdf)
- write(parton_unit,fmt=* )momentum_fraction, &
- sum(valence_pdf) + sum(sea_pdf) + sum(twin_pdf), &
- valence_pdf, sea_pdf, twin_pdf
- end do
- end subroutine proton_remnant_gnuplot_momentum_kind_pdf_array
-
-@ %def proton_remnant_gnuplot_momentum_kind_pdf_array
-@
-<<Muli remnant: public>>=
- public :: pp_remnant_t
-<<Muli remnant: types>>=
- type, extends (ser_class_t) :: pp_remnant_t
- logical :: initialized = .false.
- real(default), private :: gev_initial_cme = gev_cme_tot
- real(default), private :: X = one
- type(proton_remnant_t), dimension(2) :: proton
- class(pdfnorm_t), pointer :: pdf_norm
- contains
- <<Muli remnant: PP remnant: TBP>>
- end type pp_remnant_t
-
-@ %def pp_remnant_t
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: write_to_marker => pp_remnant_write_to_marker
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_write_to_marker (this, marker, status)
- class(pp_remnant_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("pp_remnant_t")
- call marker%mark ("gev_initial_cme", this%gev_initial_cme)
- call marker%mark ("X", this%X)
- call this%proton(1)%write_to_marker (marker, status)
- call this%proton(2)%write_to_marker (marker, status)
- call marker%mark_end ("pp_remnant_t")
- end subroutine pp_remnant_write_to_marker
-
-@ %def pp_remnant_write_to_marker
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: read_from_marker => pp_remnant_read_from_marker
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_read_from_marker (this, marker, status)
- class(pp_remnant_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- character(:), allocatable :: name
- call marker%pick_begin ("pp_remnant_t", status=status)
- call marker%pick ("gev_initial_cme", this%gev_initial_cme, status)
- call marker%pick ("X", this%X, status)
- call this%proton(1)%read_from_marker (marker, status)
- call this%proton(2)%read_from_marker (marker, status)
- call marker%pick_end ("pp_remnant_t", status=status)
- end subroutine pp_remnant_read_from_marker
-
-@ %def pp_remnant_read_from_marker
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: print_to_unit => pp_remnant_print_to_unit
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_print_to_unit (this, unit, parents, components, peers)
- class(pp_remnant_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- write (unit, "(1x,A)") "Components of pp_remnant_t:"
- write (unit, "(1x,A,F10.3)") "Initial center of mass energy: ", &
- this%gev_initial_cme
- write (unit, "(1x,A,F10.3)") "Actual center of mass energy: ", &
- this%get_gev_actual_cme ()
- write (unit, "(1x,A,F10.3)") "Total Momentum Fraction is: ", this%X
- if (components>0) then
- write (unit, "(3x,A)") "Proton 1:"
- call this%proton(1)%print_to_unit (unit, parents, components-1, peers)
- write (unit, "(3x,A)") "Proton 2:"
- call this%proton(2)%print_to_unit (unit, parents, components-1, peers)
- end if
- ! write (unit, "(1x,A,F7.2)") "Total Momentum Fraction: ", &
- ! this%momentum_fraction
- end subroutine pp_remnant_print_to_unit
-
-@ %def pp_remnant_print_to_unit
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure, nopass :: get_type => pp_remnant_get_type
-<<Muli remnant: procedures>>=
- pure subroutine pp_remnant_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="pp_remnant_t")
- end subroutine pp_remnant_get_type
-
-@ %def pp_remnant_get_type
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: initialize => pp_remnant_initialize
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_initialize (this, muli_dir, &
- lhapdf_dir, lhapdf_file, lhapdf_member)
- class(pp_remnant_t), intent(out) :: this
- character(*), intent(in) :: muli_dir, lhapdf_dir, lhapdf_file
- integer, intent(in) :: lhapdf_member
- logical :: exist
- allocate (this%pdf_norm)
- ! call InitPDFset (lhapdf_dir // lhapdf_file)
- ! call InitPDF (lhapdf_member)
- print *, "looking for previously generated pdf integrals..."
- inquire (file=muli_dir // "/pdf_norm_" // lhapdf_file // &
- ".xml", exist=exist)
- if (exist) then
- print *, "found. Starting deserialization..."
- call this%pdf_norm%deserialize (name="pdf_norm_" // lhapdf_file, &
- file=muli_dir // "/pdf_norm_" // lhapdf_file // ".xml")
- print *, "done."
- else
- print *, "No integrals found. Starting generation..."
- call this%pdf_norm%scan ()
- print *, "done."
- call this%pdf_norm%serialize (name="pdf_norm_" // lhapdf_file, &
- file=muli_dir // "/pdf_norm_" // lhapdf_file // ".xml")
- end if
- call this%proton(1)%initialize (this%pdf_norm)
- call this%proton(2)%initialize (this%pdf_norm)
- this%initialized = .true.
- ! call this%print_all ()
- end subroutine pp_remnant_initialize
-
-@ %def pp_remnant_initialize
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: finalize => pp_remnant_finalize
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_finalize (this)
- class(pp_remnant_t), intent(inout) :: this
- call this%proton(1)%finalize ()
- call this%proton(2)%finalize ()
- deallocate (this%pdf_norm)
- end subroutine pp_remnant_finalize
-
-@ %def pp_remnant_finalize
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: apply_initial_interaction => &
- pp_remnant_apply_initial_interaction
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_apply_initial_interaction (this, gev_cme, x1, &
- x2, pdg_f1, pdg_f2, n1, n2, gev_scale, rnd1, rnd2)
- class(pp_remnant_t), intent(inout) :: this
- real(default), intent(in)::gev_cme,x1,x2,gev_scale,rnd1,rnd2
- integer, intent(in) :: pdg_f1, pdg_f2, n1, n2
- if (this%initialized) then
- call this%proton(1)%apply_initial_splitting &
- (n1, pdg_f1, x1, gev_scale, rnd1)
- call this%proton(2)%apply_initial_splitting &
- (n2, pdg_f2, x2, gev_scale, rnd2)
- this%X = (one - x1) * (one - x2)
- this%gev_initial_cme = gev_cme
- ! call this%print_all ()
- else
- call msg_error ("pp_remnant_apply_initial_interaction: Not yet " // &
- "initialized, call pp_remnant_initialize first!")
- end if
- end subroutine pp_remnant_apply_initial_interaction
-
-@ %def pp_remnant_apply_initial_interaction
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: reset => pp_remnant_reset
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_reset (this)
- class(pp_remnant_t), intent(inout) :: this
- call this%proton(1)%reset ()
- call this%proton(2)%reset ()
- this%X = one
- end subroutine pp_remnant_reset
-
-@ %def pp_remnant_reset
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: replace_parton => pp_remnant_replace_parton
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_replace_parton (this, proton_id, old_id, &
- new_id, pdg_f, x_proton, gev_scale)
- class(pp_remnant_t), intent(inout) :: this
- integer, intent(in) :: proton_id, old_id, new_id, pdg_f
- real(default), intent(in) :: x_proton, gev_scale
- call this%proton(proton_id)%replace_is_parton &
- (old_id, new_id, pdg_f, x_proton, gev_scale)
- end subroutine pp_remnant_replace_parton
-
-@ %def pp_remnant_replace_parton
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: momentum_pdf => pp_remnant_momentum_pdf
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_momentum_pdf &
- (this, x_proton, gev2_scale, n, pdg_f, pdf)
- class(pp_remnant_t), intent(in) :: this
- real(default), intent(in) :: x_proton, gev2_scale
- integer, intent(in) :: n, pdg_f
- real(default), intent(out) :: pdf
- if (n==1 .or. n==2) then
- if (x_proton <= this%proton(n)%momentum_fraction) then
- if (pdg_f == PDG_FLAVOR_g) then
- call this%proton(n)%momentum_flavor_pdf (sqrt(GeV2_scale), &
- x_proton / this%proton(n)%momentum_fraction, &
- LHA_FLAVOR_g, pdf)
- else
- call this%proton(n)%momentum_flavor_pdf (sqrt(GeV2_scale), &
- x_proton / this%proton(n)%momentum_fraction, &
- pdg_f, pdf)
- end if
- pdf = pdf * this%proton(n)%momentum_fraction
- else
- pdf = zero
- end if
- else
- call msg_error ("pp_remnant_momentum_pdf: n must be either 1 or 2, " &
- // "but it is " // char (str (n)) // ".")
- stop
- end if
- end subroutine pp_remnant_momentum_pdf
-
-@ %def pp_remnant_momentum_pdf
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: parton_pdf => pp_remnant_parton_pdf
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_parton_pdf (this, x_proton, gev2_scale, n, pdg_f, pdf)
- class(pp_remnant_t), intent(in) :: this
- real(default), intent(in) :: x_proton, gev2_scale
- integer, intent(in) :: n, pdg_f
- real(default), intent(out) :: pdf
- if (n==1 .or. n==2) then
- if (x_proton <= this%proton(n)%momentum_fraction) then
- if (pdg_f == PDG_FLAVOR_g) then
- call this%proton(n)%parton_flavor_pdf (sqrt(GeV2_scale), &
- x_proton/this%proton(n)%momentum_fraction, LHA_FLAVOR_g, &
- pdf)
- else
- call this%proton(n)%parton_flavor_pdf (sqrt(GeV2_scale), &
- x_proton/this%proton(n)%momentum_fraction,pdg_f, pdf)
- end if
- pdf = pdf * this%proton(n)%momentum_fraction
- else
- pdf = zero
- end if
- else
- call msg_error ("pp_remnant_parton_pdf: n must be either 1 or 2, " &
- // "but it is " // char (str (n)) // ".")
- stop
- end if
- end subroutine pp_remnant_parton_pdf
-
-@ %def pp_remnant_parton_pdf
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: apply_interaction => pp_remnant_apply_interaction
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_apply_interaction (this, qcd_2_2)
- class(pp_remnant_t), intent(inout) :: this
- class(qcd_2_2_class), intent(in) :: qcd_2_2
- integer, dimension(4) :: lha_f
- integer, dimension(2) :: int_k
- real(default) :: gev_pt
- real(default), dimension(2) :: mom_f
- integer :: n
- mom_f = qcd_2_2%get_remnant_momentum_fractions ()
- lha_f = qcd_2_2%get_lha_flavors ()
- int_k = qcd_2_2%get_pdf_int_kinds ()
- gev_pt = qcd_2_2%get_gev_scale ()
- ! print *,"pp_remnant_apply_interaction", mom_f, &
- ! qcd_2_2%get_parton_id(1), qcd_2_2%get_parton_id(2), lha_f
- do n = 1, 2
- select case (int_k(n))
- case (PDF_VALENCE_DOWN)
- call this%proton(n)%remove_valence_down_quark &
- (qcd_2_2%get_parton_id(n), gev_pt, mom_f(n))
- case (PDF_VALENCE_UP)
- call this%proton(n)%remove_valence_up_quark &
- (qcd_2_2%get_parton_id(n), gev_pt, mom_f(n))
- case (PDF_SEA)
- call this%proton(n)%remove_sea_quark &
- (qcd_2_2%get_parton_id(n), gev_pt, mom_f(n), lha_f(n))
- case (PDF_GLUON)
- call this%proton(n)%remove_gluon &
- (qcd_2_2%get_parton_id(n), gev_pt, mom_f(n))
- end select
- end do
- this%X = this%proton(1)%momentum_fraction * &
- this%proton(2)%momentum_fraction
- end subroutine pp_remnant_apply_interaction
-
-@ %def pp_remnant_apply_interaction
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: get_pdf_int_weights => pp_remnant_get_pdf_int_weights
-<<Muli remnant: procedures>>=
- pure function pp_remnant_get_pdf_int_weights &
- (this, pdf_int_kinds) result (weight)
- class(pp_remnant_t), intent(in) :: this
- real(default) :: weight
- integer, dimension(2), intent(in) :: pdf_int_kinds ! pdf_int_kind
- weight = this%proton(1)%pdf_int_weight (pdf_int_kinds(1)) * &
- this%proton(2)%pdf_int_weight (pdf_int_kinds(2)) !*((this%x)**2)
- end function pp_remnant_get_pdf_int_weights
-
-@ %def pp_remnant_get_pdf_int_weights
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: get_pdf_int_weight => pp_remnant_get_pdf_int_weight
-<<Muli remnant: procedures>>=
- elemental function pp_remnant_get_pdf_int_weight &
- (this, kind1, kind2) result (weight)
- class(pp_remnant_t), intent(in) :: this
- real(double) :: weight
- integer, intent(in) :: kind1, kind2 ! pdf_int_kind
- weight = this%proton(1)%pdf_int_weight(kind1) * &
- this%proton(2)%pdf_int_weight(kind2) !*((this%x)**2)
- end function pp_remnant_get_pdf_int_weight
-
-@ %def pp_remnant_get_pdf_int_weight
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: set_pdf_weight => pp_remnant_set_pdf_weight
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_set_pdf_weight (this, weights)
- class(pp_remnant_t), intent(inout) :: this
- real(default), dimension(10), intent(in) :: weights
- this%proton(1)%pdf_int_weight = weights(1:5)
- this%proton(2)%pdf_int_weight = weights(6:10)
- end subroutine pp_remnant_set_pdf_weight
-
-@ %def pp_remnant_set_pdf_weight
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: get_gev_initial_cme => pp_remnant_get_gev_initial_cme
-<<Muli remnant: procedures>>=
- elemental function pp_remnant_get_gev_initial_cme (this) result (cme)
- class(pp_remnant_t), intent(in) :: this
- real(double) :: cme
- cme =this%gev_initial_cme
- end function pp_remnant_get_gev_initial_cme
-
-@ %def pp_remnant_get_gev_initial_cme
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: get_gev_actual_cme => pp_remnant_get_gev_actual_cme
-<<Muli remnant: procedures>>=
- elemental function pp_remnant_get_gev_actual_cme (this) result (cme)
- class(pp_remnant_t), intent(in) :: this
- real(double) :: cme
- cme = this%gev_initial_cme * this%X
- end function pp_remnant_get_gev_actual_cme
-
-@ %def pp_remnant_get_gev_actual_cme
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: get_cme_fraction => pp_remnant_get_cme_fraction
-<<Muli remnant: procedures>>=
- elemental function pp_remnant_get_cme_fraction (this) result (cme)
- class(pp_remnant_t), intent(in) :: this
- real(double) :: cme
- cme = this%X
- end function pp_remnant_get_cme_fraction
-
-@ %def pp_remnant_get_cme_fraction
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: get_proton_remnant_momentum_fractions => &
- pp_remnant_get_proton_remnant_momentum_fractions
-<<Muli remnant: procedures>>=
- pure function pp_remnant_get_proton_remnant_momentum_fractions &
- (this) result (fractions)
- class(pp_remnant_t), intent(in) :: this
- real(double), dimension(2) :: fractions
- fractions = [this%proton(1)%get_momentum_fraction(), &
- this%proton(2)%get_momentum_fraction()]
- end function pp_remnant_get_proton_remnant_momentum_fractions
-
-@ %def pp_remnant_get_proton_remnant_momentum_fractions
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: get_proton_remnants => pp_remnant_get_proton_remnants
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_get_proton_remnants (this, proton1, proton2)
- class(pp_remnant_t), target, intent(in) :: this
- class(proton_remnant_t), intent(out), pointer :: proton1, proton2
- proton1 => this%proton(1)
- proton2 => this%proton(2)
- end subroutine pp_remnant_get_proton_remnants
-
-@ %def pp_remnant_get_proton_remnants
-@
-<<Muli remnant: PP remnant: TBP>>=
- procedure :: get_remnant_parton_flavor_pdf_arrays => &
- pp_remnant_get_remnant_parton_flavor_pdf_arrays
-<<Muli remnant: procedures>>=
- subroutine pp_remnant_get_remnant_parton_flavor_pdf_arrays &
- (this, GeV_scale, momentum1, momentum2, pdf1, pdf2)
- class(pp_remnant_t), intent(in) :: this
- real(default), intent(in) :: GeV_scale, momentum1, momentum2
- real(double), dimension(-6:6), intent(out) :: pdf1, pdf2
- call this%proton(1)%parton_flavor_pdf_array (GeV_scale, momentum1, pdf1)
- call this%proton(2)%parton_flavor_pdf_array (GeV_scale, momentum2, pdf2)
- end subroutine pp_remnant_get_remnant_parton_flavor_pdf_arrays
-
-@ %def pp_remnant_get_remnant_parton_flavor_pdf_arrays
-@
-<<Muli remnant: interfaces>>=
- interface
- subroutine getxmin (mem, xmin)
- integer, intent(in) :: mem
- double precision, intent(out) :: xmin
- end subroutine getxmin
- end interface
-@ %def getxmin
-@
-<<Muli remnant: interfaces>>=
- interface
- subroutine getxmax (mem, xmax)
- integer, intent(in) :: mem
- double precision, intent(out) :: xmax
- end subroutine getxmax
- end interface
-@ %def getxmax
-@
-<<Muli remnant: interfaces>>=
- interface
- subroutine getq2min (mem, q2min)
- integer, intent(in) :: mem
- double precision, intent(out) :: q2min
- end subroutine getq2min
- end interface
-@ %def getq2min
-@
-<<Muli remnant: interfaces>>=
- interface
- subroutine getq2max (mem, q2max)
- integer, intent(in) :: mem
- double precision, intent(out) :: q2max
- end subroutine getq2max
- end interface
-
-@ %def getq2max
-@
-<<Muli remnant: procedures>>=
- pure function remnant_dglap_splitting_gqq (z) result(p)
- real(default) :: p
- real(default), intent(in) :: z
- p = (z**2 + (1-z)**2) / two
- end function remnant_dglap_splitting_gqq
-
-@ %def remnant_dglap_splitting_gqq
-@
-<<Muli remnant: procedures>>=
- pure function remnant_gluon_pdf_approx (x, p) result (g)
- real(default) :: g
- integer, intent(in) :: p
- real(default), intent(in) :: x
- g = ((1-x)**p) / x
- end function remnant_gluon_pdf_approx
-
-@ %def remnant_gluon_pdf_approx
-@
-<<Muli remnant: procedures>>=
- pure function remnant_norm_0 (xs) result (c0)
- real(default) :: c0
- real(default), intent(in) :: xs
- c0 = 6*xs / (2 - xs * (3 - 3*xs + 2*xs**2))
- end function remnant_norm_0
-
-@ %def remnant_norm_0
-@
-<<Muli remnant: procedures>>=
- pure function remnant_norm_1 (xs) result (c1)
- real(default) :: c1
- real(default), intent(in)::xs
- c1 = 3*xs / (2 - xs**2 * (3-xs) + 3*xs*log(xs))
- end function remnant_norm_1
-
-@ %def remnant_norm_1
-@
-<<Muli remnant: procedures>>=
- pure function remnant_norm_4 (xs) result (c4)
- real(default) :: c4
- real(default), intent(in) :: xs
- real(default) :: y
- if ((one-xs) > 1E-3_default) then
- c4 = 3*xs / (1 + 11*xs + 6*xs*log(xs) + 12*xs**3*log(xs) + &
- 18*xs**2*log(xs) + 9*xs**2 - 19*xs**3 - 2*xs**4)
- else
- y=one / (one-xs)
- c4= 1130._default / 11907._default &
- - 10._default * y**5 &
- - 40._default * y**4 / three &
- -160._default * y**3 / 63._default &
- + 50._default * y**2 / 189._default &
- -565._default * y / 3969._default &
- -186170._default * (one-xs) / 2750517._default
- end if
- end function remnant_norm_4
-
-@ %def remnant_norm_4
-@
-<<Muli remnant: procedures>>=
- pure function remnant_norm (xs, p) result (c)
- real(default) :: c
- real(default), intent(in) :: xs
- integer, intent(in) :: p
- select case (p)
- case (0)
- c = remnant_norm_0 (xs)
- case (1)
- c = remnant_norm_1 (xs)
- case default
- c = remnant_norm_4 (xs)
- end select
- end function remnant_norm
-
-@ %def remnant_norm
-@
-<<Muli remnant: procedures>>=
- pure function remnant_twin_pdf_p (x, xs, p) result (qc)
- real(default) :: qc
- real(default), intent(in) :: x, xs
- integer, intent(in) :: p
- qc = remnant_norm (xs, p) * remnant_gluon_pdf_approx (xs + x, p) &
- * remnant_dglap_splitting_gqq (xs / (xs+x)) / (xs+x)
- end function remnant_twin_pdf_p
-
-@ %def remnant_twin_pdf_p
-@
-<<Muli remnant: procedures>>=
- elemental function remnant_twin_momentum_4 (xs) result (p)
- real(default) :: p
- real(default), intent(in) :: xs
- if (xs < 0.99_default) then
- p = (-9 * (-1+xs) * xs * (1+xs) * (5+xs*(24+xs)) + &
- 12*xs*(1+2*xs)*(1+2*xs*(5+2*xs))*Log(xs))/&
- (8*(1+2*xs)*((-1+xs)*(1+xs*(10+xs))-6*xs*(1+xs)*Log(xs)))
- else
- p = (1-xs) / 6 - (5*(-1+xs)**2) / 63 + (5*(-1+xs)**3) / 216
- end if
- end function remnant_twin_momentum_4
-
-@ %def remnant_twin_momentum_4
-@
-<<Muli remnant: procedures>>=
- subroutine gnuplot_integrated_pdf (this, momentum_unit, parton_unit)
- class(proton_remnant_t), intent(in) :: this
- integer, intent(in) :: momentum_unit, parton_unit
- ! real(double), intent(in) :: gev_scale
- integer, parameter :: x_grid = 1000000
- integer, parameter :: q_grid = 100
- integer :: n, m, mem
- real(default) :: x, q, dx, dq, overall_sum, xmin, xmax, &
- q2min, q2max, qmin, qmax
- real(double) :: q2min_dbl, q2max_dbl, xmin_dbl, xmax_dbl
- real(double), dimension(-6:6) :: sea_pdf, sea_momentum_pdf_sum, &
- sea_parton_pdf_sum
- real(default), dimension(2) :: valence_pdf, valence_momentum_pdf_sum,&
- valence_parton_pdf_sum
- real(default), allocatable, dimension(:) :: twin_momentum_pdf_sum
- class(muli_parton_t), pointer :: tmp_twin
- mem = 1
- call GetXmin (mem, xmin_dbl)
- call GetXmax (mem, xmax_dbl)
- call GetQ2max (mem, q2max_dbl)
- call GetQ2min (mem, q2min_dbl)
- xmin = xmin_dbl
- xmax = xmax_dbl
- q2min = q2min_dbl
- q2max = q2max_dbl
- qmin = sqrt(q2min)
- qmax = sqrt(q2max)
- print *, "qmin=", qmin, "GeV"
- print *, "qmax=", qmax, "GeV"
- dx = (xmax-xmin) / x_grid
- dq = (qmax-qmin) / q_grid
- q = qmin + dq / 2D0
- tmp_twin => this%twin_partons%next
- n = 0
- if (this%n_twins > 0) then
- allocate (twin_momentum_pdf_sum (this%n_twins))
- do while (associated (tmp_twin))
- n = n + 1
- twin_momentum_pdf_sum(n) = tmp_twin%momentum
- tmp_twin => tmp_twin%next
- end do
- end if
- do m = 1, q_grid
- valence_momentum_pdf_sum = [0D0,0D0]
- valence_parton_pdf_sum = [0D0,0D0]
- sea_momentum_pdf_sum = &
- [0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0]
- sea_parton_pdf_sum = &
- [0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0]
- x = xmin + dx / 2D0
- do n = 1, x_grid
- call this%parton_kind_pdf_array (Q, x, valence_pdf, sea_pdf)
- valence_parton_pdf_sum = valence_parton_pdf_sum + valence_pdf
- sea_parton_pdf_sum = sea_parton_pdf_sum + sea_pdf
- call this%momentum_kind_pdf_array (Q, x, valence_pdf, sea_pdf)
- valence_momentum_pdf_sum = valence_momentum_pdf_sum + valence_pdf
- sea_momentum_pdf_sum = sea_momentum_pdf_sum + sea_pdf
- x = x + dx
- end do
- valence_parton_pdf_sum = valence_parton_pdf_sum * dx
- sea_parton_pdf_sum = sea_parton_pdf_sum * dx
- valence_momentum_pdf_sum = valence_momentum_pdf_sum * dx
- sea_momentum_pdf_sum = sea_momentum_pdf_sum * dx
- if (this%n_twins > 0) then
- write (momentum_unit, fmt=*) q, &
- sum(valence_momentum_pdf_sum) + &
- sum(sea_momentum_pdf_sum) + sum(twin_momentum_pdf_sum), &
- valence_momentum_pdf_sum, &
- sea_momentum_pdf_sum, &
- twin_momentum_pdf_sum
- else
- write (momentum_unit, fmt=*) q, &
- sum(valence_momentum_pdf_sum) + sum(sea_momentum_pdf_sum), &
- valence_momentum_pdf_sum, &
- sea_momentum_pdf_sum
- end if
- write (parton_unit,fmt=*) q, &
- sum(valence_parton_pdf_sum) + sum(sea_parton_pdf_sum), &
- valence_parton_pdf_sum, &
- sea_parton_pdf_sum
- q = q + dq
- end do
- end subroutine gnuplot_integrated_pdf
-
-@ %def gnuplot_integrated_pdf
-@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{The Multiple Interactions main module}
This file contains the module [[muli]] which is the multiple parton
interactions interface module to \whizard. [[muli]] is supposed to run
together with initial state radiation. Both share a momentum evolution
variable and compete for beam momentum, so the generation of this
-scale variable must be fully transparent to \whizard. That is why the
-corresponding procedures are here, while all other work like phase
-space integration, flavor generation and treatment of the beam remnant
-is put into [[muli_dsigma]], [[muli_mcint]] and [[muli_remnant]],
-respectively.
-
-[[qcd_2_2_t]] is a container class for properties of QCD $2\to 2$
-interactions. It holds a very condensed internal representation and
-offers a convenient set of TBP to query all aspects without the burden
-of the generator internals.
-
-[[muli_t]] then is an extension of [[qcd_2_2_t]] that adds generator
-internals like random number generator, integrated cross-sections, the
-actual Monte Carlo generator for flavor generation and beam remnants in
-[[tao_rnd]], [[dsigma]], samples and beam, respectively.
+scale variable must be fully transparent to \whizard. This here is a stub
+as long as there is no working \whizard\ implementation for multiple
+interactions. It gives an interface for the necessary routines.
<<[[muli.f90]]>>=
<<File header>>
module muli
use, intrinsic :: iso_fortran_env
<<Use kinds>>
- use constants
- use tao_random_numbers !NODEP!
- use muli_base
- use muli_momentum
- use muli_trapezium
- use muli_interactions
- use muli_dsigma
- use muli_mcint
- use muli_remnant
<<Standard module head>>
<<Muli: variables>>
<<Muli: public>>
<<Muli: types>>
contains
<<Muli: procedures>>
end module muli
@ %def muli
-<<Muli: variables>>=
- logical, parameter :: muli_default_modify_pdfs = .true.
- integer, parameter :: muli_default_lhapdf_member = 0
- character(*), parameter :: muli_default_lhapdf_file = "cteq6ll.LHpdf"
-
-@ %def muli_default_modify_pdfs muli_default_lhapdf_member
-@ %def muli_default_lhapdf_file
-@
-<<Muli: types>>=
- type, extends(qcd_2_2_class) :: qcd_2_2_t
- private
- integer :: process_id = -1
- integer :: integrand_id = -1
- integer, dimension(2) :: parton_ids = [0,0]
- integer, dimension(4) :: flow = [0,0,0,0]
- real(default), dimension(3) :: momentum_fractions = [-one, -one, -one]
- real(default), dimension(3) :: hyperbolic_fractions = [-one ,- one,- one]
- contains
- <<Muli: QCD22: TBP>>
- end type qcd_2_2_t
-
-@ %def qcd_2_2_t
-@
-<<Muli: QCD22: TBP>>=
- procedure :: write_to_marker => qcd_2_2_write_to_marker
-<<Muli: procedures>>=
- subroutine qcd_2_2_write_to_marker (this, marker, status)
- class(qcd_2_2_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("qcd_2_2_t")
- call this%mom_write_to_marker (marker, status)
- call marker%mark ("process_id", this%process_id)
- call marker%mark ("integrand_id", this%integrand_id)
- call marker%mark ("momentum_fractions", this%momentum_fractions)
- call marker%mark ("hyperbolic_fractions", this%hyperbolic_fractions)
- call marker%mark_end("qcd_2_2_t")
- end subroutine qcd_2_2_write_to_marker
-
-@ %def qcd_2_2_write_to_marker
-@
-<<Muli: QCD22: TBP>>=
- procedure :: read_from_marker => qcd_2_2_read_from_marker
-<<Muli: procedures>>=
- subroutine qcd_2_2_read_from_marker (this, marker, status)
- class(qcd_2_2_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%pick_begin ("qcd_2_2_t", status=status)
- call this%mom_read_from_marker (marker, status)
- call marker%pick ("process_id", this%process_id, status)
- call marker%pick ("integrand_id", this%integrand_id, status)
- call marker%pick ("momentum_fractions", this%momentum_fractions, status)
- call marker%pick &
- ("hyperbolic_fractions", this%hyperbolic_fractions, status)
- call marker%pick_end ("qcd_2_2_t", status=status)
- end subroutine qcd_2_2_read_from_marker
-
-@ %def qcd_2_2_read_from_marker
-@
-<<Muli: QCD22: TBP>>=
- procedure :: print_to_unit => qcd_2_2_print_to_unit
-<<Muli: procedures>>=
- subroutine qcd_2_2_print_to_unit (this, unit, parents, components, peers)
- class(qcd_2_2_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- integer, dimension(2,4) :: flow
- integer :: index
- if (parents > i_zero) &
- call this%mom_print_to_unit (unit, parents-1, components, peers)
- write (unit, "(1x,A)") "Components of qcd_2_2_t:"
- write (unit, "(3x,A,I3)") "Process id is: ", this%get_process_id ()
- write (unit, "(3x,A,I3)") "Integrand id is: ", this%get_integrand_id ()
- if (this%get_integrand_id () > 0) then
- write (unit, "(3x,A,4(I3))") "LHA Flavors are: ", &
- this%get_lha_flavors ()
- write (unit, "(3x,A,4(I3))") "PDG Flavors are: ", &
- this%get_pdg_flavors ()
- write (unit, "(3x,A,2(I3))") "Parton kinds are: ", &
- this%get_parton_kinds ()
- write (unit, "(3x,A,2(I3))") "PDF int kinds are: ", &
- this%get_pdf_int_kinds ()
- write (unit, "(3x,A,2(I3))") "Diagram kind is: ", &
- this%get_diagram_kind ()
- end if
- call this%get_color_correlations (1, index, flow)
- write (unit, "(3x,A,4(I0))") "Color Permutations: ", this%flow
- write (unit, "(3x,A)") "Color Connections:"
- write (unit, &
- '(" (",I0,",",I0,")+(",I0,",",I0,")->(",I0,",",I0,&
- &")+(",I0,",",I0,")")') flow
- write (unit, "(3x,A,E14.7)") "Evolution scale is: ", &
- this%get_unit2_scale ()
- write (unit, "(3x,A,E14.7)") "Momentum boost is: ", &
- this%get_momentum_boost ()
- write (unit, "(3x,A,2(E14.7))") "Remant momentum fractions are: ", &
- this%get_remnant_momentum_fractions ()
- write (unit, "(3x,A,2(E14.7))") "Total momentum fractions are: ", &
- this%get_total_momentum_fractions ()
- end subroutine qcd_2_2_print_to_unit
-
-@ %def qcd_2_2_print_to_unit
-@
-<<Muli: QCD22: TBP>>=
- procedure, nopass :: get_type => qcd_2_2_get_type
-<<Muli: procedures>>=
- pure subroutine qcd_2_2_get_type (type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="qcd_2_2_t")
- end subroutine qcd_2_2_get_type
-
-@ %def qcd_2_2_get_type
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_process_id => qcd_2_2_get_process_id
-<<Muli: procedures>>=
- elemental function qcd_2_2_get_process_id (this) result (id)
- class(qcd_2_2_t), intent(in) :: this
- integer :: id
- id = this%process_id
- end function qcd_2_2_get_process_id
-
-@ %def qcd_2_2_get_process_id
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_integrand_id => qcd_2_2_get_integrand_id
-<<Muli: procedures>>=
- elemental function qcd_2_2_get_integrand_id (this) result (id)
- class(qcd_2_2_t), intent(in) :: this
- integer :: id
- id = this%integrand_id
- end function qcd_2_2_get_integrand_id
-
-@ %def qcd_2_2_get_integrand_id
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_diagram_kind => qcd_2_2_get_diagram_kind
-<<Muli: procedures>>=
- elemental function qcd_2_2_get_diagram_kind (this) result (kind)
- class(qcd_2_2_t), intent(in) :: this
- integer :: kind
- kind = valid_processes (6, this%process_id)
- end function qcd_2_2_get_diagram_kind
-
-@ %def qcd_2_2_get_diagram_kind
-@ This is one more hack. Before merging into the interleaved
-algorithm, [[muli]] has only cared for summed cross sections, but not
-in specific color flows. So two different diagrams with equal cross
-sections were summed up to diagram kind 1. Now [[muli]] also generates
-color flows, so we must devide diagram kind 1 into diagram color kind
-0 and diagram color kind 1.
-<<Muli: QCD22: TBP>>=
- procedure :: get_diagram_color_kind => qcd_2_2_get_diagram_color_kind
-<<Muli: procedures>>=
- pure function qcd_2_2_get_diagram_color_kind (this) result (kind)
- class(qcd_2_2_t), intent(in) :: this
- integer :: kind
- kind = valid_processes (6, this%process_id)
- if (kind == 1) then
- if (product (valid_processes (1:2,this%process_id)) > 0) then
- kind = 0
- end if
- end if
- end function qcd_2_2_get_diagram_color_kind
-
-@ %def qcd_2_2_get_diagram_color_kind
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_io_kind => qcd_2_2_get_io_kind
-<<Muli: procedures>>=
- elemental function qcd_2_2_get_io_kind (this) result (kind)
- class(qcd_2_2_t), intent(in) :: this
- integer :: kind
- kind = valid_processes (5, this%process_id)
- end function qcd_2_2_get_io_kind
-
-@ %def qcd_2_2_get_io_kind
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_lha_flavors => qcd_2_2_get_lha_flavors
-<<Muli: procedures>>=
- pure function qcd_2_2_get_lha_flavors (this) result (lha)
- class(qcd_2_2_t), intent(in) :: this
- integer, dimension(4) :: lha
- lha = valid_processes (1:4, this%process_id)
- end function qcd_2_2_get_lha_flavors
-
-@ %def qcd_2_2_get_lha_flavors
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_pdg_flavors => qcd_2_2_get_pdg_flavors
-<<Muli: procedures>>=
- pure function qcd_2_2_get_pdg_flavors (this) result (pdg)
- class(qcd_2_2_t), intent(in) :: this
- integer, dimension(4) :: pdg
- pdg = this%get_lha_flavors ()
- where (pdg == 0) pdg = 21
- end function qcd_2_2_get_pdg_flavors
-
-@ %def qcd_2_2_get_pdg_flavors
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_parton_id => qcd_2_2_get_parton_id
-<<Muli: procedures>>=
- pure function qcd_2_2_get_parton_id (this, n) result (id)
- class(qcd_2_2_t), intent(in) :: this
- integer, intent(in) :: n
- integer :: id
- id = this%parton_ids (n)
- end function qcd_2_2_get_parton_id
-
-@ %def qcd_2_2_get_parton_id
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_parton_kinds => qcd_2_2_get_parton_kinds
-<<Muli: procedures>>=
- pure function qcd_2_2_get_parton_kinds (this) result (kinds)
- class(qcd_2_2_t), intent(in) :: this
- integer, dimension(2) :: kinds
- kinds = this%get_pdf_int_kinds ()
- kinds(1) = parton_kind_of_int_kind (kinds(1))
- kinds(2) = parton_kind_of_int_kind (kinds(2))
- end function qcd_2_2_get_parton_kinds
-
-@ %def qcd_2_2_get_parton_kinds
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_pdf_int_kinds => qcd_2_2_get_pdf_int_kinds
-<<Muli: procedures>>=
- pure function qcd_2_2_get_pdf_int_kinds (this) result (kinds)
- class(qcd_2_2_t), intent(in) :: this
- integer, dimension(2) :: kinds
- kinds = double_pdf_kinds (1:2, this%integrand_id)
- end function qcd_2_2_get_pdf_int_kinds
-
-@ %def qcd_2_2_get_pdf_int_kinds
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_momentum_boost => qcd_2_2_get_momentum_boost
-<<Muli: procedures>>=
- elemental function qcd_2_2_get_momentum_boost (this) result (boost)
- class(qcd_2_2_t), intent(in) :: this
- real(default) :: boost
- boost = - one
- ! print('("qcd_2_2_get_momentum_boost: not yet implemented.")')
- ! boost = this%momentum_boost
- end function qcd_2_2_get_momentum_boost
-
-@ %def qcd_2_2_get_momentum_boost
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_hyperbolic_fractions => qcd_2_2_get_hyperbolic_fractions
-<<Muli: procedures>>=
- pure function qcd_2_2_get_hyperbolic_fractions (this) result (fractions)
- class(qcd_2_2_t), intent(in) :: this
- real(double), dimension(3) :: fractions
- fractions = this%hyperbolic_fractions
- end function qcd_2_2_get_hyperbolic_fractions
-
-@ %def qcd_2_2_get_hyperbolic_fractions
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_remnant_momentum_fractions => &
- qcd_2_2_get_remnant_momentum_fractions
-<<Muli: procedures>>=
- pure function qcd_2_2_get_remnant_momentum_fractions &
- (this) result (fractions)
- class(qcd_2_2_t), intent(in) :: this
- real(default), dimension(2) :: fractions
- fractions = this%momentum_fractions(1:2)
- end function qcd_2_2_get_remnant_momentum_fractions
-
-@ %def qcd_2_2_get_remnant_momentum_fractions
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_total_momentum_fractions => &
- qcd_2_2_get_total_momentum_fractions
-<<Muli: procedures>>=
- pure function qcd_2_2_get_total_momentum_fractions &
- (this) result (fractions)
- class(qcd_2_2_t), intent(in) :: this
- real(default), dimension(2) :: fractions
- fractions = [-one, -one]
- ! fractions = this%hyperbolic_fractions(1:2) * &
- ! this%beam%get_proton_remnant_momentum_fractions()
- end function qcd_2_2_get_total_momentum_fractions
-
-@ %def qcd_2_2_get_total_momentum_fractions
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_color_flow => qcd_2_2_get_color_flow
-<<Muli: procedures>>=
- pure function qcd_2_2_get_color_flow (this) result (flow)
- class(qcd_2_2_t), intent(in) :: this
- integer, dimension(4) :: flow
- flow = this%flow
- end function qcd_2_2_get_color_flow
-
-@ %def qcd_2_2_get_color_flow
-@
-<<Muli: QCD22: TBP>>=
- procedure :: get_color_correlations => qcd_2_2_get_color_correlations
-<<Muli: procedures>>=
- subroutine qcd_2_2_get_color_correlations &
- (this, start_index, final_index, flow)
- class(qcd_2_2_t), intent(in) :: this
- integer, intent(in) :: start_index
- integer, intent(out) :: final_index
- integer, dimension(2,4), intent(out) :: flow
- integer :: pos, f_end, f_beginning
- final_index = start_index
- !!! We set all flows to i_zero. i_zero means no connection.
- flow = reshape([0,0,0,0,0,0,0,0],[2,4])
- !!! look at all four possible ends of color lines
- do f_end = 1, 4
- !!! The beginning of of this potential line is stored in flow.
- !!! i_zero means no line.
- f_beginning = this%flow(f_end)
- !!! Is there a line beginning at f_beginning and ending at f_end?
- if (f_beginning > 0) then
- !!! yes it is. we get a new number for this new line
- final_index = final_index + 1
- !!! Is this line beginning in the initial state?
- if (f_beginning < 3) then
- !!! Yes it is. lets connect the color entry of f_begin.
- flow(1,f_beginning) = final_index
- else
- !!! No, it's the final state.
- !!! lets connect the anticolor entry of f_begin.
- flow(2,f_beginning) = final_index
- end if
- !!! Is this line ending in the final state?
- if (f_end > 2) then
- !!! Yes it is. lets connect the color entry of f_end.
- flow(1,f_end) = final_index
- else
- !!! No, it's the initial state.
- !!! Lets connect the anticolor entry of f_end.
- flow(2,f_end) = final_index
- end if
- end if
- end do
- end subroutine qcd_2_2_get_color_correlations
-
-@ %def qcd_2_2_get_color_correlations
-@
-<<Muli: QCD22: TBP>>=
- generic :: initialize => qcd_2_2_initialize
- procedure :: qcd_2_2_initialize
-<<Muli: procedures>>=
- subroutine qcd_2_2_initialize (this, gev2_s, process_id, &
- integrand_id, parton_ids, flow, hyp, cart)
- class(qcd_2_2_t), intent(out) :: this
- real(default), intent(in) :: gev2_s
- integer, intent(in) :: process_id, integrand_id
- integer, dimension(2), intent(in) :: parton_ids
- integer, dimension(4), intent(in) :: flow
- real(default), dimension(3), intent(in)::hyp
- real(default), dimension(3), intent(in), optional :: cart
- call this%initialize (gev2_s)
- this%process_id = process_id
- this%integrand_id = integrand_id
- this%parton_ids = parton_ids
- this%flow = flow
- this%hyperbolic_fractions = hyp
- if (present (cart)) then
- this%momentum_fractions = cart
- else
- this%momentum_fractions = h_to_c_param (hyp)
- end if
- end subroutine qcd_2_2_initialize
-
-@ %def qcd_2_2_initialize
@
\subsection{The main Multiple Interactions type}
<<Muli: public>>=
public :: muli_t
<<Muli: types>>=
- type, extends(qcd_2_2_t) :: muli_t
+ type :: muli_t
real(default) :: GeV2_scale_cutoff
- logical :: modify_pdfs = muli_default_modify_pdfs
- !!! Pt chain status
- logical :: finished = .false.
- logical :: exceeded = .false.
- !!! Timers
- real(default) :: init_time = zero
- real(default) :: pt_time = zero
- real(default) :: partons_time = zero
- real(default) :: confirm_time = zero
- !!! Generator internals
logical :: initialized = .false.
- logical :: initial_interaction_given = .false.
- real(default) :: mean = one
- real(default), dimension(0:16) :: start_integrals = &
- [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]
- type(tao_random_state) :: tao_rnd
- type(muli_trapezium_tree_t) :: dsigma
- type(sample_inclusive_t) :: samples
- type(pp_remnant_t) :: beam
- !!! These pointers shall not be allocated, deallocated,
- !!! serialized or deserialized explicitly.
- class(muli_trapezium_node_class_t), pointer :: node => null()
+ integer, dimension(4) :: flow
contains
<<Muli: muli: TBP>>
end type muli_t
@ %def muli_t
@
<<Muli: muli: TBP>>=
- procedure :: write_to_marker => muli_write_to_marker
-<<Muli: procedures>>=
- subroutine muli_write_to_marker (this, marker, status)
- class(muli_t), intent(in) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%mark_begin ("muli_t")
- call qcd_2_2_write_to_marker (this, marker, status)
- call marker%mark ("modify_pdfs", this%modify_pdfs)
- call marker%mark ("initialized", this%initialized)
- call marker%mark &
- ("initial_interaction_given", this%initial_interaction_given)
- call marker%mark ("finished", this%finished)
- call marker%mark ("init_time", this%init_time)
- call marker%mark ("pt_time", this%pt_time)
- call marker%mark ("partons_time", this%partons_time)
- call marker%mark ("confirm_time", this%confirm_time)
- ! call marker%mark_instance (this%start_values, "start_values")
- call marker%mark_instance (this%dsigma, "dsigma")
- call marker%mark_instance (this%samples, "samples")
- call marker%mark_instance (this%beam, "beam")
- call marker%mark_end ("muli_t")
- end subroutine muli_write_to_marker
-
-@ %def muli_write_to_marker
-@
-<<Muli: muli: TBP>>=
- procedure :: read_from_marker => muli_read_from_marker
-<<Muli: procedures>>=
- subroutine muli_read_from_marker (this, marker, status)
- class(muli_t), intent(out) :: this
- class(marker_t), intent(inout) :: marker
- integer(dik), intent(out) :: status
- call marker%pick_begin ("muli_t", status=status)
- call qcd_2_2_read_from_marker (this, marker, status)
- call marker%pick ("modify_pdfs", this%modify_pdfs, status)
- call marker%pick ("initialized", this%initialized, status)
- call marker%pick &
- ("initial_interaction_given", this%initial_interaction_given, status)
- call marker%pick ("finished", this%finished, status)
- call marker%pick ("init_time", this%init_time, status)
- call marker%pick ("pt_time", this%pt_time, status)
- call marker%pick ("partons_time", this%partons_time, status)
- call marker%pick ("confirm_time", this%confirm_time, status)
- ! call marker%pick_instance &
- ! ("start_values", this%start_values, status=status)
- call marker%pick_instance ("dsigma", this%dsigma, status=status)
- call marker%pick_instance ("samples", this%samples, status=status)
- call marker%pick_instance ("beam", this%beam, status=status)
- call marker%pick_end ("muli_t", status)
- end subroutine muli_read_from_marker
-
-@ %def muli_read_from_marker
-@
-<<Muli: muli: TBP>>=
- procedure :: print_to_unit => muli_print_to_unit
-<<Muli: procedures>>=
- subroutine muli_print_to_unit (this, unit, parents, components, peers)
- class(muli_t), intent(in) :: this
- integer, intent(in) :: unit
- integer(dik), intent(in) :: parents, components, peers
- if (parents>0) &
- call qcd_2_2_print_to_unit (this, unit, parents-1, components, peers)
- write (unit, "(1x,A)") "Components of muli_t :"
- write (unit, "(3x,A)") "Model Parameters:"
- write (unit, "(3x,A,E20.10)") "GeV2_scale_cutoff : ", &
- this%GeV2_scale_cutoff
- write (unit, "(3x,A,L1)") "Modify PDF : ", this%modify_pdfs
- write (unit, "(3x,A)") "PT Chain Status:"
- write (unit, "(3x,A,L1)") "Initialized : ", this%initialized
- write (unit, "(3x,A,L1)") "initial_interaction_given: ", &
- this%initial_interaction_given
- write (unit, "(3x,A,L1)") "Finished : ", this%finished
- write (unit, "(3x,A,L1)") "Exceeded : ", this%exceeded
- write (unit, "(3x,A)") "Generator Internals:"
- write (unit, "(3x,A,E20.10)") "Mean Value : ", this%mean
- if (components > i_zero) then
- write (unit, "(3x,A,16(E20.10))") "Start Integrals : ", &
- this%start_integrals(1:16)
- ! write (unit, "(3x,A)") "start_values Component:"
- ! call this%start_values%print_to_unit &
- ! (unit, parents, components-1, peers)
- write (unit, "(3x,A)") "dsigma Component:"
- call this%dsigma%print_to_unit (unit, parents, components-1, peers)
- write (unit, "(3x,A)") "samples Component:"
- call this%samples%print_to_unit (unit, parents, components-1, peers)
- write (unit, "(3x,A)") "beam Component:"
- call this%beam%print_to_unit (unit, parents, components-1, peers)
- else
- write (unit, "(3x,A)") "Skipping Derived-Type Components."
- end if
- ! call print_comp_pointer (this%start_node, unit, i_zero, &
- ! min(components-1,i_one), i_zero, "start_node")
- ! call serialize_print_comp_pointer (this%node, unit, i_zero, &
- ! min(components-1,i_one), i_zero, "node")
- end subroutine muli_print_to_unit
-
-@ %def muli_print_to_unit
-@
-<<Muli: muli: TBP>>=
- procedure, nopass :: get_type => muli_get_type
-<<Muli: procedures>>=
- pure subroutine muli_get_type(type)
- character(:), allocatable, intent(out) :: type
- allocate (type, source="muli_t")
- end subroutine muli_get_type
-
-@ %def muli_get_type
-@
-<<Muli: muli: TBP>>=
generic :: initialize => muli_initialize
procedure :: muli_initialize
<<Muli: procedures>>=
subroutine muli_initialize (this, GeV2_scale_cutoff, gev2_s, &
muli_dir, random_seed)
class(muli_t), intent(out) :: this
real(kind=default), intent(in) :: gev2_s, GeV2_scale_cutoff
character(*), intent(in) :: muli_dir
integer, intent(in), optional :: random_seed
- real(double) :: time
- logical :: exist
- type(muli_dsigma_t) :: dsigma_aq
- character(3) :: lhapdf_member_c
- call cpu_time(time)
- this%init_time = this%init_time-time
- print *, "muli_initialize: The MULI modules are still not fully " &
- // "populated, so MULI might generate some dummy values instead " &
- // "of real Monte Carlo generated interactions."
- print *, "Given Parameters:"
- print *, "GeV2_scale_cutoff=", GeV2_scale_cutoff
- print *, "muli_dir=", muli_dir
- print *, "lhapdf_dir=", ""
- print *, "lhapdf_file=", muli_default_lhapdf_file
- print *, "lhapdf_member=", muli_default_lhapdf_member
- print *, ""
- call this%transverse_mom_t%initialize (gev2_s)
- call this%beam%initialize (muli_dir, lhapdf_dir="", &
- lhapdf_file=muli_default_lhapdf_file, &
- lhapdf_member=muli_default_lhapdf_member)
- this%GeV2_scale_cutoff = GeV2_scale_cutoff
- if (present(random_seed)) then
- call tao_random_create (this%tao_rnd, random_seed)
- else
- call tao_random_create (this%tao_rnd, 1)
- end if
- print *, "looking for previously generated root function..."
- call integer_with_leading_zeros (muli_default_lhapdf_member, 3, &
- lhapdf_member_c)
- inquire (file=muli_dir//"/dsigma_"//muli_default_lhapdf_file//".xml", &
- exist=exist)
- if (exist) then
- print *, "found. Starting deserialization..."
- call this%dsigma%deserialize &
- (name="dsigma_"//muli_default_lhapdf_file//"_"//lhapdf_member_c, &
- file=muli_dir//"/dsigma_"//muli_default_lhapdf_file//".xml")
- ! call this%dsigma%print_all ()
- print *, "done. Starting generation of plots..."
- call this%dsigma%gnuplot (muli_dir)
- print *, "done."
- else
- print *, &
- "No root function found. Starting generation of root function..."
- call dsigma_aq%generate (GeV2_scale_cutoff, gev2_s, this%dsigma)
- print *, "done. Starting serialization of root function..."
- call this%dsigma%serialize &
- (name="dsigma_"//muli_default_lhapdf_file//"_"//lhapdf_member_c, &
- file=muli_dir//"/dsigma_"//muli_default_lhapdf_file//".xml")
- print *, "done. Starting serialization of generator..."
- call dsigma_aq%serialize &
- (name="dsigma_aq_"//muli_default_lhapdf_file//"_" // &
- lhapdf_member_c, file=muli_dir//"/dsigma_aq_" // &
- muli_default_lhapdf_file//".xml")
- print *,"done. Starting generation of plots..."
- call this%dsigma%gnuplot (muli_dir)
- print *, "done."
- end if
- print *, ""
- print *, "looking for previously generated samples..."
- inquire (file=muli_dir//"/samples.xml", exist=exist)
- if (exist) then
- print *, "found. Starting deserialization..."
- call this%samples%deserialize ("samples",muli_dir//"/samples.xml")
- else
- print *,"No samples found. Starting with default initialization."
- call this%samples%initialize (4, int_sizes_all, int_all, 1E-2_default)
- end if
- call this%restart ()
this%initialized = .true.
- call cpu_time (time)
- this%init_time = this%init_time + time
end subroutine muli_initialize
@ %def muli_initialize
@
<<Muli: muli: TBP>>=
procedure :: apply_initial_interaction => muli_apply_initial_interaction
<<Muli: procedures>>=
subroutine muli_apply_initial_interaction (this, GeV2_s, &
x1, x2, pdg_f1, pdg_f2, n1, n2)
class(muli_t), intent(inout) :: this
real(default), intent(in) :: Gev2_s, x1, x2
integer, intent(in):: pdg_f1, pdg_f2, n1, n2
- real(default) :: rnd1, rnd2, time
- if (this%initialized) then
- call cpu_time (time)
- this%init_time = this%init_time - time
- print *, "muli_apply_initial_interaction:"
- print *, "gev2_s=", gev2_s
- print *, "x1=", x1
- print *, "x2=", x2
- print *, "pdg_f1=", pdg_f1
- print *, "pdg_f2=", pdg_f2
- print *, "n1=", n1
- print *, "n2=", n2
- call tao_random_number (this%tao_rnd, rnd1)
- call tao_random_number (this%tao_rnd, rnd2)
- call cpu_time (time)
- this%init_time = this%init_time + time
- call this%beam%apply_initial_interaction &
- (sqrt (gev2_s), x1, x2, pdg_f1, pdg_f2, n1, n2,&
- !!! This is a hack: We should give the pt scale of the initial
- !!! interaction. Unfortunately, we only know the invariant
- !!! mass shat. shat/2 is the upper bound of pt, so we
- !!! use it for now.
- sqrt(gev2_s) * x1 *x2 / 2D0, &
- rnd1, rnd2)
- this%initial_interaction_given = .true.
- else
- print *, &
- "muli_apply_initial_interaction: call muli_initialize first. STOP"
- stop
- end if
end subroutine muli_apply_initial_interaction
@ %def muli_apply_initial_interaction
@
<<Muli: muli: TBP>>=
- procedure :: finalize => muli_finalize
-<<Muli: procedures>>=
- subroutine muli_finalize (this)
- class(muli_t), intent(inout) :: this
- print *, "muli_finalize"
- nullify (this%node)
- call this%dsigma%finalize ()
- call this%samples%finalize ()
- call this%beam%finalize ()
- end subroutine muli_finalize
-
-@ %def muli_finalize
-@
-<<Muli: muli: TBP>>=
- procedure :: stop_trainer => muli_stop_trainer
-<<Muli: procedures>>=
- subroutine muli_stop_trainer (this)
- class(muli_t), intent(inout) :: this
- print *, "muli_stop_trainer: DUMMY!"
- end subroutine muli_stop_trainer
-
-@ %def muli_stop_trainer
-@
-<<Muli: muli: TBP>>=
- procedure :: reset_timer => muli_reset_timer
-<<Muli: procedures>>=
- subroutine muli_reset_timer (this)
- class(muli_t), intent(inout) :: this
- this%init_time = 0D0
- this%pt_time = 0D0
- this%partons_time = 0D0
- this%confirm_time = 0D0
- end subroutine muli_reset_timer
-
-@ %def muli_reset_timer
-@
-<<Muli: muli: TBP>>=
procedure :: restart => muli_restart
<<Muli: procedures>>=
subroutine muli_restart (this)
class(muli_t), intent(inout) :: this
- call this%dsigma%get_rightmost (this%node)
- call this%beam%reset ()
- ! print *, associated(this%node)
- ! nullify (this%node)
- this%finished = .false.
- this%process_id = -1
- this%integrand_id = -1
- this%momentum_fractions = [-1D0,-1D0,1D0]
- this%hyperbolic_fractions = [-1D0,-1D0,1D0]
- ! this%start_values%process_id = -1
- ! this%start_values%integrand_id = -1
- ! this%start_values%momentum_fractions = [-1D0,-1D0,1D0]
- ! this%start_values%hyperbolic_fractions = [-1D0,-1D0,1D0]
- this%start_integrals = &
- [0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0]
end subroutine muli_restart
@ %def muli_restart
@
<<Muli: muli: TBP>>=
procedure :: is_initialized => muli_is_initialized
<<Muli: procedures>>=
elemental function muli_is_initialized (this) result (res)
logical :: res
class(muli_t), intent(in) :: this
res = this%initialized
end function muli_is_initialized
@ %def muli_is_initialized
@
<<Muli: muli: TBP>>=
- procedure :: is_initial_interaction_given => &
- muli_is_initial_interaction_given
-<<Muli: procedures>>=
- elemental function muli_is_initial_interaction_given (this) result (res)
- logical :: res
- class(muli_t), intent(in) :: this
- res = this%initial_interaction_given
- end function muli_is_initial_interaction_given
-
-@ %def muli_is_initial_interaction_given
-@
-<<Muli: muli: TBP>>=
- procedure :: is_finished => muli_is_finished
-<<Muli: procedures>>=
- elemental function muli_is_finished (this) result (res)
- logical :: res
- class(muli_t), intent(in) :: this
- res = this%finished
- end function muli_is_finished
-
-@ %def muli_is_finished
-@
-<<Muli: muli: TBP>>=
- procedure :: enable_remnant_pdf => muli_enable_remnant_pdf
-<<Muli: procedures>>=
- subroutine muli_enable_remnant_pdf (this)
- class(muli_t), intent(inout) :: this
- this%modify_pdfs = .true.
- end subroutine muli_enable_remnant_pdf
-
-@ %def muli_enable_remnant_pdf
-@
-<<Muli: muli: TBP>>=
- procedure :: disable_remnant_pdf => muli_disable_remnant_pdf
-<<Muli: procedures>>=
- subroutine muli_disable_remnant_pdf (this)
- class(muli_t), intent(inout) :: this
- this%modify_pdfs = .false.
- end subroutine muli_disable_remnant_pdf
-
-@ %def muli_disable_remnant_pdf
-@
-<<Muli: muli: TBP>>=
procedure :: generate_gev2_pt2 => muli_generate_gev2_pt2
<<Muli: procedures>>=
subroutine muli_generate_gev2_pt2 (this, gev2_start_scale, gev2_new_scale)
class(muli_t), intent(inout) :: this
real(kind=default), intent(in) :: gev2_start_scale
real(kind=default), intent(out) :: gev2_new_scale
- real(double) :: time
- call cpu_time (time)
- this%pt_time = this%pt_time - time
- call this%set_gev2_scale (gev2_start_scale)
- this%start_integrals = this%node%approx_integral (this%get_unit_scale ())
call this%generate_next_scale ()
- gev2_new_scale = this%get_gev2_scale ()
- call cpu_time (time)
- this%pt_time = this%pt_time + time
+ gev2_new_scale = 1
end subroutine muli_generate_gev2_pt2
@ %def muli_generate_gev2_pt2
@
<<Muli: muli: TBP>>=
procedure :: generate_partons => muli_generate_partons
<<Muli: procedures>>=
subroutine muli_generate_partons (this, n1, n2, x_proton_1, x_proton_2, &
pdg_f1, pdg_f2, pdg_f3, pdg_f4)
class(muli_t), intent(inout) :: this
integer, intent(in) :: n1, n2
real(kind=default), intent(out) :: x_proton_1, x_proton_2
integer, intent(out) :: pdg_f1, pdg_f2, pdg_f3, pdg_f4
integer, dimension(4) :: pdg_f
- real(double) :: time
- ! print *, "muli_generate_partons: n1=", n1, " n2=", n2
- this%parton_ids(1) = n1
- this%parton_ids(2) = n2
- call cpu_time (time)
- this%partons_time = this%partons_time - time
- this%mean = this%node%approx_value_n (this%get_unit_scale(), &
- this%integrand_id)
- call this%samples%mcgenerate_hit (this%get_unit2_scale(), &
- this%mean, this%integrand_id, this%tao_rnd, this%process_id, &
- this%momentum_fractions)
- ! print *,"muli_generate_partons", this%momentum_fractions
- call this%generate_flow ()
- if (this%modify_pdfs) then
- call cpu_time (time)
- this%partons_time = this%partons_time + time
- this%confirm_time = this%confirm_time - time
- call this%beam%apply_interaction (this)
- call cpu_time (time)
- this%confirm_time = this%confirm_time + time
- this%partons_time = this%partons_time - time
- end if
- x_proton_1 = this%momentum_fractions(1)
- x_proton_2 = this%momentum_fractions(2)
- pdg_f = this%get_pdg_flavors ()
- pdg_f1 = pdg_f(1)
- pdg_f2 = pdg_f(2)
- pdg_f3 = pdg_f(3)
- pdg_f4 = pdg_f(4)
- call cpu_time (time)
- this%partons_time = this%partons_time - time
- call qcd_2_2_print_to_unit (this, output_unit, 100_dik, 100_dik, 100_dik)
+ call this%generate_color_flows ()
+ pdg_f = 0
+ pdg_f1 = 0
+ pdg_f2 = 0
+ pdg_f3 = 0
+ pdg_f4 = 0
end subroutine muli_generate_partons
@ %def muli_generate_partons
@
<<Muli: muli: TBP>>=
- procedure :: generate_flow => muli_generate_flow
-<<Muli: procedures>>=
- subroutine muli_generate_flow(this)
- class(muli_t), intent(inout)::this
- integer::rnd
- integer::m,n
- logical, dimension(3)::t
- integer, dimension(4)::tmp_flow, tmp_array
- ! we initialize with zeros. a i_zero means no line ends here.
- this%flow=[0,0,0,0]
- ! we randomly pick a color flow
- call tao_random_number(this%tao_rnd,rnd)
- ! the third position of muli_flow_stats is the sum of all flow wheights of stratum diagram_kind.
- ! so we generate a random number 0 <= m < sum(weights)
- m=modulo(rnd,muli_flow_stats(3,this%get_diagram_color_kind()))
- ! lets visit all color flows of stratum diagram_kind. the first and second position of muli_flow_stats
- ! tells us the index of the first and the last valid color flow.
- do n=muli_flow_stats(1,this%get_diagram_color_kind()),muli_flow_stats(2,this%get_diagram_color_kind())
- ! now we remove the weight of flow n from our random number.
- m=m-muli_flows(0,n)
- ! this is how we pick a flow.
- if (m<0) then
- ! the actual flow
- this%flow=muli_flows(1:4,n)
- exit
- end if
- end do
- ! the diagram kind contains a primitive diagram and all diagramms which can be deriven by
- ! (1) global charge conjugation
- ! (2) permutation of the initial state particles
- ! (3) permutation of the final state particles
- ! lets see, what transformations we have got in our actual interaction.
- tmp_array = this%get_lha_flavors ()
- t = muli_get_state_transformations (this%get_diagram_color_kind (), &
- tmp_array)
- ! this%get_lha_flavors ())
- ! now we have to apply these transformations to our flow.
- ! (1) means: swap beginning and end of a line. flow is a permutation that maps
- ! ends to their beginnings, so we apply flow to itself:
-!!$ print *,"(0)",this%flow
- if (t(1)) then
- tmp_flow=this%flow
- this%flow=[0,0,0,0]
- do n=1,4
- if (tmp_flow(n)>0)this%flow(tmp_flow(n))=n
- end do
-!!$ print *,"(1)",this%flow
- end if
- if (t(2)) then
- ! we swap the particles 1 and 2
- tmp_flow(1)=this%flow(2)
- tmp_flow(2)=this%flow(1)
- tmp_flow(3:4)=this%flow(3:4)
-!!$ print *,"(2)",tmp_flow
- ! we swap the beginnings assigned to particle 1 and 2
- where(tmp_flow==1)
- this%flow=2
- elsewhere(tmp_flow==2)
- this%flow=1
- elsewhere
- this%flow=tmp_flow
- end where
-!!$ print *,"(2)",this%flow
- end if
- if (t(3)) then
- ! we swap the particles 3 and 4
- tmp_flow(1:2)=this%flow(1:2)
- tmp_flow(3)=this%flow(4)
- tmp_flow(4)=this%flow(3)
-!!$ print *,"(3)",tmp_flow
- ! we swap the beginnings assigned to particle 3 and 4
- where(tmp_flow==3)
- this%flow=4
- elsewhere(tmp_flow==4)
- this%flow=3
- elsewhere
- this%flow=tmp_flow
- end where
-!!$ print *,"(3)",this%flow
- end if
- end subroutine muli_generate_flow
-
-@ %def muli_generate_flow
-@
-<<Muli: muli: TBP>>=
- procedure :: replace_parton => muli_replace_parton
+ procedure :: generate_color_flows => muli_generate_color_flows
<<Muli: procedures>>=
- subroutine muli_replace_parton &
- (this, proton_id, old_id, new_id, pdg_f, x_proton, gev_scale)
+ subroutine muli_generate_color_flows (this)
class(muli_t), intent(inout) :: this
- integer, intent(in) :: proton_id, old_id, new_id, pdg_f
- real(kind=default), intent(in) :: x_proton, gev_scale
- ! print *, "muli_replace_parton(", proton_id, old_id, new_id, &
- ! pdg_f, x_proton, gev_scale, ")"
- if (proton_id==1 .or. proton_id==2) then
- call this%beam%replace_parton &
- (proton_id, old_id, new_id, pdg_f, x_proton, gev_scale)
- else
- print *, "muli_replace_parton: proton_id must be 1 or 2, but ", &
- proton_id, " was given."
- stop
- end if
- end subroutine muli_replace_parton
-
-@ %def muli_replace_parton
-@
-<<Muli: muli: TBP>>=
- procedure :: get_parton_pdf => muli_get_parton_pdf
-@
-<<Muli: procedures>>=
- function muli_get_parton_pdf &
- (this, x_proton, gev2_scale, n, pdg_f) result (pdf)
- real(default) :: pdf
- class(muli_t), intent(in) :: this
- real(default), intent(in) :: x_proton, gev2_scale
- integer, intent(in) :: n, pdg_f
- call this%beam%parton_pdf (x_proton, gev2_scale, n, pdg_f, pdf)
- end function muli_get_parton_pdf
+ integer, dimension(4) :: flow
+ end subroutine muli_generate_color_flows
-@ %def muli_get_parton_pdf
+@ %def muli_generate_color_flows
@
<<Muli: muli: TBP>>=
- procedure :: get_momentum_pdf => muli_get_momentum_pdf
-@
+ procedure :: get_color_flow => muli_get_color_flow
<<Muli: procedures>>=
- function muli_get_momentum_pdf &
- (this, x_proton, gev2_scale, n, pdg_f) result (pdf)
- real(default) :: pdf
+ pure function muli_get_color_flow (this) result (flow)
class(muli_t), intent(in) :: this
- real(default), intent(in) :: x_proton, gev2_scale
- integer, intent(in) :: n, pdg_f
- call this%beam%momentum_pdf (x_proton, gev2_scale, n, pdg_f, pdf)
- end function muli_get_momentum_pdf
+ integer, dimension(4) :: flow
+ flow = this%flow
+ end function muli_get_color_flow
-@ %def muli_get_momentum_pdf
+@ %def muli_get_color_flow
@
<<Muli: muli: TBP>>=
- procedure :: print_timer => muli_print_timer
+ procedure :: get_color_correlations => muli_get_color_correlations
<<Muli: procedures>>=
- subroutine muli_print_timer(this)
+ subroutine muli_get_color_correlations &
+ (this, start_index, final_index, flow)
class(muli_t), intent(in) :: this
- print ("(1x,A,E20.10)"), "Init time: ", this%init_time
- print ("(1x,A,E20.10)"), "PT gen time: ", this%pt_time
- print ("(1x,A,E20.10)"), "Partons time: ", this%partons_time
- print ("(1x,A,E20.10)"), "Confirm time: ", this%confirm_time
- print ("(1x,A,E20.10)"), "Overall time: ", &
- this%init_time + this%pt_time + this%partons_time + this%confirm_time
- end subroutine muli_print_timer
-
-@ %def muli_print_timer
-@
-<<Muli: muli: TBP>>=
- procedure :: generate_samples => muli_generate_samples
-<<Muli: procedures>>=
- subroutine muli_generate_samples &
- (this, n_total, n_print, integrand_kind, muli_dir, analyse)
- class(muli_t), intent(inout) :: this
- integer(dik), intent(in) :: n_total, n_print
- integer, intent(in) :: integrand_kind
- character(*), intent(in) :: muli_dir
- logical, intent(in) :: analyse
- integer(dik) :: n_inner
-
- class(muli_trapezium_node_class_t), pointer :: start_node => null()
- class(muli_trapezium_node_class_t), pointer, save :: s_node => null()
- class(muli_trapezium_node_class_t), pointer, save :: node => null()
-
- character(2) :: prefix
- integer, save :: t_slice, t_region, t_proc, t_subproc, t_max_n = 0
- integer(dik) :: n_t, n_p, n_m
- integer :: n, m, u, unit = 0
- integer(dik) :: n_tries = 0
- integer(dik) :: n_hits = 0
- integer(dik) :: n_over = 0
- integer(dik) :: n_miss = 0
- real(default), save, dimension(3) :: cart_hit
- integer, save, dimension(4) :: t_i_rnd
- ! integer, save, dimension(5) :: r_n_proc
- real(default), dimension(16) :: d_rnd
- real(default), save :: t_area, t_dddsigma, t_rnd, t_weight, t_arg
- real(default) :: mean = 0D0
- real(default) :: time = 0D0
- real(default) :: timepa = 0D0
- real(default) :: timept = 0D0
- real(default) :: timet = 0D0
- real(default) :: pts, s_pts = 1D0
- real(default) :: pts2 = 1D0
- real(default) :: rnd
- logical :: running
- character(3) :: num
- integer :: success = -1
- integer :: chain_length = 0
- integer :: int_kind
- integer :: process_id
- real(double), dimension(0:16) :: integral
- call this%print_parents ()
- n_tries = one
- n_inner = n_total / n_print
- n_t = i_zero
- PRINT: do while (n_t < n_total)
- call cpu_time (time)
- timet = - time
- n_p = i_zero
- INNER: do while (n_p < n_print)
- chain_length = 0
- ! print *,"new chain"
- call this%restart ()
- this%integrand_id = integrand_kind
- call cpu_time (time)
- timept = timept - time
- call this%generate_next_scale (integrand_kind)
- call cpu_time (time)
- timept = timept + time
- CHAIN: do while (.not. this%is_finished ())
- chain_length = chain_length + 1
- n_p = n_p + 1
- call this%confirm ()
- call cpu_time (time)
- timepa = timepa - time
- ! print *, this%get_unit2_scale ()
- call this%samples%mcgenerate_hit (this%get_unit2_scale(), &
- this%mean, this%integrand_id, this%tao_rnd, this%process_id, &
- this%momentum_fractions)
- call cpu_time (time)
- timepa = timepa + time
- timept = timept - time
- call this%generate_next_scale (integrand_kind)
- call cpu_time (time)
- timept = timept + time
- end do CHAIN
- ! print *, "chain length = ", chain_length
- end do INNER
- n_t = n_t + n_p
- call this%samples%sum_up ()
- call cpu_time (time)
- timet = timet + time
- print *, n_t, "/", n_total
- print *, "time: ", timet
- print *, "pt time: ", timept
- print *, "pa time: ", timepa
- print *, this%samples%n_tries_sum, this%samples%n_hits_sum, &
- this%samples%n_over_sum
- if (this%samples%n_hits_sum > 0) then
- print *, (this%samples%n_hits_sum * 10000) / &
- this%samples%n_tries_sum, (this%samples%n_over_sum * 10000) / &
- this%samples%n_hits_sum
- else
- print *, "no hits"
- end if
- ! print ('(7(I11," "),5(E14.7," "))'), n_p, n_print, n_tries, &
- ! n_hits,n_over, int((n_hits*1D3)/n_tries), &
- ! int((n_over*1D6)/n_tries), n_hits/real(n_over), time1, time2, &
- ! time3, this%samples%int_kinds(integrand_kind)%overall_boost
- end do print
- call integer_with_leading_zeros (integrand_kind, 2, prefix)
- if (analyse) then
- call this%samples%int_kinds(integrand_kind)%analyse &
- (muli_dir, prefix//"_")
- call this%samples%int_kinds(integrand_kind)%serialize &
- ("sample_int_kind_"//prefix, &
- muli_dir//"/sample_int_kind/"//prefix//".xml")
- end if
- call this%samples%int_kinds(integrand_kind)%serialize &
- ("sample_int_kind_"//prefix, &
- muli_dir//"/sample_int_kind/"//prefix//".xml")
- end subroutine muli_generate_samples
+ integer, intent(in) :: start_index
+ integer, intent(out) :: final_index
+ integer, dimension(2,4), intent(out) :: flow
+ integer :: pos, f_end, f_beginning
+ final_index = start_index
+ flow = reshape([0,0,0,0,0,0,0,0],[2,4])
+ end subroutine muli_get_color_correlations
-@ %def muli_generate_samples
+@ %def muli_get_color_correlations
@
<<Muli: muli: TBP>>=
- procedure :: fake_interaction => muli_fake_interaction
+ procedure :: replace_parton => muli_replace_parton
<<Muli: procedures>>=
- subroutine muli_fake_interaction (this, GeV2_scale, x1, x2, &
- process_id, integrand_id, n1, n2, flow)
+ subroutine muli_replace_parton &
+ (this, proton_id, old_id, new_id, pdg_f, x_proton, gev_scale)
class(muli_t), intent(inout) :: this
- real(default), intent(in) :: Gev2_scale, x1, x2
- integer, intent(in) :: process_id, integrand_id, n1, n2
- integer, dimension(4), intent(in), optional :: flow
- call this%set_gev2_scale (Gev2_scale)
- this%process_id = process_id
- this%integrand_id = integrand_id
- this%parton_ids = [n1, n2]
- if (present (flow)) then
- this%flow = flow
- else
- this%flow = [0,0,0,0]
- end if
- this%momentum_fractions = [x1, x2, this%get_unit2_scale()]
- call this%beam%apply_interaction (this)
- call this%beam%print_all ()
- end subroutine muli_fake_interaction
+ integer, intent(in) :: proton_id, old_id, new_id, pdg_f
+ real(kind=default), intent(in) :: x_proton, gev_scale
+ end subroutine muli_replace_parton
-@ %def muli_fake_interaction
+@ %def muli_replace_parton
@
<<Muli: muli: TBP>>=
procedure :: generate_next_scale => muli_generate_next_scale
<<Muli: procedures>>=
subroutine muli_generate_next_scale (this, integrand_kind)
class(muli_t), intent(inout) :: this
integer, intent(in), optional :: integrand_kind
- real(default) :: pts, tmp_pts, rnd
- integer :: tmp_int_kind
- class(muli_trapezium_node_class_t), pointer :: tmp_node
- pts = - one
- if (present (integrand_kind)) then
- call tao_random_number (this%tao_rnd, rnd)
- call generate_single_pts (integrand_kind, &
- this%start_integrals(integrand_kind), &
- this%beam%get_pdf_int_weights &
- (double_pdf_kinds (1:2,integrand_kind)), rnd, this%dsigma, &
- pts, this%node)
- else
- do tmp_int_kind = 1, 16
- call tao_random_number (this%tao_rnd, rnd)
- call generate_single_pts (tmp_int_kind, &
- this%start_integrals(tmp_int_kind), &
- this%beam%get_pdf_int_weights &
- (double_pdf_kinds(1:2,tmp_int_kind)), rnd, &
- this%dsigma, tmp_pts, tmp_node)
- if (tmp_pts > pts) then
- pts = tmp_pts
- this%integrand_id = tmp_int_kind
- this%node => tmp_node
- end if
- end do
- end if
- if (pts > 0) then
- call this%set_unit_scale (pts)
- else
- this%finished = .true.
- end if
- ! print *, this%finished, this%integrand_id
- contains
- subroutine generate_single_pts &
- (int_kind, start_int, weight, rnd, int_tree, pts, node)
- integer, intent(in) :: int_kind
- real(default), intent(in) :: start_int, weight, rnd
- type(muli_trapezium_tree_t), intent(in) :: int_tree
- real(default), intent(out) :: pts
- class(muli_trapezium_node_class_t),pointer, intent(out) :: node
- real(default) :: arg
- ! print *, int_kind, start_int, weight, rnd
- if (weight > 0D0) then
- arg = start_int - log(rnd) / weight
- call int_tree%find_decreasing (arg, int_kind, node)
- if (node%get_l_integral(int_kind) > arg) then
- pts = node%approx_position_by_integral (int_kind, arg)
- else
- pts = -1D0
- end if
- else
- pts = -1D0
- end if
- end subroutine generate_single_pts
end subroutine muli_generate_next_scale
@ %def muli_generate_next_scale
@
-<<Muli: muli: TBP>>=
- procedure :: confirm => muli_confirm
-<<Muli: procedures>>=
- subroutine muli_confirm (this)
- class(muli_t), intent(inout) :: this
- this%mean = this%node%approx_value_n(this%get_unit_scale (), &
- this%integrand_id)
- this%start_integrals = this%node%approx_integral (this%get_unit_scale ())
- end subroutine muli_confirm
-
-@ %def muli_confirm
-@
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-<<[[muli_cross_sections.f90]]>>=
-! This is a dummy for muli_cross_sections_module
-module muli_cross_sections_module
-end module muli_cross_sections_module
-
-@
-<<[[muli_sampling.f90]]>>=
-! This is a dummy for muli_sampling_module
-module muli_sampling_module
-end module muli_sampling_module
-
-@
-@

File Metadata

Mime Type
application/octet-stream
Expires
Fri, May 10, 12:55 AM (2 d)
Storage Engine
local-disk
Storage Format
Raw Data
Storage Handle
65/27/32b531c73f031b5997ed7fb61764
Default Alt Text
(1 MB)

Event Timeline